diff options
| author | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2009-12-02 07:31:39 +0000 |
|---|---|---|
| committer | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2009-12-02 07:31:39 +0000 |
| commit | 47c16a8cec2c48947e6d85683f5f916777ccc169 (patch) | |
| tree | 3a8bf827ae1df7e637a2a4ede4dba5f0421ac0d2 | |
| parent | b27941d363b11d115e30a9676e61c8536a12adf7 (diff) | |
| download | gcc-47c16a8cec2c48947e6d85683f5f916777ccc169.tar.gz | |
2009-12-02 Basile Starynkevitch <basile@starynkevitch.net>
MELT branch merged with trunk rev 154895
{after more plugin events from ICI folks}
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@154896 138bc75d-0d04-0410-961f-82ee72b054a4
318 files changed, 13266 insertions, 7154 deletions
diff --git a/ChangeLog.MELT b/ChangeLog.MELT index 07064b4319d..36ae3ca5e6f 100644 --- a/ChangeLog.MELT +++ b/ChangeLog.MELT @@ -1,7 +1,8 @@ -2009-11-30 Basile Starynkevitch <basile@starynkevitch.net> +2009-12-02 Basile Starynkevitch <basile@starynkevitch.net> - MELT branch merged with trunk rev 154755 + MELT branch merged with trunk rev 154895 + {after more plugin events from ICI folks} 2009-11-30 Basile Starynkevitch <basile@starynkevitch.net> diff --git a/boehm-gc/ChangeLog b/boehm-gc/ChangeLog index 5b615d956a4..03e51589580 100644 --- a/boehm-gc/ChangeLog +++ b/boehm-gc/ChangeLog @@ -1,5 +1,11 @@ 2009-11-30 Ben Elliston <bje@au.ibm.com> + * mark_rts.c (GC_approx_sp): Use __builtin_frame_address when + compiling with GCC rather than taking the address of a local + variable. + +2009-11-30 Ben Elliston <bje@au.ibm.com> + * os_dep.c: Use the POSIX signal API in preference to the BSD API. Generate a compilation error if neither the POSIX nor BSD APIs can be detected. diff --git a/boehm-gc/mark_rts.c b/boehm-gc/mark_rts.c index 4074879a71a..7a9fb8f2b72 100644 --- a/boehm-gc/mark_rts.c +++ b/boehm-gc/mark_rts.c @@ -376,7 +376,13 @@ ptr_t GC_approx_sp() # ifdef _MSC_VER # pragma warning(disable:4172) # endif - return((ptr_t)(&dummy)); +#ifdef __GNUC__ + /* Eliminate a warning from GCC about taking the address of a + local variable. */ + return __builtin_frame_address (0); +#else + return ((ptr_t)(&dummy)); +#endif /* __GNUC__ */ # ifdef _MSC_VER # pragma warning(default:4172) # endif diff --git a/config/ChangeLog b/config/ChangeLog index aa716ea437d..9e524fc8737 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -1,3 +1,8 @@ +2009-11-30 Joseph Myers <joseph@codesourcery.com> + + * largefile.m4 (ACX_LARGEFILE): Require AC_CANONICAL_HOST and + AC_CANONICAL_TARGET. + 2009-11-24 Joel Brobecker <brobecker@adacore.com> * zlib.m4: New file. diff --git a/config/largefile.m4 b/config/largefile.m4 index 9449b12dca4..4a88fd738fd 100644 --- a/config/largefile.m4 +++ b/config/largefile.m4 @@ -5,6 +5,11 @@ AC_DEFUN([ACX_LARGEFILE],[dnl +# The tests for host and target for $enable_largefile require +# canonical names. +AC_REQUIRE([AC_CANONICAL_HOST]) +AC_REQUIRE([AC_CANONICAL_TARGET]) + # As the $enable_largefile decision depends on --enable-plugins we must set it # even in directories otherwise not depending on the $plugins option. diff --git a/gcc/ChangeLog b/gcc/ChangeLog index ae70d025cb4..a28fc61680f 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,315 @@ +2009-12-01 Sebastian Pop <sebastian.pop@amd.com> + + * config/i386/abmintrin.h (__lzcnt16): New. + (__lzcnt): New. + (__lzcnt64): New. + * config/i386/i386-builtin-types.def (UINT16_FTYPE_UINT16): New. + * config/i386/i386.c (IX86_BUILTIN_CLZS): New. + (bdesc_special_args): Add __builtin_clzs. + (ix86_expand_args_builtin): Handle UINT16_FTYPE_UINT16. + +2009-12-01 Sebastian Pop <sebastian.pop@amd.com> + + * config/i386/abmintrin.h (_mm_popcnt_u32): New. + (_mm_popcnt_u64): New. + +2009-12-01 Sebastian Pop <sebastian.pop@amd.com> + + * config/i386/abmintrin.h: New. + * config/i386/i386-c.c (ix86_target_macros_internal): Defined __ABM__. + * config/i386/x86intrin.h: Include abmintrin.h when __ABM__ is defined. + +2009-12-01 Uros Bizjak <ubizjak@gmail.com> + + * config/i386/i386.md (SWI124): Rename from CRC32MODE. + (crc32modesuffix): Remove. + (crc32modeconstraint): Ditto. + (sse4_2_crc32<mode>): Update for renamed mode iterator. Use + imodesuffix instead of crc32modesuffix and <r>m instead of + crc32modeconstraint. + +2009-12-01 Jakub Jelinek <jakub@redhat.com> + + PR c++/42234 + * tree-cfgcleanup.c (cleanup_omp_return): Don't ICE if control_bb + contains no statements. + +2009-12-01 Grigori Fursin <grigori.fursin@inria.fr> + Joern Rennecke <amylaar@spamcop.net> + + * cgraphunit.c (plugin.h): Include. + (ipa_passes): Invoke PLUGIN_ALL_IPA_PASSES_START / + PLUGIN_ALL_IPA_PASSES_END at start / end of processing. + * gcc-plugin.h (highlev-plugin-common.h, hashtab.h): Include. + (enum plugin_event): Define by including plugin.def. + Last enumerator is now called PLUGIN_EVENT_FIRST_DYNAMIC. + (plugin_event_name): Change type to const char **. + (get_event_last, get_named_event_id, unregister_callback): Declare. + (register_callback): Change type of event argument to int. + (highlev-plugin-common.h): New file. + * Makefile.in (GCC_PLUGIN_H): Add highlev-plugin-common.h and + $(HASHTAB_H) + (tree-optimize.o passes.o): Depend on $(PLUGIN_H). + (PLUGIN_HEADERS): Add opts.h, $(PARAMS_H) and plugin.def. + (s-header-vars): New rule. + (install-plugin): Depend on s-header-vars. Install b-header-vars. + * params.c (get_num_compiler_params): New function. + * params.h (get_num_compiler_params): Declare. + * passes.c (plugin.h): Include. + (make_pass_instance): Invoke PLUGIN_NEW_PASS. + (do_per_function_toporder, pass_init_dump_file): No longer static. + (pass_fini_dump_file): Likewise. + (execute_one_pass): Likewise. Invoke PLUGIN_OVERRIDE_GATE and + PLUGIN_PASS_EXECUTION. + (execute_ipa_pass_list): Invoke PLUGIN_EARLY_GIMPLE_PASSES_START and + PLUGIN_EARLY_GIMPLE_PASSES_END. + * plugin.c (plugin_event_name_init): New array, defined by + including plugin.def. + (FMT_FOR_PLUGIN_EVENT): Update. + (plugin_event_name): Change type to const char ** and initialize + to plugin_event_name_init. + (event_tab, event_last, event_horizon): New variable. + (get_event_last): New function. + (plugin_callbacks_init): New array. + (plugin_callbacks: Change type to struct callback_info **. + Initialize to plugin_callbacks_init. + (htab_event_eq, get_named_event_id, unregister_callback): New function. + (invoke_plugin_va_callbacks): Likewise. + (register_callback): Change type of event argument to int. + Handle new events. Allow dynamic events. + (invoke_plugin_callbacks): Likewise. Return success status. + (plugins_active_p): Allow dynamic callbacks. + * plugin.def: New file. + * plugin.h (invoke_plugin_callbacks): Update prototype. + (invoke_plugin_va_callbacks): Declare. + * tree-optimize.c (plugin.h): Include. + (tree_rest_of_compilation): Invoke PLUGIN_ALL_PASSES_START and + PLUGIN_ALL_PASSES_END. + * tree-pass.h (execute_one_pass, pass_init_dump_file): Declare. + (pass_fini_dump_file, do_per_function_toporder): Likewise. + * doc/plugin.texi: Document new event types. + +2009-12-01 Martin Jambor <mjambor@suse.cz> + + PR tree-optimization/42237 + * tree-sra.c (sra_ipa_modify_assign): Split gimple_reg_type assignments + in between references into two. + +2009-12-01 Richard Guenther <rguenther@suse.de> + + * tree-inline.c (copy_tree_body_r): Do not set TREE_BLOCK + to the block of the call when remapping a type. + +2009-12-01 Martin Jambor <mjambor@suse.cz> + + * cgraph.h (struct cgraph_edge): Reorder fields. Make loop_nest + unsigned short int. + * ipa-prop.h (struct ipa_param_call_note): Likewise. + * ipa-prop.c (ipa_note_param_call): Initialize note->loop_nest. + +2009-12-01 Richard Guenther <rguenther@suse.de> + + * final.c (rest_of_clean_state): If -fcompare-debug is + given dump final insns without UIDs. + * tree-ssa-live.c (remove_unused_scope_block_p): Remove + after_inlining checks. + +2009-11-30 Chao-ying Fu <fu@mips.com> + + * config/mips/mips-dsp.md (mips_lhx_<mode>): Use sign_extend. + +2009-11-30 Dave Korn <dave.korn.cygwin@gmail.com> + + * configure.ac (USE_CYGWIN_LIBSTDCXX_WRAPPERS): Define to reflect + status of AC_CHECK_FUNC for Cygwin DLL libstdc++ support wrappers. + * configure: Regenerate. + * config.in: Regenerate. + + * config/i386/cygwin.h (CXX_WRAP_SPEC_LIST): Define list of --wrap + options for Cygwin DLL libstdc++ support wrappers. + (CXX_WRAP_SPEC_OPT): Define spec to use wrappers or not by default + according to defined value of USE_CYGWIN_LIBSTDCXX_WRAPPERS. + (CXX_WRAP_SPEC): Define entire wrapper spec in or out according to + whether USE_CYGWIN_LIBSTDCXX_WRAPPERS is even defined or not. + (LINK_SPEC): Include CXX_WRAP_SPEC. + * gcc/config/i386/winnt.c (wrapper_strcmp): New qsort helper function. + (i386_find_on_wrapper_list): Check if a function is found on the list + of libstdc++ wrapper options. + (i386_pe_file_end): If we are importing a wrapped function, also emit + an external declaration for the real version. + * config/i386/cygming.opt (muse-libstdc-wrappers): New option for + Cygwin targets. Update copyright year. + +2009-11-30 Steve Ellcey <sje@cup.hp.com> + Jakub Jelinek <jakub@redhat.com> + + * function.c (instantiate_virtual_regs_in_insn): Copy to new reg + before forcing mode. + +2009-11-30 Anatoly Sokolov <aesok@post.ru> + + * config/sh/sh.c (sh_promote_prototypes): Make static. + (sh_function_value, sh_libcall_value, sh_function_value_regno_p): New + functions. + (TARGET_FUNCTION_VALUE, TARGET_LIBCALL_VALUE): Declare. + * config/sh/sh.h: (FUNCTION_VALUE_REGNO_P): Redefine, use + sh_function_value_regno_p. + (FUNCTION_VALUE, LIBCALL_VALUE): Remove. + * config/sh/sh-protos.h (sh_function_value_regno_p): Declare. + (sh_promote_prototypes) : Remove. + +2009-11-30 Julian Brown <julian@codesourcery.com> + + * config/arm/arm.h (PREFERRED_RELOAD_CLASS): Don't restrict Thumb-2 + reloads to LO_REGS. + +2009-11-30 Richard Henderson <rth@redhat.com> + + * config/i386/i386.c (ix86_vec_interleave_v2df_operator_ok): New. + (bdesc_special_args): Update insn codes. + (avx_vpermilp_parallel): Correct range check. + (ix86_rtx_costs): Handle vector permutation rtx codes. + (struct expand_vec_perm_d): Move earlier. + (get_mode_wider_vector): New. + (expand_vec_perm_broadcast_1): New. + (ix86_expand_vector_init_duplicate): Use it. Tidy AVX modes. + (expand_vec_perm_broadcast): New. + (ix86_expand_vec_perm_builtin_1): Use it. + * config/i386/i386-protos.h: Update. + * config/i386/predicates.md (avx_vbroadcast_operand): New. + * config/i386/sse.md (AVX256MODE24P): New. + (ssescalarmodesuffix2s): New. + (avxhalfvecmode, avxscalarmode): Fill out to all modes. + (avxmodesuffixf2c): Add V8SI, V4DI. + (vec_dupv4sf): New expander. + (*vec_dupv4sf_avx): Add vbroadcastss alternative. + (*vec_set<mode>_0_avx, **vec_set<mode>_0_sse4_1): Macro-ize for + V4SF and V4SI. Move C alternatives to front. Add insertps and + pinsrd alternatives. + (*vec_set<mode>_0_sse2): Split out from ... + (vec_set<mode>_0): Macro-ize for V4SF and V4SI. + (vec_interleave_highv2df, vec_interleave_lowv2df): Require register + destination; use ix86_vec_interleave_v2df_operator_ok, instead of + ix86_fixup_binary_operands. + (*avx_interleave_highv2df, avx_interleave_lowv2df): Add movddup. + (*sse3_interleave_highv2df, sse3_interleave_lowv2df): New. + (*avx_movddup, *sse3_movddup): Remove. New splitter from + vec_select form to vec_duplicate form. + (*sse2_interleave_highv2df, sse2_interleave_lowv2df): Use + ix86_vec_interleave_v2df_operator_ok. + (avx_movddup256, avx_unpcklpd256): Change to expanders, merge into ... + (*avx_unpcklpd256): ... here. + (*vec_dupv4si_avx): New. + (*vec_dupv2di_avx): Add movddup alternative. + (*vec_dupv2di_sse3): New. + (vec_dup<AVX256MODE24P>): Replace avx_vbroadcasts<AVXMODEF4P> and + avx_vbroadcastss256; represent with vec_duplicate instead of + nested vec_concat operations. + (avx_vbroadcastf128_<mode>): Rename from + avx_vbroadcastf128_p<avxmodesuffixf2c>256. + (*avx_vperm_broadcast_v4sf): New. + (*avx_vperm_broadcast_<AVX256MODEF2P>): New. + +2009-11-30 Martin Jambor <mjambor@suse.cz> + + PR middle-end/42196 + * tree-sra.c (struct access): New field grp_different_types. + (dump_access): Dump grp_different_types. + (compare_access_positions): Prefer scalars and vectors over other + scalar types. + (sort_and_splice_var_accesses): Set grp_different_types if appropriate. + (sra_modify_expr): Use the original also when dealing with a complex + or vector group accessed as multiple types. + +2009-11-30 Richard Henderson <rth@redhat.com> + + * config/i386/i386.c (avx_vperm2f128_parallel): New. + * config/i386/i386-protos.h: Declare it. + * config/i386/predicates.md (avx_vperm2f128_v8sf_operand, + avx_vperm2f128_v8si_operand, avx_vperm2f128_v4df_operand): New. + * config/i386/sse.md (avx_vperm2f128<mode>3): Change to expander. + (*avx_vperm2f128<mode>_full): Renamed from avx_vperm2f128<mode>3. + (*avx_vperm2f128<mode>_nozero): New. + +2009-11-30 Richard Henderson <rth@redhat.com> + + * config/i386/i386-builtin-types.def (V4DF_FTYPE_V4DF_V4DF_V4DI): New. + (V8SF_FTYPE_V8SF_V8SF_V8SI): New. + * config/i386/i386.c (ix86_vectorize_builtin_vec_perm): Support + V4DF and V8SF for AVX; relax constraint on V4SF to SSE1 from SSE2. + (IX86_BUILTIN_VEC_PERM_V4DF, IX86_BUILTIN_VEC_PERM_V8SF): New. + (bdesc_args): Add them. + (ix86_expand_builtin): Expand them. + (expand_vec_perm_pshufb2): Only operate on 16-byte vectors. + +2009-11-30 Martin Jambor <mjambor@suse.cz> + + PR middle-end/42206 + * ipa-prop.c (ipa_write_node_info): Initialize note_count to zero. + +2009-11-30 Jakub Jelinek <jakub@redhat.com> + + * ipa-reference.c (propagate): Only dump bitmaps if computed. + +2009-11-30 Olga Golovanevsky <olga@il.ibm.com> + + PR middle-end/39806 + * ipa-struct-reorg.c (new_var_eq): Use DECL_UID to hash new variables. + (new_var_hash): Likewise. + (is_in_new_vars_htab): Likewise. + (add_to_new_vars_htab): Likewise. + +2009-11-30 Ira Rosen <irar@il.ibm.com> + + * tree-vect-stmts.c (vectorizable_assignment): Support + multiple types. + +2009-11-30 Richard Guenther <rguenther@suse.de> + + * doc/contrib.texi (Contributors): Add myself. + +2009-11-30 Richard Guenther <rguenther@suse.de> + + * tree.c (free_lang_data): Do not set debug_info_level to + none if terse. + +2009-11-30 Richard Guenther <rguenther@suse.de> + + PR middle-end/42119 + PR fortran/38530 + * expr.c (expand_expr_addr_expr_1): Properly expand the initializer + of CONST_DECLs. + +2009-11-30 Richard Guenther <rguenther@suse.de> + + * tree-into-ssa.c (insert_phi_nodes): Add PHI nodes in + variable UID order. + +2009-11-30 Richard Guenther <rguenther@suse.de> + + * tree-dump.c (dump_option_value_in): Add TDF_NOUID. + * tree-pass.h (TDF_NOUID): Likewise. + * print-rtl.c: Include tree-pass.h. + (print_mem_expr): Pass dump_flags. + (print_rtx): Likewise. + * print-tree.c: Include tree-pass.h. + (print_node_brief): Handle TDF_NOUID. + (print_node): Likewise. + * tree-pretty-print.c (dump_decl_name): Likewise. + (dump_generic_node): Likewise. + * Makefile.in (print-rtl.o, print-tree.o): Add $(TREE_PASS_H) + dependency. + +2009-11-30 Nick Clifton <nickc@redhat.com> + + * config/stormy16/stormy16-lib2-count-leading-zeros.c: Delete. + * config/stormy16/t-stormy16 (LIB2FUNCS_EXTRA): Remove + stormy16-lib2-count-leading-zeros.c. + * config/stormy16/stormy16-lib2.c (__clzhi2): Move code from + __stormy16_count_leading_zeros() into this function. + (__ctzhi2): Use __builtin_clz. + (__ffshi2): Likewise. + 2009-11-30 Eric Botcazou <ebotcazou@adacore.com> * config/sparc/sparc.c (DF_MODES): Simplify. @@ -63,7 +375,8 @@ (cgraph_expand_function): Handle thunks. (thunk_adjust): New. (init_lowered_empty_function): New. - * cp-objcp-common.h (LANG_HOOKS_CALLGRAPH_EMIT_ASSOCIATED_THUNKS): Remove. + * cp-objcp-common.h (LANG_HOOKS_CALLGRAPH_EMIT_ASSOCIATED_THUNKS): + Remove. * lto-cgraph.c (lto_output_node): Stream thunk info. (input_node): Likewise. * langhooks.h (lang_hooks_for_callgraph): Remove emit_associated_thunks. @@ -177,7 +490,7 @@ 2009-11-28 Andy Hutchinson <hutchinsonandy@gcc.gnu.org> - * config/avr/avr.h (ASM_OUTPUT_EXTERNAL): Add. + * config/avr/avr.h (ASM_OUTPUT_EXTERNAL): Add. 2009-11-28 David Binderman <dcb314@hotmail.com> @@ -197,9 +510,8 @@ 2009-11-27 Nick Clifton <nickc@redhat.com> - * longlong.h (count_leading_zeros): Define macro for stormy16 - target. - (COUNT_LEADING_ZEROS_0): Likewise. + * longlong.h (count_leading_zeros): Define macro for stormy16 target. + (COUNT_LEADING_ZEROS_0): Likewise. * config/stormy16/stormy16-lib2.c: Arrange for separate compilation of each function. (__ffshi2): New function. @@ -251,8 +563,7 @@ [SUPPORTS_WEAK && GTHREAD_USE_WEAK] (__gthread_active_p): Use __extension__ to allow cast from function pointer to object pointer in C++. - * doc/install.texi (--enable-threads): Clarify use of Solaris - threads. + * doc/install.texi (--enable-threads): Clarify use of Solaris threads. 2009-11-27 Steven Bosscher <steven@gcc.gnu.org> @@ -291,8 +602,7 @@ 2009-11-27 Andreas Krebbel <Andreas.Krebbel@de.ibm.com> - * emit-rtl.c (next_active_insn, prev_active_insn): Correct - comment. + * emit-rtl.c (next_active_insn, prev_active_insn): Correct comment. 2009-11-27 Jakub Jelinek <jakub@redhat.com> @@ -499,7 +809,7 @@ (struct builtin_description) <CODE_FOR_avx_vzeroupper_rex64>: Remove initailization. <CODE_FOR_avx_vzeroupper>: Unconditionally initialize here. - + 2009-11-25 Paul Brook <paul@codesourcery.com> * config/arm/arm.md (consttable_4): Handle (high ...). diff --git a/gcc/ChangeLog.graphite b/gcc/ChangeLog.graphite index 53ffd9359cd..3ae20755abf 100644 --- a/gcc/ChangeLog.graphite +++ b/gcc/ChangeLog.graphite @@ -1,3 +1,65 @@ +2009-11-29 Alexander Monakov <amonakov@gcc.gnu.org> + + * testsuite/g++.dg/graphite/pr42130.C: Correct testcase. + +2009-11-24 Tobias Grosser <grosser@fim.uni-passau.de> + + * graphite-clast-to-gimple.c (try_mark_loop_parallel, + graphite_create_new_loop_guard, translate_clast_for): Fix comments. + +2009-11-23 Tobias Grosser <grosser@fim.uni-passau.de> + + PR middle-end/42130 + * graphite-clast-to-gimple.c (graphite_create_new_loop_guard, + translate_clast_for_loop): New. + (translate_clast_for): Add a condition around the loop, to do not + execute loops with zero iterations. + * testsuite/g++.dg/graphite/pr42130.C: New. + * testsuite/gcc.dg/graphite/pr35356-2.c: Adapt. + +2009-11-23 Tobias Grosser <grosser@fim.uni-passau.de> + + * graphite-clast-to-gimple.c (try_mark_loop_parallel): New. + (translate_clast_for, translate_clast_guard, translate_clast, gloog): + Remove context_loop and level. + +2009-11-23 Tobias Grosser <grosser@fim.uni-passau.de> + + * graphite-clast-to-gimple.c (translate_clast_user, + translate_clast_for, translate_clast_guard): Simplify and move common + elements to translate_clast(). + (translate_clast): Simplify and get common elements. + +2009-11-23 Tobias Grosser <grosser@fim.uni-passau.de> + + * graphite-clast-to-gimple.c (translate_clast_user, + translate_clast_for, translate_clast_guard): Split out of + translate_clast. + +2009-11-21 Tobias Grosser <grosser@fim.uni-passau.de> + + * graphite-clast-to-gimple.c (clast_name_index, new_clast_name_index, + clast_name_to_index, save_clast_name_index, debug_clast_name_index, + debug_clast_name_indexes_1, debug_clast_name_indexes, + clast_name_index_elt_info, eq_clast_name_indexes): Moved from sese.h. + (clast_name_to_gcc, clast_to_gcc_expression, + clast_to_gcc_expression_red, gcc_type_for_clast_expr, + gcc_type_for_clast_eq, graphite_translate_clast_equation, + graphite_create_guard_cond_expr, graphite_create_new_loop, + translate_clast): Add params_index. + (initialize_cloog_names): Create parameter strings from scratch, do + not reference other strings. + (create_params_index): New. + (gloog): Initialize params_index. + * graphite-scop-detection (free_scops_1): Removed. + (limit_scops): Use normal free_scops. + * graphite-sese-to-poly.c (save_var_names): Removed. + (parameter_index_in_region): Do not initialize SESE_PARAM_NAMES + and SESE_PARAMS_INDEX. + * sese.c (new_sese, free_sese): Dito. + * sese.h (struct sese): Remove params_index, params_names. + (SESE_PARAMS_INDEX, SESE_PARAMS_NAMES): Removed. + 2009-11-20 Sebastian Pop <sebastian.pop@amd.com> Revert the following patch from 2009-09-14: diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index a41965d584c..e1c821eb5f4 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20091130 +20091202 diff --git a/gcc/Makefile.in b/gcc/Makefile.in index 80ed24b278c..a46860f0276 100644 --- a/gcc/Makefile.in +++ b/gcc/Makefile.in @@ -954,7 +954,8 @@ TREE_VECTORIZER_H = tree-vectorizer.h $(TREE_DATA_REF_H) IPA_PROP_H = ipa-prop.h $(TREE_H) vec.h $(CGRAPH_H) GSTAB_H = gstab.h stab.def BITMAP_H = bitmap.h $(HASHTAB_H) statistics.h -GCC_PLUGIN_H = gcc-plugin.h $(CONFIG_H) $(SYSTEM_H) +GCC_PLUGIN_H = gcc-plugin.h highlev-plugin-common.h $(CONFIG_H) $(SYSTEM_H) \ + $(HASHTAB_H) PLUGIN_H = plugin.h $(GCC_PLUGIN_H) PLUGIN_VERSION_H = plugin-version.h configargs.h @@ -2287,7 +2288,7 @@ tree-inline.o : tree-inline.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ $(IPA_PROP_H) value-prof.h $(TREE_PASS_H) $(TARGET_H) $(INTEGRATE_H) print-tree.o : print-tree.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ $(GGC_H) langhooks.h $(REAL_H) tree-iterator.h fixed-value.h \ - $(DIAGNOSTIC_H) $(TREE_FLOW_H) + $(DIAGNOSTIC_H) $(TREE_FLOW_H) $(TREE_PASS_H) stor-layout.o : stor-layout.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ $(TREE_H) $(PARAMS_H) $(FLAGS_H) $(FUNCTION_H) $(EXPR_H) output.h $(RTL_H) \ $(GGC_H) $(TM_P_H) $(TARGET_H) langhooks.h $(REGS_H) gt-stor-layout.h \ @@ -2526,8 +2527,9 @@ tree-ssa-reassoc.o : tree-ssa-reassoc.c $(TREE_FLOW_H) $(CONFIG_H) \ langhooks.h alloc-pool.h pointer-set.h $(CFGLOOP_H) tree-optimize.o : tree-optimize.c $(TREE_FLOW_H) $(CONFIG_H) $(SYSTEM_H) \ $(RTL_H) $(TREE_H) $(TM_P_H) hard-reg-set.h $(EXPR_H) $(GGC_H) output.h \ - $(DIAGNOSTIC_H) $(BASIC_BLOCK_H) $(FLAGS_H) $(TIMEVAR_H) $(TM_H) coretypes.h \ - $(TREE_DUMP_H) $(TOPLEV_H) $(FUNCTION_H) langhooks.h $(FLAGS_H) $(CGRAPH_H) \ + $(DIAGNOSTIC_H) $(BASIC_BLOCK_H) $(FLAGS_H) $(TIMEVAR_H) $(TM_H) \ + coretypes.h $(TREE_DUMP_H) $(TOPLEV_H) $(FUNCTION_H) langhooks.h \ + $(FLAGS_H) $(CGRAPH_H) $(PLUGIN_H) \ $(TREE_INLINE_H) tree-mudflap.h $(GGC_H) graph.h $(CGRAPH_H) \ $(TREE_PASS_H) $(CFGLOOP_H) $(EXCEPT_H) @@ -2768,7 +2770,8 @@ passes.o : passes.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ langhooks.h insn-flags.h $(CFGLAYOUT_H) $(REAL_H) $(CFGLOOP_H) \ hosthooks.h $(CGRAPH_H) $(COVERAGE_H) $(TREE_PASS_H) $(TREE_DUMP_H) \ $(GGC_H) $(INTEGRATE_H) $(CPPLIB_H) opts.h $(TREE_FLOW_H) $(TREE_INLINE_H) \ - gt-passes.h $(DF_H) $(PREDICT_H) $(LTO_HEADER_H) $(LTO_SECTION_OUT_H) + gt-passes.h $(DF_H) $(PREDICT_H) $(LTO_HEADER_H) $(LTO_SECTION_OUT_H) \ + $(PLUGIN_H) plugin.o : plugin.c $(PLUGIN_H) $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TOPLEV_H) $(TREE_H) $(TREE_PASS_H) intl.h $(PLUGIN_VERSION_H) $(GGC_H) @@ -2787,7 +2790,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) $(DIAGNOSTIC_H) cselib.h + $(BCONFIG_H) $(REAL_H) $(DIAGNOSTIC_H) cselib.h $(TREE_PASS_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) \ @@ -4333,7 +4336,7 @@ installdirs: PLUGIN_HEADERS = $(TREE_H) $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ $(TOPLEV_H) $(BASIC_BLOCK_H) $(GIMPLE_H) $(TREE_PASS_H) $(GCC_PLUGIN_H) \ - $(GGC_H) $(TREE_DUMP_H) $(PRETTY_PRINT_H) \ + $(GGC_H) $(TREE_DUMP_H) $(PRETTY_PRINT_H) opts.h $(PARAMS_H) plugin.def \ $(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) $(DIAGNOSTIC_H) $(C_COMMON_H) $(C_PRETTY_PRINT_H) \ @@ -4345,8 +4348,15 @@ PLUGIN_HEADERS = $(TREE_H) $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ ## extra MELT required plugin headers! MELT_PLUGIN_HEADERS= melt-runtime.h run-melt.h melt-predef.h +# generate the 'build fragment' b-header-vars +s-header-vars: Makefile + rm -f tmp-header-vars + $(foreach header_var,$(shell sed < Makefile -e 's/^\([A-Z0-9_]*_H\)[ ]*=.*/\1/p' -e d),echo $(header_var)=$(shell echo $($(header_var):$(srcdir)/%=.../%) | sed -e 's~\.\.\./config/~config/~' -e 's~\.\.\..*/~~') >> tmp-header-vars;) \ + $(SHELL) $(srcdir)/../move-if-change tmp-header-vars b-header-vars + $(STAMP) s-header-vars + # Install the headers needed to build a plugin. -install-plugin: installdirs lang.install-plugin +install-plugin: installdirs lang.install-plugin s-header-vars # 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) @@ -4370,6 +4380,7 @@ install-plugin: installdirs lang.install-plugin $(mkinstalldirs) $(DESTDIR)$$dir; \ $(INSTALL_DATA) $$path $(DESTDIR)$$dest; \ done + $(INSTALL_DATA) b-header-vars $(DESTDIR)$(plugin_includedir)/b-header-vars # Install the compiler executables built during cross compilation. install-common: native lang.install-common installdirs diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 298dda24736..4c928457077 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,804 @@ +2009-12-01 Pascal Obry <obry@adacore.com> + + * s-osprim-mingw.adb (Get_Base_Time): Make sure that the base time is + taken at a clock tick boundary. + +2009-12-01 Thomas Quinot <quinot@adacore.com> + + * g-sechas.ads (GNAT.Secure_Hashes.H."=" on Context): Make abstract. + +2009-12-01 Matthew Gingell <gingell@adacore.com> + + * adadecode.c: Allow compilation when building the run time in the gnat + runtime. + (__gnat_decode): Strip the .nnnn suffix from names of nested functions. + + * gcc-interface/Makefile.in: Ada adadecode to LIBGNAT_SRCS and + LIBGNAT_OBJS. + +2009-12-01 Vincent Celier <celier@adacore.com> + + * gnatcmd.adb (Check_Files): Quote the path names as they may include + spaces. + +2009-12-01 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): If the defining identifier + has already been declared, it may have been rewritten as a renaming + declaration. + +2009-12-01 Ed Schonberg <schonberg@adacore.com> + + * einfo.ads: Clarify use of Is_Private_Primitive. + * sem_ch6.adb (Analyze_Subprogram_Declaration): An operation is a + private primitive operation only if it is declared in the scope of the + private controlling type. + * exp_ch9.adb (Build_Wrapper_Spec): Build wrappers for private + protected operations as well. + +2009-12-01 Arnaud Charlet <charlet@adacore.com> + + * gnat1drv.adb (Adjust_Global_Switches): Disable front-end + optimizations in CodePeer mode, to keep the tree as close to the source + code as possible, and also to avoid inconsistencies between trees when + using different optimization switches. + +2009-12-01 Thomas Quinot <quinot@adacore.com> + + * scos.ads: Updated specification of source coverage obligation + information. + +2009-12-01 Thomas Quinot <quinot@adacore.com> + + * g-sercom.ads, g-sercom-mingw.adb, g-sercom-linux.adb, + a-ststio.adb, s-commun.adb, s-commun.ads, g-socket.adb, + g-socket.ads (System.Communications.Last_Index): For the case where no + element has been transferred and Item'First = + Stream_Element_Offset'First, raise CONSTRAINT_ERROR. + +2009-12-01 Ed Schonberg <schonberg@adacore.com> + + * sem_ch10.adb (Install_Siblings): A private with_clause on some child + unit U in an ancestor of the current unit must be ignored if the + current unit has a regular with_clause on U. + +2009-11-30 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + * s-oscons-tmplt.c [__mips && __sgi]: Only define _XOPEN5, IOV_MAX + if _XOPEN_IOV_MAX is defined. + +2009-11-30 Vasiliy Fofanov <fofanov@adacore.com> + + * vms_data.ads: Add new VMS qualifiers, + REVERSE_BIT_ORDER/NOREVERSE_BIT_ORDER, to support warnings on bit order + effects. + +2009-11-30 Thomas Quinot <quinot@adacore.com> + + * exp_ch9.adb, exp_ch9.ads, sem_util.ads: Minor reformatting. + +2009-11-30 Gary Dismukes <dismukes@adacore.com> + + * sem_prag.adb: Fix spelling error. + +2009-11-30 Ed Schonberg <schonberg@adacore.com> + + * exp_ch9.ads (Build_Private_Protected_Declaration): For a protected + operation that is only declared in a protected body, create a + corresponding subprogram declaration. + * exp_ch9.adb (Expand_N_Protected_Body): Create protected body of + operation in all cases, including for an operation that is only + declared in the body. + * sem_ch6.adb: Call Build_Private_Protected_Declaration + * exp_ch6.adb (Expand_N_Subprogram_Declaration): For an operation + declared in a protected body, create the declaration for the + corresponding protected version of the operation. + +2009-11-30 Arnaud Charlet <charlet@adacore.com> + + * gnat1drv.adb (Adjust_Global_Switches): Disable specific expansions + for Restrictions pragmas, to avoid tree inconsistencies between + compilations with different pragmas. + +2009-11-30 Jerome Lambourg <lambourg@adacore.com> + + * sem_prag.adb (Check_Duplicated_Export_Name): Allow entities exported + to CIL to have duplicated export name. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * a-tiinio.adb: Remove extraneous pragma Warnings (Off). + +2009-11-30 Thomas Quinot <quinot@adacore.com> + + * par_sco.adb: Minor reformatting + +2009-11-30 Ed Falis <falis@adacore.com> + + * s-vxwext.ad[s,b], system-vxworks-ppc.ads, s-stchop-vxworks.adb: + Comment update. + +2009-11-30 Ed Schonberg <schonberg@adacore.com> + + * par_sco.adb (Traverse_Handled_Statement_Sequence): Do not emit SCO's + for null statements that do not come from source. + * sinfo.ads: Clarify documentation of Comes_From_Source + +2009-11-30 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Add_Source): Use Display_Name for both projects when + displaying the paths in error message. + +2009-11-30 Emmanuel Briot <briot@adacore.com> + + * adaint.h, adaint.c (file_attributes): force the use of unsigned char. + On some platforms, "char" is signed, on others unsigned, so we + explicitly specify the one we expect + +2009-11-30 Matthew Heaney <heaney@adacore.com> + + * a-coinve.adb (Insert): Move exception handler closer to point where + exception can occur. + Minor reformatting & comment additions. + +2009-11-30 Arnaud Charlet <charlet@adacore.com> + + * freeze.adb (Freeze_Entity): Disable warning on 'Foreign caller must + pass bounds' for VM targets, not relevant. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * sem_util.adb (Wrong_Type): Diagnose additional case of modular + missing parens. + * a-tiinio.adb, a-wtinio.adb, a-ztinio.adb: Minor reformatting + + * exp_util.adb (Kill_Dead_Code): Suppress warning for some additional + cases. + + * sem_warn.adb (Set_Warning_Flag): Clean up gnatwA list and ensure + completeness. + (Set_Dot_Warning_Flag): Ditto for -gnatw.e + (Set_Dot_Warning_Flag): Implement -gnbatw.v/w.V + * usage.adb: Add lines for -gnatw.v/w.V + +2009-11-30 Emmanuel Briot <briot@adacore.com> + + * make.adb (Check_Standard_Library): use Full_Source_Name instead of + direct call to Find_File. The former provides caching of the results, so + might be more efficient + (Start_Compile_If_Necessary): Add comment on possible optimization, + not done for now. + +2009-11-30 Thomas Quinot <quinot@adacore.com> + + * g-sechas.adb: Minor reformatting + +2009-11-30 Matthew Heaney <heaney@adacore.com> + + * a-crbtgo.adb (Delete_Fixup): Add comments explaining why predicates + were removed. + * a-cdlili.adb (Vet): Remove always-true predicates. + +2009-11-30 Thomas Quinot <quinot@adacore.com> + + * s-sechas.adb, s-sechas.ads, s-shshco.adb, s-shshco.ads, s-shsh64.adb, + s-shsh64.ads, s-sehamd.adb, s-sehamd.ads, s-shsh32.adb, s-shsh32.ads, + s-sehash.adb, s-sehash.ads, g-sechas.adb, g-sechas.ads, g-shshco.adb, + g-shshco.ads, g-md5.ads, g-sha256.ads, g-shsh64.adb, g-shsh64.ads, + g-sehamd.adb, g-sehamd.ads, g-sha512.ads, g-sha1.ads, Makefile.rtl, + g-sha224.ads, g-shsh32.adb, g-shsh32.ads, g-sha384.ads, g-sehash.adb, + g-sehash.ads: Rename System.Secure_Hashes to GNAT.Secure_Hashes. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * osint.ads: Minor comment update. + +2009-11-30 Thomas Quinot <quinot@adacore.com> + + * s-sechas.adb: Fix swapping error in previous checkin. + * g-md5.ads, g-sha256.ads, g-sha512.ads, g-sha1.ads, g-sha224.ads, + g-sha384.ads: Add missing documentation. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * g-sha256.ads, s-sehamd.ads, s-sehamd.adb, g-sha512.ads, g-sha224.ads, + g-sha384.ads: Minor reformatting + +2009-11-30 Emmanuel Briot <briot@adacore.com> + + * adaint.h (file_attributes): Reduce size of the structure, so that it + is less costly to store in records. + * makeutl.adb: + (Check_Source_Info_In_ALI): use Full_Source_Name instead of a direct + call to Find_File, since the former provides caching when appropriate, + which limits the number of system calls in some cases. + * osint.ads, prj.ads (Source_Data): do not store directly the timestamp, + but the file attributes since we also need access to the size of the + ALI file to parse it. This gives an opportunity for saving system calls + on Unix systems. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb, s-sechas.ads, s-sechas.adb: Minor reformatting. + +2009-11-30 Gary Dismukes <dismukes@adacore.com> + + * sem_prag.adb (Process_Convention): Change formal E to Ent. In the + case where the pragma's entity argument is a renaming, return the + entity denoted by the renaming rather than the renamed entity. Loop + through the homonyms of the original argument entity, rather than the + homonyms of any renamed entity. Correct call to Generate_Entity to + pass the homonym. + +2009-11-30 Vincent Celier <celier@adacore.com> + + * impunit.adb: Add packages that were added to the GNAT library: + GNAT.SHA224, GNAT.SHA256, GNAT.SHA384 and GNAT.SHA512. + * s-sechas.adb (Fill_Buffer_Copy): Fixes incorrect slice index + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * exp_ch3.adb: Minor reformatting + * g-md5.ads, g-sha1.ads: Add comment. + +2009-11-30 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Makefile.in: Remove handling of libgccprefix, no longer + needed. + +2009-11-30 Pascal Obry <obry@adacore.com> + + * expect.c: Fix cast to avoid warnings in x86-64 Windows. + +2009-11-30 Thomas Quinot <quinot@adacore.com> + + * gnat_rm.texi, s-sechas.adb, s-sechas.ads, s-shshco.adb, + s-shshco.ads, g-md5.adb, g-md5.ads, g-sha256.ads, s-shsh64.adb, + s-shsh64.ads, s-sehamd.adb, s-sehamd.ads, g-sha512.ads, g-sha1.adb, + g-sha1.ads, Makefile.rtl, g-sha224.ads, g-sha384.ads, s-shsh32.adb, + s-shsh32.ads, s-sehash.adb, s-sehash.ads: Reimplementation of GNAT.MD5 + and GNAT.SHA1 to factor shared code and avoid unnecessary stack copies. + Also introduce new functions SHA-{224,256,384,512} + +2009-11-30 Jerome Lambourg <lambourg@adacore.com> + + * exp_ch3.adb (Make_Predefined_Primitive_Specs): Improve comment for + the Value_Type case. + +2009-11-30 Thomas Quinot <quinot@adacore.com> + + * a-textio.adb: Minor reformatting + +2009-11-30 Pascal Obry <obry@adacore.com> + + * adaint.c: Fix bug in passing parameter. + * expect.c: Include io.h to get definition of _open_osfhandle + +2009-11-30 Javier Miranda <miranda@adacore.com> + + * exp_ch6.adb, sem_scil.adb (Adjust_SCIL_Node): Add missing management + of N_Unchecked_Type_Conversion nodes when searching for SCIL nodes. + (Expand_Call): Adjust decoration of SCIL node associated with relocated + function call. + +2009-11-30 Emmanuel Briot <briot@adacore.com> + + * prj-env.adb (Add_To_Source_Path): Preserve casing of directories + +2009-11-30 Vincent Celier <celier@adacore.com> + + * opt.ads (No_Split_Units): New flag initialized to False + +2009-11-30 Jerome Lambourg <lambourg@adacore.com> + + * exp_ch7.adb (Needs_Finalization): Add comments. + * exp_ch3.adb (Make_Predefined_Primitive_Specs): Improve handling of + CIL Value types. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * osint.adb, a-rttiev.adb: Minor reformatting. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Remove list of warning letters, and refer instead to + using gnatmake to get a brief list. + + * debug.adb: Document -gnatd.i to disable pragma Warnings + * par-prag.adb, sem_prag.adb: Recognize -gnatd.i to disable Warnings + pragma. + * vms_data.ads: Add /NOWARNINGS_PRAGMS for -gnatd.i + +2009-11-30 Geert Bosch <bosch@adacore.com> + + * a-ngelfu.adb (Sin): Correct spelling of sine in comment. + +2009-11-30 Vincent Celier <celier@adacore.com> + + * gnatls.adb: Do not call Get_Target_Parameters in Verbose_Mode, as it + is not needed and gnatls fails when called with -v -nostdinc. + +2009-11-30 Emmanuel Briot <briot@adacore.com> + + * osint.adb, osint.ads (File_Time_Stamp): new subprogram. + +2009-11-30 Ed Schonberg <schonberg@adacore.com> + + * gnat_rm.texi, gnat_ugn.texi: Document new syntax for pragma Annotate + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * scans.ads (Wide_Wide_Character_Found): New flag + * scn.adb (Post_Scan): Set new flag Has_Wide_Wide_Character + * scng.adb (Set_String): Set new flag Wide_Wide_Character_Found + (Set_String): Fix failure to reset Wide_Character_Found + * sinfo.adb (Has_Wide_Wide_Character): New flag in N_String_Literal + * sinfo.ads (Has_Wide_Wide_Character): New flag in N_String_Literal + * a-ngelfu.adb: Minor reformatting & code reorganization. + * usage.adb: Fix typo in -gnatw.W line + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * osint.adb, prj-nmsc.adb, sem_prag.adb, sem_util.adb: Minor + reformatting. + * csinfo.adb: Terminate run if improper use of reserved flag + * sinfo.ads, sinfo.adb (Is_Accessibility_Actual): Don't use reserved + Flag12, used Flag13 instead. + +2009-11-30 Vincent Celier <celier@adacore.com> + + * gnatcmd.adb (Check_Files): Recognize documented switches that have a + separate parameter. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * sem_util.ads: Minor reformatting + * errout.adb: Minor reformatting + Minor code reorganization (use N_Subprogram_Specification to simplify) + * exp_ch7.adb: Add comment. + +2009-11-30 Thomas Quinot <quinot@adacore.com> + + * put_scos.adb (Put_SCOs): Do not generate a SCO unit header for a unit + that has no SCOs. + * scos.ads: Minor reformatting + +2009-11-30 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb: Second unanalyzed parameter of Annotate is optional. + +2009-11-30 Eric Botcazou <ebotcazou@adacore.com> + + * init.c (__gnat_adjust_context_for_raise, Linux version): Add guard + for null PC saved in the context. + +2009-11-30 Hristian Kirtchev <kirtchev@adacore.com> + + * a-calend.adb (Day_Of_Week): Rewritten. The routine determines the + number of days from the Ada Epoch to the input date while ensuring that + both dates are in the same time zone. + +2009-11-30 Emmanuel Briot <briot@adacore.com> + + * clean.adb ("-eL"): Also set Follow_Links_For_Dirs, to match what is + done in other project-aware tools like gnatmake and gprbuild. + +2009-11-30 Jerome Lambourg <lambourg@adacore.com> + + * exp_ch3.adb (Make_Predefined_Primitive_Specs): Take care of CIL + ValueTypes. + * exp_ch7.adb (Needs_Finalization): Do not finalize CIL valuetypes. + * sem_util.adb (Is_Value_Type): Protect against invalid calls to Chars + (Is_Delegate): New method used for CIL. + * sem_util.ads (Is_Delegate): New method for CIL handling. + (Is_Value_Type): Improve documentation. + +2009-11-30 Ed Schonberg <schonberg@adacore.com> + + * errout.adb (Unwind_Internal_Type): Improve error reporting if the + type is an anonymous access to subprogram that is the type of a formal + in a subprogram spec. + +2009-11-30 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Check_Interfaces): In a Stand-Alone Library project, if + attribute Interfaces is not declared, then Library_Interface should + define the interfaces. + +2009-11-30 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb: New semantics for Annotate. + +2009-11-30 Tristan Gingold <gingold@adacore.com> + + * gcc-interface/Makefile.in: Do not link with -static-libgcc on Darwin. + +2009-11-30 Emmanuel Briot <briot@adacore.com> + + * gnat_ugn.texi: Extend doc for -eL + +2009-11-30 Vincent Celier <celier@adacore.com> + + * osint.adb (Executable_Name (File_Name_Type)): Put the Name in the + Name_Buffer before testing for a dot in the Name. + +2009-11-30 Vincent Celier <celier@adacore.com> + + * prj-part.adb (Project_Path_Name_Of): Resolve links for final result + if -eL has been specified. + +2009-11-30 Vincent Celier <celier@adacore.com> + + * osint.adb (Executable_Name): Test the name instead of the name buffer + to check if there is a dot in the given name. + +2009-11-30 Sergey Rybin <rybin@adacore.com> + + * gnat_ugn.texi: Update gnatcheck doc. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * sem_ch3.adb, sem_disp.adb, usage.adb: Minor reformatting + +2009-11-30 Vasiliy Fofanov <fofanov@adacore.com> + + * gnat_ugn.texi: Minor editing. + +2009-11-30 Emmanuel Briot <briot@adacore.com> + + * prj-nmsc.adb (Search_Directories): when -eL was not specified, assume + that no directory matches the naming scheme for sources. + +2009-11-30 Emmanuel Briot <briot@adacore.com> + + * prj.adb, prj.ads, prj-nmsc.adb (Has_Multi_Unit_Sources): New field in + project_data. + +2009-11-30 Vincent Celier <celier@adacore.com> + + * osint.adb (Executable_Name): Correctly decide if the executable + suffix should be added when Only_If_No_Suffix is True. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * frontend.adb, gnatlink.adb, prj-conf.adb, prj-tree.adb, + prj-tree.ads: Minor reformatting + +2009-11-30 Vincent Celier <celier@adacore.com> + + * gnatlink.adb (Process_Args): Call Executable_Name on argument of -o + with Only_If_No_Suffix set to True. + * osint.adb (Executable_Name): Do not add executable suffix if there is + already a suffix and Only_If_No_Suffix is True. + * osint.ads (Executable_Name): New Boolean parameter Only_If_No_Suffix, + defaulted to False. + +2009-11-30 Javier Miranda <miranda@adacore.com> + + * exp_atag.adb (Build_TSD): Change argument name because the actual is + now the address of a tag (instead of the tag). Update implementation + accordingly. + (Build_CW_Membership): New implementation. Converted into a procedure + because it has an additional out mode parameter. Its implementation has + been rewritten to improve the generated code but also to facilitate + referencing the relocated object node in the caller. + * exp_atag.ads (Build_CW_Membership): Update profile and documentation. + * sinfo.ads (N_SCIL_Membership_Test) New_Node. + (SCIL_Tag_Value): New field of N_SCIL_Membership_Test nodes. + (Is_Syntactic_Field): Add entry of new node. + (SCIL_Tag_Value/Set_SCIL_Tag_Value): New subprograms. + * sinfo.adb (SCIL_Related_Node, SCIL_Entity): Update assertions to + handle N_SCIL_Membership_Test nodes. + (SCIL_Tag_Value/Set_SCIL_Tag_Value): New subprograms. + * sem.adb (Analyze): Add null management for new node. + * sem_scil.adb (Find_SCIL_Node): Add null management for new node. + (Check_SCIL_Node): Add checks of N_SCIL_Membership_Test nodes. + * exp_ch4.adb (Tagged_Membership): Change profile from function to + procedure. Add generation of SCIL node associated with class-wide + membership test. + (Expand_N_In): Complete decoration of SCIL nodes. + * exp_intr.adb (Expand_Dispatching_Constructor_Call): Tune call to + Build_CW_Membership because its profile has been changed. + * exp_util.adb (Insert_Actions): Add null management for new node. + * sprint.adb (Sprint_Node_Actual): Handle new node. + * gcc-interface/trans.c Add no processing for N_SCIL_Membership_Test + nodes. + * gcc-interface/Make-lang.in: Update dependencies. + +2009-11-30 Ed Schonberg <schonberg@adacore.com> + + * opt.ads: New flags Init_Or_Norm_Scalars_Config, + Initialize_Scalars_Config, to capture the presence of the corresponding + pragmas in a configuration file. + * opt.adb (Register_, Save_, Set_, Restore_Opt_Configuration_Switches): + handle new flags so that they are restored for each compilation unit. + * frontend.adb: At the end of compilation, scan the context of the main + unit to recover occurrences of pragma Initialize_Scalars, to annotate + the ALI file accordingly. + +2009-11-30 Vincent Celier <celier@adacore.com> + + * prj-tree.ads: Minor comment updates + * prj-tree.adb: Minor reformatting + +2009-11-30 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Derive_Subprogram): Indicate that an inherited + predefined control operation is hidden if the parent type is not + visibly controlled. + * sem_ch6.adb (Check_Overriding_Indicator): Do not report error if + overridden operation is not visible, as may be the case with predefined + control operations. + * sem_disp.adb (Check_Dispatching_Operation): Do not emit warning on + non-overriding control operation when type is not visibly controlled, + if the subprogram has an explicit overriding indicator. + * sem_util.ads, sem_util.adb (Is_Visibly_Controlled): Moved here from + sem_disp.adb. + +2009-11-30 Emmanuel Briot <briot@adacore.com> + + * prj-tree.adb (Create_Attribute): Fix handling of VMS and Windows + * prj-attr.ads: Minor comment updates + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Document pragma Short_Circuit + +2009-11-30 Emmanuel Briot <briot@adacore.com> + + * prj-conf.adb, prj-tree.adb, prj-tree.ads (Create_Attribute): Now set + the index either on the attribute or on its value, depending on the + kind of the attribute. Done to match recent changes in Prj.PP that were + not synchronized with this function. + +2009-11-30 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Make-lang.in: Fix typo. + Update dependencies. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Add documentation for attribute Result. + +2009-11-30 Arnaud Charlet <charlet@adacore.com> + + * s-osinte-hpux.ads, s-osinte-aix.ads, s-osinte-solaris-posix.ads, + s-osinte-tru64.ads, s-osinte-darwin.ads, s-osinte-freebsd.ads + (Get_Page_Size): Update comment since Get_Page_Size is now required. + +2009-11-30 Jerome Lambourg <lambourg@adacore.com> + + * freeze.adb: Disable Warning on VM targets concerning C Imports, not + relevant. + +2009-11-30 Bob Duff <duff@adacore.com> + + * sprint.adb (Source_Dump): Minor comment fix. + (Write_Itype): When writing a string literal subtype, use Expr_Value + instead of Intval to get the low bound. + +2009-11-30 Vincent Celier <celier@adacore.com> + + * gnatlink.adb (Process_Args): Do not call Executable_Name on arguments + of switch -o. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * exp_ch4.adb (Expand_N_Op_And): Implement pragma Short_Circuit_And_Or + (Expand_N_Op_Or): Implement pragma Short_Circuit_And_Or + * opt.ads (Short_Circuit_And_Or): New flag + * par-prag.adb: Add dummy entry for pragma Short_Circuit_And_Or + * sem_prag.adb: Implement pragma Short_Circuit_And_Or + * snames.ads-tmpl: Add entries for pragma Short_Circuit_And_Or + +2009-11-30 Arnaud Charlet <charlet@adacore.com> + + * s-taprop-posix.adb: Fix casing. + * s-osinte-tru64.adb: Complete previous check-in. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Document pragma Compiler_Unit + * s-bitops.adb, s-restri.adb, g-htable.adb, s-restri.ads, + a-comlin.ads, a-strhas.ads, s-strhas.adb, s-parame.adb, + s-parame.ads, a-clrefi.adb, a-clrefi.ads, a-ioexce.ads: Supply missing + Compiler_Unit pragmas. + * freeze.adb (Freeze_Entity): Improve message for 8-bit boolean passed + to C. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * makeutl.adb, makeutl.ads, prj-proc.adb, prj.adb, prj.ads: Minor + reformatting. + +2009-11-30 Thomas Quinot <quinot@adacore.com> + + * osint.adb: Minor reformatting + +2009-11-30 Vincent Celier <celier@adacore.com> + + * makeutl.ads, makeutl.adb (Base_Name_Index_For): New function to get + the base name of a main without the extension, with an eventual source + index. + (Mains.Get_Index): New procedure to set the source index of a main + (Mains.Get_Index): New function to get the source index of a main + * prj-attr.adb: New attributes Config_Body_File_Name_Index, + Config_Spec_File_Name_Index, Multi_Unit_Object_Separator and + Multi_Unit_Switches. + * prj-nmsc.adb (Process_Compiler): Takle into account new attributes + Config_Body_File_Name_Index, Config_Spec_File_Name_Index, + Multi_Unit_Object_Separator and Multi_Unit_Switches. + Allow only one character for Multi_Unit_Object_Separator. + * prj-proc.adb (Process_Declarative_Items): Take into account the + source indexes in indexes of associative array attribute declarations. + * prj.adb (Object_Name): New function to get the object file name for + units in multi-unit sources. + * prj.ads (Language_Config): New components Multi_Unit_Switches, + Multi_Unit_Object_Separator Config_Body_Index and Config_Spec_Index. + (Object_Name): New function to get the object file name for units in + multi-unit sources. + * snames.ads-tmpl: New standard names Config_Body_File_Name_Index, + Config_Spec_File_Name_Index, Multi_Unit_Object_Separator and + Multi_Unit_Switches. + +2009-11-30 Arnaud Charlet <charlet@adacore.com> + + * s-tassta.adb: Update comment. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * a-ngelfu.adb: Minor code reorganization. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * osint.ads, prj.adb, prj.ads: Minor reformatting + * s-stchop.adb, s-taprop-vxworks.adb, s-taprop-tru64.adb, + s-taprop-vms.adb, s-taprop-linux.adb, s-taprop-solaris.adb, + s-strxdr.adb, s-taprop-irix.adb, s-osinte-hpux-dce.adb, + s-osinte-tru64.adb, s-taenca.adb, s-taprop-hpux-dce.adb, s-stausa.adb, + s-taprop-posix.adb: Minor code reorganization (use conditional + expressions). + +2009-11-30 Bob Duff <duff@adacore.com> + + * g-sttsne-locking.adb (Copy_Service_Entry): Complete previous change. + +2009-11-30 Bob Duff <duff@adacore.com> + + * socket.c: Add more accessor functions for struct servent (need + setters as well as getters). + * g-sothco.ads (Servent): Declare interfaces to C setter functions for + struct servent. + * g-sttsne-locking.adb (Copy_Service_Entry): Use setter functions for + struct servent. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * s-stchop-vxworks.adb: Add comment. + +2009-11-30 Emmanuel Briot <briot@adacore.com> + + * make.adb, prj.adb, prj.ads (Compute_All_Imported_Projects): Now acts + on the whole tree, to better share code with gprbuild. + (Length): New subprogram, to share code in gprbuild. + (Project_Data): Remove fields that are only needed when compiling a + project in gprbuild (where we use local variables instead) + * osint.adb, osint.ads: Added minor comment on memory management + +2009-11-30 Sergey Rybin <rybin@adacore.com> + + * gnat_ugn.texi: Update gnatcheck doc. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + make.adb, prj-makr.adb, g-sothco.ads: Minor reformattting + * s-taprop-dummy.adb: Minor code reorganization (raise with msgs start + with lower case). + * i-vxwoio.adb, g-dirope.adb, g-sercom-linux.adb, + g-enblsp-vms-alpha.adb, g-regist.adb, s-imgcha.adb, s-tarest.adb, + s-taprop-mingw.adb, g-exctra.adb, g-expect.adb, g-comlin.adb, + g-debpoo.adb, g-expect-vms.adb, g-pehage.adb, g-trasym-vms-alpha.adb, + g-enblsp-vms-ia64.adb, s-fatgen.adb, s-fileio.adb: Minor code + reorganization (use conditional expressions). + +2009-11-30 Vincent Celier <celier@adacore.com> + + * prj-makr.adb (Source_Files): New hash table to keep track of source + file names. + (Finalize): Avoid putting several times the same source file name + in the source list file. + * prj-pp.adb (Print): Fix a bug in the placement of "at nn" for + associative array indexes. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * g-dyntab.ads: Add missing pragma Compiler_Unit + +2009-11-30 Thomas Quinot <quinot@adacore.com> + + * s-crtrun.ads, s-crtl.ads, g-stseme.adb, Makefile.rtl, s-fileio.adb + (System.CRTL.Runtime): New unit, to contain parts of s-crtl that are + used in the Ada runtime but can't be used in the compiler because of + bootstrap issues. + * socket.c, s-oscons-tmplt.c, g-sothco.ads + (System.OS_Constants.SIZEOF_struct_servent): New constant. + Use s-oscons constant instead of external variable to get size of + struct hostent. + +2009-11-30 Thomas Quinot <quinot@adacore.com> + + * s-crtl.ads, g-stseme.adb, s-fileio.adb (System.CRTL.strerror): Change + return type to Interfaces.C.Strings.chars_ptr to eliminate need for + dubious unchecked conversion at call sites. + * s-errrep.adb, s-errrep.ads, Makefile.rtl (System.Error_Reporting): + Remove obsolete, unused runtime unit. + * gcc-interface/Make-lang.in: Update dependencies. + * gcc-interface/Makefile.in: Remove VMS specialization of s-crtl, not + required anymore. + +2009-11-30 Vincent Celier <celier@adacore.com> + + * gnatlink.adb: Delete an eventual existing executable file, in case it + is a symbolic link, to avoid modifying the target of the symbolic link. + +2009-11-30 Bob Duff <duff@adacore.com> + + * socket.c: Add accessor functions for struct servent. + * g-sothco.ads (Servent): Declare interfaces to C accessor functions + for struct servent. + * g-socket.adb (To_Service_Entry): Use accessor functions for struct + servent. + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * g-arrspl.adb: Minor reformatting + * g-dyntab.adb: Add missing pragma Compiler_Unit + +2009-11-30 Thomas Quinot <quinot@adacore.com> + + * s-crtl.ads, s-oscons-tmplt.c: Fix support for VMS + * make.adb, g-comlin.ads, exp_ch6.adb: Minor reformatting + +2009-11-30 Robert Dewar <dewar@adacore.com> + + * bcheck.adb, gnatlink.adb, make.adb, makeutl.adb, osint.adb, + osint.ads, prj-ext.adb, sem_case.adb: Minor reformatting + * g-alleve.adb: Minor code reorganization (use conditional expressions) + +2009-11-30 Matthew Heaney <heaney@adacore.com> + + * a-crbtgo.adb (Delete_Fixup): Changed always-true predicates to + assertions. + +2009-11-30 Thomas Quinot <quinot@adacore.com> + + * a-tasatt.adb, s-crtl.ads, s-taprop-dummy.adb (System.CRTL.malloc32, + System.CRTL.realloc32): Remove VMS-specific routines. + (Ada.Task_Attributes.Reference): Remove unreachable code. + (System.Task_Primitives.Operations.Initialize, dummy version): + Use plain Program_Error rather than call to + System.Error_Reporting.Shutdown. + +2009-11-30 Thomas Quinot <quinot@adacore.com> + + * s-oscons-tmplt.c, xoscons.adb: Add new constants in preparation for + sharing s-crtl across all platforms. + +2009-11-30 Thomas Quinot <quinot@adacore.com> + + * s-commun.adb, s-commun.ads: New internal support unit, + allowing code sharing between GNAT.Sockets and + GNAT.Serial_Communication. + * g-sercom.ads, g-sercom-mingw.adb, g-sercom-linux.adb, + g-socket.adb (GNAT.Sockets.Last_Index): Move to System.Communication. + (GNAT.Serial_Communication.Read): Handle correctly the case where no + data was read, and Buffer'First = Stream_Element_Offset'First. + * Makefile.rtl: Add entry for s-commun + * g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.adb, + g-socthi-vxworks.ads, g-stseme.adb, g-socthi-mingw.ads, + g-socthi.adb, g-socthi.ads (GNAT.Sockets.Thin.Socket_Error_Message): + Reimplement in terms of System.CRTL.strerror. + 2009-11-26 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/utils.c (copy_type): Unshare the language-specific data diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 4f26f1569b5..f101a52e025 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -80,9 +80,9 @@ GNATRTL_TASKING_OBJS= \ GNATRTL_NONTASKING_OBJS= \ a-assert$(objext) \ a-calari$(objext) \ + a-calcon$(objext) \ a-caldel$(objext) \ a-calend$(objext) \ - a-calcon$(objext) \ a-calfor$(objext) \ a-catizo$(objext) \ a-cdlili$(objext) \ @@ -146,12 +146,12 @@ GNATRTL_NONTASKING_OBJS= \ a-izteio$(objext) \ a-lcteio$(objext) \ a-lfteio$(objext) \ - a-llctio$(objext) \ a-lfwtio$(objext) \ a-lfztio$(objext) \ a-liteio$(objext) \ a-liwtio$(objext) \ a-liztio$(objext) \ + a-llctio$(objext) \ a-llftio$(objext) \ a-llfwti$(objext) \ a-llfzti$(objext) \ @@ -239,9 +239,9 @@ GNATRTL_NONTASKING_OBJS= \ a-szuzha$(objext) \ a-szuzti$(objext) \ a-tags$(objext) \ - a-tgdico$(objext) \ a-teioed$(objext) \ a-textio$(objext) \ + a-tgdico$(objext) \ a-tiboio$(objext) \ a-ticoau$(objext) \ a-ticoio$(objext) \ @@ -337,18 +337,18 @@ GNATRTL_NONTASKING_OBJS= \ g-crc32$(objext) \ g-ctrl_c$(objext) \ g-curexc$(objext) \ - g-debuti$(objext) \ g-debpoo$(objext) \ + g-debuti$(objext) \ g-decstr$(objext) \ g-deutst$(objext) \ g-diopit$(objext) \ g-dirope$(objext) \ - g-dyntab$(objext) \ g-dynhta$(objext) \ + g-dyntab$(objext) \ g-encstr$(objext) \ g-enutst$(objext) \ - g-except$(objext) \ g-excact$(objext) \ + g-except$(objext) \ g-exctra$(objext) \ g-expect$(objext) \ g-flocon$(objext) \ @@ -367,12 +367,22 @@ GNATRTL_NONTASKING_OBJS= \ g-rannum$(objext) \ g-regexp$(objext) \ g-regpat$(objext) \ + g-sechas$(objext) \ + g-sehamd$(objext) \ + g-sehash$(objext) \ g-sercom$(objext) \ g-sestin$(objext) \ g-sha1$(objext) \ + g-sha224$(objext) \ + g-sha256$(objext) \ + g-sha384$(objext) \ + g-sha512$(objext) \ + g-shsh32$(objext) \ + g-shsh64$(objext) \ + g-shshco$(objext) \ g-souinf$(objext) \ - g-speche$(objext) \ g-spchge$(objext) \ + g-speche$(objext) \ g-spipat$(objext) \ g-spitbo$(objext) \ g-sptabo$(objext) \ @@ -384,8 +394,8 @@ GNATRTL_NONTASKING_OBJS= \ g-tasloc$(objext) \ g-timsta$(objext) \ g-traceb$(objext) \ - g-utf_32$(objext) \ g-u3spch$(objext) \ + g-utf_32$(objext) \ g-wispch$(objext) \ g-wistsp$(objext) \ g-zspche$(objext) \ @@ -421,6 +431,7 @@ GNATRTL_NONTASKING_OBJS= \ s-caun32$(objext) \ s-caun64$(objext) \ s-chepoo$(objext) \ + s-commun$(objext) \ s-conca2$(objext) \ s-conca3$(objext) \ s-conca4$(objext) \ @@ -429,13 +440,13 @@ GNATRTL_NONTASKING_OBJS= \ s-conca7$(objext) \ s-conca8$(objext) \ s-conca9$(objext) \ - s-crtl$(objext) \ s-crc32$(objext) \ + s-crtl$(objext) \ + s-crtrun$(objext) \ s-direio$(objext) \ s-dsaser$(objext) \ - s-errrep$(objext) \ - s-exctab$(objext) \ s-except$(objext) \ + s-exctab$(objext) \ s-exnint$(objext) \ s-exnllf$(objext) \ s-exnlli$(objext) \ @@ -452,14 +463,15 @@ GNATRTL_NONTASKING_OBJS= \ s-ficobl$(objext) \ s-fileio$(objext) \ s-filofl$(objext) \ - s-fishfl$(objext) \ s-finimp$(objext) \ s-finroo$(objext) \ + s-fishfl$(objext) \ s-fore$(objext) \ s-fvadfl$(objext) \ s-fvaffl$(objext) \ s-fvagfl$(objext) \ s-geveop$(objext) \ + s-gloloc$(objext) \ s-htable$(objext) \ s-imenne$(objext) \ s-imgbiu$(objext) \ @@ -478,10 +490,11 @@ GNATRTL_NONTASKING_OBJS= \ s-imgwch$(objext) \ s-imgwiu$(objext) \ s-io$(objext) \ - s-gloloc$(objext) \ s-maccod$(objext) \ s-mantis$(objext) \ s-mastop$(objext) \ + s-memcop$(objext) \ + s-memory$(objext) \ s-os_lib$(objext) \ s-osprim$(objext) \ s-pack03$(objext) \ @@ -558,19 +571,17 @@ GNATRTL_NONTASKING_OBJS= \ s-secsta$(objext) \ s-sequio$(objext) \ s-shasto$(objext) \ + s-soflin$(objext) \ s-stache$(objext) \ + s-stalib$(objext) \ s-stausa$(objext) \ s-stchop$(objext) \ - s-stalib$(objext) \ s-stoele$(objext) \ s-stopoo$(objext) \ s-stratt$(objext) \ s-strhas$(objext) \ - s-ststop$(objext) \ - s-soflin$(objext) \ - s-memory$(objext) \ - s-memcop$(objext) \ s-string$(objext) \ + s-ststop$(objext) \ s-tasloc$(objext) \ s-traceb$(objext) \ s-traces$(objext) \ diff --git a/gcc/ada/a-calend.adb b/gcc/ada/a-calend.adb index 1a49c58888a..dd500f43691 100644 --- a/gcc/ada/a-calend.adb +++ b/gcc/ada/a-calend.adb @@ -1029,63 +1029,40 @@ package body Ada.Calendar is ----------------- function Day_Of_Week (Date : Time) return Integer is - Y : Year_Number; - Mo : Month_Number; - D : Day_Number; - Ds : Day_Duration; - H : Integer; - Mi : Integer; - Se : Integer; - Su : Duration; - Le : Boolean; - - pragma Unreferenced (Ds, H, Mi, Se, Su, Le); + Date_N : constant Time_Rep := Time_Rep (Date); + Time_Zone : constant Long_Integer := + Time_Zones_Operations.UTC_Time_Offset (Date); + Ada_Low_N : Time_Rep; Day_Count : Long_Integer; - Res_Dur : Time_Dur; - Res_N : Time_Rep; + Day_Dur : Time_Dur; + High_N : Time_Rep; + Low_N : Time_Rep; begin - Formatting_Operations.Split - (Date => Date, - Year => Y, - Month => Mo, - Day => D, - Day_Secs => Ds, - Hour => H, - Minute => Mi, - Second => Se, - Sub_Sec => Su, - Leap_Sec => Le, - Is_Ada_05 => True, - Time_Zone => 0); - - -- Build a time value in the middle of the same day - - Res_N := - Time_Rep - (Formatting_Operations.Time_Of - (Year => Y, - Month => Mo, - Day => D, - Day_Secs => 0.0, - Hour => 12, - Minute => 0, - Second => 0, - Sub_Sec => 0.0, - Leap_Sec => False, - Use_Day_Secs => False, - Is_Ada_05 => True, - Time_Zone => 0)); + -- As declared, the Ada Epoch is set in UTC. For this calculation to + -- work properly, both the Epoch and the input date must be in the + -- same time zone. The following places the Epoch in the input date's + -- time zone. + + Ada_Low_N := Ada_Low - Time_Rep (Time_Zone) * Nano; + + if Date_N > Ada_Low_N then + High_N := Date_N; + Low_N := Ada_Low_N; + else + High_N := Ada_Low_N; + Low_N := Date_N; + end if; -- Determine the elapsed seconds since the start of Ada time - Res_Dur := Time_Dur (Res_N / Nano - Ada_Low / Nano); + Day_Dur := Time_Dur (High_N / Nano - Low_N / Nano); - -- Count the number of days since the start of Ada time. 1901-1-1 + -- Count the number of days since the start of Ada time. 1901-01-01 -- GMT was a Tuesday. - Day_Count := Long_Integer (Res_Dur / Secs_In_Day) + 1; + Day_Count := Long_Integer (Day_Dur / Secs_In_Day) + 1; return Integer (Day_Count mod 7); end Day_Of_Week; diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index f9d7db832da..c2e0d9d0a0a 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -1711,12 +1711,18 @@ package body Ada.Containers.Doubly_Linked_Lists is return False; end if; + -- If we get here, we know that this disjunction is true: + -- Position.Node.Prev /= null or else Position.Node = L.First + if Position.Node.Next = null and then Position.Node /= L.Last then return False; end if; + -- If we get here, we know that this disjunction is true: + -- Position.Node.Next /= null or else Position.Node = L.Last + if L.Length = 1 then return L.First = L.Last; end if; @@ -1761,21 +1767,21 @@ package body Ada.Containers.Doubly_Linked_Lists is return False; end if; - if Position.Node = L.First then + if Position.Node = L.First then -- eliminates ealier disjunct return True; end if; - if Position.Node = L.Last then - return True; - end if; + -- If we get here, we know, per disjunctive syllogism (modus + -- tollendo ponens), that this predicate is true: + -- Position.Node.Prev /= null - if Position.Node.Next = null then - return False; + if Position.Node = L.Last then -- eliminates earlier disjunct + return True; end if; - if Position.Node.Prev = null then - return False; - end if; + -- If we get here, we know, per disjunctive syllogism (modus + -- tollendo ponens), that this predicate is true: + -- Position.Node.Next /= null if Position.Node.Next.Prev /= Position.Node then return False; diff --git a/gcc/ada/a-clrefi.adb b/gcc/ada/a-clrefi.adb index 210e8615aa6..938ea18fb5e 100644 --- a/gcc/ada/a-clrefi.adb +++ b/gcc/ada/a-clrefi.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2007-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- -- @@ -29,6 +29,8 @@ -- -- ------------------------------------------------------------------------------ +pragma Compiler_Unit; + with Ada.Unchecked_Deallocation; with System.OS_Lib; use System.OS_Lib; diff --git a/gcc/ada/a-clrefi.ads b/gcc/ada/a-clrefi.ads index 63b45881499..fdefafcccc9 100644 --- a/gcc/ada/a-clrefi.ads +++ b/gcc/ada/a-clrefi.ads @@ -36,6 +36,8 @@ -- Using a response file allow passing a set of arguments to an executable -- longer than the maximum allowed by the system on the command line. +pragma Compiler_Unit; + with System.Strings; package Ada.Command_Line.Response_File is diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index 9169e086ebd..84ad22ec1f9 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -1121,21 +1121,45 @@ package body Ada.Containers.Indefinite_Vectors is Index : constant Index_Type := Index_Type (Index_As_Int); - J : Index_Type'Base := Before; + J : Index_Type'Base; begin + -- The new items are being inserted in the middle of the + -- array, in the range [Before, Index). Copy the existing + -- elements to the end of the array, to make room for the + -- new items. + E (Index .. New_Last) := E (Before .. Container.Last); Container.Last := New_Last; - while J < Index loop - E (J) := new Element_Type'(New_Item); - J := J + 1; - end loop; + -- We have copied the existing items up to the end of the + -- array, to make room for the new items in the middle of + -- the array. Now we actually allocate the new items. - exception - when others => - E (J .. Index - 1) := (others => null); - raise; + -- Note: initialize J outside loop to make it clear that + -- J always has a value if the exception handler triggers. + + J := Before; + begin + while J < Index loop + E (J) := new Element_Type'(New_Item); + J := J + 1; + end loop; + + exception + when others => + + -- Values in the range [Before, J) were successfully + -- allocated, but values in the range [J, Index) are + -- stale (these array positions contain copies of the + -- old items, that did not get assigned a new item, + -- because the allocation failed). We must finish what + -- we started by clearing out all of the stale values, + -- leaving a "hole" in the middle of the array. + + E (J .. Index - 1) := (others => null); + raise; + end; end; else @@ -1149,6 +1173,9 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; + -- There follows LOTS of code completely devoid of comments ??? + -- This is not our general style ??? + declare C, CC : UInt; diff --git a/gcc/ada/a-comlin.ads b/gcc/ada/a-comlin.ads index a0335a49d72..8d66e1542b9 100644 --- a/gcc/ada/a-comlin.ads +++ b/gcc/ada/a-comlin.ads @@ -33,6 +33,8 @@ -- -- ------------------------------------------------------------------------------ +pragma Compiler_Unit; + package Ada.Command_Line is pragma Preelaborate; diff --git a/gcc/ada/a-crbtgo.adb b/gcc/ada/a-crbtgo.adb index 9b30226b066..c8ddcff02a5 100644 --- a/gcc/ada/a-crbtgo.adb +++ b/gcc/ada/a-crbtgo.adb @@ -49,6 +49,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access); procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access); +-- Why is all the following code commented out ??? + -- --------------------- -- -- Check_Invariant -- -- --------------------- @@ -171,9 +173,14 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is if Right (W) = null or else Color (Right (W)) = Black then - if Left (W) /= null then - Set_Color (Left (W), Black); - end if; + -- As a condition for setting the color of the left child to + -- black, the left child access value must be non-null. A + -- truth table analysis shows that if we arrive here, that + -- condition holds, so there's no need for an explicit test. + -- The assertion is here to document what we know is true. + + pragma Assert (Left (W) /= null); + Set_Color (Left (W), Black); Set_Color (W, Red); Right_Rotate (Tree, W); @@ -208,9 +215,15 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is else if Left (W) = null or else Color (Left (W)) = Black then - if Right (W) /= null then - Set_Color (Right (W), Black); - end if; + + -- As a condition for setting the color of the right child + -- to black, the right child access value must be non-null. + -- A truth table analysis shows that if we arrive here, that + -- condition holds, so there's no need for an explicit test. + -- The assertion is here to document what we know is true. + + pragma Assert (Right (W) /= null); + Set_Color (Right (W), Black); Set_Color (W, Red); Left_Rotate (Tree, W); @@ -250,6 +263,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is "attempt to tamper with cursors (container is busy)"; end if; + -- Why are these all commented out ??? + -- pragma Assert (Tree.Length > 0); -- pragma Assert (Tree.Root /= null); -- pragma Assert (Tree.First /= null); diff --git a/gcc/ada/a-ioexce.ads b/gcc/ada/a-ioexce.ads index 43239ddb066..44865ab6649 100644 --- a/gcc/ada/a-ioexce.ads +++ b/gcc/ada/a-ioexce.ads @@ -13,6 +13,8 @@ -- -- ------------------------------------------------------------------------------ +pragma Compiler_Unit; + package Ada.IO_Exceptions is pragma Pure; diff --git a/gcc/ada/a-ngelfu.adb b/gcc/ada/a-ngelfu.adb index 55d14e7db53..b615f9da957 100644 --- a/gcc/ada/a-ngelfu.adb +++ b/gcc/ada/a-ngelfu.adb @@ -35,8 +35,8 @@ -- advantage of the C functions, e.g. in providing interface to hardware -- provided versions of the elementary functions. --- Uses functions sqrt, exp, log, pow, sin, asin, cos, acos, tan, atan, --- sinh, cosh, tanh from C library via math.h +-- Uses functions sqrt, exp, log, pow, sin, asin, cos, acos, tan, atan, sinh, +-- cosh, tanh from C library via math.h with Ada.Numerics.Aux; @@ -46,6 +46,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is Sqrt_Two : constant := 1.41421_35623_73095_04880_16887_24209_69807_85696; Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755; + Half_Log_Two : constant := Log_Two / 2; subtype T is Float_Type'Base; @@ -63,14 +64,12 @@ package body Ada.Numerics.Generic_Elementary_Functions is ----------------------- function Exp_Strict (X : Float_Type'Base) return Float_Type'Base; - -- Cody/Waite routine, supposedly more precise than the library - -- version. Currently only needed for Sinh/Cosh on X86 with the largest - -- FP type. + -- Cody/Waite routine, supposedly more precise than the library version. + -- Currently only needed for Sinh/Cosh on X86 with the largest FP type. function Local_Atan - (Y : Float_Type'Base; - X : Float_Type'Base := 1.0) - return Float_Type'Base; + (Y : Float_Type'Base; + X : Float_Type'Base := 1.0) return Float_Type'Base; -- Common code for arc tangent after cycle reduction ---------- @@ -121,9 +120,9 @@ package body Ada.Numerics.Generic_Elementary_Functions is A_Right := abs (Right); -- If exponent is larger than one, compute integer exponen- - -- tiation if possible, and evaluate fractional part with - -- more precision. The relative error is now proportional - -- to the fractional part of the exponent only. + -- tiation if possible, and evaluate fractional part with more + -- precision. The relative error is now proportional to the + -- fractional part of the exponent only. if A_Right > 1.0 and then A_Right < Float_Type'Base (Integer'Last) @@ -241,8 +240,8 @@ package body Ada.Numerics.Generic_Elementary_Functions is function Arccosh (X : Float_Type'Base) return Float_Type'Base is begin - -- Return positive branch of Log (X - Sqrt (X * X - 1.0)), or - -- the proper approximation for X close to 1 or >> 1. + -- Return positive branch of Log (X - Sqrt (X * X - 1.0)), or the proper + -- approximation for X close to 1 or >> 1. if X < 1.0 then raise Argument_Error; @@ -305,8 +304,8 @@ package body Ada.Numerics.Generic_Elementary_Functions is raise Argument_Error; else - -- 1.0 < abs X <= 2.0. One of X + 1.0 and X - 1.0 is exact, the - -- other has error 0 or Epsilon. + -- 1.0 < abs X <= 2.0. One of X + 1.0 and X - 1.0 is exact, the other + -- has error 0 or Epsilon. return 0.5 * (Log (abs (X + 1.0)) - Log (abs (X - 1.0))); end if; @@ -394,9 +393,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is return Float_Type'Base is begin - if X = 0.0 - and then Y = 0.0 - then + if X = 0.0 and then Y = 0.0 then raise Argument_Error; elsif Y = 0.0 then @@ -407,11 +404,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is end if; elsif X = 0.0 then - if Y > 0.0 then - return Half_Pi; - else -- Y < 0.0 - return -Half_Pi; - end if; + return Float_Type'Copy_Sign (Half_Pi, Y); else return Local_Atan (Y, X); @@ -430,9 +423,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is if Cycle <= 0.0 then raise Argument_Error; - elsif X = 0.0 - and then Y = 0.0 - then + elsif X = 0.0 and then Y = 0.0 then raise Argument_Error; elsif Y = 0.0 then @@ -443,11 +434,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is end if; elsif X = 0.0 then - if Y > 0.0 then - return Cycle / 4.0; - else -- Y < 0.0 - return -(Cycle / 4.0); - end if; + return Float_Type'Copy_Sign (Cycle / 4.0, Y); else return Local_Atan (Y, X) * Cycle / Two_Pi; @@ -460,6 +447,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is function Arctanh (X : Float_Type'Base) return Float_Type'Base is A, B, D, A_Plus_1, A_From_1 : Float_Type'Base; + Mantissa : constant Integer := Float_Type'Base'Machine_Mantissa; begin @@ -491,9 +479,9 @@ package body Ada.Numerics.Generic_Elementary_Functions is -- why is above line commented out ??? else - -- Use several piecewise linear approximations. - -- A is close to X, chosen so 1.0 + A, 1.0 - A, and X - A are exact. - -- The two scalings remove the low-order bits of X. + -- Use several piecewise linear approximations. A is close to X, + -- chosen so 1.0 + A, 1.0 - A, and X - A are exact. The two scalings + -- remove the low-order bits of X. A := Float_Type'Base'Scaling ( Float_Type'Base (Long_Long_Integer @@ -505,16 +493,13 @@ package body Ada.Numerics.Generic_Elementary_Functions is D := A_Plus_1 * A_From_1; -- 1 - A*A. -- use one term of the series expansion: - -- f (x + e) = f(x) + e * f'(x) + .. + + -- f (x + e) = f(x) + e * f'(x) + .. -- The derivative of Arctanh at A is 1/(1-A*A). Next term is -- A*(B/D)**2 (if a quadratic approximation is ever needed). return 0.5 * (Log (A_Plus_1) - Log (A_From_1)) + B / D; - - -- else - -- return 0.5 * Log ((X + 1.0) / (1.0 - X)); - -- why are above lines commented out ??? end if; end Arctanh; @@ -541,8 +526,8 @@ package body Ada.Numerics.Generic_Elementary_Functions is function Cos (X, Cycle : Float_Type'Base) return Float_Type'Base is begin - -- Just reuse the code for Sin. The potential small - -- loss of speed is negligible with proper (front-end) inlining. + -- Just reuse the code for Sin. The potential small loss of speed is + -- negligible with proper (front-end) inlining. return -Sin (abs X - Cycle * 0.25, Cycle); end Cos; @@ -705,8 +690,8 @@ package body Ada.Numerics.Generic_Elementary_Functions is -- Deal with case of Exp returning IEEE infinity. If Machine_Overflows -- is False, then we can just leave it as an infinity (and indeed we - -- prefer to do so). But if Machine_Overflows is True, then we have - -- to raise a Constraint_Error exception as required by the RM. + -- prefer to do so). But if Machine_Overflows is True, then we have to + -- raise a Constraint_Error exception as required by the RM. if Float_Type'Machine_Overflows and then not R'Valid then raise Constraint_Error; @@ -721,9 +706,8 @@ package body Ada.Numerics.Generic_Elementary_Functions is ---------------- function Local_Atan - (Y : Float_Type'Base; - X : Float_Type'Base := 1.0) - return Float_Type'Base + (Y : Float_Type'Base; + X : Float_Type'Base := 1.0) return Float_Type'Base is Z : Float_Type'Base; Raw_Atan : Float_Type'Base; @@ -741,18 +725,9 @@ package body Ada.Numerics.Generic_Elementary_Functions is end if; if X > 0.0 then - if Y > 0.0 then - return Raw_Atan; - else -- Y < 0.0 - return -Raw_Atan; - end if; - - else -- X < 0.0 - if Y > 0.0 then - return Pi - Raw_Atan; - else -- Y < 0.0 - return -(Pi - Raw_Atan); - end if; + return Float_Type'Copy_Sign (Raw_Atan, Y); + else + return Float_Type'Copy_Sign (Pi - Raw_Atan, Y); end if; end Local_Atan; @@ -821,27 +796,27 @@ package body Ada.Numerics.Generic_Elementary_Functions is if Cycle <= 0.0 then raise Argument_Error; + -- If X is zero, return it as the result, preserving the argument sign. + -- Is this test really needed on any machine ??? + elsif X = 0.0 then - -- Is this test really needed on any machine ??? return X; end if; T := Float_Type'Base'Remainder (X, Cycle); - -- The following two reductions reduce the argument - -- to the interval [-0.25 * Cycle, 0.25 * Cycle]. - -- This reduction is exact and is needed to prevent - -- inaccuracy that may result if the sinus function - -- a different (more accurate) value of Pi in its - -- reduction than is used in the multiplication with Two_Pi. + -- The following two reductions reduce the argument to the interval + -- [-0.25 * Cycle, 0.25 * Cycle]. This reduction is exact and is needed + -- to prevent inaccuracy that may result if the sine function uses a + -- different (more accurate) value of Pi in its reduction than is used + -- in the multiplication with Two_Pi. if abs T > 0.25 * Cycle then T := 0.5 * Float_Type'Copy_Sign (Cycle, T) - T; end if; - -- Could test for 12.0 * abs T = Cycle, and return - -- an exact value in those cases. It is not clear that - -- this is worth the extra test though. + -- Could test for 12.0 * abs T = Cycle, and return an exact value in + -- those cases. It is not clear this is worth the extra test though. return Float_Type'Base (Aux.Sin (Double (T / Cycle * Two_Pi))); end Sin; @@ -924,7 +899,6 @@ package body Ada.Numerics.Generic_Elementary_Functions is elsif X = 0.0 then return X; - end if; return Float_Type'Base (Aux.Sqrt (Double (X))); diff --git a/gcc/ada/a-rttiev.adb b/gcc/ada/a-rttiev.adb index 55687ec8f6b..2fe78212c3d 100644 --- a/gcc/ada/a-rttiev.adb +++ b/gcc/ada/a-rttiev.adb @@ -75,9 +75,9 @@ package body Ada.Real_Time.Timing_Events is -- with mutually exclusive access via Event_Queue_Lock. procedure Remove_From_Queue (This : Any_Timing_Event); - -- Remove the specified event pointer from the queue of pending events - -- with mutually exclusive access via Event_Queue_Lock. - -- This procedure is used by the client-side routines (Set_Handler, etc.). + -- Remove the specified event pointer from the queue of pending events with + -- mutually exclusive access via Event_Queue_Lock. This procedure is used + -- by the client-side routines (Set_Handler, etc.). ----------- -- Timer -- @@ -94,6 +94,7 @@ package body Ada.Real_Time.Timing_Events is -- selected is arbitrary and could be changed to suit the application -- requirements. Obviously a shorter period would give better resolution -- at the cost of more overhead. + begin System.Tasking.Utilities.Make_Independent; @@ -171,6 +172,7 @@ package body Ada.Real_Time.Timing_Events is declare Handler : constant Timing_Event_Handler := Next_Event.Handler; + begin -- The first act is to clear the event, per D.15(13/2). Besides, -- we cannot clear the handler pointer *after* invoking the @@ -205,11 +207,17 @@ package body Ada.Real_Time.Timing_Events is package By_Timeout is new Events.Generic_Sorting (Sooner); -- Used to keep the events in ascending order by timeout value + ------------ + -- Sooner -- + ------------ + function Sooner (Left, Right : Any_Timing_Event) return Boolean is begin return Left.Timeout < Right.Timeout; end Sooner; + -- Start of processing for Insert_Into_Queue + begin SSL.Abort_Defer.all; @@ -236,12 +244,14 @@ package body Ada.Real_Time.Timing_Events is procedure Remove_From_Queue (This : Any_Timing_Event) is use Events; Location : Cursor; + begin SSL.Abort_Defer.all; Write_Lock (Event_Queue_Lock'Access); Location := All_Events.Find (This); + if Location /= No_Element then All_Events.Delete (Location); end if; @@ -332,13 +342,9 @@ package body Ada.Real_Time.Timing_Events is function Time_Of_Event (Event : Timing_Event) return Time is begin - -- RM D.15(18/2): Time_First must be returned if the event is not set + -- RM D.15(18/2): Time_First must be returned in the event is not set - if Event.Handler = null then - return Time_First; - else - return Event.Timeout; - end if; + return (if Event.Handler = null then Time_First else Event.Timeout); end Time_Of_Event; -------------- diff --git a/gcc/ada/a-strhas.ads b/gcc/ada/a-strhas.ads index 7d33bf7d019..c2574d1e996 100644 --- a/gcc/ada/a-strhas.ads +++ b/gcc/ada/a-strhas.ads @@ -13,6 +13,8 @@ -- -- ------------------------------------------------------------------------------ +pragma Compiler_Unit; + with Ada.Containers; function Ada.Strings.Hash (Key : String) return Containers.Hash_Type; diff --git a/gcc/ada/a-ststio.adb b/gcc/ada/a-ststio.adb index 79ee6cdfd5a..89273a89f4c 100644 --- a/gcc/ada/a-ststio.adb +++ b/gcc/ada/a-ststio.adb @@ -29,9 +29,10 @@ -- -- ------------------------------------------------------------------------------ -with Interfaces.C_Streams; use Interfaces.C_Streams; +with Interfaces.C_Streams; use Interfaces.C_Streams; with System; use System; +with System.Communication; use System.Communication; with System.File_IO; with System.Soft_Links; with System.CRTL; @@ -293,8 +294,8 @@ package body Ada.Streams.Stream_IO is end if; File.Index := File.Index + Count (Nread); - Last := Item'First + Stream_Element_Offset (Nread) - 1; File.Last_Op := Op_Read; + Last := Last_Index (Item'First, Nread); end Read; -- This version of Read is the primitive operation on the underlying diff --git a/gcc/ada/a-tasatt.adb b/gcc/ada/a-tasatt.adb index 11db89e4648..cb9fbab6e34 100644 --- a/gcc/ada/a-tasatt.adb +++ b/gcc/ada/a-tasatt.adb @@ -221,7 +221,6 @@ -- general use 'Unchecked_Access instead of 'Access as the package can be -- instantiated from within a local context. -with System.Error_Reporting; with System.Storage_Elements; with System.Task_Primitives.Operations; with System.Tasking; @@ -237,8 +236,7 @@ pragma Elaborate_All (System.Tasking.Task_Attributes); package body Ada.Task_Attributes is - use System.Error_Reporting, - System.Tasking.Initialization, + use System.Tasking.Initialization, System.Tasking, System.Tasking.Task_Attributes, Ada.Exceptions; @@ -424,9 +422,6 @@ package body Ada.Task_Attributes is end; end if; - pragma Assert (Shutdown ("Should never get here in Reference")); - return null; - exception when Tasking_Error | Program_Error => raise; diff --git a/gcc/ada/a-textio.adb b/gcc/ada/a-textio.adb index ceacfe5b127..0dd54632068 100644 --- a/gcc/ada/a-textio.adb +++ b/gcc/ada/a-textio.adb @@ -1659,8 +1659,8 @@ package body Ada.Text_IO is begin -- Don't allow change of mode for current file (RM A.10.2(5)) - if (File = Current_In or else - File = Current_Out or else + if (File = Current_In or else + File = Current_Out or else File = Current_Error) and then To_FCB (Mode) /= File.Mode then diff --git a/gcc/ada/a-tiinio.adb b/gcc/ada/a-tiinio.adb index 4a4eb520f91..f477dbf77a1 100644 --- a/gcc/ada/a-tiinio.adb +++ b/gcc/ada/a-tiinio.adb @@ -36,11 +36,10 @@ package body Ada.Text_IO.Integer_IO is package Aux renames Ada.Text_IO.Integer_Aux; Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; - -- Throughout this generic body, we distinguish between the case - -- where type Integer is acceptable, and where a Long_Long_Integer - -- is needed. This constant Boolean is used to test for these cases - -- and since it is a constant, only the code for the relevant case - -- will be included in the instance. + -- Throughout this generic body, we distinguish between the case where type + -- Integer is acceptable, and where a Long_Long_Integer is needed. This + -- Boolean is used to test for these cases and since it is a constant, only + -- code for the relevant case will be included in the instance. --------- -- Get -- diff --git a/gcc/ada/a-wtinio.adb b/gcc/ada/a-wtinio.adb index 78f4bb8f3bb..507145f98e7 100644 --- a/gcc/ada/a-wtinio.adb +++ b/gcc/ada/a-wtinio.adb @@ -36,11 +36,10 @@ with System.WCh_WtS; use System.WCh_WtS; package body Ada.Wide_Text_IO.Integer_IO is Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; - -- Throughout this generic body, we distinguish between the case - -- where type Integer is acceptable, and where a Long_Long_Integer - -- is needed. This constant Boolean is used to test for these cases - -- and since it is a constant, only the code for the relevant case - -- will be included in the instance. + -- Throughout this generic body, we distinguish between the case where type + -- Integer is acceptable, and where a Long_Long_Integer is needed. This + -- Boolean is used to test for these cases and since it is a constant, only + -- code for the relevant case will be included in the instance. subtype TFT is Ada.Wide_Text_IO.File_Type; -- File type required for calls to routines in Aux diff --git a/gcc/ada/a-ztinio.adb b/gcc/ada/a-ztinio.adb index ff36c4fd1a5..93e4d280960 100644 --- a/gcc/ada/a-ztinio.adb +++ b/gcc/ada/a-ztinio.adb @@ -36,11 +36,10 @@ with System.WCh_WtS; use System.WCh_WtS; package body Ada.Wide_Wide_Text_IO.Integer_IO is Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; - -- Throughout this generic body, we distinguish between the case - -- where type Integer is acceptable, and where a Long_Long_Integer - -- is needed. This constant Boolean is used to test for these cases - -- and since it is a constant, only the code for the relevant case - -- will be included in the instance. + -- Throughout this generic body, we distinguish between the case where type + -- Integer is acceptable, and where a Long_Long_Integer is needed. This + -- Boolean is used to test for these cases and since it is a constant, only + -- code for the relevant case will be included in the instance. subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; -- File type required for calls to routines in Aux diff --git a/gcc/ada/adadecode.c b/gcc/ada/adadecode.c index 86216fcfe7d..43f14f12792 100644 --- a/gcc/ada/adadecode.c +++ b/gcc/ada/adadecode.c @@ -29,14 +29,26 @@ * * ****************************************************************************/ -#ifdef IN_GCC + +#if defined(IN_RTS) +#include "tconfig.h" +#include "tsystem.h" +#elif defined(IN_GCC) #include "config.h" #include "system.h" -#else +#endif + #include <string.h> #include <stdio.h> #include <ctype.h> + +#include "adaint.h" + +#ifndef ISDIGIT #define ISDIGIT(c) isdigit(c) +#endif + +#ifndef PARMS #define PARMS(ARGS) ARGS #endif @@ -237,6 +249,21 @@ __gnat_decode (const char *coded_name, char *ada_name, int verbose) } } + /* Check for nested subprogram ending in .nnnn and strip suffix. */ + { + int last = strlen (ada_name) - 1; + + while (ISDIGIT (ada_name[last]) && last > 0) + { + last--; + } + + if (ada_name[last] == '.') + { + ada_name[last] = (char) 0; + } + } + /* Change all "__" to ".". */ { int len = strlen (ada_name); diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 5bce387d2bb..54b32232bb8 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -377,19 +377,21 @@ to_ptr32 (char **ptr64) #define MAYBE_TO_PTR32(argv) argv #endif +const char ATTR_UNSET = 127; + void __gnat_reset_attributes (struct file_attributes* attr) { - attr->exists = -1; + attr->exists = ATTR_UNSET; - attr->writable = -1; - attr->readable = -1; - attr->executable = -1; + attr->writable = ATTR_UNSET; + attr->readable = ATTR_UNSET; + attr->executable = ATTR_UNSET; - attr->regular = -1; - attr->symbolic_link = -1; - attr->directory = -1; + attr->regular = ATTR_UNSET; + attr->symbolic_link = ATTR_UNSET; + attr->directory = ATTR_UNSET; attr->timestamp = (OS_Time)-2; attr->file_length = -1; @@ -697,7 +699,7 @@ __gnat_os_filename (char *filename ATTRIBUTE_UNUSED, char *encoding ATTRIBUTE_UNUSED, int *e_length) { #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) - WS2SC (os_name, (TCHAR *)w_filename, (DWORD)o_length); + WS2SC (os_name, (TCHAR *)w_filename, (DWORD)*o_length); *o_length = strlen (os_name); strcpy (encoding, "encoding=utf8"); *e_length = strlen (encoding); @@ -1799,7 +1801,7 @@ __gnat_stat (char *name, GNAT_STRUCT_STAT *statbuf) int __gnat_file_exists_attr (char* name, struct file_attributes* attr) { - if (attr->exists == -1) { + if (attr->exists == ATTR_UNSET) { #ifdef __MINGW32__ /* On Windows do not use __gnat_stat() because of a bug in Microsoft _stat() routine. When the system time-zone is set with a negative @@ -1865,7 +1867,7 @@ __gnat_is_absolute_path (char *name, int length) int __gnat_is_regular_file_attr (char* name, struct file_attributes* attr) { - if (attr->regular == -1) { + if (attr->regular == ATTR_UNSET) { __gnat_stat_to_attr (-1, name, attr); } @@ -1883,7 +1885,7 @@ __gnat_is_regular_file (char *name) int __gnat_is_directory_attr (char* name, struct file_attributes* attr) { - if (attr->directory == -1) { + if (attr->directory == ATTR_UNSET) { __gnat_stat_to_attr (-1, name, attr); } @@ -2091,7 +2093,7 @@ __gnat_can_use_acl (TCHAR *wname) int __gnat_is_readable_file_attr (char* name, struct file_attributes* attr) { - if (attr->readable == -1) { + if (attr->readable == ATTR_UNSET) { #if defined (_WIN32) && !defined (RTX) TCHAR wname [GNAT_MAX_PATH_LEN + 2]; GENERIC_MAPPING GenericMapping; @@ -2125,7 +2127,7 @@ __gnat_is_readable_file (char *name) int __gnat_is_writable_file_attr (char* name, struct file_attributes* attr) { - if (attr->writable == -1) { + if (attr->writable == ATTR_UNSET) { #if defined (_WIN32) && !defined (RTX) TCHAR wname [GNAT_MAX_PATH_LEN + 2]; GENERIC_MAPPING GenericMapping; @@ -2163,7 +2165,7 @@ __gnat_is_writable_file (char *name) int __gnat_is_executable_file_attr (char* name, struct file_attributes* attr) { - if (attr->executable == -1) { + if (attr->executable == ATTR_UNSET) { #if defined (_WIN32) && !defined (RTX) TCHAR wname [GNAT_MAX_PATH_LEN + 2]; GENERIC_MAPPING GenericMapping; @@ -2314,7 +2316,7 @@ __gnat_set_non_readable (char *name) int __gnat_is_symbolic_link_attr (char* name, struct file_attributes* attr) { - if (attr->symbolic_link == -1) { + if (attr->symbolic_link == ATTR_UNSET) { #if defined (__vxworks) || defined (__nucleus__) attr->symbolic_link = 0; diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 0412ffbf808..7af079e35a9 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -74,15 +74,15 @@ typedef long OS_Time; */ struct file_attributes { - short exists; + unsigned char exists; - short writable; - short readable; - short executable; + unsigned char writable; + unsigned char readable; + unsigned char executable; - short symbolic_link; - short regular; - short directory; + unsigned char symbolic_link; + unsigned char regular; + unsigned char directory; OS_Time timestamp; long file_length; diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb index 18739e878ed..084ce199dda 100644 --- a/gcc/ada/bcheck.adb +++ b/gcc/ada/bcheck.adb @@ -191,6 +191,7 @@ package body Bcheck is else ALI_Path_Id := Osint.Full_Lib_File_Name (ALIs.Table (A).Afile); + if Osint.Is_Readonly_Library (ALI_Path_Id) then if Tolerate_Consistency_Errors then Error_Msg ("?{ should be recompiled"); diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index b7bfd059869..978a5e7006f 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -1740,6 +1740,7 @@ package body Clean is when 'e' => if Arg = "-eL" then Follow_Links_For_Files := True; + Follow_Links_For_Dirs := True; else Bad_Argument; diff --git a/gcc/ada/csinfo.adb b/gcc/ada/csinfo.adb index 9d8b16b572c..be4e79f2567 100644 --- a/gcc/ada/csinfo.adb +++ b/gcc/ada/csinfo.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- -- @@ -23,10 +23,10 @@ -- -- ------------------------------------------------------------------------------ --- Program to check consistency of sinfo.ads and sinfo.adb. Checks that --- field name usage is consistent and that assertion cross-reference lists --- are correct, as well as making sure that all the comments on field name --- usage are consistent. +-- Program to check consistency of sinfo.ads and sinfo.adb. Checks that field +-- name usage is consistent and that assertion cross-reference lists are +-- correct, as well as making sure that all the comments on field name usage +-- are consistent. with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; @@ -296,6 +296,7 @@ begin if Bad then Put_Line ("fields conflict with standard fields for node " & Node); + raise Done; end if; end loop; diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index f60a67b5b40..ca207b2e4d8 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -99,7 +99,7 @@ package body Debug is -- d.f Inhibit folding of static expressions -- d.g Enable conversion of raise into goto -- d.h - -- d.i + -- d.i Ignore Warnings pragmas -- d.j -- d.k -- d.l Use Ada 95 semantics for limited function returns @@ -513,6 +513,10 @@ package body Debug is -- this if this debug flag is set. Later we will enable this more -- generally by default. + -- d.i Ignore all occurrences of pragma Warnings in the sources. This can + -- be used in particular to disable Warnings (Off) to check if any of + -- these statements are inappropriate. + -- d.l Use Ada 95 semantics for limited function returns. This may be -- used to work around the incompatibility introduced by AI-318-2. -- It is useful only in -gnat05 mode. diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 6330dec57f2..d4294728563 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2098,7 +2098,11 @@ package Einfo is -- Present in all entities. Set true for all entities declared in the -- private part or body of a package. Also marks generic formals of a -- formal package declared without a box. For library level entities, --- this flag is set if the entity is not publicly visible. +-- this flag is set if the entity is not publicly visible. This flag +-- is reset when compiling the body of the package where the entity +-- is declared, when compiling the private part or body of a public +-- child unit, and when compiling a private child unit (see Install_ +-- Private_Declaration in sem_ch7). -- Is_Hidden_Open_Scope (Flag171) -- Present in all entities. Set true for a scope that contains the @@ -2451,8 +2455,12 @@ package Einfo is -- child unit, or if it is the descendent of a private child unit. -- Is_Private_Primitive (Flag245) --- Present in subprograms. Set if the first parameter of the subprogram --- is of concurrent tagged type with a private view. +-- Present in subprograms. Set if the operation is a primitive of a +-- tagged type (procedure or function dispatching on result) whose +-- full view has not been seen. Used in particular for primitive +-- subprograms of a synchronized type declared between the two views +-- of the type, so that the wrapper built for such a subprogram can +-- be given the proper signature. -- Is_Private_Type (synthesized) -- Applies to all entities, true for private types and subtypes, diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index aa36a9ddaab..651b43d1122 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -2848,13 +2848,35 @@ package body Errout is Buffer_Remove ("type "); end if; - Set_Msg_Str ("access to subprogram with profile "); + if Is_Itype (Ent) then + declare + Assoc : constant Node_Id := + Associated_Node_For_Itype (Ent); + + begin + if Nkind (Assoc) in N_Subprogram_Specification then + + -- Anonymous access to subprogram in a signature. + -- Indicate the enclosing subprogram. + + Ent := + Defining_Unit_Name + (Associated_Node_For_Itype (Ent)); + Set_Msg_Str + ("access to subprogram declared in profile of "); + + else + Set_Msg_Str ("access to subprogram with profile "); + end if; + end; + end if; elsif Ekind (Ent) = E_Function then Set_Msg_Str ("access to function "); else Set_Msg_Str ("access to procedure "); end if; + exit; -- Type is access to object, named or anonymous diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb index 314258c3070..d5cdf0b79b7 100644 --- a/gcc/ada/exp_atag.adb +++ b/gcc/ada/exp_atag.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Atree; use Atree; with Einfo; use Einfo; with Elists; use Elists; with Exp_Util; use Exp_Util; @@ -53,12 +54,14 @@ package body Exp_Atag is -- To_Dispatch_Table_Ptr -- (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position); - function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id; + function Build_TSD + (Loc : Source_Ptr; + Tag_Node_Addr : Node_Id) return Node_Id; -- Build code that retrieves the address of the record containing the Type -- Specific Data generated by GNAT. -- -- Generate: To_Type_Specific_Data_Ptr - -- (To_Addr_Ptr (To_Address (Tag) - Typeinfo_Offset).all); + -- (To_Addr_Ptr (Tag_Node_Addr - Typeinfo_Offset).all); ------------------------------------------------ -- Build_Common_Dispatching_Select_Statements -- @@ -140,39 +143,90 @@ package body Exp_Atag is -- Build_CW_Membership -- ------------------------- - function Build_CW_Membership + procedure Build_CW_Membership (Loc : Source_Ptr; - Obj_Tag_Node : Node_Id; - Typ_Tag_Node : Node_Id) return Node_Id + Obj_Tag_Node : in out Node_Id; + Typ_Tag_Node : Node_Id; + Related_Nod : Node_Id; + New_Node : out Node_Id) is - function Build_Pos return Node_Id; - -- Generate TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth; + Tag_Addr : constant Entity_Id := Make_Defining_Identifier (Loc, + New_Internal_Name ('D')); + Obj_TSD : constant Entity_Id := Make_Defining_Identifier (Loc, + New_Internal_Name ('D')); + Typ_TSD : constant Entity_Id := Make_Defining_Identifier (Loc, + New_Internal_Name ('D')); + Index : constant Entity_Id := Make_Defining_Identifier (Loc, + New_Internal_Name ('D')); - function Build_Pos return Node_Id is - begin - return + begin + -- Generate: + + -- Tag_Addr : constant Tag := Address!(Obj_Tag); + -- Obj_TSD : constant Type_Specific_Data_Ptr + -- := Build_TSD (Tag_Addr); + -- Typ_TSD : constant Type_Specific_Data_Ptr + -- := Build_TSD (Address!(Typ_Tag)); + -- Index : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth + -- Index > 0 and then Obj_TSD.Tags_Table (Index) = Typ'Tag + + Insert_Action (Related_Nod, + Make_Object_Declaration (Loc, + Defining_Identifier => Tag_Addr, + Constant_Present => True, + Object_Definition => New_Reference_To (RTE (RE_Address), Loc), + Expression => Unchecked_Convert_To + (RTE (RE_Address), Obj_Tag_Node))); + + -- Unchecked_Convert_To relocates Obj_Tag_Node and therefore we must + -- update it. + + Obj_Tag_Node := Expression (Expression (Parent (Tag_Addr))); + + Insert_Action (Related_Nod, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_TSD, + Constant_Present => True, + Object_Definition => New_Reference_To + (RTE (RE_Type_Specific_Data_Ptr), Loc), + Expression => Build_TSD (Loc, New_Reference_To (Tag_Addr, Loc)))); + + Insert_Action (Related_Nod, + Make_Object_Declaration (Loc, + Defining_Identifier => Typ_TSD, + Constant_Present => True, + Object_Definition => New_Reference_To + (RTE (RE_Type_Specific_Data_Ptr), Loc), + Expression => Build_TSD (Loc, + Unchecked_Convert_To (RTE (RE_Address), + Typ_Tag_Node)))); + + Insert_Action (Related_Nod, + Make_Object_Declaration (Loc, + Defining_Identifier => Index, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), + Expression => Make_Op_Subtract (Loc, Left_Opnd => Make_Selected_Component (Loc, - Prefix => Build_TSD (Loc, Duplicate_Subexpr (Obj_Tag_Node)), - Selector_Name => - New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)), - - Right_Opnd => - Make_Selected_Component (Loc, - Prefix => Build_TSD (Loc, Duplicate_Subexpr (Typ_Tag_Node)), + Prefix => New_Reference_To (Obj_TSD, Loc), Selector_Name => - New_Reference_To (RTE_Record_Component (RE_Idepth), Loc))); - end Build_Pos; + New_Reference_To + (RTE_Record_Component (RE_Idepth), Loc)), - -- Start of processing for Build_CW_Membership + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Typ_TSD, Loc), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Idepth), Loc))))); - begin - return + New_Node := Make_And_Then (Loc, Left_Opnd => Make_Op_Ge (Loc, - Left_Opnd => Build_Pos, + Left_Opnd => New_Occurrence_Of (Index, Loc), Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), Right_Opnd => @@ -181,12 +235,12 @@ package body Exp_Atag is Make_Indexed_Component (Loc, Prefix => Make_Selected_Component (Loc, - Prefix => Build_TSD (Loc, Obj_Tag_Node), + Prefix => New_Reference_To (Obj_TSD, Loc), Selector_Name => New_Reference_To (RTE_Record_Component (RE_Tags_Table), Loc)), Expressions => - New_List (Build_Pos)), + New_List (New_Occurrence_Of (Index, Loc))), Right_Opnd => Typ_Tag_Node)); end Build_CW_Membership; @@ -197,7 +251,8 @@ package body Exp_Atag is function Build_DT (Loc : Source_Ptr; - Tag_Node : Node_Id) return Node_Id is + Tag_Node : Node_Id) return Node_Id + is begin return Make_Function_Call (Loc, @@ -217,7 +272,9 @@ package body Exp_Atag is begin return Make_Selected_Component (Loc, - Prefix => Build_TSD (Loc, Tag_Node), + Prefix => + Build_TSD (Loc, + Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), Selector_Name => New_Reference_To (RTE_Record_Component (RE_Access_Level), Loc)); @@ -390,7 +447,9 @@ package body Exp_Atag is begin return Make_Selected_Component (Loc, - Prefix => Build_TSD (Loc, Tag_Node), + Prefix => + Build_TSD (Loc, + Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), Selector_Name => New_Reference_To (RTE_Record_Component (RE_Transportable), Loc)); @@ -529,7 +588,9 @@ package body Exp_Atag is Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, - Prefix => Build_TSD (Loc, Tag_Node), + Prefix => + Build_TSD (Loc, + Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), Selector_Name => New_Reference_To (RTE_Record_Component (RE_Size_Func), Loc)), @@ -572,7 +633,9 @@ package body Exp_Atag is -- Build_TSD -- --------------- - function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id is + function Build_TSD + (Loc : Source_Ptr; + Tag_Node_Addr : Node_Id) return Node_Id is begin return Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr), @@ -590,9 +653,9 @@ package body Exp_Atag is Chars => Name_Op_Subtract)), Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Address), Tag_Node), - New_Reference_To - (RTE (RE_DT_Typeinfo_Ptr_Size), Loc)))))); + Tag_Node_Addr, + New_Reference_To + (RTE (RE_DT_Typeinfo_Ptr_Size), Loc)))))); end Build_TSD; end Exp_Atag; diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads index 42ec4769c38..1fa243cf91f 100644 --- a/gcc/ada/exp_atag.ads +++ b/gcc/ada/exp_atag.ads @@ -41,18 +41,23 @@ package Exp_Atag is -- Ada 2005 (AI-345): Generate statements that are common between timed, -- asynchronous, and conditional select expansion. - function Build_CW_Membership + procedure Build_CW_Membership (Loc : Source_Ptr; - Obj_Tag_Node : Node_Id; - Typ_Tag_Node : Node_Id) return Node_Id; + Obj_Tag_Node : in out Node_Id; + Typ_Tag_Node : Node_Id; + Related_Nod : Node_Id; + New_Node : out Node_Id); -- Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each DT -- has a table of ancestors and its inheritance level (Idepth). Obj is in -- Typ'Class if Typ'Tag is found in the table of ancestors referenced by -- Obj'Tag. Knowing the level of inheritance of both types, this can be -- computed in constant time by the formula: -- - -- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth) - -- = Typ'tag + -- Index := TSD (Obj'Tag).Idepth - TSD (Typ'Tag).Idepth; + -- Index > 0 and then TSD (Obj'Tag).Tags_Table (Index) = Typ'Tag + -- + -- Related_Nod is the node where the implicit declaration of variable Index + -- is inserted. Obj_Tag_Node is relocated. function Build_Get_Access_Level (Loc : Source_Ptr; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 9a91e2aa9bb..f61a4a5b47b 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -8104,6 +8104,11 @@ package body Exp_Ch3 is elsif Restriction_Active (No_Finalization) then null; + -- Skip these for CIL Value types, where finalization is not available + + elsif Is_Value_Type (Tag_Typ) then + null; + elsif Etype (Tag_Typ) = Tag_Typ or else Needs_Finalization (Tag_Typ) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 6a7ea4fdb1b..4f0ef91a419 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -205,7 +205,10 @@ package body Exp_Ch4 is -- its expression. If N is neither comparison nor a type conversion, the -- call has no effect. - function Tagged_Membership (N : Node_Id) return Node_Id; + procedure Tagged_Membership + (N : Node_Id; + SCIL_Node : out Node_Id; + Result : out Node_Id); -- Construct the expression corresponding to the tagged membership test. -- Deals with a second operand being (or not) a class-wide type. @@ -4503,10 +4506,12 @@ package body Exp_Ch4 is else declare - Typ : Entity_Id := Etype (Rop); - Is_Acc : constant Boolean := Is_Access_Type (Typ); - Obj : Node_Id := Lop; - Cond : Node_Id := Empty; + Typ : Entity_Id := Etype (Rop); + Is_Acc : constant Boolean := Is_Access_Type (Typ); + Cond : Node_Id := Empty; + New_N : Node_Id; + Obj : Node_Id := Lop; + SCIL_Node : Node_Id; begin Remove_Side_Effects (Obj); @@ -4521,8 +4526,19 @@ package body Exp_Ch4 is -- normal tagged membership expansion is not what we want). if Tagged_Type_Expansion then - Rewrite (N, Tagged_Membership (N)); + Tagged_Membership (N, SCIL_Node, New_N); + Rewrite (N, New_N); Analyze_And_Resolve (N, Rtyp); + + -- Update decoration of relocated node referenced by the + -- SCIL node. + + if Generate_SCIL + and then Present (SCIL_Node) + then + Set_SCIL_Related_Node (SCIL_Node, N); + Insert_Action (N, SCIL_Node); + end if; end if; return; @@ -5025,10 +5041,26 @@ package body Exp_Ch4 is Expand_Boolean_Operator (N); elsif Is_Boolean_Type (Etype (N)) then - Adjust_Condition (Left_Opnd (N)); - Adjust_Condition (Right_Opnd (N)); - Set_Etype (N, Standard_Boolean); - Adjust_Result_Type (N, Typ); + + -- Replace AND by AND THEN if Short_Circuit_And_Or active and the + -- type is standard Boolean (do not mess with AND that uses a non- + -- standard Boolean type, because something strange is going on). + + if Short_Circuit_And_Or and then Typ = Standard_Boolean then + Rewrite (N, + Make_And_Then (Sloc (N), + Left_Opnd => Relocate_Node (Left_Opnd (N)), + Right_Opnd => Relocate_Node (Right_Opnd (N)))); + Analyze_And_Resolve (N, Typ); + + -- Otherwise, adjust conditions + + else + Adjust_Condition (Left_Opnd (N)); + Adjust_Condition (Right_Opnd (N)); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + end if; end if; end Expand_N_Op_And; @@ -6913,10 +6945,26 @@ package body Exp_Ch4 is Expand_Boolean_Operator (N); elsif Is_Boolean_Type (Etype (N)) then - Adjust_Condition (Left_Opnd (N)); - Adjust_Condition (Right_Opnd (N)); - Set_Etype (N, Standard_Boolean); - Adjust_Result_Type (N, Typ); + + -- Replace OR by OR ELSE if Short_Circuit_And_Or active and the + -- type is standard Boolean (do not mess with AND that uses a non- + -- standard Boolean type, because something strange is going on). + + if Short_Circuit_And_Or and then Typ = Standard_Boolean then + Rewrite (N, + Make_Or_Else (Sloc (N), + Left_Opnd => Relocate_Node (Left_Opnd (N)), + Right_Opnd => Relocate_Node (Right_Opnd (N)))); + Analyze_And_Resolve (N, Typ); + + -- Otherwise, adjust conditions + + else + Adjust_Condition (Left_Opnd (N)); + Adjust_Condition (Right_Opnd (N)); + Set_Etype (N, Standard_Boolean); + Adjust_Result_Type (N, Typ); + end if; end if; end Expand_N_Op_Or; @@ -9825,16 +9873,23 @@ package body Exp_Ch4 is -- table of abstract interface types plus the ancestor table contained in -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag - function Tagged_Membership (N : Node_Id) return Node_Id is + procedure Tagged_Membership + (N : Node_Id; + SCIL_Node : out Node_Id; + Result : out Node_Id) + is Left : constant Node_Id := Left_Opnd (N); Right : constant Node_Id := Right_Opnd (N); Loc : constant Source_Ptr := Sloc (N); Left_Type : Entity_Id; + New_Node : Node_Id; Right_Type : Entity_Id; Obj_Tag : Node_Id; begin + SCIL_Node := Empty; + -- Handle entities from the limited view Left_Type := Available_View (Etype (Left)); @@ -9882,7 +9937,8 @@ package body Exp_Ch4 is (Typ => Left_Type, Iface => Etype (Right_Type)))) then - return New_Reference_To (Standard_True, Loc); + Result := New_Reference_To (Standard_True, Loc); + return; end if; -- Ada 2005 (AI-251): Class-wide applied to interfaces @@ -9899,10 +9955,11 @@ package body Exp_Ch4 is if not RTE_Available (RE_IW_Membership) then Error_Msg_CRT ("dynamic membership test on interface types", N); - return Empty; + Result := Empty; + return; end if; - return + Result := Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc), Parameter_Associations => New_List ( @@ -9917,14 +9974,27 @@ package body Exp_Ch4 is -- Ada 95: Normal case else - return - Build_CW_Membership (Loc, - Obj_Tag_Node => Obj_Tag, - Typ_Tag_Node => - New_Reference_To ( - Node (First_Elmt - (Access_Disp_Table (Root_Type (Right_Type)))), - Loc)); + Build_CW_Membership (Loc, + Obj_Tag_Node => Obj_Tag, + Typ_Tag_Node => + New_Reference_To ( + Node (First_Elmt + (Access_Disp_Table (Root_Type (Right_Type)))), + Loc), + Related_Nod => N, + New_Node => New_Node); + + -- Generate the SCIL node for this class-wide membership test. + -- Done here because the previous call to Build_CW_Membership + -- relocates Obj_Tag. + + if Generate_SCIL then + SCIL_Node := Make_SCIL_Membership_Test (Sloc (N)); + Set_SCIL_Entity (SCIL_Node, Etype (Right_Type)); + Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag); + end if; + + Result := New_Node; end if; -- Right_Type is not a class-wide type @@ -9933,10 +10003,10 @@ package body Exp_Ch4 is -- No need to check the tag of the object if Right_Typ is abstract if Is_Abstract_Type (Right_Type) then - return New_Reference_To (Standard_False, Loc); + Result := New_Reference_To (Standard_False, Loc); else - return + Result := Make_Op_Eq (Loc, Left_Opnd => Obj_Tag, Right_Opnd => diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 4a31187d9d1..fa74f6cc7ab 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2314,9 +2314,9 @@ package body Exp_Ch6 is end case; - -- For allocators we pass the level of the execution of - -- the called subprogram, which is one greater than the - -- current scope level. + -- For allocators we pass the level of the execution of the + -- called subprogram, which is one greater than the current + -- scope level. when N_Allocator => Add_Extra_Actual @@ -2779,6 +2779,19 @@ package body Exp_Ch6 is Unchecked_Convert_To (Parent_Typ, Relocate_Node (Actual))); + -- If the relocated node is a function call then it + -- can be part of the expansion of the predefined + -- equality operator of a tagged type and we may + -- need to adjust its SCIL dispatching node. + + if Generate_SCIL + and then Nkind (Actual) /= N_Null + and then Nkind (Expression (Actual)) + = N_Function_Call + then + Adjust_SCIL_Node (Actual, Expression (Actual)); + end if; + Analyze (Actual); Resolve (Actual, Parent_Typ); end if; @@ -4489,6 +4502,21 @@ package body Exp_Ch6 is Analyze (Prot_Decl); Insert_Actions (N, Freeze_Entity (Prot_Id, Loc)); Set_Protected_Body_Subprogram (Subp, Prot_Id); + + -- Create protected operation as well. Even though the operation + -- is only accessible within the body, it is possible to make it + -- available outside of the protected object by using 'Access to + -- provide a callback, so we build the protected version in all + -- cases. + + Prot_Decl := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Sub_Specification + (N, Scop, Protected_Mode)); + Insert_Before (Prot_Bod, Prot_Decl); + Analyze (Prot_Decl); + Pop_Scope; end if; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index a4f6a66fd9b..880ae4e4cb9 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -3287,16 +3287,29 @@ package body Exp_Ch7 is -- Start of processing for Needs_Finalization begin - -- Class-wide types must be treated as controlled because they may - -- contain an extension that has controlled components + return + + -- Class-wide types must be treated as controlled and therefore + -- requiring finalization (because they may be extended with an + -- extension that has controlled components. + + (Is_Class_Wide_Type (T) + + -- However, avoid treating class-wide types as controlled if + -- finalization is not available and in particular CIL value + -- types never have finalization). - -- We can skip this if finalization is not available + and then not In_Finalization_Root (T) + and then not Restriction_Active (No_Finalization) + and then not Is_Value_Type (Etype (T))) + + -- Controlled types always need finalization - return (Is_Class_Wide_Type (T) - and then not In_Finalization_Root (T) - and then not Restriction_Active (No_Finalization)) or else Is_Controlled (T) or else Has_Some_Controlled_Component (T) + + -- For concurrent types, test the corresponding record type + or else (Is_Concurrent_Type (T) and then Present (Corresponding_Record_Type (T)) and then Needs_Finalization (Corresponding_Record_Type (T))); diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 7fe20b37cad..c527bf6ef32 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -2180,6 +2180,58 @@ package body Exp_Ch9 is is Def : Node_Id; Rec_Typ : Entity_Id; + procedure Scan_Declarations (L : List_Id); + -- Common processing for visible and private declarations + -- of a protected type. + + procedure Scan_Declarations (L : List_Id) is + Decl : Node_Id; + Wrap_Decl : Node_Id; + Wrap_Spec : Node_Id; + + begin + if No (L) then + return; + end if; + + Decl := First (L); + while Present (Decl) loop + Wrap_Spec := Empty; + + if Nkind (Decl) = N_Entry_Declaration + and then Ekind (Defining_Identifier (Decl)) = E_Entry + then + Wrap_Spec := + Build_Wrapper_Spec + (Subp_Id => Defining_Identifier (Decl), + Obj_Typ => Rec_Typ, + Formals => Parameter_Specifications (Decl)); + + elsif Nkind (Decl) = N_Subprogram_Declaration then + Wrap_Spec := + Build_Wrapper_Spec + (Subp_Id => Defining_Unit_Name (Specification (Decl)), + Obj_Typ => Rec_Typ, + Formals => + Parameter_Specifications (Specification (Decl))); + end if; + + if Present (Wrap_Spec) then + Wrap_Decl := + Make_Subprogram_Declaration (Loc, + Specification => Wrap_Spec); + + Insert_After (N, Wrap_Decl); + N := Wrap_Decl; + + Analyze (Wrap_Decl); + end if; + + Next (Decl); + end loop; + end Scan_Declarations; + + -- start of processing for Build_Wrapper_Specs begin if Is_Protected_Type (Typ) then @@ -2191,54 +2243,14 @@ package body Exp_Ch9 is Rec_Typ := Corresponding_Record_Type (Typ); -- Generate wrapper specs for a concurrent type which implements an - -- interface and has visible entries and/or protected procedures. + -- interface. Operations in both the visible and private parts may + -- implement progenitor operations. if Present (Interfaces (Rec_Typ)) and then Present (Def) - and then Present (Visible_Declarations (Def)) then - declare - Decl : Node_Id; - Wrap_Decl : Node_Id; - Wrap_Spec : Node_Id; - - begin - Decl := First (Visible_Declarations (Def)); - while Present (Decl) loop - Wrap_Spec := Empty; - - if Nkind (Decl) = N_Entry_Declaration - and then Ekind (Defining_Identifier (Decl)) = E_Entry - then - Wrap_Spec := - Build_Wrapper_Spec - (Subp_Id => Defining_Identifier (Decl), - Obj_Typ => Rec_Typ, - Formals => Parameter_Specifications (Decl)); - - elsif Nkind (Decl) = N_Subprogram_Declaration then - Wrap_Spec := - Build_Wrapper_Spec - (Subp_Id => Defining_Unit_Name (Specification (Decl)), - Obj_Typ => Rec_Typ, - Formals => - Parameter_Specifications (Specification (Decl))); - end if; - - if Present (Wrap_Spec) then - Wrap_Decl := - Make_Subprogram_Declaration (Loc, - Specification => Wrap_Spec); - - Insert_After (N, Wrap_Decl); - N := Wrap_Decl; - - Analyze (Wrap_Decl); - end if; - - Next (Decl); - end loop; - end; + Scan_Declarations (Visible_Declarations (Def)); + Scan_Declarations (Private_Declarations (Def)); end if; end Build_Wrapper_Specs; @@ -2551,6 +2563,70 @@ package body Exp_Ch9 is end loop; end Build_Master_Entity; + ----------------------------------------- + -- Build_Private_Protected_Declaration -- + ----------------------------------------- + + function Build_Private_Protected_Declaration + (N : Node_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (N); + Body_Id : constant Entity_Id := Defining_Entity (N); + Decl : Node_Id; + Plist : List_Id; + Formal : Entity_Id; + New_Spec : Node_Id; + Spec_Id : Entity_Id; + + begin + Formal := First_Formal (Body_Id); + + -- The protected operation always has at least one formal, namely the + -- object itself, but it is only placed in the parameter list if + -- expansion is enabled. + + if Present (Formal) or else Expander_Active then + Plist := Copy_Parameter_List (Body_Id); + else + Plist := No_List; + end if; + + if Nkind (Specification (N)) = N_Procedure_Specification then + New_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Sloc (Body_Id), + Chars => Chars (Body_Id)), + Parameter_Specifications => + Plist); + else + New_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Sloc (Body_Id), + Chars => Chars (Body_Id)), + Parameter_Specifications => + Plist, + Result_Definition => + New_Occurrence_Of (Etype (Body_Id), Loc)); + end if; + + Decl := Make_Subprogram_Declaration (Loc, Specification => New_Spec); + Insert_Before (N, Decl); + Spec_Id := Defining_Unit_Name (New_Spec); + + -- Indicate that the entity comes from source, to ensure that cross- + -- reference information is properly generated. The body itself is + -- rewritten during expansion, and the body entity will not appear in + -- calls to the operation. + + Set_Comes_From_Source (Spec_Id, True); + Analyze (Decl); + Set_Has_Completion (Spec_Id); + Set_Convention (Spec_Id, Convention_Protected); + return Spec_Id; + end Build_Private_Protected_Declaration; + --------------------------- -- Build_Protected_Entry -- --------------------------- @@ -7182,7 +7258,6 @@ package body Exp_Ch9 is New_Op_Body : Node_Id; Num_Entries : Natural := 0; Op_Body : Node_Id; - Op_Decl : Node_Id; Op_Id : Entity_Id; Chain : Entity_Id := Empty; @@ -7344,41 +7419,36 @@ package body Exp_Ch9 is -- to an external caller. This is the common idiom in code -- that uses the Ada 2005 Timing_Events package. As a result -- we need to produce the protected body for both visible - -- and private operations. + -- and private operations, as well as operations that only + -- have a body in the source, and for which we create a + -- declaration in the protected body itself. if Present (Corresponding_Spec (Op_Body)) then - Op_Decl := - Unit_Declaration_Node (Corresponding_Spec (Op_Body)); + New_Op_Body := + Build_Protected_Subprogram_Body ( + Op_Body, Pid, Specification (New_Op_Body)); - if Nkind (Parent (Op_Decl)) = - N_Protected_Definition - then - New_Op_Body := - Build_Protected_Subprogram_Body ( - Op_Body, Pid, Specification (New_Op_Body)); - - Insert_After (Current_Node, New_Op_Body); - Analyze (New_Op_Body); + Insert_After (Current_Node, New_Op_Body); + Analyze (New_Op_Body); - Current_Node := New_Op_Body; + Current_Node := New_Op_Body; - -- Generate an overriding primitive operation body for - -- this subprogram if the protected type implements - -- an interface. + -- Generate an overriding primitive operation body for + -- this subprogram if the protected type implements an + -- interface. - if Ada_Version >= Ada_05 - and then Present (Interfaces ( - Corresponding_Record_Type (Pid))) - then - Disp_Op_Body := - Build_Dispatching_Subprogram_Body ( - Op_Body, Pid, New_Op_Body); + if Ada_Version >= Ada_05 + and then + Present (Interfaces (Corresponding_Record_Type (Pid))) + then + Disp_Op_Body := + Build_Dispatching_Subprogram_Body + (Op_Body, Pid, New_Op_Body); - Insert_After (Current_Node, Disp_Op_Body); - Analyze (Disp_Op_Body); + Insert_After (Current_Node, Disp_Op_Body); + Analyze (Disp_Op_Body); - Current_Node := Disp_Op_Body; - end if; + Current_Node := Disp_Op_Body; end if; end if; end if; @@ -7434,8 +7504,8 @@ package body Exp_Ch9 is end loop; -- Finally, create the body of the function that maps an entry index - -- into the corresponding body index, except when there is no entry, - -- or in a ravenscar-like profile. + -- into the corresponding body index, except when there is no entry, or + -- in a Ravenscar-like profile. if Corresponding_Runtime_Package (Pid) = System_Tasking_Protected_Objects_Entries diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 61279d4eac5..22a27d6422e 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -81,6 +81,15 @@ package Exp_Ch9 is -- object at the outer level, but it is much easier to generate one per -- declarative part. + function Build_Private_Protected_Declaration (N : Node_Id) return Entity_Id; + -- A subprogram body without a previous spec that appears in a protected + -- body must be expanded separately to create a subprogram declaration + -- for it, in order to resolve internal calls to it from other protected + -- operations. It would seem that no locking version of the operation is + -- needed, but in fact, in Ada 2005 the subprogram may be used in a call- + -- back, and therefore a protected version of the operation must be + -- generated as well. + function Build_Protected_Sub_Specification (N : Node_Id; Prot_Typ : Entity_Id; @@ -96,28 +105,28 @@ package Exp_Ch9 is Name : Node_Id; Rec : Node_Id; External : Boolean := True); - -- The node N is a subprogram or entry call to a protected subprogram. - -- This procedure rewrites this call with the appropriate expansion. - -- Name is the subprogram, and Rec is the record corresponding to the - -- protected object. External is False if the call is to another - -- protected subprogram within the same object. + -- The node N is a subprogram or entry call to a protected subprogram. This + -- procedure rewrites this call with the appropriate expansion. Name is the + -- subprogram, and Rec is the record corresponding to the protected object. + -- External is False if the call is to another protected subprogram within + -- the same object. procedure Build_Task_Activation_Call (N : Node_Id); - -- This procedure is called for constructs that can be task activators - -- i.e. task bodies, subprogram bodies, package bodies and blocks. If - -- the construct is a task activator (as indicated by the non-empty - -- setting of Activation_Chain_Entity, either in the construct, or, in - -- the case of a package body, in its associated package spec), then - -- a call to Activate_Tasks with this entity as the single parameter - -- is inserted at the start of the statements of the activator. + -- This procedure is called for constructs that can be task activators, + -- i.e. task bodies, subprogram bodies, package bodies and blocks. If the + -- construct is a task activator (as indicated by the non-empty setting of + -- Activation_Chain_Entity, either in the construct, or, in the case of a + -- package body, in its associated package spec), then a call to + -- Activate_Tasks with this entity as the single parameter is inserted at + -- the start of the statements of the activator. procedure Build_Task_Allocate_Block (Actions : List_Id; N : Node_Id; Args : List_Id); - -- This routine is used in the case of allocators where the designated - -- type is a task or contains tasks. In this case, the normal initialize - -- call is replaced by: + -- This routine is used in the case of allocators where the designated type + -- is a task or contains tasks. In this case, the normal initialize call + -- is replaced by: -- -- blockname : label; -- blockname : declare @@ -137,10 +146,10 @@ package Exp_Ch9 is -- -- to get the task or tasks created and initialized. The expunge call -- ensures that any tasks that get created but not activated due to an - -- exception are properly expunged (it has no effect in the normal case) - -- The argument N is the allocator, and Args is the list of arguments - -- for the initialization call, constructed by the caller, which uses - -- the Master_Id of the access type as the _Master parameter, and _Chain + -- exception are properly expunged (it has no effect in the normal case). + -- The argument N is the allocator, and Args is the list of arguments for + -- the initialization call, constructed by the caller, which uses the + -- Master_Id of the access type as the _Master parameter, and _Chain -- (defined above) as the _Chain parameter. procedure Build_Task_Allocate_Block_With_Init_Stmts @@ -190,28 +199,28 @@ package Exp_Ch9 is Index : Node_Id; Ttyp : Entity_Id) return Node_Id; - -- Returns an expression to compute a task entry index given the name - -- of the entry or entry family. For the case of a task entry family, - -- the Index parameter contains the expression for the subscript. - -- Ttyp is the task type. + -- Returns an expression to compute a task entry index given the name of + -- the entry or entry family. For the case of a task entry family, the + -- Index parameter contains the expression for the subscript. Ttyp is the + -- task type. procedure Establish_Task_Master (N : Node_Id); -- Given a subprogram body, or a block statement, or a task body, this - -- procedure makes the necessary transformations required of a task - -- master (add Enter_Master call at start, and establish a cleanup - -- routine to make sure Complete_Master is called on exit). + -- procedure makes the necessary transformations required of a task master + -- (add Enter_Master call at start, and establish a cleanup routine to make + -- sure Complete_Master is called on exit). procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id); -- Build Equivalent_Type for an Access_To_Protected_Subprogram. - -- Equivalent_Type is a record type with two components: a pointer - -- to the protected object, and a pointer to the operation itself. + -- Equivalent_Type is a record type with two components: a pointer to the + -- protected object, and a pointer to the operation itself. procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id); - -- Expand declarations required for accept statement. See bodies of - -- both Expand_Accept_Declarations and Expand_N_Accept_Statement for - -- full details of the nature and use of these declarations, which - -- are inserted immediately before the accept node N. The second - -- argument is the entity for the corresponding entry. + -- Expand declarations required for accept statement. See bodies of both + -- Expand_Accept_Declarations and Expand_N_Accept_Statement for full + -- details of the nature and use of these declarations, which are inserted + -- immediately before the accept node N. The second argument is the entity + -- for the corresponding entry. procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id); -- Expand the entry barrier into a function. This is called directly diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 8f41a63c470..da6cf5a988c 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -234,19 +234,28 @@ package body Exp_Intr is -- the tag in the table of ancestor tags. elsif not Is_Interface (Result_Typ) then - Insert_Action (N, - Make_Implicit_If_Statement (N, - Condition => - Make_Op_Not (Loc, - Build_CW_Membership (Loc, - Obj_Tag_Node => Duplicate_Subexpr (Tag_Arg), - Typ_Tag_Node => - New_Reference_To ( - Node (First_Elmt (Access_Disp_Table ( - Root_Type (Result_Typ)))), Loc))), - Then_Statements => - New_List (Make_Raise_Statement (Loc, - New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); + declare + Obj_Tag_Node : Node_Id := Duplicate_Subexpr (Tag_Arg); + CW_Test_Node : Node_Id; + + begin + Build_CW_Membership (Loc, + Obj_Tag_Node => Obj_Tag_Node, + Typ_Tag_Node => + New_Reference_To ( + Node (First_Elmt (Access_Disp_Table ( + Root_Type (Result_Typ)))), Loc), + Related_Nod => N, + New_Node => CW_Test_Node); + + Insert_Action (N, + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Not (Loc, CW_Test_Node), + Then_Statements => + New_List (Make_Raise_Statement (Loc, + New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); + end; -- Call IW_Membership test if the Result_Type is an abstract interface -- to look for the tag in the table of interface tags. diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 535ec4ca16e..564c11b6613 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -2761,6 +2761,7 @@ package body Exp_Util is N_SCIL_Dispatch_Table_Object_Init | N_SCIL_Dispatch_Table_Tag_Init | N_SCIL_Dispatching_Call | + N_SCIL_Membership_Test | N_SCIL_Tag_Init | N_Selected_Component | N_Signed_Integer_Type_Definition | @@ -3411,17 +3412,49 @@ package body Exp_Util is -------------------- procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is + W : Boolean := Warn; + -- Set False if warnings suppressed + begin if Present (N) then Remove_Warning_Messages (N); - if Warn then - Error_Msg_F - ("?this code can never be executed and has been deleted!", N); + -- Generate warning if appropriate + + if W then + + -- We suppress the warning if this code is under control of an + -- if statement, whose condition is a simple identifier, and + -- either we are in an instance, or warnings off is set for this + -- identifier. The reason for killing it in the instance case is + -- that it is common and reasonable for code to be deleted in + -- instances for various reasons. + + if Nkind (Parent (N)) = N_If_Statement then + declare + C : constant Node_Id := Condition (Parent (N)); + begin + if Nkind (C) = N_Identifier + and then + (In_Instance + or else (Present (Entity (C)) + and then Has_Warnings_Off (Entity (C)))) + then + W := False; + end if; + end; + end if; + + -- Generate warning if not suppressed + + if W then + Error_Msg_F + ("?this code can never be executed and has been deleted!", N); + end if; end if; -- Recurse into block statements and bodies to process declarations - -- and statements + -- and statements. if Nkind (N) = N_Block_Statement or else Nkind (N) = N_Subprogram_Body diff --git a/gcc/ada/expect.c b/gcc/ada/expect.c index c11a3aa8652..4f0f73fd15b 100644 --- a/gcc/ada/expect.c +++ b/gcc/ada/expect.c @@ -78,12 +78,11 @@ #ifdef _WIN32 -/* We need functionality available only starting with Windows XP */ -#define _WIN32_WINNT 0x0501 - #include <windows.h> #include <process.h> #include <signal.h> +#include <io.h> +#include "mingw32.h" void __gnat_kill (int pid, int sig, int close) @@ -144,8 +143,8 @@ __gnat_pipe (int *fd) HANDLE read, write; CreatePipe (&read, &write, NULL, 0); - fd[0]=_open_osfhandle ((long)read, 0); - fd[1]=_open_osfhandle ((long)write, 0); + fd[0]=_open_osfhandle ((intptr_t)read, 0); + fd[1]=_open_osfhandle ((intptr_t)write, 0); return 0; /* always success */ } diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 85206f7ae8b..7f0f7863824 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2535,6 +2535,8 @@ package body Freeze is and then not Has_Warnings_Off (F_Type) and then not Has_Warnings_Off (Formal) then + -- Qualify mention of formals with subprogram name + Error_Msg_Qual_Level := 1; -- Check suspicious use of fat C pointer @@ -2543,8 +2545,8 @@ package body Freeze is and then Esize (F_Type) > Ttypes.System_Address_Size then Error_Msg_N - ("?type of & does not correspond " - & "to C pointer!", Formal); + ("?type of & does not correspond to C pointer!", + Formal); -- Check suspicious return of boolean @@ -2552,10 +2554,13 @@ package body Freeze is and then Convention (F_Type) = Convention_Ada and then not Has_Warnings_Off (F_Type) and then not Has_Size_Clause (F_Type) + and then VM_Target = No_VM then Error_Msg_N - ("?& is an 8-bit Ada Boolean, " - & "use char in C!", Formal); + ("& is an 8-bit Ada Boolean?", Formal); + Error_Msg_N + ("\use appropriate corresponding type in C " + & "(e.g. char)?", Formal); -- Check suspicious tagged type @@ -2584,6 +2589,8 @@ package body Freeze is Formal, F_Type); end if; + -- Turn off name qualification after message output + Error_Msg_Qual_Level := 0; end if; @@ -2595,6 +2602,11 @@ package body Freeze is and then Is_Array_Type (F_Type) and then not Is_Constrained (F_Type) and then Warn_On_Export_Import + + -- Exclude VM case, since both .NET and JVM can handle + -- unconstrained arrays without a problem. + + and then VM_Target = No_VM then Error_Msg_Qual_Level := 1; @@ -2676,13 +2688,22 @@ package body Freeze is elsif Root_Type (R_Type) = Standard_Boolean and then Convention (R_Type) = Convention_Ada + and then VM_Target = No_VM and then not Has_Warnings_Off (E) and then not Has_Warnings_Off (R_Type) and then not Has_Size_Clause (R_Type) then - Error_Msg_N - ("?return type of & is an 8-bit " - & "Ada Boolean, use char in C!", E); + declare + N : constant Node_Id := + Result_Definition (Declaration_Node (E)); + begin + Error_Msg_NE + ("return type of & is an 8-bit Ada Boolean?", + N, E); + Error_Msg_NE + ("\use appropriate corresponding type in C " + & "(e.g. char)?", N, E); + end; -- Check suspicious return tagged type diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 3285acc401c..89746b88035 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -47,6 +47,7 @@ with Prepcomp; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; +with Snames; use Snames; with Sprint; with Scn; use Scn; with Sem; use Sem; @@ -381,6 +382,29 @@ begin Sprint.Source_Dump; + -- Check again for configuration pragmas that appear in the context of + -- the main unit. These pragmas only affect the main unit, and the + -- corresponding flag is reset after each call to Semantics, but they + -- may affect the generated ali for the unit, and therefore the flag + -- must be set properly after compilation. Currently we only check for + -- Initialize_Scalars, but others should be checked: as well??? + + declare + Item : Node_Id; + + begin + Item := First (Context_Items (Cunit (Main_Unit))); + while Present (Item) loop + if Nkind (Item) = N_Pragma + and then Pragma_Name (Item) = Name_Initialize_Scalars + then + Initialize_Scalars := True; + end if; + + Next (Item); + end loop; + end; + -- If a mapping file has been specified by a -gnatem switch, update -- it if there has been some sources that were not in the mappings. diff --git a/gcc/ada/g-alleve.adb b/gcc/ada/g-alleve.adb index 3443344fe33..39d0b7240db 100644 --- a/gcc/ada/g-alleve.adb +++ b/gcc/ada/g-alleve.adb @@ -376,11 +376,8 @@ package body GNAT.Altivec.Low_Level_Vectors is begin for K in Varray_Type'Range loop - if A (K) /= Component_Type'First then - D (K) := abs (A (K)); - else - D (K) := Component_Type'First; - end if; + D (K) := (if A (K) /= Component_Type'First + then abs (A (K)) else Component_Type'First); end loop; return D; @@ -443,11 +440,7 @@ package body GNAT.Altivec.Low_Level_Vectors is begin for J in Varray_Type'Range loop - if A (J) > B (J) then - D (J) := Bool_True; - else - D (J) := Bool_False; - end if; + D (J) := (if A (J) > B (J) then Bool_True else Bool_False); end loop; return D; @@ -489,11 +482,7 @@ package body GNAT.Altivec.Low_Level_Vectors is begin for J in Varray_Type'Range loop - if A (J) > B (J) then - D (J) := A (J); - else - D (J) := B (J); - end if; + D (J) := (if A (J) > B (J) then A (J) else B (J)); end loop; return D; @@ -545,11 +534,7 @@ package body GNAT.Altivec.Low_Level_Vectors is begin for J in Varray_Type'Range loop - if A (J) < B (J) then - D (J) := A (J); - else - D (J) := B (J); - end if; + D (J) := (if A (J) < B (J) then A (J) else B (J)); end loop; return D; @@ -971,11 +956,7 @@ package body GNAT.Altivec.Low_Level_Vectors is begin for J in Varray_Type'Range loop - if A (J) = B (J) then - D (J) := Bool_True; - else - D (J) := Bool_False; - end if; + D (J) := (if A (J) = B (J) then Bool_True else Bool_False); end loop; return D; @@ -992,11 +973,7 @@ package body GNAT.Altivec.Low_Level_Vectors is D : Varray_Type; begin for J in Varray_Type'Range loop - if A (J) > B (J) then - D (J) := Bool_True; - else - D (J) := Bool_False; - end if; + D (J) := (if A (J) > B (J) then Bool_True else Bool_False); end loop; return D; @@ -1011,11 +988,7 @@ package body GNAT.Altivec.Low_Level_Vectors is begin for J in Varray_Type'Range loop - if A (J) > B (J) then - D (J) := A (J); - else - D (J) := B (J); - end if; + D (J) := (if A (J) > B (J) then A (J) else B (J)); end loop; return D; @@ -1030,11 +1003,7 @@ package body GNAT.Altivec.Low_Level_Vectors is begin for J in Varray_Type'Range loop - if A (J) < B (J) then - D (J) := A (J); - else - D (J) := B (J); - end if; + D (J) := (if A (J) < B (J) then A (J) else B (J)); end loop; return D; @@ -1248,17 +1217,15 @@ package body GNAT.Altivec.Low_Level_Vectors is begin for J in 0 .. N - 1 loop - if Use_Even_Components then - Offset := Index_Type (2 * J + Integer (Index_Type'First)); - else - Offset := Index_Type (2 * J + 1 + Integer (Index_Type'First)); - end if; + Offset := + Index_Type ((if Use_Even_Components then 2 * J else 2 * J + 1) + + Integer (Index_Type'First)); Double_Offset := Double_Index_Type (J + Integer (Double_Index_Type'First)); D (Double_Offset) := - Double_Component_Type (A (Offset)) - * Double_Component_Type (B (Offset)); + Double_Component_Type (A (Offset)) * + Double_Component_Type (B (Offset)); end loop; return D; @@ -1418,17 +1385,15 @@ package body GNAT.Altivec.Low_Level_Vectors is begin for J in 0 .. N - 1 loop - if Use_Even_Components then - Offset := Index_Type (2 * J + Integer (Index_Type'First)); - else - Offset := Index_Type (2 * J + 1 + Integer (Index_Type'First)); - end if; + Offset := + Index_Type ((if Use_Even_Components then 2 * J else 2 * J + 1) + + Integer (Index_Type'First)); Double_Offset := Double_Index_Type (J + Integer (Double_Index_Type'First)); D (Double_Offset) := - Double_Component_Type (A (Offset)) - * Double_Component_Type (B (Offset)); + Double_Component_Type (A (Offset)) * + Double_Component_Type (B (Offset)); end loop; return D; @@ -1620,11 +1585,7 @@ package body GNAT.Altivec.Low_Level_Vectors is if (Bits (VSCR, NJ_POS, NJ_POS) = 1) and then abs (X) < 2.0 ** (-126) then - if X < 0.0 then - D := -0.0; - else - D := 0.0; - end if; + D := (if X < 0.0 then -0.0 else +0.0); else D := X; end if; @@ -1648,17 +1609,18 @@ package body GNAT.Altivec.Low_Level_Vectors is function Rnd_To_FPI_Near (X : F64) return F64 is Result : F64; Ceiling : F64; + begin Result := F64 (SI64 (X)); if (F64'Ceiling (X) - X) = (X + 1.0 - F64'Ceiling (X)) then + -- Round to even + Ceiling := F64'Ceiling (X); - if Rnd_To_FPI_Trunc (Ceiling / 2.0) * 2.0 = Ceiling then - Result := Ceiling; - else - Result := Ceiling - 1.0; - end if; + Result := + (if Rnd_To_FPI_Trunc (Ceiling / 2.0) * 2.0 = Ceiling + then Ceiling else Ceiling - 1.0); end if; return Result; @@ -2111,14 +2073,9 @@ package body GNAT.Altivec.Low_Level_Vectors is begin for J in Varray_unsigned_int'Range loop - Addition_Result := - UI64 (VA.Values (J)) + UI64 (VB.Values (J)); - - if Addition_Result > UI64 (unsigned_int'Last) then - D.Values (J) := 1; - else - D.Values (J) := 0; - end if; + Addition_Result := UI64 (VA.Values (J)) + UI64 (VB.Values (J)); + D.Values (J) := + (if Addition_Result > UI64 (unsigned_int'Last) then 1 else 0); end loop; return To_LL_VSI (To_Vector (D)); @@ -2374,19 +2331,15 @@ package body GNAT.Altivec.Low_Level_Vectors is D.Values (K) := Write_Bit (D.Values (K), 1, 1); else - if NJ_Truncate (VA.Values (J)) - <= NJ_Truncate (VB.Values (J)) then - D.Values (K) := Write_Bit (D.Values (K), 0, 0); - else - D.Values (K) := Write_Bit (D.Values (K), 0, 1); - end if; - - if NJ_Truncate (VA.Values (J)) - >= -NJ_Truncate (VB.Values (J)) then - D.Values (K) := Write_Bit (D.Values (K), 1, 0); - else - D.Values (K) := Write_Bit (D.Values (K), 1, 1); - end if; + D.Values (K) := + (if NJ_Truncate (VA.Values (J)) <= NJ_Truncate (VB.Values (J)) + then Write_Bit (D.Values (K), 0, 0) + else Write_Bit (D.Values (K), 0, 1)); + + D.Values (K) := + (if NJ_Truncate (VA.Values (J)) >= -NJ_Truncate (VB.Values (J)) + then Write_Bit (D.Values (K), 1, 0) + else Write_Bit (D.Values (K), 1, 1)); end if; end loop; @@ -2441,17 +2394,11 @@ package body GNAT.Altivec.Low_Level_Vectors is VA : constant VF_View := To_View (A); VB : constant VF_View := To_View (B); D : VUI_View; - K : Vint_Range; begin for J in Varray_float'Range loop - K := Vint_Range (J); - - if VA.Values (J) = VB.Values (J) then - D.Values (K) := unsigned_int'Last; - else - D.Values (K) := 0; - end if; + D.Values (Vint_Range (J)) := + (if VA.Values (J) = VB.Values (J) then unsigned_int'Last else 0); end loop; return To_LL_VSI (To_Vector (D)); @@ -2465,17 +2412,12 @@ package body GNAT.Altivec.Low_Level_Vectors is VA : constant VF_View := To_View (A); VB : constant VF_View := To_View (B); D : VSI_View; - K : Vint_Range; begin for J in Varray_float'Range loop - K := Vint_Range (J); - - if VA.Values (J) >= VB.Values (J) then - D.Values (K) := Signed_Bool_True; - else - D.Values (K) := Signed_Bool_False; - end if; + D.Values (Vint_Range (J)) := + (if VA.Values (J) >= VB.Values (J) then Signed_Bool_True + else Signed_Bool_False); end loop; return To_Vector (D); @@ -2567,18 +2509,12 @@ package body GNAT.Altivec.Low_Level_Vectors is VA : constant VF_View := To_View (A); VB : constant VF_View := To_View (B); D : VSI_View; - K : Vint_Range; begin for J in Varray_float'Range loop - K := Vint_Range (J); - - if NJ_Truncate (VA.Values (J)) - > NJ_Truncate (VB.Values (J)) then - D.Values (K) := Signed_Bool_True; - else - D.Values (K) := Signed_Bool_False; - end if; + D.Values (Vint_Range (J)) := + (if NJ_Truncate (VA.Values (J)) > NJ_Truncate (VB.Values (J)) + then Signed_Bool_True else Signed_Bool_False); end loop; return To_Vector (D); @@ -3069,11 +3005,8 @@ package body GNAT.Altivec.Low_Level_Vectors is begin for J in Varray_float'Range loop - if VA.Values (J) > VB.Values (J) then - D.Values (J) := VA.Values (J); - else - D.Values (J) := VB.Values (J); - end if; + D.Values (J) := (if VA.Values (J) > VB.Values (J) then VA.Values (J) + else VB.Values (J)); end loop; return To_Vector (D); @@ -3186,11 +3119,8 @@ package body GNAT.Altivec.Low_Level_Vectors is begin for J in Varray_float'Range loop - if VA.Values (J) < VB.Values (J) then - D.Values (J) := VA.Values (J); - else - D.Values (J) := VB.Values (J); - end if; + D.Values (J) := (if VA.Values (J) < VB.Values (J) then VA.Values (J) + else VB.Values (J)); end loop; return To_Vector (D); @@ -3924,12 +3854,9 @@ package body GNAT.Altivec.Low_Level_Vectors is for N in Vchar_Range'Range loop J := Vchar_Range (Integer (Bits (VC.Values (N), 4, 7)) + Integer (Vchar_Range'First)); - - if Bits (VC.Values (N), 3, 3) = 0 then - D.Values (N) := VA.Values (J); - else - D.Values (N) := VB.Values (J); - end if; + D.Values (N) := + (if Bits (VC.Values (N), 3, 3) = 0 then VA.Values (J) + else VB.Values (J)); end loop; return To_LL_VSI (To_Vector (D)); @@ -4184,12 +4111,9 @@ package body GNAT.Altivec.Low_Level_Vectors is begin for N in Vchar_Range'Range loop J := Natural (N) + M; - - if J <= Natural (Vchar_Range'Last) then - D.Values (N) := VA.Values (Vchar_Range (J)); - else - D.Values (N) := 0; - end if; + D.Values (N) := + (if J <= Natural (Vchar_Range'Last) then VA.Values (Vchar_Range (J)) + else 0); end loop; return To_LL_VSI (To_Vector (D)); @@ -4530,12 +4454,8 @@ package body GNAT.Altivec.Low_Level_Vectors is begin for J in Vint_Range'Range loop Subst_Result := SI64 (VA.Values (J)) - SI64 (VB.Values (J)); - - if Subst_Result < SI64 (unsigned_int'First) then - D.Values (J) := 0; - else - D.Values (J) := 1; - end if; + D.Values (J) := + (if Subst_Result < SI64 (unsigned_int'First) then 0 else 1); end loop; return To_LL_VSI (To_Vector (D)); @@ -5023,12 +4943,11 @@ package body GNAT.Altivec.Low_Level_Vectors is D := To_View (vcmpbfp (B, C)); for J in Vint_Range'Range loop + -- vcmpbfp is not returning the usual bool vector; do the conversion - if D.Values (J) = 0 then - D.Values (J) := Signed_Bool_False; - else - D.Values (J) := Signed_Bool_True; - end if; + + D.Values (J) := + (if D.Values (J) = 0 then Signed_Bool_False else Signed_Bool_True); end loop; return LL_VSI_Operations.Check_CR6 (A, D.Values); diff --git a/gcc/ada/g-arrspl.adb b/gcc/ada/g-arrspl.adb index 9a08b8282df..a897b13f913 100644 --- a/gcc/ada/g-arrspl.adb +++ b/gcc/ada/g-arrspl.adb @@ -238,10 +238,10 @@ package body GNAT.Array_Split is loop if K > Count_Sep then - -- No more separators, last slice ends at the end of the source - -- string. + -- No more separators, last slice ends at end of source string Stop := S.Source'Last; + else Stop := S.Indexes (K) - 1; end if; diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb index e655cad763d..eb982543b38 100644 --- a/gcc/ada/g-comlin.adb +++ b/gcc/ada/g-comlin.adb @@ -574,11 +574,8 @@ package body GNAT.Command_Line is -- Depending on the value of Concatenate, the full switch is -- a single character or the rest of the argument. - if Concatenate then - End_Index := Parser.Current_Index; - else - End_Index := Arg'Last; - end if; + End_Index := + (if Concatenate then Parser.Current_Index else Arg'Last); if Switches (Switches'First) = '*' then @@ -2279,20 +2276,16 @@ package body GNAT.Command_Line is Cmd.Coalesce_Sections := new Argument_List (Cmd.Sections'Range); for E in Cmd.Sections'Range loop - if Cmd.Sections (E) = null then - Cmd.Coalesce_Sections (E) := null; - else - Cmd.Coalesce_Sections (E) := new String'(Cmd.Sections (E).all); - end if; + Cmd.Coalesce_Sections (E) := + (if Cmd.Sections (E) = null then null + else new String'(Cmd.Sections (E).all)); end loop; Cmd.Coalesce_Params := new Argument_List (Cmd.Params'Range); for E in Cmd.Params'Range loop - if Cmd.Params (E) = null then - Cmd.Coalesce_Params (E) := null; - else - Cmd.Coalesce_Params (E) := new String'(Cmd.Params (E).all); - end if; + Cmd.Coalesce_Params (E) := + (if Cmd.Params (E) = null then null + else new String'(Cmd.Params (E).all)); end loop; -- Not a clone, since we will not modify the parameters anyway diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads index 5e8f63f420c..8752ddcff5f 100644 --- a/gcc/ada/g-comlin.ads +++ b/gcc/ada/g-comlin.ads @@ -622,8 +622,7 @@ package GNAT.Command_Line is Section : String := ""; Add_Before : Boolean := False; Success : out Boolean); - -- Same as above, returning the status of - -- the operation + -- Same as above, returning the status of the operation procedure Remove_Switch (Cmd : in out Command_Line; diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index 5127de9bdd4..ef7ce9e3dbd 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -985,11 +985,7 @@ package body GNAT.Debug_Pools is is begin if H.Block_Size /= 0 then - if In_Use then - To_Byte (A).all := In_Use_Mark; - else - To_Byte (A).all := Free_Mark; - end if; + To_Byte (A).all := (if In_Use then In_Use_Mark else Free_Mark); end if; end Mark; @@ -1416,11 +1412,8 @@ package body GNAT.Debug_Pools is Backtrace_Htable_Cumulate.Set (Elem); if Cumulate then - if Data.Kind = Alloc then - K := Indirect_Alloc; - else - K := Indirect_Dealloc; - end if; + K := (if Data.Kind = Alloc then Indirect_Alloc + else Indirect_Dealloc); -- Propagate the direct call to all its parents diff --git a/gcc/ada/g-dirope.adb b/gcc/ada/g-dirope.adb index c7670ef558b..294aa7031ee 100644 --- a/gcc/ada/g-dirope.adb +++ b/gcc/ada/g-dirope.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2008, AdaCore -- +-- Copyright (C) 1998-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- -- @@ -97,12 +97,7 @@ package body GNAT.Directory_Operations is begin -- Cut_Start point to the first basename character - if Cut_Start = 0 then - Cut_Start := Path'First; - - else - Cut_Start := Cut_Start + 1; - end if; + Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1); -- Cut_End point to the last basename character @@ -580,11 +575,8 @@ package body GNAT.Directory_Operations is begin Local_Get_Current_Dir (Buffer'Address, Path_Len'Address); - if Dir'Length > Path_Len then - Last := Dir'First + Path_Len - 1; - else - Last := Dir'Last; - end if; + Last := + (if Dir'Length > Path_Len then Dir'First + Path_Len - 1 else Dir'Last); Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last); @@ -683,11 +675,9 @@ package body GNAT.Directory_Operations is return; end if; - if Str'Length > Filename_Len then - Last := Str'First + Filename_Len - 1; - else - Last := Str'Last; - end if; + Last := + (if Str'Length > Filename_Len then Str'First + Filename_Len - 1 + else Str'Last); declare subtype Path_String is String (1 .. Filename_Len); diff --git a/gcc/ada/g-dyntab.adb b/gcc/ada/g-dyntab.adb index 1ebebe4d95d..2c3ae4fcd56 100644 --- a/gcc/ada/g-dyntab.adb +++ b/gcc/ada/g-dyntab.adb @@ -31,6 +31,8 @@ -- -- ------------------------------------------------------------------------------ +pragma Compiler_Unit; + with GNAT.Heap_Sort_G; with System; use System; with System.Memory; use System.Memory; @@ -64,10 +66,7 @@ package body GNAT.Dynamic_Tables is -- Allocate -- -------------- - procedure Allocate - (T : in out Instance; - Num : Integer := 1) - is + procedure Allocate (T : in out Instance; Num : Integer := 1) is begin T.P.Last_Val := T.P.Last_Val + Num; diff --git a/gcc/ada/g-dyntab.ads b/gcc/ada/g-dyntab.ads index 897d7008f82..89634554a7d 100644 --- a/gcc/ada/g-dyntab.ads +++ b/gcc/ada/g-dyntab.ads @@ -47,6 +47,8 @@ -- GNAT.Table and the GNAT compiler source unit Table to keep as much -- coherency as possible between these three related units. +pragma Compiler_Unit; + generic type Table_Component_Type is private; type Table_Index_Type is range <>; diff --git a/gcc/ada/g-enblsp-vms-alpha.adb b/gcc/ada/g-enblsp-vms-alpha.adb index 4b703263f59..64af051d825 100644 --- a/gcc/ada/g-enblsp-vms-alpha.adb +++ b/gcc/ada/g-enblsp-vms-alpha.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2005-2008, AdaCore -- +-- Copyright (C) 2005-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- -- @@ -77,11 +77,9 @@ begin -- Fork a new process (it is not possible to do this in a subprogram) - if Alloc_Vfork_Blocks >= 0 then - Descriptor.Pid := Get_Current_Invo_Context (Get_Vfork_Jmpbuf); - else - Descriptor.Pid := -1; - end if; + Descriptor.Pid := + (if Alloc_Vfork_Blocks >= 0 + then Get_Current_Invo_Context (Get_Vfork_Jmpbuf) else -1); -- Are we now in the child diff --git a/gcc/ada/g-enblsp-vms-ia64.adb b/gcc/ada/g-enblsp-vms-ia64.adb index b7a9d340072..6ac7c5a0804 100644 --- a/gcc/ada/g-enblsp-vms-ia64.adb +++ b/gcc/ada/g-enblsp-vms-ia64.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2005-2008, AdaCore -- +-- Copyright (C) 2005-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,11 +75,8 @@ begin -- Fork a new process (it is not possible to do this in a subprogram) - if Alloc_Vfork_Blocks >= 0 then - Descriptor.Pid := Setjmp1 (Get_Vfork_Jmpbuf); - else - Descriptor.Pid := -1; - end if; + Descriptor.Pid := + (if Alloc_Vfork_Blocks >= 0 then Setjmp1 (Get_Vfork_Jmpbuf) else -1); -- Are we now in the child diff --git a/gcc/ada/g-exctra.adb b/gcc/ada/g-exctra.adb index 7d51ba4b79b..8534bbbb47e 100644 --- a/gcc/ada/g-exctra.adb +++ b/gcc/ada/g-exctra.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2005, AdaCore -- +-- Copyright (C) 2000-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- -- @@ -88,17 +88,11 @@ package body GNAT.Exception_Traces is procedure Set_Trace_Decorator (Decorator : Traceback_Decorator) is begin Current_Decorator := Decorator; - - if Current_Decorator /= null then - Traceback_Decorator_Wrapper := Decorator_Wrapper'Access; - else - Traceback_Decorator_Wrapper := null; - end if; + Traceback_Decorator_Wrapper := + (if Current_Decorator /= null + then Decorator_Wrapper'Access else null); end Set_Trace_Decorator; - -- Trace_On/Trace_Off control the kind of automatic output to occur - -- by way of the global Exception_Trace variable. - --------------- -- Trace_Off -- --------------- diff --git a/gcc/ada/g-expect-vms.adb b/gcc/ada/g-expect-vms.adb index 429a66ca55c..cc413f7248d 100644 --- a/gcc/ada/g-expect-vms.adb +++ b/gcc/ada/g-expect-vms.adb @@ -1030,11 +1030,7 @@ package body GNAT.Expect is Reinitialize_Buffer (Descriptor); end if; - if Add_LF then - Last := Full_Str'Last; - else - Last := Full_Str'Last - 1; - end if; + Last := (if Add_LF then Full_Str'Last else Full_Str'Last - 1); Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input); diff --git a/gcc/ada/g-expect.adb b/gcc/ada/g-expect.adb index a67696a649d..6510c310813 100644 --- a/gcc/ada/g-expect.adb +++ b/gcc/ada/g-expect.adb @@ -1003,11 +1003,10 @@ package body GNAT.Expect is -- Prepare low-level argument list from the normalized arguments for K in Arg_List'Range loop - if Arg_List (K) /= null then - C_Arg_List (K) := Arg_List (K).all'Address; - else - C_Arg_List (K) := System.Null_Address; - end if; + C_Arg_List (K) := + (if Arg_List (K) /= null + then Arg_List (K).all'Address + else System.Null_Address); end loop; -- This does not return on Unix systems diff --git a/gcc/ada/g-htable.adb b/gcc/ada/g-htable.adb index 7cb2660fae2..aa6c6b7bcae 100644 --- a/gcc/ada/g-htable.adb +++ b/gcc/ada/g-htable.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2005, AdaCore -- +-- Copyright (C) 1995-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- -- @@ -34,7 +34,9 @@ -- This is a dummy body, required because if we remove the body we have -- bootstrap path problems (this unit used to have a body, and if we do not -- supply a dummy body, the old incorrect body is picked up during the --- bootstrap process. +-- bootstrap process). + +pragma Compiler_Unit; package body GNAT.HTable is end GNAT.HTable; diff --git a/gcc/ada/g-md5.adb b/gcc/ada/g-md5.adb index 6c1148804fd..f8a462bc29c 100644 --- a/gcc/ada/g-md5.adb +++ b/gcc/ada/g-md5.adb @@ -4,9 +4,9 @@ -- -- -- G N A T . M D 5 -- -- -- --- B o d y -- +-- B o d y -- -- -- --- Copyright (C) 2002-2008, AdaCore -- +-- Copyright (C) 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- -- @@ -16,8 +16,8 @@ -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- @@ -31,525 +31,8 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Unchecked_Conversion; +-- This package does not require a body, since it is a package renaming. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body GNAT.MD5 is - - use Interfaces; - - Padding : constant String := - (1 => Character'Val (16#80#), 2 .. 64 => ASCII.NUL); - - Hex_Digit : constant array (Unsigned_32 range 0 .. 15) of Character := - ('0', '1', '2', '3', '4', '5', '6', '7', - '8', '9', 'a', 'b', 'c', 'd', 'e', 'f'); - -- Look-up table for each hex digit of the Message-Digest. - -- Used by function Digest (Context). - - -- The sixteen values used to rotate the context words. - -- Four for each rounds. Used in procedure Transform. - - -- Round 1 - - S11 : constant := 7; - S12 : constant := 12; - S13 : constant := 17; - S14 : constant := 22; - - -- Round 2 - - S21 : constant := 5; - S22 : constant := 9; - S23 : constant := 14; - S24 : constant := 20; - - -- Round 3 - - S31 : constant := 4; - S32 : constant := 11; - S33 : constant := 16; - S34 : constant := 23; - - -- Round 4 - - S41 : constant := 6; - S42 : constant := 10; - S43 : constant := 15; - S44 : constant := 21; - - type Sixteen_Words is array (Natural range 0 .. 15) - of Interfaces.Unsigned_32; - -- Sixteen 32-bit words, converted from block of 64 characters. - -- Used in procedure Decode and Transform. - - procedure Decode - (Block : String; - X : out Sixteen_Words); - -- Convert a String of 64 characters into 16 32-bit numbers - - -- The following functions (F, FF, G, GG, H, HH, I and II) are the - -- equivalent of the macros of the same name in the example - -- C implementation in the annex of RFC 1321. - - function F (X, Y, Z : Unsigned_32) return Unsigned_32; - pragma Inline (F); - - procedure FF - (A : in out Unsigned_32; - B, C, D : Unsigned_32; - X : Unsigned_32; - AC : Unsigned_32; - S : Positive); - pragma Inline (FF); - - function G (X, Y, Z : Unsigned_32) return Unsigned_32; - pragma Inline (G); - - procedure GG - (A : in out Unsigned_32; - B, C, D : Unsigned_32; - X : Unsigned_32; - AC : Unsigned_32; - S : Positive); - pragma Inline (GG); - - function H (X, Y, Z : Unsigned_32) return Unsigned_32; - pragma Inline (H); - - procedure HH - (A : in out Unsigned_32; - B, C, D : Unsigned_32; - X : Unsigned_32; - AC : Unsigned_32; - S : Positive); - pragma Inline (HH); - - function I (X, Y, Z : Unsigned_32) return Unsigned_32; - pragma Inline (I); - - procedure II - (A : in out Unsigned_32; - B, C, D : Unsigned_32; - X : Unsigned_32; - AC : Unsigned_32; - S : Positive); - pragma Inline (II); - - procedure Transform - (C : in out Context; - Block : String); - -- Process one block of 64 characters - - ------------ - -- Decode -- - ------------ - - procedure Decode - (Block : String; - X : out Sixteen_Words) - is - Cur : Positive := Block'First; - - begin - pragma Assert (Block'Length = 64); - - for Index in X'Range loop - X (Index) := - Unsigned_32 (Character'Pos (Block (Cur))) + - Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 1))), 8) + - Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 2))), 16) + - Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 3))), 24); - Cur := Cur + 4; - end loop; - end Decode; - - ------------ - -- Digest -- - ------------ - - function Digest (C : Context) return Message_Digest is - Result : Message_Digest; - - Cur : Natural := 1; - -- Index in Result where the next character will be placed - - Last_Block : String (1 .. 64); - - C1 : Context := C; - - procedure Convert (X : Unsigned_32); - -- Put the contribution of one of the four words (A, B, C, D) of the - -- Context in Result. Increments Cur. - - ------------- - -- Convert -- - ------------- - - procedure Convert (X : Unsigned_32) is - Y : Unsigned_32 := X; - begin - for J in 1 .. 4 loop - Result (Cur + 1) := Hex_Digit (Y and Unsigned_32'(16#0F#)); - Y := Shift_Right (Y, 4); - Result (Cur) := Hex_Digit (Y and Unsigned_32'(16#0F#)); - Y := Shift_Right (Y, 4); - Cur := Cur + 2; - end loop; - end Convert; - - -- Start of processing for Digest - - begin - -- Process characters in the context buffer, if any - - Last_Block (1 .. C.Last) := C.Buffer (1 .. C.Last); - - -- Too many magic literals below, should be defined as constants ??? - - if C.Last > 55 then - Last_Block (C.Last + 1 .. 64) := Padding (1 .. 64 - C.Last); - Transform (C1, Last_Block); - Last_Block := (others => ASCII.NUL); - - else - Last_Block (C.Last + 1 .. 56) := Padding (1 .. 56 - C.Last); - end if; - - -- Add the input length (as stored in the context) as 8 characters - - Last_Block (57 .. 64) := (others => ASCII.NUL); - - declare - L : Unsigned_64 := Unsigned_64 (C.Length) * 8; - Idx : Positive := 57; - - begin - while L > 0 loop - Last_Block (Idx) := Character'Val (L and 16#Ff#); - L := Shift_Right (L, 8); - Idx := Idx + 1; - end loop; - end; - - Transform (C1, Last_Block); - - Convert (C1.A); - Convert (C1.B); - Convert (C1.C); - Convert (C1.D); - return Result; - end Digest; - - function Digest (S : String) return Message_Digest is - C : Context; - begin - Update (C, S); - return Digest (C); - end Digest; - - function Digest - (A : Ada.Streams.Stream_Element_Array) return Message_Digest - is - C : Context; - begin - Update (C, A); - return Digest (C); - end Digest; - - ------- - -- F -- - ------- - - function F (X, Y, Z : Unsigned_32) return Unsigned_32 is - begin - return (X and Y) or ((not X) and Z); - end F; - - -------- - -- FF -- - -------- - - procedure FF - (A : in out Unsigned_32; - B, C, D : Unsigned_32; - X : Unsigned_32; - AC : Unsigned_32; - S : Positive) - is - begin - A := A + F (B, C, D) + X + AC; - A := Rotate_Left (A, S); - A := A + B; - end FF; - - ------- - -- G -- - ------- - - function G (X, Y, Z : Unsigned_32) return Unsigned_32 is - begin - return (X and Z) or (Y and (not Z)); - end G; - - -------- - -- GG -- - -------- - - procedure GG - (A : in out Unsigned_32; - B, C, D : Unsigned_32; - X : Unsigned_32; - AC : Unsigned_32; - S : Positive) - is - begin - A := A + G (B, C, D) + X + AC; - A := Rotate_Left (A, S); - A := A + B; - end GG; - - ------- - -- H -- - ------- - - function H (X, Y, Z : Unsigned_32) return Unsigned_32 is - begin - return X xor Y xor Z; - end H; - - -------- - -- HH -- - -------- - - procedure HH - (A : in out Unsigned_32; - B, C, D : Unsigned_32; - X : Unsigned_32; - AC : Unsigned_32; - S : Positive) - is - begin - A := A + H (B, C, D) + X + AC; - A := Rotate_Left (A, S); - A := A + B; - end HH; - - ------- - -- I -- - ------- - - function I (X, Y, Z : Unsigned_32) return Unsigned_32 is - begin - return Y xor (X or (not Z)); - end I; - - -------- - -- II -- - -------- - - procedure II - (A : in out Unsigned_32; - B, C, D : Unsigned_32; - X : Unsigned_32; - AC : Unsigned_32; - S : Positive) - is - begin - A := A + I (B, C, D) + X + AC; - A := Rotate_Left (A, S); - A := A + B; - end II; - - --------------- - -- Transform -- - --------------- - - procedure Transform - (C : in out Context; - Block : String) - is - X : Sixteen_Words; - - AA : Unsigned_32 := C.A; - BB : Unsigned_32 := C.B; - CC : Unsigned_32 := C.C; - DD : Unsigned_32 := C.D; - - begin - pragma Assert (Block'Length = 64); - - Decode (Block, X); - - -- Round 1 - - FF (AA, BB, CC, DD, X (00), 16#D76aa478#, S11); -- 1 - FF (DD, AA, BB, CC, X (01), 16#E8c7b756#, S12); -- 2 - FF (CC, DD, AA, BB, X (02), 16#242070db#, S13); -- 3 - FF (BB, CC, DD, AA, X (03), 16#C1bdceee#, S14); -- 4 - - FF (AA, BB, CC, DD, X (04), 16#f57c0faf#, S11); -- 5 - FF (DD, AA, BB, CC, X (05), 16#4787c62a#, S12); -- 6 - FF (CC, DD, AA, BB, X (06), 16#a8304613#, S13); -- 7 - FF (BB, CC, DD, AA, X (07), 16#fd469501#, S14); -- 8 - - FF (AA, BB, CC, DD, X (08), 16#698098d8#, S11); -- 9 - FF (DD, AA, BB, CC, X (09), 16#8b44f7af#, S12); -- 10 - FF (CC, DD, AA, BB, X (10), 16#ffff5bb1#, S13); -- 11 - FF (BB, CC, DD, AA, X (11), 16#895cd7be#, S14); -- 12 - - FF (AA, BB, CC, DD, X (12), 16#6b901122#, S11); -- 13 - FF (DD, AA, BB, CC, X (13), 16#fd987193#, S12); -- 14 - FF (CC, DD, AA, BB, X (14), 16#a679438e#, S13); -- 15 - FF (BB, CC, DD, AA, X (15), 16#49b40821#, S14); -- 16 - - -- Round 2 - - GG (AA, BB, CC, DD, X (01), 16#f61e2562#, S21); -- 17 - GG (DD, AA, BB, CC, X (06), 16#c040b340#, S22); -- 18 - GG (CC, DD, AA, BB, X (11), 16#265e5a51#, S23); -- 19 - GG (BB, CC, DD, AA, X (00), 16#e9b6c7aa#, S24); -- 20 - - GG (AA, BB, CC, DD, X (05), 16#d62f105d#, S21); -- 21 - GG (DD, AA, BB, CC, X (10), 16#02441453#, S22); -- 22 - GG (CC, DD, AA, BB, X (15), 16#d8a1e681#, S23); -- 23 - GG (BB, CC, DD, AA, X (04), 16#e7d3fbc8#, S24); -- 24 - - GG (AA, BB, CC, DD, X (09), 16#21e1cde6#, S21); -- 25 - GG (DD, AA, BB, CC, X (14), 16#c33707d6#, S22); -- 26 - GG (CC, DD, AA, BB, X (03), 16#f4d50d87#, S23); -- 27 - GG (BB, CC, DD, AA, X (08), 16#455a14ed#, S24); -- 28 - - GG (AA, BB, CC, DD, X (13), 16#a9e3e905#, S21); -- 29 - GG (DD, AA, BB, CC, X (02), 16#fcefa3f8#, S22); -- 30 - GG (CC, DD, AA, BB, X (07), 16#676f02d9#, S23); -- 31 - GG (BB, CC, DD, AA, X (12), 16#8d2a4c8a#, S24); -- 32 - - -- Round 3 - - HH (AA, BB, CC, DD, X (05), 16#fffa3942#, S31); -- 33 - HH (DD, AA, BB, CC, X (08), 16#8771f681#, S32); -- 34 - HH (CC, DD, AA, BB, X (11), 16#6d9d6122#, S33); -- 35 - HH (BB, CC, DD, AA, X (14), 16#fde5380c#, S34); -- 36 - - HH (AA, BB, CC, DD, X (01), 16#a4beea44#, S31); -- 37 - HH (DD, AA, BB, CC, X (04), 16#4bdecfa9#, S32); -- 38 - HH (CC, DD, AA, BB, X (07), 16#f6bb4b60#, S33); -- 39 - HH (BB, CC, DD, AA, X (10), 16#bebfbc70#, S34); -- 40 - - HH (AA, BB, CC, DD, X (13), 16#289b7ec6#, S31); -- 41 - HH (DD, AA, BB, CC, X (00), 16#eaa127fa#, S32); -- 42 - HH (CC, DD, AA, BB, X (03), 16#d4ef3085#, S33); -- 43 - HH (BB, CC, DD, AA, X (06), 16#04881d05#, S34); -- 44 - - HH (AA, BB, CC, DD, X (09), 16#d9d4d039#, S31); -- 45 - HH (DD, AA, BB, CC, X (12), 16#e6db99e5#, S32); -- 46 - HH (CC, DD, AA, BB, X (15), 16#1fa27cf8#, S33); -- 47 - HH (BB, CC, DD, AA, X (02), 16#c4ac5665#, S34); -- 48 - - -- Round 4 - - II (AA, BB, CC, DD, X (00), 16#f4292244#, S41); -- 49 - II (DD, AA, BB, CC, X (07), 16#432aff97#, S42); -- 50 - II (CC, DD, AA, BB, X (14), 16#ab9423a7#, S43); -- 51 - II (BB, CC, DD, AA, X (05), 16#fc93a039#, S44); -- 52 - - II (AA, BB, CC, DD, X (12), 16#655b59c3#, S41); -- 53 - II (DD, AA, BB, CC, X (03), 16#8f0ccc92#, S42); -- 54 - II (CC, DD, AA, BB, X (10), 16#ffeff47d#, S43); -- 55 - II (BB, CC, DD, AA, X (01), 16#85845dd1#, S44); -- 56 - - II (AA, BB, CC, DD, X (08), 16#6fa87e4f#, S41); -- 57 - II (DD, AA, BB, CC, X (15), 16#fe2ce6e0#, S42); -- 58 - II (CC, DD, AA, BB, X (06), 16#a3014314#, S43); -- 59 - II (BB, CC, DD, AA, X (13), 16#4e0811a1#, S44); -- 60 - - II (AA, BB, CC, DD, X (04), 16#f7537e82#, S41); -- 61 - II (DD, AA, BB, CC, X (11), 16#bd3af235#, S42); -- 62 - II (CC, DD, AA, BB, X (02), 16#2ad7d2bb#, S43); -- 63 - II (BB, CC, DD, AA, X (09), 16#eb86d391#, S44); -- 64 - - C.A := C.A + AA; - C.B := C.B + BB; - C.C := C.C + CC; - C.D := C.D + DD; - - end Transform; - - ------------ - -- Update -- - ------------ - - procedure Update - (C : in out Context; - Input : String) - is - Inp : constant String := C.Buffer (1 .. C.Last) & Input; - Cur : Positive := Inp'First; - - begin - C.Length := C.Length + Input'Length; - - while Cur + 63 <= Inp'Last loop - Transform (C, Inp (Cur .. Cur + 63)); - Cur := Cur + 64; - end loop; - - C.Last := Inp'Last - Cur + 1; - C.Buffer (1 .. C.Last) := Inp (Cur .. Inp'Last); - end Update; - - procedure Update - (C : in out Context; - Input : Ada.Streams.Stream_Element_Array) - is - subtype Stream_Array is Ada.Streams.Stream_Element_Array (Input'Range); - subtype Stream_String is - String (1 + Integer (Input'First) .. 1 + Integer (Input'Last)); - - function To_String is new Ada.Unchecked_Conversion - (Stream_Array, Stream_String); - - String_Input : constant String := To_String (Input); - begin - Update (C, String_Input); - end Update; - - ----------------- - -- Wide_Digest -- - ----------------- - - function Wide_Digest (W : Wide_String) return Message_Digest is - C : Context; - begin - Wide_Update (C, W); - return Digest (C); - end Wide_Digest; - - ----------------- - -- Wide_Update -- - ----------------- - - procedure Wide_Update - (C : in out Context; - Input : Wide_String) - is - String_Input : String (1 .. 2 * Input'Length); - Cur : Positive := 1; - - begin - for Index in Input'Range loop - String_Input (Cur) := - Character'Val - (Unsigned_32 (Wide_Character'Pos (Input (Index))) and 16#FF#); - Cur := Cur + 1; - String_Input (Cur) := - Character'Val - (Shift_Right (Unsigned_32 (Wide_Character'Pos (Input (Index))), 8) - and 16#FF#); - Cur := Cur + 1; - end loop; - - Update (C, String_Input); - end Wide_Update; - -end GNAT.MD5; +pragma No_Body; diff --git a/gcc/ada/g-md5.ads b/gcc/ada/g-md5.ads index cea8eb6a802..70eb007b32c 100644 --- a/gcc/ada/g-md5.ads +++ b/gcc/ada/g-md5.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2008, AdaCore -- +-- Copyright (C) 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- -- @@ -16,8 +16,8 @@ -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- @@ -33,79 +33,19 @@ -- This package implements the MD5 Message-Digest Algorithm as described in -- RFC 1321. The complete text of RFC 1321 can be found at: --- -- http://www.ietf.org/rfc/rfc1321.txt --- --- The implementation is derived from the RSA Data Security, Inc. MD5 --- Message-Digest Algorithm, as described in RFC 1321. -with Ada.Streams; -with Interfaces; +-- See the declaration of GNAT.Secure_Hashes.H in g-sechas.ads for complete +-- documentation. -package GNAT.MD5 is +with GNAT.Secure_Hashes.MD5; +with System; - type Context is private; - -- This type is the four-word (16 byte) MD buffer, as described in - -- RFC 1321 (3.3). Its initial value is Initial_Context below. - - Initial_Context : constant Context; - -- Initial value of a Context object. May be used to reinitialize - -- a Context value by simple assignment of this value to the object. - - procedure Update - (C : in out Context; - Input : String); - procedure Wide_Update - (C : in out Context; - Input : Wide_String); - procedure Update - (C : in out Context; - Input : Ada.Streams.Stream_Element_Array); - -- Modify the Context C. If C has the initial value Initial_Context, - -- then, after a call to one of these procedures, Digest (C) will return - -- the Message-Digest of Input. - -- - -- These procedures may be called successively with the same context and - -- different inputs, and these several successive calls will produce - -- the same final context as a call with the concatenation of the inputs. - - subtype Message_Digest is String (1 .. 32); - -- The string type returned by function Digest - - function Digest (C : Context) return Message_Digest; - -- Extracts the Message-Digest from a context. This function should be - -- used after one or several calls to Update. - - function Digest (S : String) return Message_Digest; - function Wide_Digest (W : Wide_String) return Message_Digest; - function Digest - (A : Ada.Streams.Stream_Element_Array) - return Message_Digest; - -- These functions are equivalent to the corresponding Update (or - -- Wide_Update) on a default initialized Context, followed by Digest - -- on the resulting Context. - -private - - -- Magic numbers - - Initial_A : constant := 16#67452301#; - Initial_B : constant := 16#EFCDAB89#; - Initial_C : constant := 16#98BADCFE#; - Initial_D : constant := 16#10325476#; - - type Context is record - A : Interfaces.Unsigned_32 := Initial_A; - B : Interfaces.Unsigned_32 := Initial_B; - C : Interfaces.Unsigned_32 := Initial_C; - D : Interfaces.Unsigned_32 := Initial_D; - Buffer : String (1 .. 64) := (others => ASCII.NUL); - Last : Natural := 0; - Length : Natural := 0; - end record; - - Initial_Context : constant Context := - (A => Initial_A, B => Initial_B, C => Initial_C, D => Initial_D, - Buffer => (others => ASCII.NUL), Last => 0, Length => 0); - -end GNAT.MD5; +package GNAT.MD5 is new GNAT.Secure_Hashes.H + (Block_Words => GNAT.Secure_Hashes.MD5.Block_Words, + State_Words => 4, + Hash_Words => 4, + Hash_Bit_Order => System.Low_Order_First, + Hash_State => GNAT.Secure_Hashes.MD5.Hash_State, + Initial_State => GNAT.Secure_Hashes.MD5.Initial_State, + Transform => GNAT.Secure_Hashes.MD5.Transform); diff --git a/gcc/ada/g-pehage.adb b/gcc/ada/g-pehage.adb index 5abb04c2138..e96b9cc0c58 100644 --- a/gcc/ada/g-pehage.adb +++ b/gcc/ada/g-pehage.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- -- @@ -1970,11 +1970,7 @@ package body GNAT.Perfect_Hash_Generators is Q := Seed / 127773; X := 16807 * R - 2836 * Q; - if X < 0 then - Seed := X + 2147483647; - else - Seed := X; - end if; + Seed := (if X < 0 then X + 2147483647 else X); end Random; ------------- @@ -2233,11 +2229,8 @@ package body GNAT.Perfect_Hash_Generators is -- The first position should not exceed the minimum key length. -- Otherwise, we may end up with an empty word once reduced. - if Last_Sel_Pos = 0 then - Max_Sel_Pos := Min_Key_Len; - else - Max_Sel_Pos := Max_Key_Len; - end if; + Max_Sel_Pos := + (if Last_Sel_Pos = 0 then Min_Key_Len else Max_Key_Len); -- Find which position increases more the number of differences diff --git a/gcc/ada/g-regist.adb b/gcc/ada/g-regist.adb index 2c706ff69e4..c04248e588f 100644 --- a/gcc/ada/g-regist.adb +++ b/gcc/ada/g-regist.adb @@ -417,11 +417,7 @@ package body GNAT.Registry is Result : LONG; begin - if Expand then - Value_Type := REG_EXPAND_SZ; - else - Value_Type := REG_SZ; - end if; + Value_Type := (if Expand then REG_EXPAND_SZ else REG_SZ); Result := RegSetValueEx diff --git a/gcc/ada/g-sercom-linux.adb b/gcc/ada/g-sercom-linux.adb index 1be595a2f63..a89b09b8d08 100644 --- a/gcc/ada/g-sercom-linux.adb +++ b/gcc/ada/g-sercom-linux.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2007-2008, AdaCore -- +-- Copyright (C) 2007-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- -- @@ -37,7 +37,9 @@ with Ada.Streams; use Ada.Streams; with Ada; use Ada; with Ada.Unchecked_Deallocation; -with System.CRTL; use System, System.CRTL; +with System; use System; +with System.Communication; use System.Communication; +with System.CRTL; use System.CRTL; with GNAT.OS_Lib; use GNAT.OS_Lib; @@ -167,11 +169,10 @@ package body GNAT.Serial_Communications is Res := read (Integer (Port.H.all), Buffer'Address, Len); if Res = -1 then - Last := 0; Raise_Error ("read failed"); - else - Last := Buffer'First + Stream_Element_Offset (Res) - 1; end if; + + Last := Last_Index (Buffer'First, size_t (Res)); end Read; --------- @@ -210,7 +211,10 @@ package body GNAT.Serial_Communications is pragma Import (C, tcflush, "tcflush"); Current : termios; - Res : int; + + Res : int; + pragma Warnings (Off, Res); + -- Warnings off, since we don't always test the result begin if Port.H = null then @@ -245,11 +249,7 @@ package body GNAT.Serial_Communications is -- Block - if Block then - Res := fcntl (int (Port.H.all), F_SETFL, 0); - else - Res := fcntl (int (Port.H.all), F_SETFL, FNDELAY); - end if; + Res := fcntl (int (Port.H.all), F_SETFL, (if Block then 0 else FNDELAY)); if Res = -1 then Raise_Error ("set: fcntl failed"); diff --git a/gcc/ada/g-sercom-mingw.adb b/gcc/ada/g-sercom-mingw.adb index 03bd6aba191..cc6123bbc7c 100644 --- a/gcc/ada/g-sercom-mingw.adb +++ b/gcc/ada/g-sercom-mingw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2007-2008, AdaCore -- +-- Copyright (C) 2007-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- -- @@ -35,7 +35,12 @@ with Ada.Unchecked_Deallocation; use Ada; with Ada.Streams; use Ada.Streams; -with System.Win32.Ext; use System, System.Win32, System.Win32.Ext; + +with System; use System; +with System.Communication; use System.Communication; +with System.CRTL; use System.CRTL; +with System.Win32; use System.Win32; +with System.Win32.Ext; use System.Win32.Ext; package body GNAT.Serial_Communications is @@ -158,7 +163,7 @@ package body GNAT.Serial_Communications is Raise_Error ("read error"); end if; - Last := Buffer'First - 1 + Stream_Element_Offset (Read_Last); + Last := Last_Index (Buffer'First, size_t (Read_Last)); end Read; --------- diff --git a/gcc/ada/g-sercom.ads b/gcc/ada/g-sercom.ads index 8b4c5590684..a3c4b0c610b 100644 --- a/gcc/ada/g-sercom.ads +++ b/gcc/ada/g-sercom.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2007-2008, AdaCore -- +-- Copyright (C) 2007-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- -- @@ -91,7 +91,9 @@ package GNAT.Serial_Communications is Buffer : out Ada.Streams.Stream_Element_Array; Last : out Ada.Streams.Stream_Element_Offset); -- Read a set of bytes, put result into Buffer and set Last accordingly. - -- Last is set to 0 if no byte has been read. + -- Last is set to Buffer'First - 1 if no byte has been read, unless + -- Buffer'First = Stream_Element_Offset'First, in which case + -- Constraint_Error raised instead. overriding procedure Write (Port : in out Serial_Port; diff --git a/gcc/ada/g-sha1.adb b/gcc/ada/g-sha1.adb index 72b19244a36..edc6b43d9c0 100644 --- a/gcc/ada/g-sha1.adb +++ b/gcc/ada/g-sha1.adb @@ -4,376 +4,33 @@ -- -- -- G N A T . S H A 1 -- -- -- --- B o d y -- +-- B o d y -- -- -- --- Copyright (C) 2002-2006, AdaCore -- +-- Copyright (C) 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- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- Note: the code for this unit is derived from GNAT.MD5 - -with Ada.Unchecked_Conversion; - -package body GNAT.SHA1 is - - use Interfaces; - - Padding : constant String := - (1 => Character'Val (16#80#), 2 .. 64 => ASCII.NUL); - - Hex_Digit : constant array (Unsigned_32 range 0 .. 15) of Character := - ('0', '1', '2', '3', '4', '5', '6', '7', - '8', '9', 'a', 'b', 'c', 'd', 'e', 'f'); - -- Look-up table for each hex digit of the Message-Digest. - -- Used by function Digest (Context). - - type Sixteen_Words is array (Natural range 0 .. 15) - of Interfaces.Unsigned_32; - -- Sixteen 32-bit words, converted from block of 64 characters. - -- Used in procedure Decode and Transform. - - procedure Decode (Block : String; X : out Sixteen_Words); - -- Convert a String of 64 characters into 16 32-bit numbers - - -- The following functions are the four elementary components of each - -- of the four round groups (0 .. 19, 20 .. 39, 40 .. 59, and 60 .. 79) - -- defined in RFC 3174. - - function F0 (B, C, D : Unsigned_32) return Unsigned_32; - pragma Inline (F0); - - function F1 (B, C, D : Unsigned_32) return Unsigned_32; - pragma Inline (F1); - - function F2 (B, C, D : Unsigned_32) return Unsigned_32; - pragma Inline (F2); - - function F3 (B, C, D : Unsigned_32) return Unsigned_32; - pragma Inline (F3); - - procedure Transform (Ctx : in out Context; Block : String); - -- Process one block of 64 characters - - ------------ - -- Decode -- - ------------ - - procedure Decode (Block : String; X : out Sixteen_Words) is - Cur : Positive := Block'First; - - begin - pragma Assert (Block'Length = 64); - - for Index in X'Range loop - X (Index) := - Unsigned_32 (Character'Pos (Block (Cur + 3))) + - Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 2))), 8) + - Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 1))), 16) + - Shift_Left (Unsigned_32 (Character'Pos (Block (Cur))), 24); - Cur := Cur + 4; - end loop; - end Decode; - - ------------ - -- Digest -- - ------------ - - function Digest (C : Context) return Message_Digest is - Result : Message_Digest; - - Cur : Natural := 1; - -- Index in Result where the next character will be placed - - Last_Block : String (1 .. 64); - - C1 : Context := C; - - procedure Convert (X : Unsigned_32); - -- Put the contribution of one of the five H words of the Context in - -- Result. Increments Cur. - - ------------- - -- Convert -- - ------------- - - procedure Convert (X : Unsigned_32) is - Y : Unsigned_32 := X; - begin - for J in 1 .. 8 loop - Y := Rotate_Left (Y, 4); - Result (Cur) := Hex_Digit (Y and Unsigned_32'(16#0F#)); - Cur := Cur + 1; - end loop; - end Convert; - - -- Start of processing for Digest - - begin - -- Process characters in the context buffer, if any - - pragma Assert (C.Last /= C.Buffer'Last); - Last_Block (1 .. C.Last) := C.Buffer (1 .. C.Last); - - if C.Last > 55 then - Last_Block (C.Last + 1 .. 64) := Padding (1 .. 64 - C.Last); - Transform (C1, Last_Block); - Last_Block := (others => ASCII.NUL); - - else - Last_Block (C.Last + 1 .. 56) := Padding (1 .. 56 - C.Last); - end if; - - -- Add the input length (as stored in the context) as 8 characters - - Last_Block (57 .. 64) := (others => ASCII.NUL); - - declare - L : Unsigned_64 := Unsigned_64 (C.Length) * 8; - Idx : Positive := 64; - begin - while L > 0 loop - Last_Block (Idx) := Character'Val (L and 16#Ff#); - L := Shift_Right (L, 8); - Idx := Idx - 1; - end loop; - end; - - Transform (C1, Last_Block); - - Convert (C1.H (0)); - Convert (C1.H (1)); - Convert (C1.H (2)); - Convert (C1.H (3)); - Convert (C1.H (4)); - return Result; - end Digest; - - function Digest (S : String) return Message_Digest is - C : Context; - begin - Update (C, S); - return Digest (C); - end Digest; - - function Digest - (A : Ada.Streams.Stream_Element_Array) return Message_Digest - is - C : Context; - begin - Update (C, A); - return Digest (C); - end Digest; - - -------- - -- F0 -- - -------- - - function F0 - (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 - is - begin - return (B and C) or ((not B) and D); - end F0; - - -------- - -- F1 -- - -------- - - function F1 - (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 - is - begin - return B xor C xor D; - end F1; - - -------- - -- F2 -- - -------- - - function F2 - (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 - is - begin - return (B and C) or (B and D) or (C and D); - end F2; - - -------- - -- F3 -- - -------- - - function F3 - (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 - renames F1; - - --------------- - -- Transform -- - --------------- - - procedure Transform - (Ctx : in out Context; - Block : String) - is - W : array (0 .. 79) of Interfaces.Unsigned_32; - - A, B, C, D, E, Temp : Interfaces.Unsigned_32; - - begin - pragma Assert (Block'Length = 64); - - -- a. Divide data block into sixteen words - - Decode (Block, Sixteen_Words (W (0 .. 15))); - - -- b. Prepare working block of 80 words - - for T in 16 .. 79 loop - - -- W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16)) - - W (T) := Rotate_Left - (W (T - 3) xor W (T - 8) xor W (T - 14) xor W (T - 16), 1); - - end loop; - - -- c. Set up transformation variables - - A := Ctx.H (0); - B := Ctx.H (1); - C := Ctx.H (2); - D := Ctx.H (3); - E := Ctx.H (4); - - -- d. For each of the 80 rounds, compute: - - -- TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t); - -- E = D; D = C; C = S^30(B); B = A; A = TEMP; - - for T in 0 .. 19 loop - Temp := Rotate_Left (A, 5) + F0 (B, C, D) + E + W (T) + 16#5A827999#; - E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp; - end loop; - - for T in 20 .. 39 loop - Temp := Rotate_Left (A, 5) + F1 (B, C, D) + E + W (T) + 16#6ED9EBA1#; - E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp; - end loop; - - for T in 40 .. 59 loop - Temp := Rotate_Left (A, 5) + F2 (B, C, D) + E + W (T) + 16#8F1BBCDC#; - E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp; - end loop; - - for T in 60 .. 79 loop - Temp := Rotate_Left (A, 5) + F3 (B, C, D) + E + W (T) + 16#CA62C1D6#; - E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp; - end loop; - - -- e. Update context: - -- H0 = H0 + A, H1 = H1 + B, H2 = H2 + C, H3 = H3 + D, H4 = H4 + E - - Ctx.H (0) := Ctx.H (0) + A; - Ctx.H (1) := Ctx.H (1) + B; - Ctx.H (2) := Ctx.H (2) + C; - Ctx.H (3) := Ctx.H (3) + D; - Ctx.H (4) := Ctx.H (4) + E; - end Transform; - - ------------ - -- Update -- - ------------ - - procedure Update - (C : in out Context; - Input : String) - is - Inp : constant String := C.Buffer (1 .. C.Last) & Input; - Cur : Positive := Inp'First; - - begin - C.Length := C.Length + Input'Length; - - while Cur + 63 <= Inp'Last loop - Transform (C, Inp (Cur .. Cur + 63)); - Cur := Cur + 64; - end loop; - - C.Last := Inp'Last - Cur + 1; - C.Buffer (1 .. C.Last) := Inp (Cur .. Inp'Last); - end Update; - - procedure Update - (C : in out Context; - Input : Ada.Streams.Stream_Element_Array) - is - subtype Stream_Array is Ada.Streams.Stream_Element_Array (Input'Range); - subtype Stream_String is - String (1 + Integer (Input'First) .. 1 + Integer (Input'Last)); - - function To_String is new Ada.Unchecked_Conversion - (Stream_Array, Stream_String); - - String_Input : constant String := To_String (Input); - begin - Update (C, String_Input); - end Update; - - ----------------- - -- Wide_Digest -- - ----------------- - - function Wide_Digest (W : Wide_String) return Message_Digest is - C : Context; - begin - Wide_Update (C, W); - return Digest (C); - end Wide_Digest; - - ----------------- - -- Wide_Update -- - ----------------- - - procedure Wide_Update - (C : in out Context; - Input : Wide_String) - is - String_Input : String (1 .. 2 * Input'Length); - Cur : Positive := 1; - - begin - for Index in Input'Range loop - String_Input (Cur) := - Character'Val - (Unsigned_32 (Wide_Character'Pos (Input (Index))) and 16#FF#); - Cur := Cur + 1; - String_Input (Cur) := - Character'Val - (Shift_Right (Unsigned_32 (Wide_Character'Pos (Input (Index))), 8) - and 16#FF#); - Cur := Cur + 1; - end loop; - - Update (C, String_Input); - end Wide_Update; +-- This package does not require a body, since it is a package renaming. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -end GNAT.SHA1; +pragma No_Body; diff --git a/gcc/ada/g-sha1.ads b/gcc/ada/g-sha1.ads index 36e2e25d853..39132054ddf 100644 --- a/gcc/ada/g-sha1.ads +++ b/gcc/ada/g-sha1.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2006, AdaCore -- +-- Copyright (C) 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- -- @@ -16,8 +16,8 @@ -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- @@ -31,86 +31,21 @@ -- -- ------------------------------------------------------------------------------ --- This package implements the US Secure Hash Algorithm 1 (SHA1) as described --- in RFC 3174. The complete text of RFC 3174 can be found at: +-- This package implaments the SHA-1 secure hash function as decsribed in +-- FIPS PUB 180-3. The complete text of FIPS PUB 180-3 can be found at: +-- http://csrc.nist.gov/publications/fips/fips180-3/fips180-3_final.pdf --- http://www.ietf.org/rfc/rfc3174.txt +-- See the declaration of GNAT.Secure_Hashes.H in g-sechas.ads for complete +-- documentation. --- Note: the code for this unit is derived from GNAT.MD5 +with GNAT.Secure_Hashes.SHA1; +with System; -with Ada.Streams; -with Interfaces; - -package GNAT.SHA1 is - - type Context is private; - -- This type holds the five-word (20 byte) buffer H, as described in - -- RFC 3174 (6.1). Its initial value is Initial_Context below. - - Initial_Context : constant Context; - -- Initial value of a Context object. May be used to reinitialize - -- a Context value by simple assignment of this value to the object. - - procedure Update - (C : in out Context; - Input : String); - procedure Wide_Update - (C : in out Context; - Input : Wide_String); - procedure Update - (C : in out Context; - Input : Ada.Streams.Stream_Element_Array); - -- Modify the Context C. If C has the initial value Initial_Context, - -- then, after a call to one of these procedures, Digest (C) will return - -- the Message-Digest of Input. - -- - -- These procedures may be called successively with the same context and - -- different inputs, and these several successive calls will produce - -- the same final context as a call with the concatenation of the inputs. - - subtype Message_Digest is String (1 .. 40); - -- The string type returned by function Digest - - function Digest (C : Context) return Message_Digest; - -- Extracts the Message-Digest from a context. This function should be - -- used after one or several calls to Update. - - function Digest (S : String) return Message_Digest; - function Wide_Digest (W : Wide_String) return Message_Digest; - function Digest - (A : Ada.Streams.Stream_Element_Array) return Message_Digest; - -- These functions are equivalent to the corresponding Update (or - -- Wide_Update) on a default initialized Context, followed by Digest - -- on the resulting Context. - -private - - -- Magic numbers - - Initial_H0 : constant := 16#67452301#; - Initial_H1 : constant := 16#EFCDAB89#; - Initial_H2 : constant := 16#98BADCFE#; - Initial_H3 : constant := 16#10325476#; - Initial_H4 : constant := 16#C3D2E1F0#; - - type H_Type is array (0 .. 4) of Interfaces.Unsigned_32; - - Initial_H : constant H_Type := - (0 => Initial_H0, - 1 => Initial_H1, - 2 => Initial_H2, - 3 => Initial_H3, - 4 => Initial_H4); - - type Context is record - H : H_Type := Initial_H; - Buffer : String (1 .. 64) := (others => ASCII.NUL); - Last : Natural := 0; - Length : Natural := 0; - end record; - - Initial_Context : constant Context := - (H => Initial_H, - Buffer => (others => ASCII.NUL), Last => 0, Length => 0); - -end GNAT.SHA1; +package GNAT.SHA1 is new GNAT.Secure_Hashes.H + (Block_Words => GNAT.Secure_Hashes.SHA1.Block_Words, + State_Words => 5, + Hash_Words => 5, + Hash_Bit_Order => System.High_Order_First, + Hash_State => GNAT.Secure_Hashes.SHA1.Hash_State, + Initial_State => GNAT.Secure_Hashes.SHA1.Initial_State, + Transform => GNAT.Secure_Hashes.SHA1.Transform); diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 7741dc0c76d..09537baf452 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -46,7 +46,9 @@ with GNAT.Sockets.Linker_Options; pragma Warnings (Off, GNAT.Sockets.Linker_Options); -- Need to include pragma Linker_Options which is platform dependent -with System; use System; +with System; use System; +with System.Communication; use System.Communication; +with System.CRTL; use System.CRTL; package body GNAT.Sockets is @@ -162,7 +164,7 @@ package body GNAT.Sockets is function To_Host_Entry (E : Hostent) return Host_Entry_Type; -- Conversion function - function To_Service_Entry (E : Servent) return Service_Entry_Type; + function To_Service_Entry (E : Servent_Access) return Service_Entry_Type; -- Conversion function function To_Timeval (Val : Timeval_Duration) return Timeval; @@ -249,14 +251,6 @@ package body GNAT.Sockets is function Err_Code_Image (E : Integer) return String; -- Return the value of E surrounded with brackets - function Last_Index - (First : Stream_Element_Offset; - Count : C.int) return Stream_Element_Offset; - -- Compute the Last OUT parameter for the various Receive_Socket - -- subprograms: returns First + Count - 1, except for the case - -- where First = Stream_Element_Offset'First and Res = 0, in which - -- case Stream_Element_Offset'Last is returned instead. - procedure Initialize (X : in out Sockets_Library_Controller); procedure Finalize (X : in out Sockets_Library_Controller); @@ -977,7 +971,7 @@ package body GNAT.Sockets is -- Translate from the C format to the API format - return To_Service_Entry (Res); + return To_Service_Entry (Res'Unchecked_Access); end Get_Service_By_Name; ------------------------- @@ -1003,7 +997,7 @@ package body GNAT.Sockets is -- Translate from the C format to the API format - return To_Service_Entry (Res); + return To_Service_Entry (Res'Unchecked_Access); end Get_Service_By_Port; --------------------- @@ -1416,22 +1410,6 @@ package body GNAT.Sockets is and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0; end Is_Set; - ---------------- - -- Last_Index -- - ---------------- - - function Last_Index - (First : Stream_Element_Offset; - Count : C.int) return Stream_Element_Offset - is - begin - if First = Stream_Element_Offset'First and then Count = 0 then - return Stream_Element_Offset'Last; - else - return First + Stream_Element_Offset (Count - 1); - end if; - end Last_Index; - ------------------- -- Listen_Socket -- ------------------- @@ -1659,7 +1637,7 @@ package body GNAT.Sockets is Raise_Socket_Error (Socket_Errno); end if; - Last := Last_Index (First => Item'First, Count => Res); + Last := Last_Index (First => Item'First, Count => size_t (Res)); end Receive_Socket; -------------------- @@ -1691,7 +1669,7 @@ package body GNAT.Sockets is Raise_Socket_Error (Socket_Errno); end if; - Last := Last_Index (First => Item'First, Count => Res); + Last := Last_Index (First => Item'First, Count => size_t (Res)); To_Inet_Addr (Sin.Sin_Addr, From.Addr); From.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); @@ -1940,7 +1918,7 @@ package body GNAT.Sockets is Raise_Socket_Error (Socket_Errno); end if; - Last := Last_Index (First => Item'First, Count => Res); + Last := Last_Index (First => Item'First, Count => size_t (Res)); end Send_Socket; ----------------- @@ -2375,17 +2353,17 @@ package body GNAT.Sockets is -- To_Service_Entry -- ---------------------- - function To_Service_Entry (E : Servent) return Service_Entry_Type is + function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is use type C.size_t; - Official : constant String := C.Strings.Value (E.S_Name); + Official : constant String := C.Strings.Value (Servent_S_Name (E)); Aliases : constant Chars_Ptr_Array := - Chars_Ptr_Pointers.Value (E.S_Aliases); + Chars_Ptr_Pointers.Value (Servent_S_Aliases (E)); -- S_Aliases points to a list of name aliases. The list is -- terminated by a NULL pointer. - Protocol : constant String := C.Strings.Value (E.S_Proto); + Protocol : constant String := C.Strings.Value (Servent_S_Proto (E)); Result : Service_Entry_Type (Aliases_Length => Aliases'Length - 1); -- The last element is a null pointer @@ -2406,7 +2384,7 @@ package body GNAT.Sockets is end loop; Result.Port := - Port_Type (Network_To_Short (C.unsigned_short (E.S_Port))); + Port_Type (Network_To_Short (C.unsigned_short (Servent_S_Port (E)))); Result.Protocol := To_Name (Protocol); return Result; diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index 39a917a5480..8d3138e65d6 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -895,10 +895,11 @@ package GNAT.Sockets is Flags : Request_Flag_Type := No_Request_Flag); -- Receive message from Socket. Last is the index value such that Item -- (Last) is the last character assigned. Note that Last is set to - -- Item'First - 1 (or to Stream_Element_Array'Last if Item'First is - -- Stream_Element_Offset'First) when the socket has been closed by peer. - -- This is not an error and no exception is raised. Flags allows to - -- control the reception. Raise Socket_Error on error. + -- Item'First - 1 when the socket has been closed by peer. This is not + -- an error, and no exception is raised in this case unless Item'First + -- is Stream_Element_Offset'First, in which case Constraint_Error is + -- raised. Flags allows to control the reception. Raise Socket_Error on + -- error. procedure Receive_Socket (Socket : Socket_Type; @@ -937,12 +938,13 @@ package GNAT.Sockets is -- Transmit a message over a socket. For a datagram socket, the address -- is given by To.all. For a stream socket, To must be null. Last -- is the index value such that Item (Last) is the last character - -- sent. Note that Last is set to Item'First - 1 (if Item'First is - -- Stream_Element_Offset'First, to Stream_Element_Array'Last) when the - -- socket has been closed by peer. This is not an error and no exception - -- is raised. Flags allows control of the transmission. Raises exception - -- Socket_Error on error. Note: this subprogram is inlined because it is - -- also used to implement the two variants below. + -- sent. Note that Last is set to Item'First - 1 if the socket has been + -- closed by the peer (unless Item'First is Stream_Element_Offset'First, + -- in which case Constraint_Error is raised instead). This is not an error, + -- and Socket_Error is not raised in that case. Flags allows control of the + -- transmission. Raises exception Socket_Error on error. Note: this + -- subprogram is inlined because it is also used to implement the two + -- variants below. procedure Send_Socket (Socket : Socket_Type; diff --git a/gcc/ada/g-socthi-mingw.ads b/gcc/ada/g-socthi-mingw.ads index 8ec056148f1..6d851e17cb4 100644 --- a/gcc/ada/g-socthi-mingw.ads +++ b/gcc/ada/g-socthi-mingw.ads @@ -184,9 +184,6 @@ package GNAT.Sockets.Thin is Typ : C.int; Protocol : C.int) return C.int; - function C_Strerror - (Errnum : C.int) return C.Strings.chars_ptr; - function C_System (Command : System.Address) return C.int; @@ -241,7 +238,6 @@ private pragma Import (Stdcall, C_Setsockopt, "setsockopt"); pragma Import (Stdcall, C_Shutdown, "shutdown"); pragma Import (Stdcall, C_Socket, "socket"); - pragma Import (C, C_Strerror, "strerror"); pragma Import (C, C_System, "_system"); pragma Import (Stdcall, Socket_Errno, "WSAGetLastError"); pragma Import (Stdcall, Set_Socket_Errno, "WSASetLastError"); diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb index cb2b211d2aa..b9e23ecbfb5 100644 --- a/gcc/ada/g-socthi-vms.adb +++ b/gcc/ada/g-socthi-vms.adb @@ -473,19 +473,6 @@ package body GNAT.Sockets.Thin is function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr - is - use type Interfaces.C.Strings.chars_ptr; - - C_Msg : C.Strings.chars_ptr; - - begin - C_Msg := C_Strerror (C.int (Errno)); - - if C_Msg = C.Strings.Null_Ptr then - return Unknown_System_Error; - else - return C_Msg; - end if; - end Socket_Error_Message; + is separate; end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-vms.ads b/gcc/ada/g-socthi-vms.ads index 3032b0ec72b..a1bb487e136 100644 --- a/gcc/ada/g-socthi-vms.ads +++ b/gcc/ada/g-socthi-vms.ads @@ -187,9 +187,6 @@ package GNAT.Sockets.Thin is Typ : C.int; Protocol : C.int) return C.int; - function C_Strerror - (Errnum : C.int) return C.Strings.chars_ptr; - function C_System (Command : System.Address) return C.int; @@ -255,7 +252,6 @@ private pragma Import (C, C_Select, "DECC$SELECT"); pragma Import (C, C_Setsockopt, "DECC$SETSOCKOPT"); pragma Import (C, C_Shutdown, "DECC$SHUTDOWN"); - pragma Import (C, C_Strerror, "DECC$STRERROR"); pragma Import (C, C_System, "DECC$SYSTEM"); pragma Import (C, Nonreentrant_Gethostbyname, "DECC$GETHOSTBYNAME"); diff --git a/gcc/ada/g-socthi-vxworks.adb b/gcc/ada/g-socthi-vxworks.adb index 96d0cfca7a3..e6a8ee60644 100644 --- a/gcc/ada/g-socthi-vxworks.adb +++ b/gcc/ada/g-socthi-vxworks.adb @@ -489,20 +489,6 @@ package body GNAT.Sockets.Thin is function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr - is - use type Interfaces.C.Strings.chars_ptr; - - C_Msg : C.Strings.chars_ptr; - - begin - C_Msg := C_Strerror (C.int (Errno)); - - if C_Msg = C.Strings.Null_Ptr then - return Unknown_System_Error; - - else - return C_Msg; - end if; - end Socket_Error_Message; + is separate; end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-vxworks.ads b/gcc/ada/g-socthi-vxworks.ads index 08fac05d555..4f92b3a8143 100644 --- a/gcc/ada/g-socthi-vxworks.ads +++ b/gcc/ada/g-socthi-vxworks.ads @@ -185,9 +185,6 @@ package GNAT.Sockets.Thin is Typ : C.int; Protocol : C.int) return C.int; - function C_Strerror - (Errnum : C.int) return C.Strings.chars_ptr; - function C_System (Command : System.Address) return C.int; @@ -232,6 +229,5 @@ private pragma Import (C, C_Select, "select"); pragma Import (C, C_Setsockopt, "setsockopt"); pragma Import (C, C_Shutdown, "shutdown"); - pragma Import (C, C_Strerror, "strerror"); pragma Import (C, C_System, "system"); end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi.adb b/gcc/ada/g-socthi.adb index b232378fab6..ca797631b08 100644 --- a/gcc/ada/g-socthi.adb +++ b/gcc/ada/g-socthi.adb @@ -494,19 +494,6 @@ package body GNAT.Sockets.Thin is function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr - is - use type Interfaces.C.Strings.chars_ptr; - - C_Msg : C.Strings.chars_ptr; - - begin - C_Msg := C_Strerror (C.int (Errno)); - - if C_Msg = C.Strings.Null_Ptr then - return Unknown_System_Error; - else - return C_Msg; - end if; - end Socket_Error_Message; + is separate; end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi.ads b/gcc/ada/g-socthi.ads index eb690c5b4a8..1f103e89a74 100644 --- a/gcc/ada/g-socthi.ads +++ b/gcc/ada/g-socthi.ads @@ -186,9 +186,6 @@ package GNAT.Sockets.Thin is Typ : C.int; Protocol : C.int) return C.int; - function C_Strerror - (Errnum : C.int) return C.Strings.chars_ptr; - function C_System (Command : System.Address) return C.int; @@ -257,7 +254,6 @@ private pragma Import (C, C_Select, "select"); pragma Import (C, C_Setsockopt, "setsockopt"); pragma Import (C, C_Shutdown, "shutdown"); - pragma Import (C, C_Strerror, "strerror"); pragma Import (C, C_System, "system"); pragma Import (C, Nonreentrant_Gethostbyname, "gethostbyname"); diff --git a/gcc/ada/g-sothco.ads b/gcc/ada/g-sothco.ads index c5636a8f1e3..82003e2ffd5 100644 --- a/gcc/ada/g-sothco.ads +++ b/gcc/ada/g-sothco.ads @@ -212,19 +212,45 @@ package GNAT.Sockets.Thin_Common is C.Strings.Null_Ptr); -- Arrays of C (char *) - type Servent is record - S_Name : C.Strings.chars_ptr; - S_Aliases : Chars_Ptr_Pointers.Pointer; - S_Port : C.int; - S_Proto : C.Strings.chars_ptr; - end record; - pragma Convention (C, Servent); - -- Service entry + type Servent is new + System.Storage_Elements.Storage_Array (1 .. SOSC.SIZEOF_struct_servent); + for Servent'Alignment use 8; + -- Service entry. This is an opaque type used only via the following + -- accessor functions, because 'struct servent' has different layouts on + -- different platforms. type Servent_Access is access all Servent; pragma Convention (C, Servent_Access); -- Access to service entry + function Servent_S_Name + (E : Servent_Access) return C.Strings.chars_ptr; + + function Servent_S_Aliases + (E : Servent_Access) return Chars_Ptr_Pointers.Pointer; + + function Servent_S_Port + (E : Servent_Access) return C.int; + + function Servent_S_Proto + (E : Servent_Access) return C.Strings.chars_ptr; + + procedure Servent_Set_S_Name + (E : Servent_Access; + S_Name : C.Strings.chars_ptr); + + procedure Servent_Set_S_Aliases + (E : Servent_Access; + S_Aliases : Chars_Ptr_Pointers.Pointer); + + procedure Servent_Set_S_Port + (E : Servent_Access; + S_Port : C.int); + + procedure Servent_Set_S_Proto + (E : Servent_Access; + S_Proto : C.Strings.chars_ptr); + ------------------ -- Host entries -- ------------------ @@ -335,4 +361,13 @@ private pragma Import (C, Reset_Socket_Set, "__gnat_reset_socket_set"); pragma Import (C, C_Ioctl, "__gnat_socket_ioctl"); pragma Import (C, Inet_Pton, SOSC.Inet_Pton_Linkname); + + pragma Import (C, Servent_S_Name, "__gnat_servent_s_name"); + pragma Import (C, Servent_S_Aliases, "__gnat_servent_s_aliases"); + pragma Import (C, Servent_S_Port, "__gnat_servent_s_port"); + pragma Import (C, Servent_S_Proto, "__gnat_servent_s_proto"); + pragma Import (C, Servent_Set_S_Name, "__gnat_servent_set_s_name"); + pragma Import (C, Servent_Set_S_Aliases, "__gnat_servent_set_s_aliases"); + pragma Import (C, Servent_Set_S_Port, "__gnat_servent_set_s_port"); + pragma Import (C, Servent_Set_S_Proto, "__gnat_servent_set_s_proto"); end GNAT.Sockets.Thin_Common; diff --git a/gcc/ada/g-sttsne-locking.adb b/gcc/ada/g-sttsne-locking.adb index 622587123ee..c5e39b734b9 100644 --- a/gcc/ada/g-sttsne-locking.adb +++ b/gcc/ada/g-sttsne-locking.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2007, AdaCore -- +-- Copyright (C) 2007-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- -- @@ -57,8 +57,8 @@ package body GNAT.Sockets.Thin.Task_Safe_NetDB is -- is too small for the associated data). procedure Copy_Service_Entry - (Source_Servent : Servent; - Target_Servent : out Servent; + (Source_Servent : Servent_Access; + Target_Servent : Servent_Access; Target_Buffer : System.Address; Target_Buffer_Length : C.int; Result : out C.int); @@ -194,8 +194,8 @@ package body GNAT.Sockets.Thin.Task_Safe_NetDB is ------------------------ procedure Copy_Service_Entry - (Source_Servent : Servent; - Target_Servent : out Servent; + (Source_Servent : Servent_Access; + Target_Servent : Servent_Access; Target_Buffer : System.Address; Target_Buffer_Length : C.int; Result : out C.int) @@ -206,14 +206,15 @@ package body GNAT.Sockets.Thin.Task_Safe_NetDB is Source_Aliases : Chars_Ptr_Array renames Chars_Ptr_Pointers.Value - (Source_Servent.S_Aliases, Terminator => C.Strings.Null_Ptr); + (Servent_S_Aliases (Source_Servent), + Terminator => C.Strings.Null_Ptr); -- Null-terminated list of aliases (last element of this array is -- Null_Ptr). begin Result := -1; - Names_Length := C.Strings.Strlen (Source_Servent.S_Name) + 1 - + C.Strings.Strlen (Source_Servent.S_Proto) + 1; + Names_Length := C.Strings.Strlen (Servent_S_Name (Source_Servent)) + 1 + + C.Strings.Strlen (Servent_S_Proto (Source_Servent)) + 1; for J in Source_Aliases'Range loop if Source_Aliases (J) /= C.Strings.Null_Ptr then @@ -235,6 +236,8 @@ package body GNAT.Sockets.Thin.Task_Safe_NetDB is Names_Index : size_t := Netdb_Data.Names'First; -- Index of first available location in Netdb_Data.Names + Stored_Name : C.Strings.chars_ptr; + begin if Netdb_Data'Size / 8 > Target_Buffer_Length then return; @@ -243,26 +246,29 @@ package body GNAT.Sockets.Thin.Task_Safe_NetDB is -- Copy service name Store_Name - (C.Strings.Value (Source_Servent.S_Name), + (C.Strings.Value (Servent_S_Name (Source_Servent)), Netdb_Data.Names, Names_Index, - Target_Servent.S_Name); + Stored_Name); + Servent_Set_S_Name (Target_Servent, Stored_Name); -- Copy aliases (null-terminated string pointer array) - Target_Servent.S_Aliases := - Netdb_Data.Aliases_List - (Netdb_Data.Aliases_List'First)'Unchecked_Access; + Servent_Set_S_Aliases + (Target_Servent, + Netdb_Data.Aliases_List + (Netdb_Data.Aliases_List'First)'Unchecked_Access); -- Copy port number - Target_Servent.S_Port := Source_Servent.S_Port; + Servent_Set_S_Port (Target_Servent, Servent_S_Port (Source_Servent)); -- Copy protocol name Store_Name - (C.Strings.Value (Source_Servent.S_Proto), + (C.Strings.Value (Servent_S_Proto (Source_Servent)), Netdb_Data.Names, Names_Index, - Target_Servent.S_Proto); + Stored_Name); + Servent_Set_S_Proto (Target_Servent, Stored_Name); for J in Netdb_Data.Aliases_List'Range loop if J = Netdb_Data.Aliases_List'Last then @@ -377,11 +383,14 @@ package body GNAT.Sockets.Thin.Task_Safe_NetDB is goto Unlock_Return; end if; - -- Now copy the data to the user-provided buffer + -- Now copy the data to the user-provided buffer. We convert Ret to + -- type Servent_Access using the .all'Unchecked_Access trick to avoid + -- an accessibility check. Ret could be pointing to a nested variable, + -- and we don't want to raise an exception in that case. Copy_Service_Entry - (Source_Servent => SE.all, - Target_Servent => Ret.all, + (Source_Servent => SE, + Target_Servent => Ret.all'Unchecked_Access, Target_Buffer => Buf, Target_Buffer_Length => Buflen, Result => Result); @@ -414,11 +423,12 @@ package body GNAT.Sockets.Thin.Task_Safe_NetDB is goto Unlock_Return; end if; - -- Now copy the data to the user-provided buffer + -- Now copy the data to the user-provided buffer. See Safe_Getservbyname + -- for comment regarding .all'Unchecked_Access. Copy_Service_Entry - (Source_Servent => SE.all, - Target_Servent => Ret.all, + (Source_Servent => SE, + Target_Servent => Ret.all'Unchecked_Access, Target_Buffer => Buf, Target_Buffer_Length => Buflen, Result => Result); diff --git a/gcc/ada/g-trasym-vms-alpha.adb b/gcc/ada/g-trasym-vms-alpha.adb index adfa8f83d4e..c58c5610bfd 100644 --- a/gcc/ada/g-trasym-vms-alpha.adb +++ b/gcc/ada/g-trasym-vms-alpha.adb @@ -217,11 +217,9 @@ package body GNAT.Traceback.Symbolic is System.Soft_Links.Lock_Task.all; for J in Traceback'Range loop - if J = Traceback'Last then - Return_Address := Address_Zero; - else - Return_Address := PC_For (Traceback (J + 1)); - end if; + Return_Address := + (if J = Traceback'Last then Address_Zero + else PC_For (Traceback (J + 1))); Symbolize (Status, diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 02887029b22..d57c1f0032c 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -116,60 +116,223 @@ GNAT1_C_OBJS = ada/b_gnat1.o ada/adadecode.o ada/adaint.o ada/cstreams.o \ # Object files from Ada sources that are used by gnat1 -GNAT_ADA_OBJS = ada/s-bitops.o ada/ada.o ada/a-charac.o ada/a-chlat1.o ada/a-except.o \ - ada/a-elchha.o ada/a-ioexce.o \ - ada/s-memory.o ada/s-carun8.o ada/s-casuti.o ada/s-strcom.o ada/s-strhas.o \ - ada/s-purexc.o ada/s-htable.o ada/s-traceb.o ada/s-mastop.o ada/ali.o \ - ada/alloc.o ada/atree.o ada/butil.o ada/casing.o ada/checks.o ada/comperr.o \ - ada/csets.o ada/cstand.o ada/debug.o ada/debug_a.o ada/einfo.o ada/elists.o \ - ada/errout.o ada/erroutc.o ada/err_vars.o ada/eval_fat.o ada/exp_attr.o \ - ada/exp_ch11.o ada/exp_ch12.o ada/exp_ch13.o ada/exp_ch2.o ada/exp_ch3.o \ - ada/exp_ch4.o ada/exp_ch5.o ada/exp_ch6.o ada/exp_ch7.o ada/exp_ch8.o \ - ada/exp_ch9.o ada/exp_code.o ada/exp_dbug.o ada/exp_disp.o ada/exp_atag.o \ - ada/exp_dist.o ada/exp_fixd.o ada/exp_aggr.o ada/exp_imgv.o ada/exp_intr.o \ - ada/exp_pakd.o ada/exp_prag.o ada/exp_sel.o ada/exp_smem.o ada/exp_strm.o \ - ada/exp_tss.o ada/exp_util.o ada/exp_vfpt.o ada/expander.o ada/fname.o \ - ada/fname-uf.o ada/fmap.o ada/freeze.o ada/frontend.o ada/gnat.o \ - ada/g-byorma.o \ - ada/g-hesora.o ada/g-htable.o ada/s-os_lib.o \ - ada/g-speche.o ada/g-spchge.o ada/g-u3spch.o ada/s-string.o \ - ada/s-utf_32.o ada/s-crc32.o ada/get_targ.o \ - ada/get_scos.o \ - ada/gnatvsn.o ada/hlo.o ada/hostparm.o ada/impunit.o ada/interfac.o \ - ada/itypes.o ada/inline.o ada/krunch.o ada/lib.o ada/layout.o \ - ada/lib-load.o ada/lib-util.o ada/lib-xref.o ada/lib-writ.o ada/live.o \ - ada/namet.o ada/namet-sp.o \ - ada/nlists.o ada/nmake.o ada/opt.o ada/osint.o ada/osint-c.o \ - ada/output.o \ - ada/par_sco.o \ - ada/par.o ada/prep.o ada/prepcomp.o ada/put_scos.o \ - ada/repinfo.o ada/restrict.o \ - ada/rident.o ada/rtsfind.o \ - ada/s-addope.o ada/s-assert.o ada/s-parame.o ada/s-stache.o \ - ada/s-stalib.o ada/s-imgenu.o ada/s-imenne.o ada/s-stoele.o ada/s-soflin.o \ - ada/s-except.o ada/s-exctab.o \ - ada/s-secsta.o ada/s-strops.o ada/s-sopco3.o ada/s-sopco4.o ada/s-sopco5.o \ - ada/s-traent.o ada/s-wchcnv.o ada/s-wchcon.o ada/s-wchjis.o \ - ada/s-conca2.o ada/s-conca3.o ada/s-conca4.o ada/s-conca5.o \ - ada/s-conca6.o ada/s-conca7.o ada/s-conca8.o ada/s-conca9.o \ - ada/s-unstyp.o ada/scans.o ada/scng.o ada/scn.o ada/sdefault.o ada/sem.o \ - ada/scos.o \ - ada/sem_aggr.o ada/sem_attr.o ada/sem_aux.o \ - ada/sem_cat.o ada/sem_ch10.o ada/sem_ch11.o \ - ada/sem_ch12.o ada/sem_ch13.o ada/sem_ch2.o ada/sem_ch3.o ada/sem_ch4.o \ - ada/sem_ch5.o ada/sem_ch6.o ada/sem_ch7.o ada/sem_ch8.o ada/sem_ch9.o \ - ada/sem_case.o ada/sem_disp.o ada/sem_dist.o ada/sem_elab.o ada/sem_elim.o \ - ada/sem_eval.o ada/sem_intr.o ada/sem_mech.o ada/sem_prag.o ada/sem_res.o \ - ada/sem_scil.o ada/sem_smem.o ada/sem_type.o ada/sem_util.o ada/sem_vfpt.o \ - ada/sem_warn.o ada/sinfo-cn.o ada/sinfo.o ada/sinput.o ada/sinput-d.o \ - ada/sinput-l.o ada/snames.o ada/sprint.o ada/stand.o ada/stringt.o \ - ada/style.o ada/styleg.o ada/switch.o ada/switch-c.o \ - ada/stylesw.o ada/validsw.o ada/system.o ada/table.o ada/targparm.o \ - ada/tbuild.o ada/tree_gen.o ada/tree_in.o \ - ada/tree_io.o ada/treepr.o ada/treeprs.o \ - ada/ttypef.o ada/ttypes.o ada/types.o ada/uintp.o ada/uname.o ada/urealp.o \ - ada/usage.o ada/widechar.o ada/s-crtl.o ada/seh_init.o ada/targext.o \ - ada/s-restri.o +GNAT_ADA_OBJS = \ + ada/a-charac.o \ + ada/a-chlat1.o \ + ada/a-elchha.o \ + ada/a-except.o \ + ada/a-ioexce.o \ + ada/ada.o \ + ada/ali.o \ + ada/alloc.o \ + ada/atree.o \ + ada/butil.o \ + ada/casing.o \ + ada/checks.o \ + ada/comperr.o \ + ada/csets.o \ + ada/cstand.o \ + ada/debug.o \ + ada/debug_a.o \ + ada/einfo.o \ + ada/elists.o \ + ada/err_vars.o \ + ada/errout.o \ + ada/erroutc.o \ + ada/eval_fat.o \ + ada/exp_aggr.o \ + ada/exp_atag.o \ + ada/exp_attr.o \ + ada/exp_ch11.o \ + ada/exp_ch12.o \ + ada/exp_ch13.o \ + ada/exp_ch2.o \ + ada/exp_ch3.o \ + ada/exp_ch4.o \ + ada/exp_ch5.o \ + ada/exp_ch6.o \ + ada/exp_ch7.o \ + ada/exp_ch8.o \ + ada/exp_ch9.o \ + ada/exp_code.o \ + ada/exp_dbug.o \ + ada/exp_disp.o \ + ada/exp_dist.o \ + ada/exp_fixd.o \ + ada/exp_imgv.o \ + ada/exp_intr.o \ + ada/exp_pakd.o \ + ada/exp_prag.o \ + ada/exp_sel.o \ + ada/exp_smem.o \ + ada/exp_strm.o \ + ada/exp_tss.o \ + ada/exp_util.o \ + ada/exp_vfpt.o \ + ada/expander.o \ + ada/fmap.o \ + ada/fname-uf.o \ + ada/fname.o \ + ada/freeze.o \ + ada/frontend.o \ + ada/g-byorma.o \ + ada/g-hesora.o \ + ada/g-htable.o \ + ada/g-spchge.o \ + ada/g-speche.o \ + ada/g-u3spch.o \ + ada/get_scos.o \ + ada/get_targ.o \ + ada/gnat.o \ + ada/gnatvsn.o \ + ada/hlo.o \ + ada/hostparm.o \ + ada/impunit.o \ + ada/inline.o \ + ada/interfac.o \ + ada/itypes.o \ + ada/krunch.o \ + ada/layout.o \ + ada/lib-load.o \ + ada/lib-util.o \ + ada/lib-writ.o \ + ada/lib-xref.o \ + ada/lib.o \ + ada/live.o \ + ada/namet-sp.o \ + ada/namet.o \ + ada/nlists.o \ + ada/nmake.o \ + ada/opt.o \ + ada/osint-c.o \ + ada/osint.o \ + ada/output.o \ + ada/par.o \ + ada/par_sco.o \ + ada/prep.o \ + ada/prepcomp.o \ + ada/put_scos.o \ + ada/repinfo.o \ + ada/restrict.o \ + ada/rident.o \ + ada/rtsfind.o \ + ada/s-addope.o \ + ada/s-assert.o \ + ada/s-bitops.o \ + ada/s-carun8.o \ + ada/s-casuti.o \ + ada/s-conca2.o \ + ada/s-conca3.o \ + ada/s-conca4.o \ + ada/s-conca5.o \ + ada/s-conca6.o \ + ada/s-conca7.o \ + ada/s-conca8.o \ + ada/s-conca9.o \ + ada/s-crc32.o \ + ada/s-crtl.o \ + ada/s-except.o \ + ada/s-exctab.o \ + ada/s-htable.o \ + ada/s-imenne.o \ + ada/s-imgenu.o \ + ada/s-mastop.o \ + ada/s-memory.o \ + ada/s-os_lib.o \ + ada/s-parame.o \ + ada/s-purexc.o \ + ada/s-restri.o \ + ada/s-secsta.o \ + ada/s-soflin.o \ + ada/s-sopco3.o \ + ada/s-sopco4.o \ + ada/s-sopco5.o \ + ada/s-stache.o \ + ada/s-stalib.o \ + ada/s-stoele.o \ + ada/s-strcom.o \ + ada/s-strhas.o \ + ada/s-string.o \ + ada/s-strops.o \ + ada/s-traceb.o \ + ada/s-traent.o \ + ada/s-unstyp.o \ + ada/s-utf_32.o \ + ada/s-wchcnv.o \ + ada/s-wchcon.o \ + ada/s-wchjis.o \ + ada/scans.o \ + ada/scn.o \ + ada/scng.o \ + ada/scos.o \ + ada/sdefault.o \ + ada/seh_init.o \ + ada/sem.o \ + ada/sem_aggr.o \ + ada/sem_attr.o \ + ada/sem_aux.o \ + ada/sem_case.o \ + ada/sem_cat.o \ + ada/sem_ch10.o \ + ada/sem_ch11.o \ + ada/sem_ch12.o \ + ada/sem_ch13.o \ + ada/sem_ch2.o \ + ada/sem_ch3.o \ + ada/sem_ch4.o \ + ada/sem_ch5.o \ + ada/sem_ch6.o \ + ada/sem_ch7.o \ + ada/sem_ch8.o \ + ada/sem_ch9.o \ + ada/sem_disp.o \ + ada/sem_dist.o \ + ada/sem_elab.o \ + ada/sem_elim.o \ + ada/sem_eval.o \ + ada/sem_intr.o \ + ada/sem_mech.o \ + ada/sem_prag.o \ + ada/sem_res.o \ + ada/sem_scil.o \ + ada/sem_smem.o \ + ada/sem_type.o \ + ada/sem_util.o \ + ada/sem_vfpt.o \ + ada/sem_warn.o \ + ada/sinfo-cn.o \ + ada/sinfo.o \ + ada/sinput-d.o \ + ada/sinput-l.o \ + ada/sinput.o \ + ada/snames.o \ + ada/sprint.o \ + ada/stand.o \ + ada/stringt.o \ + ada/style.o \ + ada/styleg.o \ + ada/stylesw.o \ + ada/switch-c.o \ + ada/switch.o \ + ada/system.o \ + ada/table.o \ + ada/targext.o \ + ada/targparm.o \ + ada/tbuild.o \ + ada/tree_gen.o \ + ada/tree_in.o \ + ada/tree_io.o \ + ada/treepr.o \ + ada/treeprs.o \ + ada/ttypef.o \ + ada/ttypes.o \ + ada/types.o \ + ada/uintp.o \ + ada/uname.o \ + ada/urealp.o \ + ada/usage.o \ + ada/validsw.o \ + ada/widechar.o # Object files for gnat executables GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) ada/back_end.o ada/gnat1drv.o @@ -1204,10 +1367,11 @@ ada/back_end.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ ada/switch.ads ada/switch-c.ads ada/system.ads ada/s-exctab.ads \ ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/s-parame.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads ada/bcheck.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/ali.ads ada/ali-util.ads ada/ali-util.adb \ @@ -1267,10 +1431,10 @@ ada/bindusg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/bindusg.ads ada/bindusg.adb \ ada/debug.ads ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads \ ada/output.ads ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/butil.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/butil.ads ada/butil.adb \ @@ -1499,28 +1663,24 @@ ada/exp_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_atag.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_aggr.ads ada/exp_atag.ads \ - ada/exp_atag.adb ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dist.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ - ada/fname-uf.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads \ + ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/exp_atag.ads ada/exp_atag.adb ada/exp_dist.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/fname-uf.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/lib.ads \ ada/lib-load.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/sem.ads \ - ada/sem_aux.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_dist.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/sem_aux.ads ada/sem_ch7.ads ada/sem_dist.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/types.ads \ ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads + ada/unchdeal.ads ada/urealp.ads ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2185,10 +2345,10 @@ ada/fmap.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ ada/opt.ads ada/osint.ads ada/output.ads ada/system.ads \ ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strhas.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/fname-uf.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ @@ -2197,10 +2357,11 @@ ada/fname-uf.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-stalib.ads ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tree_io.ads ada/types.ads ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ + ada/types.ads ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/widechar.ads ada/fname.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/fname.ads \ @@ -2489,9 +2650,10 @@ ada/lib-util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/lib.ads ada/lib-util.ads ada/lib-util.adb ada/namet.ads ada/opt.ads \ ada/osint.ads ada/osint-c.ads ada/output.ads ada/system.ads \ ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/lib-writ.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/ali.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2531,10 +2693,10 @@ ada/lib-xref.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/lib.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 \ @@ -2704,10 +2866,11 @@ ada/par_sco.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads \ ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/widechar.ads ada/prep.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/csets.ads \ @@ -3899,10 +4062,10 @@ ada/sinput-d.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads \ ada/osint-c.ads ada/output.ads ada/sinput.ads ada/sinput-d.ads \ ada/sinput-d.adb ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/sinput-l.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 \ @@ -3953,17 +4116,17 @@ ada/sprint.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/namet.adb \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ - ada/output.adb ada/rtsfind.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/sinput-d.ads \ - ada/snames.ads ada/sprint.ads ada/sprint.adb ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/urealp.adb ada/widechar.ads + ada/output.adb ada/rtsfind.ads ada/sem_eval.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/sinput-d.ads ada/snames.ads ada/sprint.ads ada/sprint.adb \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/urealp.adb ada/widechar.ads ada/stand.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/stand.ads \ ada/stand.adb ada/system.ads ada/s-exctab.ads ada/s-os_lib.ads \ @@ -4090,10 +4253,11 @@ ada/tree_gen.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_aux.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \ ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_gen.ads ada/tree_gen.adb \ - ada/tree_in.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_gen.ads ada/tree_gen.adb ada/tree_in.ads ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/tree_in.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/casing.ads \ @@ -4192,10 +4356,11 @@ ada/usage.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/usage.ads ada/usage.adb + ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/usage.ads ada/usage.adb ada/validsw.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/hostparm.ads ada/opt.ads ada/system.ads ada/s-exctab.ads \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index c9221fb5022..975db0f2b7d 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -190,6 +190,11 @@ TOOLSCASE = MULTISUBDIR = RTSDIR = rts$(subst /,_,$(MULTISUBDIR)) +# Link flags used to build gnat tools. By default we prefer to statically +# link with libgcc to avoid a dependency on shared libgcc (which is tricky +# to deal with as it may conflict with the libgcc provided by the system). +GCC_LINK_FLAGS=-static-libgcc + # End of variables for you to override. all: all.indirect @@ -370,18 +375,6 @@ GNATLIB_SHARED = gnatlib # default value for gnatmake's target dependent file MLIB_TGT = mlib-tgt -# By default, do not distribute prefix.o (in libgccprefix), since it is only -# needed by external GNAT tools such as gnatdist and Glide. -# Override this variable on native platforms when needed. -PREFIX_OBJS = - -# To avoid duplicate code, use this variable to set PREFIX_OBJS when needed: -PREFIX_REAL_OBJS = ../prefix.o \ - ../../libiberty/concat.o \ - ../../libiberty/xmalloc.o \ - ../../libiberty/xstrdup.o \ - ../../libiberty/xexit.o - # By default, build socket support units. On platforms that do not support # sockets, reset this variable to empty and add DUMMY_SOCKETS_TARGET_PAIRS # to LIBGNAT_TARGET_PAIRS. @@ -934,7 +927,6 @@ ifeq ($(strip $(filter-out sparc% sun solaris%,$(targ))),) SO_OPTS = -Wl,-h, GNATLIB_SHARED = gnatlib-shared-dual GMEM_LIB = gmemlib - PREFIX_OBJS = $(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) ifeq ($(strip $(filter-out pthread PTHREAD,$(THREAD_KIND))),) @@ -993,7 +985,6 @@ ifeq ($(strip $(filter-out %86 solaris2%,$(arch) $(osys))),) SO_OPTS = -Wl,-h, GNATLIB_SHARED = gnatlib-shared-dual GMEM_LIB = gmemlib - PREFIX_OBJS = $(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1065,7 +1056,6 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) GNATLIB_SHARED = gnatlib-shared-dual GMEM_LIB = gmemlib - PREFIX_OBJS = $(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1094,7 +1084,6 @@ ifeq ($(strip $(filter-out %86 kfreebsd%,$(arch) $(osys))),) THREADSLIB = -lpthread GNATLIB_SHARED = gnatlib-shared-dual GMEM_LIB = gmemlib - PREFIX_OBJS = $(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1123,7 +1112,6 @@ ifeq ($(strip $(filter-out x86_64 kfreebsd%,$(arch) $(osys))),) THREADSLIB = -lpthread GNATLIB_SHARED = gnatlib-shared-dual GMEM_LIB = gmemlib - PREFIX_OBJS = $(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1150,7 +1138,6 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),) EH_MECHANISM=-gcc THREADSLIB= -lpthread GMEM_LIB = gmemlib - PREFIX_OBJS = $(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1198,7 +1185,6 @@ ifeq ($(strip $(filter-out s390% linux%,$(arch) $(osys))),) EH_MECHANISM=-gcc THREADSLIB = -lpthread GNATLIB_SHARED = gnatlib-shared-dual - PREFIX_OBJS = $(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1248,7 +1234,6 @@ ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),) TOOLS_TARGET_PAIRS = mlib-tgt-specific.adb<mlib-tgt-specific-irix.adb TGT_LIB = -lexc MISCLIB = -lexc - PREFIX_OBJS = $(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) GMEM_LIB = gmemlib endif @@ -1270,7 +1255,6 @@ ifeq ($(strip $(filter-out hppa% hp hpux10%,$(targ))),) system.ads<system-hpux.ads EH_MECHANISM=-gcc - PREFIX_OBJS = $(PREFIX_REAL_OBJS) endif ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),) @@ -1295,7 +1279,6 @@ ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),) GMEM_LIB = gmemlib soext = .sl SO_OPTS = -Wl,+h, - PREFIX_OBJS = $(PREFIX_REAL_OBJS) GNATLIB_SHARED = gnatlib-shared-dual LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1330,7 +1313,6 @@ ifeq ($(strip $(filter-out ibm aix%,$(manu) $(osys))),) endif THREADSLIB = -lpthreads - PREFIX_OBJS=$(PREFIX_REAL_OBJS) TOOLS_TARGET_PAIRS = \ mlib-tgt-specific.adb<mlib-tgt-specific-aix.adb \ @@ -1364,7 +1346,6 @@ ifeq ($(strip $(filter-out lynxos,$(osys))),) g-trasym.adb<g-trasym-unimplemented.adb \ system.ads<system-lynxos-x86.ads - PREFIX_OBJS=$(PREFIX_REAL_OBJS) else LIBGNAT_TARGET_PAIRS = \ @@ -1425,7 +1406,6 @@ ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),) EH_MECHANISM=-gcc GMEM_LIB=gmemlib THREADSLIB = -lpthread -lmach -lexc -lrt - PREFIX_OBJS = $(PREFIX_REAL_OBJS) GNATLIB_SHARED = gnatlib-shared-default LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1503,7 +1483,6 @@ ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(targ))) i-cstrea.adb<i-cstrea-vms.adb \ memtrack.adb<memtrack-vms_64.adb \ s-auxdec.ads<s-auxdec-vms_64.ads \ - s-crtl.ads<s-crtl-vms_64.ads \ s-inmaop.adb<s-inmaop-vms.adb \ s-interr.adb<s-interr-vms.adb \ s-intman.adb<s-intman-vms.adb \ @@ -1640,7 +1619,6 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) indepsw.adb<indepsw-mingw.adb GMEM_LIB = gmemlib - PREFIX_OBJS = $(PREFIX_REAL_OBJS) EXTRA_GNATTOOLS = ../../gnatdll$(exeext) EXTRA_GNATMAKE_OBJS = mdll.o mdll-utl.o mdll-fil.o soext = .dll @@ -1667,7 +1645,6 @@ ifeq ($(strip $(filter-out mips linux%,$(arch) $(osys))),) THREADSLIB = -lpthread GNATLIB_SHARED = gnatlib-shared-dual GMEM_LIB = gmemlib - PREFIX_OBJS = $(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1710,7 +1687,6 @@ ifeq ($(strip $(filter-out mipsel linux%,$(arch) $(osys))),) THREADSLIB = -lpthread GNATLIB_SHARED = gnatlib-shared-dual GMEM_LIB = gmemlib - PREFIX_OBJS = $(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1753,7 +1729,6 @@ ifeq ($(strip $(filter-out mips64el linux%,$(arch) $(osys))),) THREADSLIB = -lpthread GNATLIB_SHARED = gnatlib-shared-dual GMEM_LIB = gmemlib - PREFIX_OBJS = $(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1814,7 +1789,6 @@ ifeq ($(strip $(filter-out powerpc% linux%,$(arch) $(osys))),) THREADSLIB = -lpthread GNATLIB_SHARED = gnatlib-shared-dual GMEM_LIB = gmemlib - PREFIX_OBJS = $(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1858,7 +1832,6 @@ ifeq ($(strip $(filter-out sparc% linux%,$(arch) $(osys))),) THREADSLIB = -lpthread GNATLIB_SHARED = gnatlib-shared-dual GMEM_LIB = gmemlib - PREFIX_OBJS = $(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1889,7 +1862,6 @@ ifeq ($(strip $(filter-out hppa% linux%,$(arch) $(osys))),) THREADSLIB = -lpthread GNATLIB_SHARED = gnatlib-shared-dual GMEM_LIB = gmemlib - PREFIX_OBJS = $(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1919,7 +1891,6 @@ ifeq ($(strip $(filter-out sh4% linux%,$(arch) $(osys))),) THREADSLIB = -lpthread GNATLIB_SHARED = gnatlib-shared-dual GMEM_LIB = gmemlib - PREFIX_OBJS = $(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1951,7 +1922,6 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),) THREADSLIB=-lpthread GNATLIB_SHARED=gnatlib-shared-dual GMEM_LIB = gmemlib - PREFIX_OBJS=$(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1977,7 +1947,6 @@ ifeq ($(strip $(filter-out ia64% hp hpux%,$(targ))),) GMEM_LIB = gmemlib soext = .sl SO_OPTS = -Wl,+h, - PREFIX_OBJS=$(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) endif @@ -2008,7 +1977,6 @@ ifeq ($(strip $(filter-out alpha% linux%,$(arch) $(osys))),) MISCLIB= THREADSLIB=-lpthread GNATLIB_SHARED=gnatlib-shared-dual - PREFIX_OBJS=$(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) endif @@ -2041,7 +2009,6 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),) THREADSLIB=-lpthread GNATLIB_SHARED=gnatlib-shared-dual GMEM_LIB = gmemlib - PREFIX_OBJS=$(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) endif @@ -2114,9 +2081,9 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) SO_OPTS = -Wl,-flat_namespace -shared-libgcc RANLIB = ranlib -c GMEM_LIB = gmemlib - PREFIX_OBJS=$(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) soext = .dylib + GCC_LINK_FLAGS= endif ifneq ($(EH_MECHANISM),) @@ -2146,15 +2113,16 @@ endif # while GNATRTL_OBJS lists the object files compiled from Ada sources that # go into the directory. The pthreads emulation is built in the threads # subdirectory and copied. -LIBGNAT_SRCS = adaint.c adaint.h argv.c cio.c cstreams.c \ - errno.c exit.c cal.c ctrl_c.c env.c env.h arit64.c \ - raise.h raise.c sysdep.c aux-io.c init.c initialize.c seh_init.c \ - final.c tracebak.c tb-alvms.c tb-alvxw.c tb-gcc.c expect.c mkdir.c \ - socket.c gsocket.h targext.c $(EXTRA_LIBGNAT_SRCS) +LIBGNAT_SRCS = adadecode.c adadecode.h adaint.c adaint.h \ + argv.c cio.c cstreams.c errno.c exit.c cal.c ctrl_c.c env.c env.h \ + arit64.c raise.h raise.c sysdep.c aux-io.c init.c initialize.c \ + seh_init.c final.c tracebak.c tb-alvms.c tb-alvxw.c tb-gcc.c \ + expect.c mkdir.c socket.c gsocket.h targext.c $(EXTRA_LIBGNAT_SRCS) -LIBGNAT_OBJS = adaint.o argv.o cio.o cstreams.o ctrl_c.o errno.o exit.o env.o \ - raise.o sysdep.o aux-io.o init.o initialize.o seh_init.o cal.o arit64.o \ - final.o tracebak.o expect.o mkdir.o socket.o targext.o $(EXTRA_LIBGNAT_OBJS) +LIBGNAT_OBJS = adadecode.o adaint.o argv.o cio.o cstreams.o ctrl_c.o \ + errno.o exit.o env.o raise.o sysdep.o aux-io.o init.o initialize.o \ + seh_init.o cal.o arit64.o final.o tracebak.o expect.o mkdir.o \ + socket.o targext.o $(EXTRA_LIBGNAT_OBJS) # NOTE ??? - when the -I option for compiling Ada code is made to work, # the library installation will change and there will be a @@ -2183,7 +2151,7 @@ ADA_INCLUDE_SRCS =\ LIBGNAT=../$(RTSDIR)/libgnat.a -GCC_LINK=$(CC) -static-libgcc $(ADA_INCLUDES) +GCC_LINK=$(CC) $(GCC_LINK_FLAGS) $(ADA_INCLUDES) # when compiling the tools, the runtime has to be first on the path so that # it hides the runtime files lying with the rest of the sources @@ -2400,11 +2368,6 @@ gnatlib: ../stamp-gnatlib1-$(RTSDIR) ../stamp-gnatlib2-$(RTSDIR) $(RM) $(RTSDIR)/libgnat$(arext) $(RTSDIR)/libgnarl$(arext) $(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgnat$(arext) \ $(addprefix $(RTSDIR)/,$(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS)) - ifneq ($(PREFIX_OBJS),) - $(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgccprefix$(arext) \ - $(PREFIX_OBJS); - $(RANLIB_FOR_TARGET) $(RTSDIR)/libgccprefix$(arext) - endif $(RANLIB_FOR_TARGET) $(RTSDIR)/libgnat$(arext) $(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgnarl$(arext) \ $(addprefix $(RTSDIR)/,$(GNATRTL_TASKING_OBJS)) diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index d14305e42f0..eff96837653 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -5321,6 +5321,7 @@ gnat_to_gnu (Node_Id gnat_node) case N_SCIL_Dispatch_Table_Object_Init: case N_SCIL_Dispatch_Table_Tag_Init: case N_SCIL_Dispatching_Call: + case N_SCIL_Membership_Test: case N_SCIL_Tag_Init: /* SCIL nodes require no processing for GCC. */ gnu_result = alloc_stmt_list (); diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index ca4fe86c8f6..79824868be5 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -158,10 +158,23 @@ procedure Gnat1drv is Front_End_Inlining := False; Inline_Active := False; - -- Turn off ASIS mode: incompatible with front-end expansion. + -- Turn off ASIS mode: incompatible with front-end expansion ASIS_Mode := False; + -- Disable front-end optimizations, to keep the tree as close to the + -- source code as possible, and also to avoid inconsistencies between + -- trees when using different optimization switches. + + Optimization_Level := 0; + + -- Disable specific expansions for Restrictions pragmas to avoid + -- tree inconsistencies between compilations with different pragmas + -- that will cause different SCIL files to be generated for the + -- same Ada spec. + + Treat_Restrictions_As_Warnings := True; + -- Suppress overflow, division by zero and access checks since they -- are handled implicitly by CodePeer. diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 4b906fe91e9..46823f9ebad 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -112,6 +112,7 @@ Implementation Defined Pragmas * Pragma Common_Object:: * Pragma Compile_Time_Error:: * Pragma Compile_Time_Warning:: +* Pragma Compiler_Unit:: * Pragma Complete_Representation:: * Pragma Complex_Representation:: * Pragma Component_Alignment:: @@ -181,6 +182,7 @@ Implementation Defined Pragmas * Pragma Pure_Function:: * Pragma Restriction_Warnings:: * Pragma Shared:: +* Pragma Short_Circuit_And_Or:: * Pragma Source_File_Name:: * Pragma Source_File_Name_Project:: * Pragma Source_Reference:: @@ -252,6 +254,7 @@ Implementation Defined Attributes * Passed_By_Reference:: * Pool_Address:: * Range_Length:: +* Result:: * Safe_Emax:: * Safe_Large:: * Small:: @@ -374,6 +377,10 @@ The GNAT Library * GNAT.Semaphores (g-semaph.ads):: * GNAT.Serial_Communications (g-sercom.ads):: * GNAT.SHA1 (g-sha1.ads):: +* GNAT.SHA224 (g-sha224.ads):: +* GNAT.SHA256 (g-sha256.ads):: +* GNAT.SHA384 (g-sha384.ads):: +* GNAT.SHA512 (g-sha512.ads):: * GNAT.Signals (g-signal.ads):: * GNAT.Sockets (g-socket.ads):: * GNAT.Source_Info (g-souinf.ads):: @@ -722,6 +729,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Common_Object:: * Pragma Compile_Time_Error:: * Pragma Compile_Time_Warning:: +* Pragma Compiler_Unit:: * Pragma Complete_Representation:: * Pragma Complex_Representation:: * Pragma Component_Alignment:: @@ -791,6 +799,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Pure_Function:: * Pragma Restriction_Warnings:: * Pragma Shared:: +* Pragma Short_Circuit_And_Or:: * Pragma Source_File_Name:: * Pragma Source_File_Name_Project:: * Pragma Source_Reference:: @@ -924,7 +933,7 @@ same syntax and effect. @noindent Syntax: @smallexample @c ada -pragma Annotate (IDENTIFIER @{, ARG@}); +pragma Annotate (IDENTIFIER [,IDENTIFIER] @{, ARG@}); ARG ::= NAME | EXPRESSION @end smallexample @@ -932,11 +941,14 @@ ARG ::= NAME | EXPRESSION @noindent This pragma is used to annotate programs. @var{identifier} identifies the type of annotation. GNAT verifies that it is an identifier, but does -not otherwise analyze it. The @var{arg} argument -can be either a string literal or an -expression. String literals are assumed to be of type -@code{Standard.String}. Names of entities are simply analyzed as entity -names. All other expressions are analyzed as expressions, and must be +not otherwise analyze it. The second optional identifier is also left +unanalyzed, and by convention is used to control the action of the tool to +which the annotation is addressed. The remaining @var{arg} arguments +can be either string literals or more generally expressions. +String literals are assumed to be either of type +@code{Standard.String} or else @code{Wide_String} or @code{Wide_Wide_String} +depending on the character literals they contain. +All other kinds of arguments are analyzed as expressions, and must be unambiguous. The analyzed pragma is retained in the tree, but not otherwise processed @@ -1333,6 +1345,24 @@ of formal parameters are tested, and warnings given appropriately. Another use with a first parameter of True is to warn a client about use of a package, for example that it is not fully implemented. +@node Pragma Compiler_Unit +@unnumberedsec Pragma Compiler_Unit +@findex Compiler_Unit +@noindent +Syntax: + +@smallexample @c ada +pragma Compiler_Unit; +@end smallexample + +@noindent +This pragma is intended only for internal use in the GNAT run-time library. +It indicates that the unit is used as part of the compiler build. The effect +is to disallow constructs (raise with message, conditional expressions etc) +that would cause trouble when bootstrapping using an older version of GNAT. +For the exact list of restrictions, see the compiler sources and references +to Is_Compiler_Unit. + @node Pragma Complete_Representation @unnumberedsec Pragma Complete_Representation @findex Complete_Representation @@ -4233,6 +4263,20 @@ if the restriction is violated. This pragma is provided for compatibility with Ada 83. The syntax and semantics are identical to pragma Atomic. +@node Pragma Short_Circuit_And_Or +@unnumberedsec Pragma Short_Circuit_And_Or +@findex Short_Circuit_And_Or + +@noindent +This configuration pragma causes any occurrence of the AND operator applied to +operands of type Standard.Boolean to be short-circuited (i.e. the AND operator +is treated as if it were AND THEN). Or is similarly treated as OR ELSE. This +may be useful in the context of certification protocols requiring the use of +short-circuited logical operators. If this configuration pragma occurs locally +within the file being compiled, it applies only to the file being compiled. +There is no requirement that all units in a partition use this option. + +semantics are identical to pragma Atomic. @node Pragma Source_File_Name @unnumberedsec Pragma Source_File_Name @findex Source_File_Name @@ -5157,80 +5201,12 @@ The form with a single static_string_EXPRESSION argument provides more precise control over which warnings are active. The string is a list of letters specifying which warnings are to be activated and which deactivated. The code for these letters is the same as the string used in the command -line switch controlling warnings. The following is a brief summary. For +line switch controlling warnings. For a brief summary, use the gnatmake +command with no arguments, which will generate usage information containing +the list of warnings switches supported. For full details see @ref{Warning Message Control,,, gnat_ugn, @value{EDITION} User's Guide}. -@smallexample -a turn on all optional warnings (except d h l .o) -A turn off all optional warnings -.a* turn on warnings for failing assertions -.A turn off warnings for failing assertions -b turn on warnings for bad fixed value (not multiple of small) -B* turn off warnings for bad fixed value (not multiple of small) -.b* turn on warnings for biased representation -.B turn off warnings for biased representation -c turn on warnings for constant conditional -C* turn off warnings for constant conditional -.c turn on warnings for unrepped components -.C* turn off warnings for unrepped components -d turn on warnings for implicit dereference -D* turn off warnings for implicit dereference -e treat all warnings as errors -.e turn on every optional warning -f turn on warnings for unreferenced formal -F* turn off warnings for unreferenced formal -g* turn on warnings for unrecognized pragma -G turn off warnings for unrecognized pragma -h turn on warnings for hiding variable -H* turn off warnings for hiding variable -i* turn on warnings for implementation unit -I turn off warnings for implementation unit -j turn on warnings for obsolescent (annex J) feature -J* turn off warnings for obsolescent (annex J) feature -k turn on warnings on constant variable -K* turn off warnings on constant variable -l turn on warnings for missing elaboration pragma -L* turn off warnings for missing elaboration pragma -m turn on warnings for variable assigned but not read -M* turn off warnings for variable assigned but not read -n* normal warning mode (cancels -gnatws/-gnatwe) -o* turn on warnings for address clause overlay -O turn off warnings for address clause overlay -.o turn on warnings for out parameters assigned but not read -.O* turn off warnings for out parameters assigned but not read -p turn on warnings for ineffective pragma Inline in frontend -P* turn off warnings for ineffective pragma Inline in frontend -.p turn on warnings for parameter ordering -.P* turn off warnings for parameter ordering -q* turn on warnings for questionable missing parentheses -Q turn off warnings for questionable missing parentheses -r turn on warnings for redundant construct -R* turn off warnings for redundant construct -.r turn on warnings for object renaming function -.R* turn off warnings for object renaming function -s suppress all warnings -t turn on warnings for tracking deleted code -T* turn off warnings for tracking deleted code -u turn on warnings for unused entity -U* turn off warnings for unused entity -v* turn on warnings for unassigned variable -V turn off warnings for unassigned variable -w* turn on warnings for wrong low bound assumption -W turn off warnings for wrong low bound assumption -.w turn on warnings for unnecessary Warnings Off pragmas -.W* turn off warnings for unnecessary Warnings Off pragmas -x* turn on warnings for export/import -X turn off warnings for export/import -.x turn on warnings for non-local exceptions -.X* turn off warnings for non-local exceptions -y* turn on warnings for Ada 2005 incompatibility -Y turn off warnings for Ada 2005 incompatibility -z* turn on convention/size/align warnings for unchecked conversion -Z turn off convention/size/align warnings for unchecked conversion -* indicates default in above list -@end smallexample - @noindent The specified warnings will be in effect until the end of the program or another pragma Warnings is encountered. The effect of the pragma is @@ -5268,6 +5244,11 @@ pragma Warnings (On, Pattern); In this usage, the pattern string must match in the Off and On pragmas, and at least one matching warning must be suppressed. +Note: the debug flag -gnatd.i (@code{/NOWARNINGS_PRAGMAS} in VMS) can be +used to cause the compiler to entirely ignore all WARNINGS pragmas. This can +be useful in checking whether obsolete pragmas in existing programs are hiding +real problems. + @node Pragma Weak_External @unnumberedsec Pragma Weak_External @findex Weak_External @@ -5403,6 +5384,7 @@ consideration, you should minimize the use of these attributes. * Passed_By_Reference:: * Pool_Address:: * Range_Length:: +* Result:: * Safe_Emax:: * Safe_Large:: * Small:: @@ -6054,6 +6036,16 @@ range). The result is static for static subtypes. @code{Range_Length} applied to the index subtype of a one dimensional array always gives the same result as @code{Range} applied to the array itself. +@node Result +@unnumberedsec Result +@findex Result +@noindent +@code{@var{function}'Result} can only be used with in a Postcondition pragma +for a function. The prefix must be the name of the corresponding function. This +is used to refer to the result of the function in the postcondition expression. +For a further discussion of the use of this attribute and examples of its use, +see the description of pragma Postcondition. + @node Safe_Emax @unnumberedsec Safe_Emax @cindex Ada 83 attributes @@ -13566,6 +13558,10 @@ of GNAT, and will generate a warning message. * GNAT.Semaphores (g-semaph.ads):: * GNAT.Serial_Communications (g-sercom.ads):: * GNAT.SHA1 (g-sha1.ads):: +* GNAT.SHA224 (g-sha224.ads):: +* GNAT.SHA256 (g-sha256.ads):: +* GNAT.SHA384 (g-sha384.ads):: +* GNAT.SHA512 (g-sha512.ads):: * GNAT.Signals (g-signal.ads):: * GNAT.Sockets (g-socket.ads):: * GNAT.Source_Info (g-souinf.ads):: @@ -14563,7 +14559,40 @@ port. This is only supported on GNU/Linux and Windows. @cindex Secure Hash Algorithm SHA-1 @noindent -Implements the SHA-1 Secure Hash Algorithm as described in RFC 3174. +Implements the SHA-1 Secure Hash Algorithm as described in FIPS PUB 180-3 +and RFC 3174. + +@node GNAT.SHA224 (g-sha224.ads) +@section @code{GNAT.SHA224} (@file{g-sha224.ads}) +@cindex @code{GNAT.SHA224} (@file{g-sha224.ads}) +@cindex Secure Hash Algorithm SHA-224 + +@noindent +Implements the SHA-224 Secure Hash Algorithm as described in FIPS PUB 180-3. + +@node GNAT.SHA256 (g-sha256.ads) +@section @code{GNAT.SHA256} (@file{g-sha256.ads}) +@cindex @code{GNAT.SHA256} (@file{g-sha256.ads}) +@cindex Secure Hash Algorithm SHA-256 + +@noindent +Implements the SHA-256 Secure Hash Algorithm as described in FIPS PUB 180-3. + +@node GNAT.SHA384 (g-sha384.ads) +@section @code{GNAT.SHA384} (@file{g-sha384.ads}) +@cindex @code{GNAT.SHA384} (@file{g-sha384.ads}) +@cindex Secure Hash Algorithm SHA-384 + +@noindent +Implements the SHA-384 Secure Hash Algorithm as described in FIPS PUB 180-3. + +@node GNAT.SHA512 (g-sha512.ads) +@section @code{GNAT.SHA512} (@file{g-sha512.ads}) +@cindex @code{GNAT.SHA512} (@file{g-sha512.ads}) +@cindex Secure Hash Algorithm SHA-512 + +@noindent +Implements the SHA-512 Secure Hash Algorithm as described in FIPS PUB 180-3. @node GNAT.Signals (g-signal.ads) @section @code{GNAT.Signals} (@file{g-signal.ads}) diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 19304a75f40..78bbf56837f 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -9326,7 +9326,21 @@ This switch cannot be used when using a project file. @ifclear vms @item -eL @cindex @option{-eL} (@command{gnatmake}) +@cindex symbolic links Follow all symbolic links when processing project files. +This should be used if your project uses symbolic links for files or +directories, but is not needed in other cases. + +@cindex naming scheme +This also assumes that no directory matches the naming scheme for files (for +instance that you do not have a directory called "sources.ads" when using the +default GNAT naming scheme). + +When you do not have to use this switch (ie by default), gnatmake is able to +save a lot of system calls (several per source file and object file), which +can result in a significant speed up to load and manipulate a project file, +especially when using source files from a remote system. + @end ifclear @item ^-eS^/STANDARD_OUTPUT_FOR_COMMANDS^ @@ -20858,28 +20872,29 @@ Turn off the check for a specified rule with the specified parameter, if any. @cindex @option{-from} (@command{gnatcheck}) @item -from=@var{rule_option_filename} -Read the rule options from the text file @var{rule_option_filename}, referred as -``rule file'' below. +Read the rule options from the text file @var{rule_option_filename}, referred +to as a ``coding standard file'' below. @end table @noindent The default behavior is that all the rule checks are disabled. -A rule file is a text file containing a set of rule options. -@cindex Rule file (for @code{gnatcheck}) +A coding standard file is a text file that contains a set of rule options +described above. +@cindex Coding standard file (for @code{gnatcheck}) The file may contain empty lines and Ada-style comments (comment -lines and end-of-line comments). The rule file has free format; that is, -you do not have to start a new rule option on a new line. +lines and end-of-line comments). There can be several rule options on a +single line (separated by a space). -A rule file may contain other @option{-from=@var{rule_option_filename}} +A coding standard file may reference other coding standard files by including +more @option{-from=@var{rule_option_filename}} options, each such option being replaced with the content of the -corresponding rule file during the rule files processing. In case a +corresponding coding standard file during processing. In case a cycle is detected (that is, @file{@var{rule_file_1}} reads rule options from @file{@var{rule_file_2}}, and @file{@var{rule_file_2}} reads (directly or indirectly) rule options from @file{@var{rule_file_1}}), -the processing of rule files is interrupted and a part of their content -is ignored. +processing fails with an error message. @node Adding the Results of Compiler Checks to gnatcheck Output @@ -21013,7 +21028,7 @@ exemption control annotations is as follows: @group pragma Annotate (gnatcheck, @i{exemption_control}, @i{Rule_Name}, [@i{justification}]); -@i{exemption_control} ::= "Exempt_On" | "Exempt_Off" +@i{exemption_control} ::= Exempt_On | Exempt_Off @i{Rule_Name} ::= string_literal @@ -21037,9 +21052,9 @@ A source code section where an exemption is active for a given rule is delimited by an @code{exempt_on} and @code{exempt_off} annotation pair: @smallexample @c ada -pragma Annotate (gnatcheck, "Exempt_On", Rule_Name, "justification"); +pragma Annotate (gnatcheck, Exempt_On, Rule_Name, "justification"); -- source code section -pragma Annotate (gnatcheck, "Exempt_Off", Rule_Name); +pragma Annotate (gnatcheck, Exempt_Off, Rule_Name); @end smallexample @@ -22519,7 +22534,9 @@ This rule has no parameters. @cindex @code{Positional_Generic_Parameters} rule (for @command{gnatcheck}) @noindent -Flag each instantiation using positional parameter notation. +Flag each positional actual generic parameter except for the case when +the generic unit being iinstantiated has exactly one generic formal +parameter. This rule has no parameters. @@ -22529,15 +22546,15 @@ This rule has no parameters. @cindex @code{Positional_Parameters} rule (for @command{gnatcheck}) @noindent -Flag each subprogram or entry call using positional parameter notation, +Flag each positional parameter notation in a subprogram or entry call, except for the following: @itemize @bullet @item -Invocations of prefix or infix operators are not flagged +Parameters of calls to of prefix or infix operators are not flagged @item If the called subprogram or entry has only one formal parameter, -the call is not flagged; +the parameter of the call is not flagged; @item If a subprogram call uses the @emph{Object.Operation} notation, then @itemize @minus diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index e0ccc228473..bfde10d6ae1 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -318,8 +318,31 @@ procedure GNATCmd is for Index in 1 .. Last_Switches.Last loop if Last_Switches.Table (Index) (1) /= '-' then - Add_Sources := False; - exit; + if Index = 1 + or else + (The_Command = Check + and then + Last_Switches.Table (Index - 1).all /= "-o") + or else + (The_Command = Pretty + and then + Last_Switches.Table (Index - 1).all /= "-o" and then + Last_Switches.Table (Index - 1).all /= "-of") + or else + (The_Command = Metric + and then + Last_Switches.Table (Index - 1).all /= "-o" and then + Last_Switches.Table (Index - 1).all /= "-og" and then + Last_Switches.Table (Index - 1).all /= "-ox" and then + Last_Switches.Table (Index - 1).all /= "-d") + or else + (The_Command /= Check and then + The_Command /= Pretty and then + The_Command /= Metric) + then + Add_Sources := False; + exit; + end if; end if; end loop; @@ -552,8 +575,12 @@ procedure GNATCmd is (Unit.File_Names (Kind).Project, Project) and then not Unit.File_Names (Kind).Locally_Removed then - Get_Name_String - (Unit.File_Names (Kind).Path.Display_Name); + Name_Len := 0; + Add_Char_To_Name_Buffer ('"'); + Add_Str_To_Name_Buffer + (Get_Name_String + (Unit.File_Names (Kind).Path.Display_Name)); + Add_Char_To_Name_Buffer ('"'); if FD /= Invalid_FD then Name_Len := Name_Len + 1; diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 5347269be00..708e1794d04 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -439,34 +439,16 @@ procedure Gnatlink is Compile_Bind_File := False; when 'o' => - if VM_Target = CLI_Target then - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := - new String'("/QUIET"); - - else - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := - new String'(Arg); - end if; - Next_Arg := Next_Arg + 1; if Next_Arg > Argument_Count then Exit_With_Error ("Missing argument for -o"); end if; - if VM_Target = CLI_Target then - Output_File_Name := - new String'("/OUTPUT=" & Argument (Next_Arg)); - else - Output_File_Name := - new String'(Argument (Next_Arg)); - end if; - - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := - Output_File_Name; + Output_File_Name := + new String'(Executable_Name + (Argument (Next_Arg), + Only_If_No_Suffix => True)); when 'R' => Opt.Run_Path_Option := False; @@ -1728,33 +1710,44 @@ begin Output_File_Name := new String'(Base_Name (Ali_File_Name.all) & Get_Target_Debuggable_Suffix.all); + end if; - if VM_Target = CLI_Target then - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := new String'("/QUIET"); + if VM_Target = CLI_Target then + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := new String'("/QUIET"); - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := new String'("/DEBUG"); + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := new String'("/DEBUG"); - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := - new String'("/OUTPUT=" & Output_File_Name.all); + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'("/OUTPUT=" & Output_File_Name.all); - elsif RTX_RTSS_Kernel_Module_On_Target then - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := - new String'("/OUT:" & Output_File_Name.all); + elsif RTX_RTSS_Kernel_Module_On_Target then + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'("/OUT:" & Output_File_Name.all); - else - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := new String'("-o"); + else + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := new String'("-o"); - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := - new String'(Output_File_Name.all); - end if; + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Output_File_Name.all); end if; + -- Delete existing executable, in case it is a symbolic link, to avoid + -- modifying the target of the symbolic link. + + declare + Dummy : Boolean; + pragma Unreferenced (Dummy); + + begin + Delete_File (Output_File_Name.all, Dummy); + end; + -- Warn if main program is called "test", as that may be a built-in command -- on Unix. On non-Unix systems executables have a suffix, so the warning -- will not appear. However, do not warn in the case of a cross compiler. @@ -2148,11 +2141,10 @@ begin if Linker_Path = Gcc_Path and then VM_Target = No_VM then - -- For systems where the default is to link statically - -- with libgcc, if gcc is not called with - -- -shared-libgcc, call it with -static-libgcc, as - -- there are some platforms where one of these two - -- switches is compulsory to link. + -- For systems where the default is to link statically with + -- libgcc, if gcc is not called with -shared-libgcc, call it + -- with -static-libgcc, as there are some platforms where one + -- of these two switches is compulsory to link. if Shared_Libgcc_Default = 'T' and then not Shared_Libgcc_Seen diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index 5b433187adb..b5a3f49df16 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -40,7 +40,6 @@ with Rident; use Rident; with Sdefault; with Snames; with Switch; use Switch; -with Targparm; use Targparm; with Types; use Types; with GNAT.Case_Util; use GNAT.Case_Util; @@ -1574,8 +1573,6 @@ begin Osint.Add_Default_Search_Dirs; if Verbose_Mode then - Targparm.Get_Target_Parameters; - Write_Eol; Display_Version ("GNATLS", "1997"); Write_Eol; diff --git a/gcc/ada/i-vxwoio.adb b/gcc/ada/i-vxwoio.adb index 00ee6356872..4d480e0519f 100644 --- a/gcc/ada/i-vxwoio.adb +++ b/gcc/ada/i-vxwoio.adb @@ -63,16 +63,10 @@ package body Interfaces.VxWorks.IO is is Status : int; Fd : int; - begin Fd := fileno (File); Status := ioctl (Fd, FIOSETOPTIONS, OPT_TERMINAL); - - if Status /= int (ERROR) then - Success := True; - else - Success := False; - end if; + Success := (if Status /= int (ERROR) then True else False); end Disable_Get_Immediate; end Interfaces.VxWorks.IO; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 4264a5a9db7..0f3ad5793ec 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -263,6 +263,10 @@ package body Impunit is "g-sercom", -- GNAT.Serial_Communications "g-sestin", -- GNAT.Secondary_Stack_Info "g-sha1 ", -- GNAT.SHA1 + "g-sha224", -- GNAT.SHA224 + "g-sha256", -- GNAT.SHA256 + "g-sha384", -- GNAT.SHA384 + "g-sha512", -- GNAT.SHA512 "g-signal", -- GNAT.Signals "g-socket", -- GNAT.Sockets "g-souinf", -- GNAT.Source_Info diff --git a/gcc/ada/init.c b/gcc/ada/init.c index a8be23dbb5f..5e5d1c60b44 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -601,14 +601,14 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) time this happens. */ #if defined (i386) - unsigned long pattern = *(unsigned long *)mcontext->gregs[REG_EIP]; + unsigned long *pc = (unsigned long *)mcontext->gregs[REG_EIP]; /* The pattern is "orl $0x0,(%esp)" for a probe in 32-bit mode. */ - if (signo == SIGSEGV && pattern == 0x00240c83) + if (signo == SIGSEGV && pc && *pc == 0x00240c83) mcontext->gregs[REG_ESP] += 4096 + 4 * sizeof (unsigned long); #elif defined (__x86_64__) - unsigned long pattern = *(unsigned long *)mcontext->gregs[REG_RIP]; + unsigned long *pc = (unsigned long *)mcontext->gregs[REG_RIP]; /* The pattern is "orq $0x0,(%rsp)" for a probe in 64-bit mode. */ - if (signo == SIGSEGV && (pattern & 0xffffffffff) == 0x00240c8348) + if (signo == SIGSEGV && pc && (*pc & 0xffffffffff) == 0x00240c8348) mcontext->gregs[REG_RSP] += 4096 + 4 * sizeof (unsigned long); #elif defined (__ia64__) /* ??? The IA-64 unwinder doesn't compensate for signals. */ diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index d5236773a3d..fa8af04d6ae 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -157,7 +157,7 @@ package Lib.Writ is -- One of these lines appears for each of the arguments present in the -- call to the gnat1 program. This can be used if it is necessary to - -- reconstruct this call (e.g. for fix and continue) + -- reconstruct this call (e.g. for fix and continue). -- ------------------- -- -- P Parameters -- @@ -235,7 +235,7 @@ package Lib.Writ is -- generated exception tables. If ZX is not present, the -- longjmp/setjmp exception scheme is in use. -- - -- Note that language defined units never output policy (Lx,Tx,Qx) + -- Note that language defined units never output policy (Lx, Tx, Qx) -- parameters. Language defined units must correctly handle all -- possible cases. These values are checked for consistency by the -- binder and then copied to the generated binder output file. diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 12e6386d045..0e3c85765d5 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -2453,14 +2453,12 @@ package body Make is procedure Await_Compile (Data : out Compilation_Data; OK : out Boolean); - -- Awaits that an outstanding compilation process terminates. When - -- it does set Data to the information registered for the corresponding - -- call to Add_Process. - -- Note that this time stamp can be used to check whether the - -- compilation did generate an object file. OK is set to True if the - -- compilation succeeded. - -- Data could be No_Compilation_Data if there was no compilation to wait - -- for. + -- Awaits that an outstanding compilation process terminates. When it + -- does set Data to the information registered for the corresponding + -- call to Add_Process. Note that this time stamp can be used to check + -- whether the compilation did generate an object file. OK is set to + -- True if the compilation succeeded. Data could be No_Compilation_Data + -- if there was no compilation to wait for. function Bad_Compilation_Count return Natural; -- Returns the number of compilation failures @@ -2474,9 +2472,9 @@ package body Make is Source_Index : Int; Pid : out Process_Id; Process_Created : out Boolean); - -- Collect arguments from project file (if any) and compile. - -- If no compilation was attempted, Processed_Created is set to False, - -- and the value of Pid is unknown. + -- Collect arguments from project file (if any) and compile. If no + -- compilation was attempted, Processed_Created is set to False, and the + -- value of Pid is unknown. function Compile (Project : Project_Id; @@ -2579,18 +2577,18 @@ package body Make is ------------------- procedure Await_Compile - (Data : out Compilation_Data; - OK : out Boolean) + (Data : out Compilation_Data; + OK : out Boolean) is - Pid : Process_Id; - Project : Project_Id; + Pid : Process_Id; + Project : Project_Id; Comp_Data : Project_Compilation_Access; begin pragma Assert (Outstanding_Compiles > 0); - Data := No_Compilation_Data; - OK := False; + Data := No_Compilation_Data; + OK := False; -- The loop here is a work-around for a problem on VMS; in some -- circumstances (shared library and several executables, for @@ -2614,13 +2612,14 @@ package body Make is -- file name for reuse by a subsequent compilation. if Running_Compile (J).Mapping_File /= No_Mapping_File then - Comp_Data := Project_Compilation_Htable.Get - (Project_Compilation, Project); + Comp_Data := + Project_Compilation_Htable.Get + (Project_Compilation, Project); Comp_Data.Last_Free_Indices := Comp_Data.Last_Free_Indices + 1; Comp_Data.Free_Mapping_File_Indices (Comp_Data.Last_Free_Indices) := - Running_Compile (J).Mapping_File; + Running_Compile (J).Mapping_File; end if; -- To actually remove this Pid and related info from @@ -2629,7 +2628,6 @@ package body Make is if J = Outstanding_Compiles then null; - else Running_Compile (J) := Running_Compile (Outstanding_Compiles); @@ -2643,6 +2641,8 @@ package body Make is -- This child process was not one of our compilation processes; -- just ignore it for now. + -- Why is this commented out code sitting here??? + -- raise Program_Error; end loop; end Await_Compile; @@ -2678,8 +2678,7 @@ package body Make is -- library only if we can find it. if RTS_Switch then - Add_It := - Find_File (Sfile, Osint.Source) /= No_File; + Add_It := Full_Source_Name (Sfile) /= No_File; end if; if Add_It then @@ -3001,6 +3000,7 @@ package body Make is Uname : Unit_Name_Type; Unit_Name : Name_Id; Uid : Prj.Unit_Index; + begin while Good_ALI_Present loop ALI := Get_Next_Good_ALI; @@ -3015,24 +3015,23 @@ package body Make is Main_Unit := ALIs.Table (ALI).Main_Program /= None; end if; - -- The following adds the standard library (s-stalib) to the - -- list of files to be handled by gnatmake: this file and any - -- files it depends on are always included in every bind, - -- even if they are not in the explicit dependency list. - -- Of course, it is not added if Suppress_Standard_Library - -- is True. + -- The following adds the standard library (s-stalib) to the list + -- of files to be handled by gnatmake: this file and any files it + -- depends on are always included in every bind, even if they are + -- not in the explicit dependency list. Of course, it is not added + -- if Suppress_Standard_Library is True. - -- However, to avoid annoying output about s-stalib.ali being - -- read only, when "-v" is used, we add the standard library - -- only when "-a" is used. + -- However, to avoid annoying output about s-stalib.ali being read + -- only, when "-v" is used, we add the standard library only when + -- "-a" is used. if Need_To_Check_Standard_Library then Check_Standard_Library; end if; - -- Now insert in the Q the unmarked source files (i.e. those - -- which have never been inserted in the Q and hence never - -- considered). Only do that if Unique_Compile is False. + -- Now insert in the Q the unmarked source files (i.e. those which + -- have never been inserted in the Q and hence never considered). + -- Only do that if Unique_Compile is False. if not Unique_Compile then for J in @@ -3044,9 +3043,8 @@ package body Make is Sfile := Withs.Table (K).Sfile; Uname := Withs.Table (K).Uname; - -- If project files are used, find the proper source - -- to compile, in case Sfile is the spec, but there - -- is a body. + -- If project files are used, find the proper source to + -- compile in case Sfile is the spec but there is a body. if Main_Project /= No_Project then Get_Name_String (Uname); @@ -3163,8 +3161,9 @@ package body Make is -------------------------------- function Must_Exit_Because_Of_Error return Boolean is - Data : Compilation_Data; - Success : Boolean; + Data : Compilation_Data; + Success : Boolean; + begin if Bad_Compilation_Count > 0 and then not Keep_Going then while Outstanding_Compiles > 0 loop @@ -3212,29 +3211,29 @@ package body Make is function Start_Compile_If_Possible (Args : Argument_List) return Boolean is - In_Lib_Dir : Boolean; - Need_To_Compile : Boolean; - Pid : Process_Id; - Process_Created : Boolean; + In_Lib_Dir : Boolean; + Need_To_Compile : Boolean; + Pid : Process_Id; + Process_Created : Boolean; Source_File : File_Name_Type; Full_Source_File : File_Name_Type; Source_File_Attr : aliased File_Attributes; -- The full name of the source file and its attributes (size, ...) - Source_Unit : Unit_Name_Type; - Source_Index : Int; + Source_Unit : Unit_Name_Type; + Source_Index : Int; -- Index of the current unit in the current source file - Lib_File : File_Name_Type; - Full_Lib_File : File_Name_Type; - Lib_File_Attr : aliased File_Attributes; - Read_Only : Boolean := False; - ALI : ALI_Id; + Lib_File : File_Name_Type; + Full_Lib_File : File_Name_Type; + Lib_File_Attr : aliased File_Attributes; + Read_Only : Boolean := False; + ALI : ALI_Id; -- The ALI file and its attributes (size, stamp, ...) - Obj_File : File_Name_Type; - Obj_Stamp : Time_Stamp_Type; + Obj_File : File_Name_Type; + Obj_Stamp : Time_Stamp_Type; -- The object file begin @@ -3247,13 +3246,19 @@ package body Make is Attr => Source_File_Attr'Access); Lib_File := Osint.Lib_File_Name (Source_File, Source_Index); + + -- ??? This call could be avoided when using projects, since we + -- know where the ALI file is supposed to be. That would avoid + -- searches in the object directories, including in the runtime + -- dir. However, that would require getting access to the + -- Source_Id. + Osint.Full_Lib_File_Name (Lib_File, Lib_File => Full_Lib_File, Attr => Lib_File_Attr); - -- If this source has already been compiled, the executable is - -- obsolete. + -- If source has already been compiled, executable is obsolete if Is_In_Obsoleted (Source_File) then Executable_Obsolete := True; @@ -3359,7 +3364,8 @@ package body Make is end if; if not Need_To_Compile then - -- The ALI file is up-to-date. Record its Id + + -- The ALI file is up-to-date; record its Id Record_Good_ALI (ALI); @@ -3368,15 +3374,15 @@ package body Make is if First_Compiled_File = No_File and then (Most_Recent_Obj_File = No_File - or else Obj_Stamp > Most_Recent_Obj_Stamp) + or else Obj_Stamp > Most_Recent_Obj_Stamp) then Most_Recent_Obj_File := Obj_File; Most_Recent_Obj_Stamp := Obj_Stamp; end if; else - -- Check that switch -x has been used if a source - -- outside of project files need to be compiled. + -- Check that switch -x has been used if a source outside + -- of project files need to be compiled. if Main_Project /= No_Project and then Arguments_Project = No_Project @@ -3396,6 +3402,7 @@ package body Make is Most_Recent_Obj_File := No_File; if Do_Not_Execute then + -- Exit the main loop return True; @@ -3404,15 +3411,17 @@ package body Make is -- Compute where the ALI file must be generated in -- In_Place_Mode (this does not require to know the - -- location of the object directory) + -- location of the object directory). if In_Place_Mode then if Full_Lib_File = No_File then + -- If the library file was not found, then save -- the library file near the source file. - Lib_File := Osint.Lib_File_Name - (Full_Source_File, Source_Index); + Lib_File := + Osint.Lib_File_Name + (Full_Source_File, Source_Index); Full_Lib_File := Lib_File; else @@ -3423,9 +3432,9 @@ package body Make is end if; end if; - -- Start the compilation and record it. We can do - -- this because there is at least one free process. - -- This might change the current directory + -- Start the compilation and record it. We can do this + -- because there is at least one free process. This might + -- change the current directory. Collect_Arguments_And_Compile (Full_Source_File => Full_Source_File, @@ -3441,6 +3450,7 @@ package body Make is -- being the same to find the resulting ALI file. if not In_Place_Mode then + -- Compute the expected location of the ALI file. This -- can be from several places: -- -i => in place mode. In such a case, @@ -3456,6 +3466,7 @@ package body Make is Add_Str_To_Name_Buffer (Object_Directory_Path.all); Add_Str_To_Name_Buffer (Get_Name_String (Lib_File)); Full_Lib_File := Name_Find; + else if Project_Of_Current_Object_Directory /= No_Project @@ -3466,6 +3477,7 @@ package body Make is Add_Str_To_Name_Buffer (Get_Name_String (Lib_File)); Full_Lib_File := Name_Find; + else Full_Lib_File := Lib_File; end if; @@ -3475,21 +3487,20 @@ package body Make is Lib_File_Attr := Unknown_Attributes; - -- Make sure we could successfully start - -- the Compilation. + -- Make sure we could successfully start the compilation if Process_Created then if Pid = Invalid_Pid then Record_Failure (Full_Source_File, Source_Unit); else Add_Process - (Pid => Pid, - Sfile => Full_Source_File, - Afile => Lib_File, - Uname => Source_Unit, - Mfile => Mfile, - Full_Lib_File => Full_Lib_File, - Lib_File_Attr => Lib_File_Attr); + (Pid => Pid, + Sfile => Full_Source_File, + Afile => Lib_File, + Uname => Source_Unit, + Mfile => Mfile, + Full_Lib_File => Full_Lib_File, + Lib_File_Attr => Lib_File_Attr); end if; end if; end if; @@ -3504,16 +3515,16 @@ package body Make is ----------------------------- procedure Wait_For_Available_Slot is - Compilation_OK : Boolean; - Text : Text_Buffer_Ptr; - ALI : ALI_Id; - Data : Compilation_Data; + Compilation_OK : Boolean; + Text : Text_Buffer_Ptr; + ALI : ALI_Id; + Data : Compilation_Data; begin if Outstanding_Compiles = Max_Process or else (Empty_Q - and then not Good_ALI_Present - and then Outstanding_Compiles > 0) + and then not Good_ALI_Present + and then Outstanding_Compiles > 0) then Await_Compile (Data, Compilation_OK); @@ -3536,26 +3547,28 @@ package body Make is Check_Object_Consistency := Check_Object_Consistency - and Compilation_OK - and (Output_Is_Object or Do_Bind_Step); + and Compilation_OK + and (Output_Is_Object or Do_Bind_Step); - Text := Read_Library_Info_From_Full - (Data.Full_Lib_File, Data.Lib_File_Attr'Access); + Text := + Read_Library_Info_From_Full + (Data.Full_Lib_File, Data.Lib_File_Attr'Access); -- Restore Check_Object_Consistency to its initial value Check_Object_Consistency := Saved_Object_Consistency; end; - -- If an ALI file was generated by this compilation, scan - -- the ALI file and record it. + -- If an ALI file was generated by this compilation, scan the + -- ALI file and record it. -- If the scan fails, a previous ali file is inconsistent with -- the unit just compiled. if Text /= null then - ALI := Scan_ALI - (Data.Lib_File, Text, Ignore_ED => False, Err => True); + ALI := + Scan_ALI + (Data.Lib_File, Text, Ignore_ED => False, Err => True); if ALI = No_ALI_Id then @@ -3616,11 +3629,11 @@ package body Make is end if; -- The following two flags affect the behavior of ALI.Set_Source_Table. - -- We set Check_Source_Files to True to ensure that source file - -- time stamps are checked, and we set All_Sources to False to - -- avoid checking the presence of the source files listed in the - -- source dependency section of an ali file (which would be a mistake - -- since the ali file may be obsolete). + -- We set Check_Source_Files to True to ensure that source file time + -- stamps are checked, and we set All_Sources to False to avoid checking + -- the presence of the source files listed in the source dependency + -- section of an ali file (which would be a mistake since the ali file + -- may be obsolete). Check_Source_Files := True; All_Sources := False; @@ -4357,8 +4370,7 @@ package body Make is -- Otherwise, if there is a spec, put it in the mapping elsif Unit.File_Names (Spec) /= No_Source - and then Unit.File_Names (Spec).Project /= - No_Project + and then Unit.File_Names (Spec).Project /= No_Project then Get_Name_String (Unit.Name); Add_Str_To_Name_Buffer ("%s"); @@ -4576,9 +4588,9 @@ package body Make is end if; -- If no mains have been specified on the command line, and we are - -- using a project file, we either find the main(s) in attribute - -- Main of the main project, or we put all the sources of the project - -- file as mains. + -- using a project file, we either find the main(s) in attribute Main + -- of the main project, or we put all the sources of the project file + -- as mains. else if Main_Index /= 0 then @@ -4626,19 +4638,18 @@ package body Make is end if; else - -- The attribute Main is not an empty list. - -- Put all the main subprograms in the list as if they were - -- specified on the command line. However, if attribute - -- Languages includes a language other than Ada, only - -- include the Ada mains; if there is no Ada main, compile - -- all the sources of the project. + -- The attribute Main is not an empty list. Put all the main + -- subprograms in the list as if they were specified on the + -- command line. However, if attribute Languages includes a + -- language other than Ada, only include the Ada mains; if + -- there is no Ada main, compile all sources of the project. declare Languages : constant Variable_Value := Prj.Util.Value_Of - (Name_Languages, - Main_Project.Decl.Attributes, - Project_Tree); + (Name_Languages, + Main_Project.Decl.Attributes, + Project_Tree); Current : String_List_Id; Element : String_Element; @@ -4652,7 +4663,6 @@ package body Make is if not Languages.Default then Current := Languages.Values; - Look_For_Foreign : while Current /= Nil_String loop Element := Project_Tree.String_Elements. @@ -6871,24 +6881,15 @@ package body Make is -- We add the source directories and the object directories to the -- search paths. + -- ??? Why do we need these search directories, we already know the + -- locations from parsing the project, except for the runtime which + -- has its own directories anyway Add_Source_Directories (Main_Project, Project_Tree); Add_Object_Directories (Main_Project); Recursive_Compute_Depth (Main_Project); - - -- For each project compute the list of the projects it imports - -- directly or indirectly. - - declare - Proj : Project_List; - begin - Proj := Project_Tree.Projects; - while Proj /= null loop - Compute_All_Imported_Projects (Proj.Project); - Proj := Proj.Next; - end loop; - end; + Compute_All_Imported_Projects (Project_Tree); else @@ -7698,6 +7699,7 @@ package body Make is declare Norm : constant String := Normalize_Pathname (Argv); + begin if Norm (Norm'Last) = Directory_Separator then Object_Directory_Path := new String'(Norm); diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index 307ec6ffccc..ab00b506578 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -157,6 +157,47 @@ package body Makeutl is end if; end Add_Linker_Option; + ------------------------- + -- Base_Name_Index_For -- + ------------------------- + + function Base_Name_Index_For + (Main : String; + Main_Index : Int; + Index_Separator : Character) return File_Name_Type + is + Result : File_Name_Type; + + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Base_Name (Main)); + + -- Remove the extension, if any, that is the last part of the base name + -- starting with a dot and following some characters. + + for J in reverse 2 .. Name_Len loop + if Name_Buffer (J) = '.' then + Name_Len := J - 1; + exit; + end if; + end loop; + + -- Add the index info, if index is different from 0 + + if Main_Index > 0 then + Add_Char_To_Name_Buffer (Index_Separator); + + declare + Img : constant String := Main_Index'Img; + begin + Add_Str_To_Name_Buffer (Img (2 .. Img'Last)); + end; + end if; + + Result := Name_Find; + return Result; + end Base_Name_Index_For; + ------------------------------ -- Check_Source_Info_In_ALI -- ------------------------------ @@ -231,7 +272,7 @@ package body Makeutl is if not Fname.Is_Internal_File_Name (SD.Sfile) or else (Check_Readonly_Files - and then Find_File (SD.Sfile, Osint.Source) = No_File) + and then Full_Source_Name (SD.Sfile) = No_File) then if Verbose_Mode then Write_Line @@ -329,8 +370,8 @@ package body Makeutl is end if; return Normalize_Pathname - (Exec (Exec'First .. Path_Last - 4), - Resolve_Links => Opt.Follow_Links_For_Dirs) + (Exec (Exec'First .. Path_Last - 4), + Resolve_Links => Opt.Follow_Links_For_Dirs) & Directory_Separator; end Get_Install_Dir; @@ -599,6 +640,7 @@ package body Makeutl is type File_And_Loc is record File_Name : File_Name_Type; + Index : Int := 0; Location : Source_Ptr := No_Location; end record; @@ -623,7 +665,7 @@ package body Makeutl is Name_Len := 0; Add_Str_To_Name_Buffer (Name); Names.Increment_Last; - Names.Table (Names.Last) := (Name_Find, No_Location); + Names.Table (Names.Last) := (Name_Find, 0, No_Location); end Add_Main; ------------ @@ -636,6 +678,19 @@ package body Makeutl is Mains.Reset; end Delete; + --------------- + -- Get_Index -- + --------------- + + function Get_Index return Int is + begin + if Current in Names.First .. Names.Last then + return Names.Table (Current).Index; + else + return 0; + end if; + end Get_Index; + ------------------ -- Get_Location -- ------------------ @@ -681,6 +736,17 @@ package body Makeutl is Current := 0; end Reset; + --------------- + -- Set_Index -- + --------------- + + procedure Set_Index (Index : Int) is + begin + if Names.Last > 0 then + Names.Table (Names.Last).Index := Index; + end if; + end Set_Index; + ------------------ -- Set_Location -- ------------------ diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index 95114f07c9a..a7614f399c4 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -60,7 +60,14 @@ package Makeutl is function Create_Name (Name : String) return File_Name_Type; function Create_Name (Name : String) return Name_Id; function Create_Name (Name : String) return Path_Name_Type; - -- Get the Name_Id of a name + -- Get an id for a name + + function Base_Name_Index_For + (Main : String; + Main_Index : Int; + Index_Separator : Character) return File_Name_Type; + -- Returns the base name of Main, without the extension, followed by the + -- Index_Separator followed by the Main_Index if it is non-zero. function Executable_Prefix_Path return String; -- Return the absolute path parent directory of the directory where the @@ -80,9 +87,9 @@ package Makeutl is -- one of its source. Returns False otherwise. function Check_Source_Info_In_ALI (The_ALI : ALI.ALI_Id) return Boolean; - -- Check whether all file references in ALI are still valid (ie the + -- Check whether all file references in ALI are still valid (i.e. the -- source files are still associated with the same units). Return True - -- if everything is still valid + -- if everything is still valid. function Is_External_Assignment (Tree : Prj.Tree.Project_Node_Tree_Ref; @@ -114,11 +121,11 @@ package Makeutl is S2 : String := ""; Prefix : String := " -> "; Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low); - -- If the verbose flag (Verbose_Mode) is set and the verbosity level is - -- at least equal to Minimum_Verbosity, then print Prefix to standard - -- output followed by N1 and S1. If N2 /= No_Name then N2 is printed after - -- S1. S2 is printed last. Both N1 and N2 are printed in quotation marks. - -- The two forms differ only in taking Name_Id or File_name_Type arguments. + -- If the verbose flag (Verbose_Mode) is set and the verbosity level is at + -- least equal to Minimum_Verbosity, then print Prefix to standard output + -- followed by N1 and S1. If N2 /= No_Name then N2 is printed after S1. S2 + -- is printed last. Both N1 and N2 are printed in quotation marks. The two + -- forms differ only in taking Name_Id or File_name_Type arguments. function Linker_Options_Switches (Project : Project_Id; @@ -135,14 +142,36 @@ package Makeutl is -- Find the index of a unit in a source file. Return zero if the file is -- not a multi-unit source file. - package Mains is + procedure Test_If_Relative_Path + (Switch : in out String_Access; + Parent : String; + Including_L_Switch : Boolean := True; + Including_Non_Switch : Boolean := True; + Including_RTS : Boolean := False); + -- Test if Switch is a relative search path switch. If it is, fail if + -- Parent is the empty string, otherwise prepend the path with Parent. + -- This subprogram is only called when using project files. For gnatbind + -- switches, Including_L_Switch is False, because the argument of the -L + -- switch is not a path. If Including_RTS is True, process also switches + -- --RTS=. + + function Path_Or_File_Name (Path : Path_Name_Type) return String; + -- Returns a file name if -df is used, otherwise return a path name + + ----------- + -- Mains -- + ----------- + + -- Mains are stored in a table. An index is used to retrieve the mains + -- from the table. - -- Mains are stored in a table. An index is used to retrieve the mains - -- from the table. + package Mains is procedure Add_Main (Name : String); -- Add one main to the table + procedure Set_Index (Index : Int); + procedure Set_Location (Location : Source_Ptr); -- Set the location of the last main added. By default, the location is -- No_Location. @@ -157,6 +186,8 @@ package Makeutl is -- Increase the index and return the next main. If table is exhausted, -- return an empty string. + function Get_Index return Int; + function Get_Location return Source_Ptr; -- Get the location of the current main @@ -169,22 +200,6 @@ package Makeutl is end Mains; - procedure Test_If_Relative_Path - (Switch : in out String_Access; - Parent : String; - Including_L_Switch : Boolean := True; - Including_Non_Switch : Boolean := True; - Including_RTS : Boolean := False); - -- Test if Switch is a relative search path switch. If it is, fail if - -- Parent is the empty string, otherwise prepend the path with Parent. - -- This subprogram is only called when using project files. For gnatbind - -- switches, Including_L_Switch is False, because the argument of the -L - -- switch is not a path. If Including_RTS is True, process also switches - -- --RTS=. - - function Path_Or_File_Name (Path : Path_Name_Type) return String; - -- Returns a file name if -df is used, otherwise return a path name - ---------------------- -- Marking Routines -- ---------------------- diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index aec6d77ee0b..a1528962b01 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -56,6 +56,8 @@ package body Opt is External_Name_Exp_Casing_Config := External_Name_Exp_Casing; External_Name_Imp_Casing_Config := External_Name_Imp_Casing; Fast_Math_Config := Fast_Math; + Init_Or_Norm_Scalars_Config := Init_Or_Norm_Scalars; + Initialize_Scalars_Config := Initialize_Scalars; Optimize_Alignment_Config := Optimize_Alignment; Persistent_BSS_Mode_Config := Persistent_BSS_Mode; Polling_Required_Config := Polling_Required; @@ -86,6 +88,8 @@ package body Opt is External_Name_Exp_Casing := Save.External_Name_Exp_Casing; External_Name_Imp_Casing := Save.External_Name_Imp_Casing; Fast_Math := Save.Fast_Math; + Init_Or_Norm_Scalars := Save.Init_Or_Norm_Scalars; + Initialize_Scalars := Save.Initialize_Scalars; Optimize_Alignment := Save.Optimize_Alignment; Optimize_Alignment_Local := Save.Optimize_Alignment_Local; Persistent_BSS_Mode := Save.Persistent_BSS_Mode; @@ -111,6 +115,8 @@ package body Opt is Save.External_Name_Exp_Casing := External_Name_Exp_Casing; Save.External_Name_Imp_Casing := External_Name_Imp_Casing; Save.Fast_Math := Fast_Math; + Save.Init_Or_Norm_Scalars := Init_Or_Norm_Scalars; + Save.Initialize_Scalars := Initialize_Scalars; Save.Optimize_Alignment := Optimize_Alignment; Save.Optimize_Alignment_Local := Optimize_Alignment_Local; Save.Persistent_BSS_Mode := Persistent_BSS_Mode; @@ -175,6 +181,8 @@ package body Opt is External_Name_Exp_Casing := External_Name_Exp_Casing_Config; External_Name_Imp_Casing := External_Name_Imp_Casing_Config; Fast_Math := Fast_Math_Config; + Init_Or_Norm_Scalars := Init_Or_Norm_Scalars_Config; + Initialize_Scalars := Initialize_Scalars_Config; Optimize_Alignment := Optimize_Alignment_Config; Optimize_Alignment_Local := False; Persistent_BSS_Mode := Persistent_BSS_Mode_Config; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 542b1f02551..9013d7d3dcd 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -861,6 +861,12 @@ package Opt is -- This flag is set True if a No_Run_Time pragma is encountered. See -- spec of Rtsfind for a full description of handling of this pragma. + No_Split_Units : Boolean := False; + -- GPRBUILD + -- Set to True with switch --no-split-units. When True, unit sources, spec, + -- body and subunits, must all be in the same project.This is checked after + -- each compilation. + No_Stdinc : Boolean := False; -- GNAT, GNATBIND, GNATMAKE, GNATFIND, GNATXREF -- Set to True if no default source search dirs added to search list @@ -1042,6 +1048,10 @@ package Opt is -- for GNATBIND and to False when using the -static option. The value of -- this flag is set by Gnatbind.Scan_Bind_Arg. + Short_Circuit_And_Or : Boolean := False; + -- GNAT + -- Set True if a pragma Short_Circuit_And_Or applies to the current unit. + Sprint_Line_Limit : Nat := 72; -- Limit values for chopping long lines in Sprint output, can be reset -- by use of NNN parameter with -gnatG or -gnatD switches. @@ -1547,6 +1557,18 @@ package Opt is -- used to set the initial value of Fast_Math at the start of each new -- compilation unit. + Init_Or_Norm_Scalars_Config : Boolean; + -- GNAT + -- This is the value of the configuration switch that is set by one + -- of the pragmas Initialize_Scalars or Normalize_Scalars. + + Initialize_Scalars_Config : Boolean; + -- GNAT + -- This is the value of the configuration switch that is set by the + -- pragma Initialize_Scalars when it appears in the gnat.adc file. + -- This switch is not set when the pragma appears ahead of a given + -- unit, so it does not affect the compilation of other units. + Optimize_Alignment_Config : Character; -- GNAT -- This is the value of the configuration switch that controls the @@ -1695,6 +1717,8 @@ private External_Name_Exp_Casing : External_Casing_Type; External_Name_Imp_Casing : External_Casing_Type; Fast_Math : Boolean; + Init_Or_Norm_Scalars : Boolean; + Initialize_Scalars : Boolean; Optimize_Alignment : Character; Optimize_Alignment_Local : Boolean; Persistent_BSS_Mode : Boolean; diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 1b1f5085984..6265ede68d1 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -80,8 +80,8 @@ package body Osint is -- Appends Suffix to Name and returns the new name function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type; - -- Convert OS format time to GNAT format time stamp. - -- Returns Empty_Time_Stamp if T is Invalid_Time + -- Convert OS format time to GNAT format time stamp. If T is Invalid_Time, + -- then returns Empty_Time_Stamp. function Executable_Prefix return String_Ptr; -- Returns the name of the root directory where the executable is stored. @@ -91,8 +91,8 @@ package body Osint is -- "/foo/bar/". Return "" if location is not recognized as described above. function Update_Path (Path : String_Ptr) return String_Ptr; - -- Update the specified path to replace the prefix with the location - -- where GNAT is installed. See the file prefix.c in GCC for details. + -- Update the specified path to replace the prefix with the location where + -- GNAT is installed. See the file prefix.c in GCC for details. procedure Locate_File (N : File_Name_Type; @@ -106,9 +106,11 @@ package body Osint is -- if T = Source, Dir is an index into the Src_Search_Directories table. -- Returns the File_Name_Type of the full file name if file found, or -- No_File if not found. + -- -- On exit, Found is set to the file that was found, and Attr to a cache of -- its attributes (at least those that have been computed so far). Reusing -- the cache will save some system calls. + -- -- Attr is always reset in this call to Unknown_Attributes, even in case of -- failure @@ -136,6 +138,7 @@ package body Osint is Path_Len : Integer) return String_Access; -- Converts a C String to an Ada String. Are we doing this to avoid withing -- Interfaces.C.Strings ??? + -- Caller must free result. function Include_Dir_Default_Prefix return String_Access; -- Same as exported version, except returns a String_Access @@ -239,8 +242,9 @@ package body Osint is File : File_Name_Type; Attr : aliased File_Attributes; end record; + No_File_Info_Cache : constant File_Info_Cache := - (No_File, Unknown_Attributes); + (No_File, Unknown_Attributes); package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable ( Header_Num => File_Hash_Num, @@ -584,13 +588,13 @@ package body Osint is declare Norm : String_Ptr := Normalize_Directory_Name (Dir); - begin + begin -- Do nothing if the directory is already in the list. This saves -- system calls and avoid unneeded work for D in Lib_Search_Directories.First .. - Lib_Search_Directories.Last + Lib_Search_Directories.Last loop if Lib_Search_Directories.Table (D).all = Norm.all then Free (Norm); @@ -789,8 +793,12 @@ package body Osint is -- Executable_Name -- --------------------- - function Executable_Name (Name : File_Name_Type) return File_Name_Type is + function Executable_Name + (Name : File_Name_Type; + Only_If_No_Suffix : Boolean := False) return File_Name_Type + is Exec_Suffix : String_Access; + Add_Suffix : Boolean; begin if Name = No_File then @@ -804,40 +812,63 @@ package body Osint is Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len)); end if; - Get_Name_String (Name); - if Exec_Suffix'Length /= 0 then - declare - Buffer : String := Name_Buffer (1 .. Name_Len); - - begin - -- Get the file name in canonical case to accept as is names - -- ending with ".EXE" on VMS and Windows. - - Canonical_Case_File_Name (Buffer); + Get_Name_String (Name); + + Add_Suffix := True; + if Only_If_No_Suffix then + for J in reverse 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Add_Suffix := False; + exit; + + elsif Name_Buffer (J) = '/' or else + Name_Buffer (J) = Directory_Separator + then + exit; + end if; + end loop; + end if; - -- If Executable does not end with the executable suffix, add it + if Add_Suffix then + declare + Buffer : String := Name_Buffer (1 .. Name_Len); - if Buffer'Length <= Exec_Suffix'Length - or else - Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last) - /= Exec_Suffix.all - then - Name_Buffer (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) := - Exec_Suffix.all; - Name_Len := Name_Len + Exec_Suffix'Length; - Free (Exec_Suffix); - return Name_Find; - end if; - end; + begin + -- Get the file name in canonical case to accept as is names + -- ending with ".EXE" on VMS and Windows. + + Canonical_Case_File_Name (Buffer); + + -- If Executable does not end with the executable suffix, add + -- it. + + if Buffer'Length <= Exec_Suffix'Length + or else + Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last) + /= Exec_Suffix.all + then + Name_Buffer + (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) := + Exec_Suffix.all; + Name_Len := Name_Len + Exec_Suffix'Length; + Free (Exec_Suffix); + return Name_Find; + end if; + end; + end if; end if; Free (Exec_Suffix); return Name; end Executable_Name; - function Executable_Name (Name : String) return String is + function Executable_Name + (Name : String; + Only_If_No_Suffix : Boolean := False) return String + is Exec_Suffix : String_Access; + Add_Suffix : Boolean; Canonical_Name : String := Name; begin @@ -848,30 +879,50 @@ package body Osint is Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len)); end if; - declare - Suffix : constant String := Exec_Suffix.all; - - begin + if Exec_Suffix'Length = 0 then Free (Exec_Suffix); - Canonical_Case_File_Name (Canonical_Name); + return Name; + + else + declare + Suffix : constant String := Exec_Suffix.all; - if Suffix'Length /= 0 - and then - (Canonical_Name'Length <= Suffix'Length + begin + Free (Exec_Suffix); + Canonical_Case_File_Name (Canonical_Name); + + Add_Suffix := True; + if Only_If_No_Suffix then + for J in reverse Canonical_Name'Range loop + if Canonical_Name (J) = '.' then + Add_Suffix := False; + exit; + + elsif Canonical_Name (J) = '/' or else + Canonical_Name (J) = Directory_Separator + then + exit; + end if; + end loop; + end if; + + if Add_Suffix and then + (Canonical_Name'Length <= Suffix'Length or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1 - .. Canonical_Name'Last) /= Suffix) - then - declare - Result : String (1 .. Name'Length + Suffix'Length); - begin - Result (1 .. Name'Length) := Name; - Result (Name'Length + 1 .. Result'Last) := Suffix; - return Result; - end; - else - return Name; - end if; - end; + .. Canonical_Name'Last) /= Suffix) + then + declare + Result : String (1 .. Name'Length + Suffix'Length); + begin + Result (1 .. Name'Length) := Name; + Result (Name'Length + 1 .. Result'Last) := Suffix; + return Result; + end; + else + return Name; + end if; + end; + end if; end Executable_Name; ----------------------- @@ -1002,10 +1053,13 @@ package body Osint is ----------------- function File_Length - (Name : C_File_Name; Attr : access File_Attributes) return Long_Integer + (Name : C_File_Name; + Attr : access File_Attributes) return Long_Integer is function Internal - (F : Integer; N : C_File_Name; A : System.Address) return Long_Integer; + (F : Integer; + N : C_File_Name; + A : System.Address) return Long_Integer; pragma Import (C, Internal, "__gnat_file_length_attr"); begin return Internal (-1, Name, Attr.all'Address); @@ -1016,7 +1070,8 @@ package body Osint is --------------------- function File_Time_Stamp - (Name : C_File_Name; Attr : access File_Attributes) return OS_Time + (Name : C_File_Name; + Attr : access File_Attributes) return OS_Time is function Internal (N : C_File_Name; A : System.Address) return OS_Time; pragma Import (C, Internal, "__gnat_file_time_name_attr"); @@ -1024,6 +1079,21 @@ package body Osint is return Internal (Name, Attr.all'Address); end File_Time_Stamp; + function File_Time_Stamp + (Name : Path_Name_Type; + Attr : access File_Attributes) return Time_Stamp_Type + is + begin + if Name = No_Path then + return Empty_Time_Stamp; + end if; + + Get_Name_String (Name); + Name_Buffer (Name_Len + 1) := ASCII.NUL; + return OS_Time_To_GNAT_Time + (File_Time_Stamp (Name_Buffer'Address, Attr)); + end File_Time_Stamp; + ---------------- -- File_Stamp -- ---------------- @@ -1036,13 +1106,13 @@ package body Osint is Get_Name_String (Name); - -- File_Time_Stamp will always return Invalid_Time if the file does not - -- exist, and OS_Time_To_GNAT_Time will convert this value to - -- Empty_Time_Stamp. Therefore we do not need to first test whether the - -- file actually exists, which saves a system call. + -- File_Time_Stamp will always return Invalid_Time if the file does + -- not exist, and OS_Time_To_GNAT_Time will convert this value to + -- Empty_Time_Stamp. Therefore we do not need to first test whether + -- the file actually exists, which saves a system call. return OS_Time_To_GNAT_Time - (File_Time_Stamp (Name_Buffer (1 .. Name_Len))); + (File_Time_Stamp (Name_Buffer (1 .. Name_Len))); end File_Stamp; function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is @@ -1084,9 +1154,9 @@ package body Osint is begin -- If we are looking for a config file, look only in the current - -- directory, i.e. return input argument unchanged. Also look - -- only in the current directory if we are looking for a .dg - -- file (happens in -gnatD mode). + -- directory, i.e. return input argument unchanged. Also look only in + -- the curren directory if we are looking for a .dg file (happens in + -- -gnatD mode). if T = Config or else (Debug_Generated_Code @@ -2392,10 +2462,13 @@ package body Osint is if Opt.Check_Object_Consistency then -- On most systems, this does not result in an extra system call - Current_Full_Lib_Stamp := OS_Time_To_GNAT_Time - (File_Time_Stamp (Name_Buffer'Address, Lib_File_Attr)); + + Current_Full_Lib_Stamp := + OS_Time_To_GNAT_Time + (File_Time_Stamp (Name_Buffer'Address, Lib_File_Attr)); -- ??? One system call here + Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name); if Current_Full_Obj_Stamp (1) = ' ' then @@ -2710,6 +2783,7 @@ package body Osint is is File : File_Name_Type; Attr : aliased File_Attributes; + begin if not File_Cache_Enabled then Find_File (N, T, File, Attr'Access); @@ -2722,8 +2796,9 @@ package body Osint is else Get_Name_String (File); Name_Buffer (Name_Len + 1) := ASCII.NUL; - return OS_Time_To_GNAT_Time - (File_Time_Stamp (Name_Buffer'Address, Attr'Access)); + return + OS_Time_To_GNAT_Time + (File_Time_Stamp (Name_Buffer'Address, Attr'Access)); end if; end Smart_File_Stamp; @@ -2757,8 +2832,10 @@ package body Osint is begin if not File_Cache_Enabled then Find_File (N, T, Info.File, Info.Attr'Access); + else Info := File_Name_Hash_Table.Get (N); + if Info.File = No_File then Find_File (N, T, Info.File, Info.Attr'Access); File_Name_Hash_Table.Set (N, Info); @@ -2801,8 +2878,7 @@ package body Osint is if Is_Directory_Separator (Name_Buffer (J)) then - -- Return the part of Name that follows this last directory - -- separator. + -- Return part of Name that follows this last directory separator Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len); Name_Len := Name_Len - J; @@ -2849,7 +2925,7 @@ package body Osint is Prefix_Flag : Integer) return Address; pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec"); - C_Host_Dir : String (1 .. Host_Dir'Length + 1); + C_Host_Dir : String (1 .. Host_Dir'Length + 1); Canonical_Dir_Addr : Address; Canonical_Dir_Len : Integer; @@ -2862,6 +2938,7 @@ package body Osint is else Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0); end if; + Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr); if Canonical_Dir_Len = 0 then diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index 34b3f642fee..ae827ba286b 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -30,8 +30,8 @@ with Namet; use Namet; with Types; use Types; with System.Storage_Elements; -with System.OS_Lib; use System.OS_Lib; -with System; use System; +with System.OS_Lib; use System.OS_Lib; +with System; use System; pragma Elaborate_All (System.OS_Lib); -- For the call to function Get_Target_Object_Suffix in the private part @@ -147,13 +147,17 @@ package Osint is -- Strips the suffix (the last '.' and whatever comes after it) from Name. -- Returns the stripped name. - function Executable_Name (Name : File_Name_Type) return File_Name_Type; + function Executable_Name + (Name : File_Name_Type; + Only_If_No_Suffix : Boolean := False) return File_Name_Type; -- Given a file name it adds the appropriate suffix at the end so that -- it becomes the name of the executable on the system at end. For -- instance under DOS it adds the ".exe" suffix, whereas under UNIX no -- suffix is added. - function Executable_Name (Name : String) return String; + function Executable_Name + (Name : String; + Only_If_No_Suffix : Boolean := False) return String; -- Same as above, with String parameters function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type; @@ -207,9 +211,9 @@ package Osint is function To_Host_Dir_Spec (Canonical_Dir : String; Prefix_Style : Boolean) return String_Access; - -- Convert a canonical syntax directory specification to host syntax. - -- The Prefix_Style flag is currently ignored but should be set to - -- False. + -- Convert a canonical syntax directory specification to host syntax. The + -- Prefix_Style flag is currently ignored but should be set to False. + -- Note that the caller must free result. function To_Host_File_Spec (Canonical_File : String) return String_Access; @@ -234,10 +238,12 @@ package Osint is --------------------- -- File attributes -- --------------------- + -- The following subprograms offer services similar to those found in -- System.OS_Lib, but with the ability to extra multiple information from -- a single system call, depending on the system. This can result in fewer -- system calls when reused. + -- In all these subprograms, the requested value is either read from the -- File_Attributes parameter (resulting in no system call), or computed -- from the disk and then cached in the File_Attributes parameter (possibly @@ -249,27 +255,38 @@ package Osint is -- This must be initialized to Unknown_Attributes prior to the first call. function Is_Directory - (Name : C_File_Name; Attr : access File_Attributes) return Boolean; + (Name : C_File_Name; + Attr : access File_Attributes) return Boolean; function Is_Regular_File - (Name : C_File_Name; Attr : access File_Attributes) return Boolean; + (Name : C_File_Name; + Attr : access File_Attributes) return Boolean; function Is_Symbolic_Link - (Name : C_File_Name; Attr : access File_Attributes) return Boolean; + (Name : C_File_Name; + Attr : access File_Attributes) return Boolean; -- Return the type of the file, function File_Length - (Name : C_File_Name; Attr : access File_Attributes) return Long_Integer; + (Name : C_File_Name; + Attr : access File_Attributes) return Long_Integer; -- Return the length (number of bytes) of the file function File_Time_Stamp - (Name : C_File_Name; Attr : access File_Attributes) return OS_Time; + (Name : C_File_Name; + Attr : access File_Attributes) return OS_Time; + function File_Time_Stamp + (Name : Path_Name_Type; + Attr : access File_Attributes) return Time_Stamp_Type; -- Return the time stamp of the file function Is_Readable_File - (Name : C_File_Name; Attr : access File_Attributes) return Boolean; + (Name : C_File_Name; + Attr : access File_Attributes) return Boolean; function Is_Executable_File - (Name : C_File_Name; Attr : access File_Attributes) return Boolean; + (Name : C_File_Name; + Attr : access File_Attributes) return Boolean; function Is_Writable_File - (Name : C_File_Name; Attr : access File_Attributes) return Boolean; + (Name : C_File_Name; + Attr : access File_Attributes) return Boolean; -- Return the access rights for the file ------------------------- @@ -436,6 +453,7 @@ package Osint is -- The source file directory lookup penalty is incurred every single time -- the routines are called unless you have previously called -- Source_File_Data (Cache => True). See below. + -- -- The procedural version also returns some file attributes for the ALI -- file (to save on system calls later on). @@ -468,11 +486,11 @@ package Osint is -- Representation of Library Information -- ------------------------------------------- - -- Associated with each compiled source file is library information, - -- a string of bytes whose exact format is described in the body of - -- Lib.Writ. Compiling a source file generates this library information - -- for the compiled unit, and access the library information for units - -- that were compiled previously on which the unit being compiled depends. + -- Associated with each compiled source file is library information, a + -- string of bytes whose exact format is described in the body of Lib.Writ. + -- Compiling a source file generates this library information for the + -- compiled unit, and access the library information for units that were + -- compiled previously on which the unit being compiled depends. -- How this information is stored is up to the implementation of this -- package. At the interface level, this information is simply associated @@ -524,15 +542,14 @@ package Osint is -- include any directory information. The implementation is responsible -- for searching for the file in appropriate directories. -- - -- If Opt.Check_Object_Consistency is set to True then this routine - -- checks whether the object file corresponding to the Lib_File is - -- consistent with it. The object file is inconsistent if the object - -- does not exist or if it has an older time stamp than Lib_File. - -- This check is not performed when the Lib_File is "locked" (i.e. - -- read/only) because in this case the object file may be buried - -- in a library. In case of inconsistencies Read_Library_Info - -- behaves as if it did not find Lib_File (namely if Fatal_Err is - -- False, null is returned). + -- If Opt.Check_Object_Consistency is set to True then this routine checks + -- whether the object file corresponding to the Lib_File is consistent with + -- it. The object file is inconsistent if the object does not exist or if + -- it has an older time stamp than Lib_File. This check is not performed + -- when the Lib_File is "locked" (i.e. read/only) because in this case the + -- object file may be buried in a library. In case of inconsistencies + -- Read_Library_Info behaves as if it did not find Lib_File (namely if + -- Fatal_Err is False, null is returned). function Read_Library_Info_From_Full (Full_Lib_File : File_Name_Type; @@ -718,15 +735,17 @@ private -- detected, the file being written is deleted, and a fatal error is -- signalled. - File_Attributes_Size : constant Integer := 50; + File_Attributes_Size : constant Natural := 24; -- This should be big enough to fit a "struct file_attributes" on any - -- system. It doesn't matter if it is too big (which avoids the need for - -- either mapping the struct exactly or importing the sizeof from C, which - -- would result in dynamic code) + -- system. It doesn't cause any malfunction if it is too big (which avoids + -- the need for either mapping the struct exactly or importing the sizeof + -- from C, which would result in dynamic code). However, it does waste + -- space (e.g. when a component of this type appears in a record, if it is + -- unnecessarily large. type File_Attributes is array (1 .. File_Attributes_Size) - of System.Storage_Elements.Storage_Element; + of System.Storage_Elements.Storage_Element; for File_Attributes'Alignment use Standard'Maximum_Alignment; Unknown_Attributes : constant File_Attributes := (others => 0); diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index eb77f860b4f..8d823cedd61 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -974,10 +974,11 @@ begin -- The one argument ON/OFF case is processed by the parser, since it may -- control parser warnings as well as semantic warnings, and in any case -- we want to be absolutely sure that the range in the warnings table is - -- set well before any semantic analysis is performed. + -- set well before any semantic analysis is performed. Note that we + -- ignore this pragma if debug flag -gnatd.i is set. when Pragma_Warnings => - if Arg_Count = 1 then + if Arg_Count = 1 and then not Debug_Flag_Dot_I then Check_No_Identifier (Arg1); declare @@ -1171,6 +1172,7 @@ begin Pragma_Share_Generic | Pragma_Shared | Pragma_Shared_Passive | + Pragma_Short_Circuit_And_Or | Pragma_Storage_Size | Pragma_Storage_Unit | Pragma_Static_Elaboration_Desired | diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index ea7726395a1..e6d71dd525b 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -989,7 +989,12 @@ package body Par_SCO is Handler : Node_Id; begin - if Present (N) then + + -- For package bodies without a statement part, the parser adds an empty + -- one, to normalize the representation. The null statement therein, + -- which does not come from source, does not get a SCO. + + if Present (N) and then Comes_From_Source (N) then Traverse_Declarations_Or_Statements (Statements (N)); if Present (Exception_Handlers (N)) then diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index 13f0904665a..ebb19503663 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -179,6 +179,8 @@ package body Prj.Attr is "Sapath_syntax#" & "Saobject_file_suffix#" & "Laobject_file_switches#" & + "Lamulti_unit_switches#" & + "Samulti_unit_object_separator#" & -- Configuration - Mapping files @@ -190,8 +192,10 @@ package body Prj.Attr is "Laconfig_file_switches#" & "Saconfig_body_file_name#" & - "Saconfig_spec_file_name#" & + "Saconfig_body_file_name_index#" & "Saconfig_body_file_name_pattern#" & + "Saconfig_spec_file_name#" & + "Saconfig_spec_file_name_index#" & "Saconfig_spec_file_name_pattern#" & "Saconfig_file_unique#" & diff --git a/gcc/ada/prj-attr.ads b/gcc/ada/prj-attr.ads index a8f9e15412e..6fad3f0a0dc 100644 --- a/gcc/ada/prj-attr.ads +++ b/gcc/ada/prj-attr.ads @@ -46,15 +46,27 @@ package Prj.Attr is type Attribute_Kind is (Unknown, + -- The attribute does not exist + Single, + -- Single variable attribute (not an associative array) + Associative_Array, + -- Associative array attribute with a case sensitive index + Optional_Index_Associative_Array, + -- Associative array attribute with a case sensitive index and an + -- optional source index. + Case_Insensitive_Associative_Array, + -- Associative array attribute with a case insensitive index + Optional_Index_Case_Insensitive_Associative_Array); + -- Associative array attribute with a case insensitive index and an + -- optional source index. -- Characteristics of an attribute. Optional_Index indicates that there -- may be an optional index in the index of the associative array, as in -- for Switches ("files.ada" at 2) use ... - -- Above character literals should be documented ??? subtype Defined_Attribute_Kind is Attribute_Kind range Single .. Optional_Index_Case_Insensitive_Associative_Array; diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index bcf434b15e1..30823a3862d 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -1188,8 +1188,11 @@ package body Prj.Conf is Index : String := ""; Pkg : Project_Node_Id := Empty_Node) is - Attr : Project_Node_Id; - Val : Name_Id := No_Name; + Attr : Project_Node_Id; + pragma Unreferenced (Attr); + + Expr : Name_Id := No_Name; + Val : Name_Id := No_Name; Parent : Project_Node_Id := Config_File; begin if Index /= "" then @@ -1202,24 +1205,21 @@ package body Prj.Conf is Parent := Pkg; end if; + Name_Len := Value'Length; + Name_Buffer (1 .. Name_Len) := Value; + Expr := Name_Find; + 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)); + Kind => Prj.Single, + Value => Create_Literal_String (Expr, Project_Tree)); end Create_Attribute; + -- Local variables + Name : Name_Id; Naming : Project_Node_Id; diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index c5182abea09..f7fc668dd8f 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -410,7 +410,7 @@ package body Prj.Env is end loop; if Add_It then - Source_Path_Table.Append (Source_Paths, Source_Dir.Value); + Source_Path_Table.Append (Source_Paths, Source_Dir.Display_Value); end if; -- Next source directory diff --git a/gcc/ada/prj-ext.adb b/gcc/ada/prj-ext.adb index 8c7a5d95d96..fe6216f82fa 100644 --- a/gcc/ada/prj-ext.adb +++ b/gcc/ada/prj-ext.adb @@ -213,9 +213,9 @@ package body Prj.Ext is declare New_Dir : constant String := - Normalize_Pathname - (Name_Buffer (First .. Last), - Resolve_Links => Opt.Follow_Links_For_Dirs); + Normalize_Pathname + (Name_Buffer (First .. Last), + Resolve_Links => Opt.Follow_Links_For_Dirs); begin -- If the absolute path was resolved and is different from diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb index 0f91936b1b7..50cd0703d67 100644 --- a/gcc/ada/prj-makr.adb +++ b/gcc/ada/prj-makr.adb @@ -39,8 +39,9 @@ with Table; use Table; with Ada.Characters.Handling; use Ada.Characters.Handling; with GNAT.Directory_Operations; use GNAT.Directory_Operations; -with System.Case_Util; use System.Case_Util; +with System.Case_Util; use System.Case_Util; with System.CRTL; +with System.HTable; package body Prj.Makr is @@ -170,6 +171,16 @@ package body Prj.Makr is -- in the source attribute and package Naming of the project file, or in -- the pragmas Source_File_Name in the configuration pragmas file. + package Source_Files is new System.HTable.Simple_HTable + (Header_Num => Prj.Header_Num, + Element => Boolean, + No_Element => False, + Key => Name_Id, + Hash => Prj.Hash, + Equal => "="); + -- Hash table to keep track of source file names, to avoid putting several + -- times the same file name in case of multi-unit files. + --------- -- Dup -- --------- @@ -602,15 +613,20 @@ package body Prj.Makr is In_Tree => Tree); begin - -- Add source file name to the source list file + -- Add source file name to the source list file if it is not + -- already there. - Get_Name_String (Current_Source.File_Name); - Add_Char_To_Name_Buffer (ASCII.LF); - if Write (Source_List_FD, - Name_Buffer (1)'Address, - Name_Len) /= Name_Len - then - Prj.Com.Fail ("disk full"); + if not Source_Files.Get (Current_Source.File_Name) then + Source_Files.Set (Current_Source.File_Name, True); + Get_Name_String (Current_Source.File_Name); + Add_Char_To_Name_Buffer (ASCII.LF); + + if Write (Source_List_FD, + Name_Buffer (1)'Address, + Name_Len) /= Name_Len + then + Prj.Com.Fail ("disk full"); + end if; end if; -- For an Ada source, add entry in package Naming @@ -854,7 +870,7 @@ package body Prj.Makr is -- Fail if parsing was not successful if No (Project_Node) then - Fail ("parsing of existing project file failed"); + Prj.Com.Fail ("parsing of existing project file failed"); else -- If parsing was successful, remove the components that are diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 5e76bce58ac..35d7e041bb6 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -655,7 +655,7 @@ package body Prj.Nmsc is Location, Project); Error_Msg_Name_1 := Project.Name; - Error_Msg_Name_2 := Name_Id (Path.Name); + Error_Msg_Name_2 := Name_Id (Path.Display_Name); Error_Msg (Data.Flags, "\ project %%, %%", Location, Project); @@ -777,6 +777,10 @@ package body Prj.Nmsc is Source_Paths_Htable.Set (Data.Tree.Source_Paths_HT, Path.Name, Id); end if; + if Index /= 0 then + Project.Has_Multi_Unit_Sources := True; + end if; + -- Add the source to the language list Id.Next_In_Lang := Lang_Id.First_Source; @@ -1431,6 +1435,34 @@ package body Prj.Nmsc is From_List => Element.Value.Values, In_Tree => Data.Tree); + when Name_Multi_Unit_Switches => + Put (Into_List => + Lang_Index.Config.Multi_Unit_Switches, + From_List => Element.Value.Values, + In_Tree => Data.Tree); + + when Name_Multi_Unit_Object_Separator => + Get_Name_String (Element.Value.Value); + + if Name_Len /= 1 then + Error_Msg + (Data.Flags, + "multi-unit object separator must have " & + "a single character", + Element.Value.Location, Project); + + elsif Name_Buffer (1) = ' ' then + Error_Msg + (Data.Flags, + "multi-unit object separator cannot be " & + "a space", + Element.Value.Location, Project); + + else + Lang_Index.Config.Multi_Unit_Object_Separator := + Name_Buffer (1); + end if; + when Name_Path_Syntax => begin Lang_Index.Config.Path_Syntax := @@ -1552,10 +1584,18 @@ package body Prj.Nmsc is Lang_Index.Config.Config_Body := Element.Value.Value; + when Name_Config_Body_File_Name_Index => + + -- Attribute Config_Body_File_Name_Index + -- ( < Language > ) + + Lang_Index.Config.Config_Body_Index := + Element.Value.Value; + when Name_Config_Body_File_Name_Pattern => -- Attribute Config_Body_File_Name_Pattern - -- (<language>) + -- (<language>) Lang_Index.Config.Config_Body_Pattern := Element.Value.Value; @@ -1567,10 +1607,18 @@ package body Prj.Nmsc is Lang_Index.Config.Config_Spec := Element.Value.Value; + when Name_Config_Spec_File_Name_Index => + + -- Attribute Config_Spec_File_Name_Index + -- ( < Language > ) + + Lang_Index.Config.Config_Spec_Index := + Element.Value.Value; + when Name_Config_Spec_File_Name_Pattern => -- Attribute Config_Spec_File_Name_Pattern - -- (<language>) + -- (<language>) Lang_Index.Config.Config_Spec_Pattern := Element.Value.Value; @@ -2472,6 +2520,12 @@ package body Prj.Nmsc is Project.Decl.Attributes, Data.Tree); + Library_Interface : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Interface, + Project.Decl.Attributes, + Data.Tree); + List : String_List_Id; Element : String_Element; Name : File_Name_Type; @@ -2556,22 +2610,90 @@ package body Prj.Nmsc is Project.Interfaces_Defined := True; - elsif Project.Extends /= No_Project then - Project.Interfaces_Defined := Project.Extends.Interfaces_Defined; + elsif Project.Library and then not Library_Interface.Default then + + -- Set In_Interfaces to False for all sources. It will be set to True + -- later for the sources in the Library_Interface list. - if Project.Interfaces_Defined then - Iter := For_Each_Source (Data.Tree, Project); + Project_2 := Project; + while Project_2 /= No_Project loop + Iter := For_Each_Source (Data.Tree, Project_2); loop Source := Prj.Element (Iter); exit when Source = No_Source; - - if not Source.Declared_In_Interfaces then - Source.In_Interfaces := False; - end if; - + Source.In_Interfaces := False; Next (Iter); end loop; - end if; + + Project_2 := Project_2.Extends; + end loop; + + List := Library_Interface.Values; + while List /= Nil_String loop + Element := Data.Tree.String_Elements.Table (List); + Get_Name_String (Element.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + Name := Name_Find; + + Project_2 := Project; + Big_Loop_2 : + while Project_2 /= No_Project loop + Iter := For_Each_Source (Data.Tree, Project_2); + + loop + Source := Prj.Element (Iter); + exit when Source = No_Source; + + if Source.Unit /= No_Unit_Index and then + Source.Unit.Name = Name_Id (Name) + then + if not Source.Locally_Removed then + Source.In_Interfaces := True; + Source.Declared_In_Interfaces := True; + + Other := Other_Part (Source); + + if Other /= No_Source then + Other.In_Interfaces := True; + Other.Declared_In_Interfaces := True; + end if; + + if Current_Verbosity = High then + Write_Str (" interface: "); + Write_Line (Get_Name_String (Source.Path.Name)); + end if; + end if; + + exit Big_Loop_2; + end if; + + Next (Iter); + end loop; + + Project_2 := Project_2.Extends; + end loop Big_Loop_2; + + List := Element.Next; + end loop; + + Project.Interfaces_Defined := True; + + elsif Project.Extends /= No_Project + and then Project.Extends.Interfaces_Defined + then + Project.Interfaces_Defined := True; + + Iter := For_Each_Source (Data.Tree, Project); + loop + Source := Prj.Element (Iter); + exit when Source = No_Source; + + if not Source.Declared_In_Interfaces then + Source.In_Interfaces := False; + end if; + + Next (Iter); + end loop; end if; end Check_Interfaces; @@ -6785,12 +6907,15 @@ package body Prj.Nmsc is exit when Last = 0; - -- ??? Duplicate system call here, we just did a a - -- similar one. Maybe Ada.Directories would be more - -- appropriate here. + -- In fast project loading mode (without -eL), the user + -- guarantees that no directory has a name which is a + -- valid source name, so we can avoid doing a system call + -- here. This provides a very significant speed up on + -- slow file systems (remote files for instance). - if Is_Regular_File - (Source_Directory & Name (1 .. Last)) + if not Opt.Follow_Links_For_Files + or else Is_Regular_File + (Source_Directory & Name (1 .. Last)) then if Current_Verbosity = High then Write_Str (" Checking "); diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 7702f540930..c733f38365c 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -2083,7 +2083,7 @@ package body Prj.Part is GNAT.OS_Lib.Normalize_Pathname (Result.all, Directory => Directory, - Resolve_Links => False, + Resolve_Links => Opt.Follow_Links_For_Files, Case_Sensitive => True); begin Free (Result); diff --git a/gcc/ada/prj-pp.adb b/gcc/ada/prj-pp.adb index cc88f8e5eb5..d318c1192c5 100644 --- a/gcc/ada/prj-pp.adb +++ b/gcc/ada/prj-pp.adb @@ -532,6 +532,12 @@ package body Prj.PP is Write_String (" ("); Output_String (Associative_Array_Index_Of (Node, In_Tree)); + + if Source_Index_Of (Node, In_Tree) /= 0 then + Write_String (" at"); + Write_String (Source_Index_Of (Node, In_Tree)'Img); + end if; + Write_String (")"); end if; @@ -574,11 +580,6 @@ package body Prj.PP is Output_Attribute_Name (Name_Of (Node, In_Tree)); end if; - if Source_Index_Of (Node, In_Tree) /= 0 then - Write_String (" at"); - Write_String (Source_Index_Of (Node, In_Tree)'Img); - end if; - Write_String (";"); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent); diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 0cd20c8f19d..49841522dc9 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -1869,9 +1869,16 @@ package body Prj.Proc is else declare Index_Name : Name_Id := - Associative_Array_Index_Of - (Current_Item, From_Project_Node_Tree); - The_Array : Array_Id; + Associative_Array_Index_Of + (Current_Item, + From_Project_Node_Tree); + + Source_Index : constant Int := + Source_Index_Of + (Current_Item, + From_Project_Node_Tree); + + The_Array : Array_Id; The_Array_Element : Array_Element_Id := No_Array_Element; @@ -1889,9 +1896,9 @@ package body Prj.Proc is if Pkg /= No_Package then The_Array := In_Tree.Packages.Table (Pkg).Decl.Arrays; - else - The_Array := Project.Decl.Arrays; + The_Array := + Project.Decl.Arrays; end if; while @@ -1900,8 +1907,8 @@ package body Prj.Proc is In_Tree.Arrays.Table (The_Array).Name /= Current_Item_Name loop - The_Array := In_Tree.Arrays.Table - (The_Array).Next; + The_Array := + In_Tree.Arrays.Table (The_Array).Next; end loop; -- If the array cannot be found, create a new entry @@ -1943,12 +1950,15 @@ package body Prj.Proc is end if; -- Look in the list, if any, to find an element - -- with the same index. + -- with the same index and same source index. while The_Array_Element /= No_Array_Element and then - In_Tree.Array_Elements.Table + (In_Tree.Array_Elements.Table (The_Array_Element).Index /= Index_Name + or else + In_Tree.Array_Elements.Table + (The_Array_Element).Src_Index /= Source_Index) loop The_Array_Element := In_Tree.Array_Elements.Table @@ -1962,23 +1972,23 @@ package body Prj.Proc is if The_Array_Element = No_Array_Element then Array_Element_Table.Increment_Last (In_Tree.Array_Elements); - The_Array_Element := Array_Element_Table.Last - (In_Tree.Array_Elements); + The_Array_Element := + Array_Element_Table.Last + (In_Tree.Array_Elements); In_Tree.Array_Elements.Table (The_Array_Element) := - (Index => Index_Name, - Src_Index => - Source_Index_Of - (Current_Item, From_Project_Node_Tree), + (Index => Index_Name, + Src_Index => Source_Index, Index_Case_Sensitive => not Case_Insensitive (Current_Item, From_Project_Node_Tree), - Value => New_Value, - Next => In_Tree.Arrays.Table - (The_Array).Value); - In_Tree.Arrays.Table - (The_Array).Value := The_Array_Element; + Value => New_Value, + Next => + In_Tree.Arrays.Table (The_Array).Value); + + In_Tree.Arrays.Table (The_Array).Value := + The_Array_Element; -- An element with the same index already exists, -- just replace its value with the new one. diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb index df6e5acb6cf..be8f5fcfeda 100644 --- a/gcc/ada/prj-tree.adb +++ b/gcc/ada/prj-tree.adb @@ -2966,12 +2966,17 @@ package body Prj.Tree is (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; + Expr : Project_Node_Id; + begin + if Kind_Of (Node, Tree) /= N_Expression then + Expr := Default_Project_Node (Tree, N_Expression, Single); + Set_First_Term + (Expr, Tree, Default_Project_Node (Tree, N_Term, Single)); + Set_Current_Term (First_Term (Expr, Tree), Tree, Node); + return Expr; + else + return Node; + end if; end Enclose_In_Expression; -------------------- @@ -3022,7 +3027,7 @@ package body Prj.Tree is return Pack; end Create_Package; - ------------------- + ---------------------- -- Create_Attribute -- ---------------------- @@ -3032,7 +3037,8 @@ package body Prj.Tree is Name : Name_Id; Index_Name : Name_Id := No_Name; Kind : Variable_Kind := List; - At_Index : Integer := 0) return Project_Node_Id + At_Index : Integer := 0; + Value : Project_Node_Id := Empty_Node) return Project_Node_Id is Node : constant Project_Node_Id := Default_Project_Node (Tree, N_Attribute_Declaration, Kind); @@ -3041,14 +3047,11 @@ package body Prj.Tree is Pkg : Package_Node_Id; Start_At : Attribute_Node_Id; + Expr : Project_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; @@ -3073,6 +3076,33 @@ package body Prj.Tree is Attribute_Kind_Of (Start_At) = Case_Insensitive_Associative_Array; Tree.Project_Nodes.Table (Node).Flag1 := Case_Insensitive; + if At_Index /= 0 then + if Attribute_Kind_Of (Start_At) = + Optional_Index_Associative_Array + or else Attribute_Kind_Of (Start_At) = + Optional_Index_Case_Insensitive_Associative_Array + then + -- Results in: for Name ("index" at index) use "value"; + -- This is currently only used for executables. + + Set_Source_Index_Of (Node, Tree, To => Int (At_Index)); + + else + -- Results in: for Name ("index") use "value" at index; + + -- ??? This limitation makes no sense, we should be able to + -- set the source index on an expression. + + pragma Assert (Kind_Of (Value, Tree) = N_Literal_String); + Set_Source_Index_Of (Value, Tree, To => Int (At_Index)); + end if; + end if; + + if Value /= Empty_Node then + Expr := Enclose_In_Expression (Value, Tree); + Set_Expression_Of (Node, Tree, Expr); + end if; + return Node; end Create_Attribute; diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads index 96a28279c32..fa8c132e565 100644 --- a/gcc/ada/prj-tree.ads +++ b/gcc/ada/prj-tree.ads @@ -408,7 +408,8 @@ package Prj.Tree is (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (First_Declarative_Item_Of); - -- Only valid for N_With_Clause nodes + -- Only valid for N_Project_Declaration, N_Case_Item and + -- N_Package_Declaration. function Extended_Project_Of (Node : Project_Node_Id; @@ -492,7 +493,7 @@ package Prj.Tree is In_Tree : Project_Node_Tree_Ref) return Name_Id; pragma Inline (Associative_Array_Index_Of); -- Only valid for N_Attribute_Declaration and N_Attribute_Reference. - -- Returns No_String for non associative array attributes. + -- Returns No_Name for non associative array attributes. function Next_Variable (Node : Project_Node_Id; @@ -573,8 +574,8 @@ package Prj.Tree is (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (First_Choice_Of); - -- Return the first choice in a N_Case_Item, or Empty_Node if - -- this is when others. + -- Only valid for N_Case_Item nodes. Return the first choice in a + -- N_Case_Item, or Empty_Node if this is when others. function Next_Case_Item (Node : Project_Node_Id; @@ -613,16 +614,25 @@ package Prj.Tree is (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; + Index_Name : Name_Id := No_Name; + Kind : Variable_Kind := List; + At_Index : Integer := 0; + Value : Project_Node_Id := Empty_Node) 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) + -- exceptions. + -- + -- To set the value of the attribute, either provide a value for Value, or + -- use Set_Expression_Of to set the value of the attribute (in which case + -- Enclose_In_Expression might be useful). The former is recommended since + -- it will more correctly handle cases where the index needs to be set on + -- the expression rather than on the index of the attribute (i.e. 'for + -- Specification ("unit") use "file" at 3', versus 'for Executable ("file" + -- at 3) use "name"'). Value must be a N_String_Literal if an index will be + -- added to it. function Create_Literal_String (Str : Namet.Name_Id; @@ -647,7 +657,8 @@ package Prj.Tree is 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 + -- Enclose the Node inside a N_Expression node, and return this expression. + -- This does nothing if Node is already a N_Expression. -------------------- -- Set Procedures -- @@ -656,8 +667,11 @@ package Prj.Tree is -- 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. + -- Foe each Set_* procedure the condition of validity is specified. If an + -- access function is called with invalid arguments, then exception + -- Assertion_Error is raised if assertions are enabled, otherwise the + -- behaviour is not defined and may result in a crash. + -- 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 @@ -667,146 +681,183 @@ package Prj.Tree is In_Tree : Project_Node_Tree_Ref; To : Name_Id); pragma Inline (Set_Name_Of); + -- Valid for all non empty nodes. procedure Set_Kind_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Kind); pragma Inline (Set_Kind_Of); + -- Valid for all non empty nodes procedure Set_Location_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Source_Ptr); pragma Inline (Set_Location_Of); + -- Valid for all non empty nodes procedure Set_First_Comment_After (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Comment_After); + -- Valid only for N_Comment_Zones nodes procedure Set_First_Comment_After_End (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Comment_After_End); + -- Valid only for N_Comment_Zones nodes procedure Set_First_Comment_Before (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Comment_Before); + -- Valid only for N_Comment_Zones nodes procedure Set_First_Comment_Before_End (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Comment_Before_End); + -- Valid only for N_Comment_Zones nodes procedure Set_Next_Comment (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Comment); + -- Valid only for N_Comment nodes procedure Set_Parent_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); + -- Valid only for N_Project nodes procedure Set_Project_File_Includes_Unkept_Comments (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Boolean); + -- Valid only for N_Project nodes procedure Set_Directory_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Path_Name_Type); pragma Inline (Set_Directory_Of); + -- Valid only for N_Project nodes procedure Set_Expression_Kind_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Variable_Kind); pragma Inline (Set_Expression_Kind_Of); + -- Only valid for N_Literal_String, N_Attribute_Declaration, + -- N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression, + -- N_Term, N_Variable_Reference or N_Attribute_Reference nodes. procedure Set_Is_Extending_All (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref); pragma Inline (Set_Is_Extending_All); + -- Only valid for N_Project and N_With_Clause procedure Set_Is_Not_Last_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref); pragma Inline (Set_Is_Not_Last_In_List); + -- Only valid for N_With_Clause procedure Set_First_Variable_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Variable_Node_Id); pragma Inline (Set_First_Variable_Of); + -- Only valid for N_Project or N_Package_Declaration nodes procedure Set_First_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Package_Declaration_Id); pragma Inline (Set_First_Package_Of); + -- Only valid for N_Project nodes procedure Set_Package_Id_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Package_Node_Id); pragma Inline (Set_Package_Id_Of); + -- Only valid for N_Package_Declaration nodes procedure Set_Path_Name_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Path_Name_Type); pragma Inline (Set_Path_Name_Of); + -- Only valid for N_Project and N_With_Clause nodes procedure Set_String_Value_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Name_Id); pragma Inline (Set_String_Value_Of); + -- Only valid for N_With_Clause, N_Literal_String nodes or N_Comment. + + procedure Set_Source_Index_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Int); + pragma Inline (Set_Source_Index_Of); + -- Only valid for N_Literal_String and N_Attribute_Declaration nodes. For + -- N_Literal_String, set the source index of the litteral string. For + -- N_Attribute_Declaration, set the source index of the index of the + -- associative array element. procedure Set_First_With_Clause_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_With_Clause_Of); + -- Only valid for N_Project nodes procedure Set_Project_Declaration_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Project_Declaration_Of); + -- Only valid for N_Project nodes procedure Set_Project_Qualifier_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Qualifier); pragma Inline (Set_Project_Qualifier_Of); + -- Only valid for N_Project nodes procedure Set_Extending_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Extending_Project_Of); + -- Only valid for N_Project_Declaration nodes procedure Set_First_String_Type_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_String_Type_Of); + -- Only valid for N_Project nodes procedure Set_Extended_Project_Path_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Path_Name_Type); pragma Inline (Set_Extended_Project_Path_Of); + -- Only valid for N_With_Clause nodes procedure Set_Project_Node_Of (Node : Project_Node_Id; @@ -814,185 +865,214 @@ package Prj.Tree is To : Project_Node_Id; Limited_With : Boolean := False); pragma Inline (Set_Project_Node_Of); + -- Only valid for N_With_Clause, N_Variable_Reference and + -- N_Attribute_Reference nodes. procedure Set_Next_With_Clause_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_With_Clause_Of); + -- Only valid for N_With_Clause nodes procedure Set_First_Declarative_Item_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Declarative_Item_Of); + -- Only valid for N_Project_Declaration, N_Case_Item and + -- N_Package_Declaration. procedure Set_Extended_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Extended_Project_Of); + -- Only valid for N_Project_Declaration nodes procedure Set_Current_Item_Node (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Current_Item_Node); + -- Only valid for N_Declarative_Item nodes procedure Set_Next_Declarative_Item (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Declarative_Item); + -- Only valid for N_Declarative_Item node procedure Set_Project_Of_Renamed_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Project_Of_Renamed_Package_Of); + -- Only valid for N_Package_Declaration nodes. procedure Set_Next_Package_In_Project (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Package_In_Project); + -- Only valid for N_Package_Declaration nodes procedure Set_First_Literal_String (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Literal_String); + -- Only valid for N_String_Type_Declaration nodes procedure Set_Next_String_Type (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_String_Type); + -- Only valid for N_String_Type_Declaration nodes procedure Set_Next_Literal_String (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Literal_String); + -- Only valid for N_Literal_String nodes procedure Set_Expression_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Expression_Of); + -- Only valid for N_Attribute_Declaration, N_Typed_Variable_Declaration + -- or N_Variable_Declaration nodes procedure Set_Associative_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Associative_Project_Of); + -- Only valid for N_Attribute_Declaration nodes procedure Set_Associative_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Associative_Package_Of); + -- Only valid for N_Attribute_Declaration nodes procedure Set_Associative_Array_Index_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Name_Id); pragma Inline (Set_Associative_Array_Index_Of); + -- Only valid for N_Attribute_Declaration and N_Attribute_Reference. procedure Set_Next_Variable (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Variable); + -- Only valid for N_Typed_Variable_Declaration or N_Variable_Declaration + -- nodes. procedure Set_First_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Term); + -- Only valid for N_Expression nodes procedure Set_Next_Expression_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Expression_In_List); + -- Only valid for N_Expression nodes procedure Set_Current_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Current_Term); + -- Only valid for N_Term nodes procedure Set_Next_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Term); + -- Only valid for N_Term nodes procedure Set_First_Expression_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Expression_In_List); + -- Only valid for N_Literal_String_List nodes procedure Set_Package_Node_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Package_Node_Of); - - procedure Set_Source_Index_Of - (Node : Project_Node_Id; - In_Tree : Project_Node_Tree_Ref; - To : Int); - pragma Inline (Set_Source_Index_Of); + -- Only valid for N_Variable_Reference or N_Attribute_Reference nodes. procedure Set_String_Type_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_String_Type_Of); + -- Only valid for N_Variable_Reference or N_Typed_Variable_Declaration + -- nodes. procedure Set_External_Reference_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_External_Reference_Of); + -- Only valid for N_External_Value nodes procedure Set_External_Default_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_External_Default_Of); + -- Only valid for N_External_Value nodes procedure Set_Case_Variable_Reference_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Case_Variable_Reference_Of); + -- Only valid for N_Case_Construction nodes procedure Set_First_Case_Item_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Case_Item_Of); + -- Only valid for N_Case_Construction nodes procedure Set_First_Choice_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Choice_Of); + -- Only valid for N_Case_Item nodes. procedure Set_Next_Case_Item (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Case_Item); + -- Only valid for N_Case_Item nodes. procedure Set_Case_Insensitive (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Boolean); + -- Only valid for N_Attribute_Declaration and N_Attribute_Reference nodes ------------------------------- -- Restricted Access Section -- @@ -1377,8 +1457,8 @@ package Prj.Tree is Key => Name_Id, Hash => Hash, Equal => "="); - -- General type for htables associating name_id to name_id. - -- This is in particular used to store the values of external references + -- General type for htables associating name_id to name_id. This is in + -- particular used to store the values of external references. type Project_Node_Tree_Data is record Project_Nodes : Tree_Private_Part.Project_Node_Table.Instance; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index d42e7117cd5..0bae53c23fc 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -23,9 +23,6 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Characters.Handling; use Ada.Characters.Handling; -with Ada.Unchecked_Deallocation; - with Debug; with Osint; use Osint; with Output; use Output; @@ -34,6 +31,9 @@ with Prj.Err; use Prj.Err; with Snames; use Snames; with Uintp; use Uintp; +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Unchecked_Deallocation; + with GNAT.Directory_Operations; use GNAT.Directory_Operations; with System.Case_Util; use System.Case_Util; @@ -86,8 +86,6 @@ package body Prj is Libgnarl_Needed => Unknown, Symbol_Data => No_Symbols, Interfaces_Defined => False, - Include_Path => null, - Include_Data_Set => False, Source_Dirs => Nil_String, Source_Dir_Ranks => No_Number_List, Object_Directory => No_Path_Information, @@ -98,18 +96,18 @@ package body Prj is Languages => No_Language_Index, Decl => No_Declarations, Imported_Projects => null, + Include_Path_File => No_Path, All_Imported_Projects => null, Ada_Include_Path => null, - Imported_Directories_Switches => null, Ada_Objects_Path => null, Objects_Path => null, - Include_Path_File => No_Path, Objects_Path_File_With_Libs => No_Path, Objects_Path_File_Without_Libs => No_Path, Config_File_Name => No_Path, Config_File_Temp => False, Config_Checked => False, Need_To_Build_Lib => False, + Has_Multi_Unit_Sources => False, Depth => 0, Unkept_Comments => False); @@ -682,6 +680,39 @@ package body Prj is end if; end Object_Name; + function Object_Name + (Source_File_Name : File_Name_Type; + Source_Index : Int; + Index_Separator : Character; + Object_File_Suffix : Name_Id := No_Name) return File_Name_Type + is + Index_Img : constant String := Source_Index'Img; + Last : Natural; + + begin + Get_Name_String (Source_File_Name); + + Last := Name_Len; + while Last > 1 and then Name_Buffer (Last) /= '.' loop + Last := Last - 1; + end loop; + + if Last > 1 then + Name_Len := Last - 1; + end if; + + Add_Char_To_Name_Buffer (Index_Separator); + Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last)); + + if Object_File_Suffix = No_Name then + Add_Str_To_Name_Buffer (Object_Suffix); + else + Add_Str_To_Name_Buffer (Get_Name_String (Object_File_Suffix)); + end if; + + return Name_Find; + end Object_Name; + ---------------------- -- Record_Temp_File -- ---------------------- @@ -704,7 +735,6 @@ package body Prj is begin if Project /= null then - Free (Project.Include_Path); Free (Project.Ada_Include_Path); Free (Project.Objects_Path); Free (Project.Ada_Objects_Path); @@ -1055,7 +1085,8 @@ package body Prj is -- Compute_All_Imported_Projects -- ----------------------------------- - procedure Compute_All_Imported_Projects (Project : Project_Id) is + procedure Compute_All_Imported_Projects (Tree : Project_Tree_Ref) is + Project : Project_Id; procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean); -- Recursively add the projects imported by project Project, but not @@ -1103,10 +1134,16 @@ package body Prj is new For_Every_Project_Imported (Boolean, Recursive_Add); Dummy : Boolean := False; + List : Project_List; begin - Free_List (Project.All_Imported_Projects, Free_Project => False); - For_All_Projects (Project, Dummy); + List := Tree.Projects; + while List /= null loop + Project := List.Project; + Free_List (Project.All_Imported_Projects, Free_Project => False); + For_All_Projects (Project, Dummy); + List := List.Next; + end loop; end Compute_All_Imported_Projects; ------------------- @@ -1207,6 +1244,27 @@ package body Prj is Require_Obj_Dirs => Require_Obj_Dirs); end Create_Flags; + ------------ + -- Length -- + ------------ + + function Length + (Table : Name_List_Table.Instance; + List : Name_List_Index) return Natural + is + Count : Natural := 0; + Tmp : Name_List_Index; + + begin + Tmp := List; + while Tmp /= No_Name_List loop + Count := Count + 1; + Tmp := Table.Table (Tmp).Next; + end loop; + + return Count; + end Length; + 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 453a7ca4d70..7fd97916ad1 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -31,6 +31,7 @@ with Casing; use Casing; with Namet; use Namet; +with Osint; with Scans; use Scans; with Types; use Types; @@ -160,7 +161,7 @@ package Prj is end case; end record; -- Values for variables and array elements. Default is True if the - -- current value is the default one for the variable + -- current value is the default one for the variable. Nil_Variable_Value : constant Variable_Value; -- Value of a non existing variable or array element @@ -278,8 +279,8 @@ package Prj is function Hash (Name : Name_Id) return Header_Num; function Hash (Name : File_Name_Type) return Header_Num; function Hash (Name : Path_Name_Type) return Header_Num; - function Hash (Project : Project_Id) return Header_Num; - -- Used for computing hash values for names put into above hash table + function Hash (Project : Project_Id) return Header_Num; + -- Used for computing hash values for names put into hash tables type Language_Kind is (File_Based, Unit_Based); -- Type for the kind of language. All languages are file based, except Ada @@ -316,6 +317,11 @@ package Prj is Table_Increment => 100); -- The table for lists of names + function Length + (Table : Name_List_Table.Instance; + List : Name_List_Index) return Natural; + -- Return the number of elements in specified list + type Number_List_Index is new Nat; No_Number_List : constant Number_List_Index := 0; @@ -341,6 +347,8 @@ package Prj is Equal => "="); -- A hash table to store the mapping files that are not used + -- The following record ??? + type Lang_Naming_Data is record Dot_Replacement : File_Name_Type := No_File; -- The string to replace '.' in the source file name (for Ada) @@ -396,10 +404,11 @@ package Prj is type Path_Syntax_Kind is (Canonical, -- Unix style - Host); -- Host specific syntax, for example on VMS (the default) + -- The following record describes the configuration of a language + type Language_Config is record Kind : Language_Kind := File_Based; -- Kind of language. All languages are file based, except Ada which is @@ -409,10 +418,10 @@ package Prj is -- The naming data for the languages (prefixes, etc.) Include_Compatible_Languages : Name_List_Index := No_Name_List; - -- The list of languages that are "include compatible" with this - -- language. A language B (for example "C") is "include compatible" with - -- a language A (for example "C++") if it is expected that sources of - -- language A may "include" header files from language B. + -- List of languages that are "include compatible" with this language. A + -- language B (for example "C") is "include compatible" with a language + -- A (for example "C++") if it is expected that sources of language A + -- may "include" header files from language B. Compiler_Driver : File_Name_Type := No_File; -- The name of the executable for the compiler of the language @@ -428,14 +437,21 @@ package Prj is -- The list of final switches that are required as a minimum to invoke -- the compiler driver. - Path_Syntax : Path_Syntax_Kind := Host; + Multi_Unit_Switches : Name_List_Index := No_Name_List; + -- The switch(es) to indicate the index of a unit in a multi-source file + + Multi_Unit_Object_Separator : Character := ' '; + -- The string separating the base name of a source from the index of the + -- unit in a multi-source file, in the object file name. + + Path_Syntax : Path_Syntax_Kind := Host; -- Value may be Canonical (Unix style) or Host (host syntax, for example -- on VMS for DEC C). - Object_File_Suffix : Name_Id := No_Name; + Object_File_Suffix : Name_Id := No_Name; -- Optional alternate object file suffix - Object_File_Switches : Name_List_Index := No_Name_List; + Object_File_Switches : Name_List_Index := No_Name_List; -- Optional object file switches. When this is defined, the switches -- are used to specify the object file. The object file name is appended -- to the last switch in the list. Example: ("-o", ""). @@ -445,48 +461,47 @@ package Prj is -- shared libraries. Specified in the configuration. When not specified, -- there is no need for such switch. - Object_Generated : Boolean := True; + Object_Generated : Boolean := True; -- False in no object file is generated - Objects_Linked : Boolean := True; + Objects_Linked : Boolean := True; -- False if object files are not use to link executables and build -- libraries. - Runtime_Library_Dir : Name_Id := No_Name; + Runtime_Library_Dir : Name_Id := No_Name; -- Path name of the runtime library directory, if any - Runtime_Source_Dir : Name_Id := No_Name; + Runtime_Source_Dir : Name_Id := No_Name; -- Path name of the runtime source directory, if any - Mapping_File_Switches : Name_List_Index := No_Name_List; + Mapping_File_Switches : Name_List_Index := No_Name_List; -- The option(s) to provide a mapping file to the compiler. Specified in -- the configuration. When value is No_Name_List, there is no mapping -- file. - Mapping_Spec_Suffix : File_Name_Type := No_File; + Mapping_Spec_Suffix : File_Name_Type := No_File; -- Placeholder representing the spec suffix in a mapping file - Mapping_Body_Suffix : File_Name_Type := No_File; + Mapping_Body_Suffix : File_Name_Type := No_File; -- Placeholder representing the body suffix in a mapping file - Config_File_Switches : Name_List_Index := No_Name_List; + Config_File_Switches : Name_List_Index := No_Name_List; -- The option(s) to provide a config file to the compiler. Specified in - -- the configuration. When value is No_Name_List, there is no config - -- file. + -- the configuration. If value is No_Name_List there is no config file. - Dependency_Kind : Dependency_File_Kind := None; + Dependency_Kind : Dependency_File_Kind := None; -- The kind of dependency to be checked: none, Makefile fragment or -- ALI file (for Ada). - Dependency_Option : Name_List_Index := No_Name_List; + Dependency_Option : Name_List_Index := No_Name_List; -- The option(s) to be used to create the dependency file. When value is -- No_Name_List, there is not such option(s). - Compute_Dependency : Name_List_Index := No_Name_List; + Compute_Dependency : Name_List_Index := No_Name_List; -- Hold the value of attribute Dependency_Driver, if declared for the -- language. - Include_Option : Name_List_Index := No_Name_List; + Include_Option : Name_List_Index := No_Name_List; -- Hold the value of attribute Include_Switches, if declared for the -- language. @@ -506,47 +521,54 @@ package Prj is -- Name of environment variable declared by attribute Objects_Path_File -- for the language. - Config_Body : Name_Id := No_Name; + Config_Body : Name_Id := No_Name; -- The template for a pragma Source_File_Name(_Project) for a specific -- file name of a body. - Config_Spec : Name_Id := No_Name; + Config_Body_Index : Name_Id := No_Name; -- The template for a pragma Source_File_Name(_Project) for a specific - -- file name of a spec. + -- file name of a body in a multi-source file. - Config_Body_Pattern : Name_Id := No_Name; + Config_Body_Pattern : Name_Id := No_Name; -- The template for a pragma Source_File_Name(_Project) for a naming -- body pattern. - Config_Spec_Pattern : Name_Id := No_Name; + Config_Spec : Name_Id := No_Name; + -- The template for a pragma Source_File_Name(_Project) for a specific + -- file name of a spec. + + Config_Spec_Index : Name_Id := No_Name; + -- The template for a pragma Source_File_Name(_Project) for a specific + -- file name of a spec in a multi-source file. + + Config_Spec_Pattern : Name_Id := No_Name; -- The template for a pragma Source_File_Name(_Project) for a naming -- spec pattern. - Config_File_Unique : Boolean := False; + Config_File_Unique : Boolean := False; -- Indicate if the config file specified to the compiler needs to be -- unique. If it is unique, then all config files are concatenated into -- a temp config file. - Binder_Driver : File_Name_Type := No_File; + Binder_Driver : File_Name_Type := No_File; -- The name of the binder driver for the language, if any - Binder_Driver_Path : Path_Name_Type := No_Path; + Binder_Driver_Path : Path_Name_Type := No_Path; -- The path name of the binder driver - Binder_Required_Switches : Name_List_Index := No_Name_List; + Binder_Required_Switches : Name_List_Index := No_Name_List; -- Hold the value of attribute Binder'Required_Switches for the language - Binder_Prefix : Name_Id := No_Name; + Binder_Prefix : Name_Id := No_Name; -- Hold the value of attribute Binder'Prefix for the language - Toolchain_Version : Name_Id := No_Name; + Toolchain_Version : Name_Id := No_Name; -- Hold the value of attribute Toolchain_Version for the language - Toolchain_Description : Name_Id := No_Name; + Toolchain_Description : Name_Id := No_Name; -- Hold the value of attribute Toolchain_Description for the language end record; - -- Record describing the configuration of a language No_Language_Config : constant Language_Config := (Kind => File_Based, @@ -556,6 +578,8 @@ package Prj is Compiler_Driver_Path => null, Compiler_Leading_Required_Switches => No_Name_List, Compiler_Trailing_Required_Switches => No_Name_List, + Multi_Unit_Switches => No_Name_List, + Multi_Unit_Object_Separator => ' ', Path_Syntax => Canonical, Object_File_Suffix => No_Name, Object_File_Switches => No_Name_List, @@ -577,8 +601,10 @@ package Prj is Objects_Path => No_Name, Objects_Path_File => No_Name, Config_Body => No_Name, - Config_Spec => No_Name, + Config_Body_Index => No_Name, Config_Body_Pattern => No_Name, + Config_Spec => No_Name, + Config_Spec_Index => No_Name, Config_Spec_Pattern => No_Name, Config_File_Unique => False, Binder_Driver => No_File, @@ -588,6 +614,8 @@ package Prj is Toolchain_Version => No_Name, Toolchain_Description => No_Name); + -- The following record ??? + type Language_Data is record Name : Name_Id := No_Name; Display_Name : Name_Id := No_Name; @@ -636,104 +664,105 @@ package Prj is -- Structure to define source data type Source_Data is record - Project : Project_Id := No_Project; + Project : Project_Id := No_Project; -- Project of the source - Source_Dir_Rank : Natural := 0; + Source_Dir_Rank : Natural := 0; -- The rank of the source directory in list declared with attribute -- Source_Dirs. Two source files with the same name cannot appears in -- different directory with the same rank. That can happen when the -- recursive notation <dir>/** is used in attribute Source_Dirs. - Language : Language_Ptr := No_Language_Index; + Language : Language_Ptr := No_Language_Index; -- Index of the language. This is an index into -- Project_Tree.Languages_Data. - In_Interfaces : Boolean := True; + In_Interfaces : Boolean := True; -- False when the source is not included in interfaces, when attribute -- Interfaces is declared. - Declared_In_Interfaces : Boolean := False; + Declared_In_Interfaces : Boolean := False; -- True when source is declared in attribute Interfaces - Alternate_Languages : Language_List := null; + Alternate_Languages : Language_List := null; -- List of languages a header file may also be, in addition of language -- Language_Name. - Kind : Source_Kind := Spec; + Kind : Source_Kind := Spec; -- Kind of the source: spec, body or subunit - Unit : Unit_Index := No_Unit_Index; + Unit : Unit_Index := No_Unit_Index; -- Name of the unit, if language is unit based. This is only set for -- 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). - Index : Int := 0; + Index : Int := 0; -- Index of the source in a multi unit source file (the same Source_Data -- is duplicated several times when there are several units in the same -- file). Index is 0 if there is either no unit or a single one, and -- starts at 1 when there are multiple units - Locally_Removed : Boolean := False; + Locally_Removed : Boolean := False; -- True if the source has been "excluded" - Replaced_By : Source_Id := No_Source; + Replaced_By : Source_Id := No_Source; + -- Missing comment ??? - File : File_Name_Type := No_File; + File : File_Name_Type := No_File; -- Canonical file name of the source - Display_File : File_Name_Type := No_File; + Display_File : File_Name_Type := No_File; -- File name of the source, for display purposes - Path : Path_Information := No_Path_Information; + Path : Path_Information := No_Path_Information; -- Path name of the source - Source_TS : Time_Stamp_Type := Empty_Time_Stamp; + Source_TS : Time_Stamp_Type := Empty_Time_Stamp; -- Time stamp of the source file - Object_Project : Project_Id := No_Project; + Object_Project : Project_Id := No_Project; -- Project where the object file is. This might be different from -- Project when using extending project files. - Object : File_Name_Type := No_File; + Object : File_Name_Type := No_File; -- File name of the object file - Current_Object_Path : Path_Name_Type := No_Path; + Current_Object_Path : Path_Name_Type := No_Path; -- Object path of an existing object file - Object_Path : Path_Name_Type := No_Path; + Object_Path : Path_Name_Type := No_Path; -- Object path of the real object file - Object_TS : Time_Stamp_Type := Empty_Time_Stamp; + Object_TS : Time_Stamp_Type := Empty_Time_Stamp; -- Object file time stamp - Dep_Name : File_Name_Type := No_File; + Dep_Name : File_Name_Type := No_File; -- Dependency file simple name - Current_Dep_Path : Path_Name_Type := No_Path; + Current_Dep_Path : Path_Name_Type := No_Path; -- Path name of an existing dependency file - Dep_Path : Path_Name_Type := No_Path; + Dep_Path : Path_Name_Type := No_Path; -- Path name of the real dependency file - Dep_TS : Time_Stamp_Type := Empty_Time_Stamp; + Dep_TS : aliased Osint.File_Attributes := Osint.Unknown_Attributes; -- Dependency file time stamp - Switches : File_Name_Type := No_File; + Switches : File_Name_Type := No_File; -- File name of the switches file. For all languages, this is a file -- that ends with the .cswi extension. - Switches_Path : Path_Name_Type := No_Path; + Switches_Path : Path_Name_Type := No_Path; -- Path name of the switches file - Switches_TS : Time_Stamp_Type := Empty_Time_Stamp; + Switches_TS : Time_Stamp_Type := Empty_Time_Stamp; -- Switches file time stamp - Naming_Exception : Boolean := False; + Naming_Exception : Boolean := False; -- True if the source has an exceptional name - Next_In_Lang : Source_Id := No_Source; + Next_In_Lang : Source_Id := No_Source; -- Link to another source of the same language in the same project end record; @@ -761,7 +790,7 @@ package Prj is Dep_Name => No_File, Current_Dep_Path => No_Path, Dep_Path => No_Path, - Dep_TS => Empty_Time_Stamp, + Dep_TS => Osint.Unknown_Attributes, Switches => No_File, Switches_Path => No_Path, Switches_TS => Empty_Time_Stamp, @@ -839,9 +868,10 @@ package Prj is -- If Only_If_Ada is True, then No_Name will be returned when the project -- doesn't Ada sources. - procedure Compute_All_Imported_Projects (Project : Project_Id); - -- Compute, the list of the projects imported directly or indirectly by - -- project Project. The result is stored in Project.All_Imported_Projects + procedure Compute_All_Imported_Projects (Tree : Project_Tree_Ref); + -- For all projects in the tree, compute the list of the projects imported + -- directly or indirectly by project Project. The result is stored in + -- Project.All_Imported_Projects for each project function Ultimate_Extending_Project_Of (Proj : Project_Id) return Project_Id; @@ -869,117 +899,117 @@ package Prj is -- The format of the different response files type Project_Configuration is record - Target : Name_Id := No_Name; + Target : Name_Id := No_Name; -- The target of the configuration, when specified - Run_Path_Option : Name_List_Index := No_Name_List; + Run_Path_Option : Name_List_Index := No_Name_List; -- The option to use when linking to specify the path where to look for -- libraries. - Separate_Run_Path_Options : Boolean := False; + Separate_Run_Path_Options : Boolean := False; -- True if each directory needs to be specified in a separate run path -- option. - Executable_Suffix : Name_Id := No_Name; + Executable_Suffix : Name_Id := No_Name; -- The suffix of executables, when specified in the configuration or in -- package Builder of the main project. When this is not specified, the -- executable suffix is the default for the platform. -- Linking - Linker : Path_Name_Type := No_Path; + Linker : Path_Name_Type := No_Path; -- Path name of the linker driver. Specified in the configuration or in -- the package Builder of the main project. - Map_File_Option : Name_Id := No_Name; + Map_File_Option : Name_Id := No_Name; -- Option to use when invoking the linker to build a map file - Minimum_Linker_Options : Name_List_Index := No_Name_List; + Minimum_Linker_Options : Name_List_Index := No_Name_List; -- The minimum options for the linker driver. Specified in the -- configuration. - Linker_Executable_Option : Name_List_Index := No_Name_List; + Linker_Executable_Option : Name_List_Index := No_Name_List; -- The option(s) to indicate the name of the executable in the linker -- command. Specified in the configuration. When not specified, default -- to -o <executable name>. - Linker_Lib_Dir_Option : Name_Id := No_Name; + Linker_Lib_Dir_Option : Name_Id := No_Name; -- The option to specify where to find a library for linking. Specified -- in the configuration. When not specified, defaults to "-L". - Linker_Lib_Name_Option : Name_Id := No_Name; + Linker_Lib_Name_Option : Name_Id := No_Name; -- The option to specify the name of a library for linking. Specified in -- the configuration. When not specified, defaults to "-l". - Max_Command_Line_Length : Natural := 0; + Max_Command_Line_Length : Natural := 0; -- When positive and when Resp_File_Format (see below) is not None, -- if the command line for the invocation of the linker would be greater -- than this value, a response file is used to invoke the linker. - Resp_File_Format : Response_File_Format := None; + Resp_File_Format : Response_File_Format := None; -- The format of a response file, when linking with a response file is -- supported. - Resp_File_Options : Name_List_Index := No_Name_List; + Resp_File_Options : Name_List_Index := No_Name_List; -- The switches, if any, that precede the path name of the response -- file in the invocation of the linker. -- Libraries - Library_Builder : Path_Name_Type := No_Path; + Library_Builder : Path_Name_Type := No_Path; -- The executable to build library (specified in the configuration) - Lib_Support : Library_Support := None; + Lib_Support : Library_Support := None; -- The level of library support. Specified in the configuration. Support -- is none, static libraries only or both static and shared libraries. - Archive_Builder : Name_List_Index := No_Name_List; + Archive_Builder : Name_List_Index := No_Name_List; -- The name of the executable to build archives, with the minimum -- switches. Specified in the configuration. Archive_Builder_Append_Option : Name_List_Index := No_Name_List; -- The options to append object files to an archive - Archive_Indexer : Name_List_Index := No_Name_List; + Archive_Indexer : Name_List_Index := No_Name_List; -- The name of the executable to index archives, with the minimum -- switches. Specified in the configuration. - Archive_Suffix : File_Name_Type := No_File; + Archive_Suffix : File_Name_Type := No_File; -- The suffix of archives. Specified in the configuration. When not -- specified, defaults to ".a". - Lib_Partial_Linker : Name_List_Index := No_Name_List; + Lib_Partial_Linker : Name_List_Index := No_Name_List; -- Shared libraries - Shared_Lib_Driver : File_Name_Type := No_File; + Shared_Lib_Driver : File_Name_Type := No_File; -- The driver to link shared libraries. Set with attribute Library_GCC. -- Default to gcc. - Shared_Lib_Prefix : File_Name_Type := No_File; + Shared_Lib_Prefix : File_Name_Type := No_File; -- Part of a shared library file name that precedes the name of the -- library. Specified in the configuration. When not specified, defaults -- to "lib". - Shared_Lib_Suffix : File_Name_Type := No_File; + Shared_Lib_Suffix : File_Name_Type := No_File; -- Suffix of shared libraries, after the library name in the shared -- library name. Specified in the configuration. When not specified, -- default to ".so". - Shared_Lib_Min_Options : Name_List_Index := No_Name_List; + Shared_Lib_Min_Options : Name_List_Index := No_Name_List; -- The minimum options to use when building a shared library - Lib_Version_Options : Name_List_Index := No_Name_List; + Lib_Version_Options : Name_List_Index := No_Name_List; -- The options to use to specify a library version - Symbolic_Link_Supported : Boolean := False; + Symbolic_Link_Supported : Boolean := False; -- True if the platform supports symbolic link files - Lib_Maj_Min_Id_Supported : Boolean := False; + Lib_Maj_Min_Id_Supported : Boolean := False; -- True if platform supports library major and minor options, such as -- libname.so -> libname.so.2 -> libname.so.2.4 - Auto_Init_Supported : Boolean := False; + Auto_Init_Supported : Boolean := False; -- True if automatic initialisation is supported for shared stand-alone -- libraries. end record; @@ -1159,21 +1189,13 @@ package Prj is -- The sources for all languages including Ada are accessible through -- the Source_Iterator type - Interfaces_Defined : Boolean := False; + Interfaces_Defined : Boolean := False; -- True if attribute Interfaces is declared for the project or any -- project it extends. - Include_Path : String_Access := null; - -- The search source path for the project. Used as the value for an - -- environment variable, specified by attribute Include_Path - -- (<language>). The names of the environment variables are in component - -- Include_Path of the records Language_Config. - Include_Path_File : Path_Name_Type := No_Path; - -- The path name of the of the source search directory file - - Include_Data_Set : Boolean := False; - -- Set True when Imported_Directories_Switches or Include_Path are set + -- The path name of the of the source search directory file. + -- This is only used by gnatmake Source_Dirs : String_List_Id := Nil_String; -- The list of all the source directories @@ -1186,14 +1208,13 @@ package Prj is -- use this field directly outside of the project manager, use -- Prj.Env.Ada_Include_Path instead. + Has_Multi_Unit_Sources : Boolean := False; + -- Whether there is at least one source file containing multiple units + ------------------- -- Miscellaneous -- ------------------- - Imported_Directories_Switches : Argument_List_Access := null; - -- List of the source search switches (-I<source dir>) to be used - -- when compiling. - Ada_Objects_Path : String_Access := null; -- The cached value of ADA_OBJECTS_PATH for this project file. Do not -- use this field directly outside of the compiler, use @@ -1368,6 +1389,14 @@ package Prj is Object_File_Suffix : Name_Id := No_Name) return File_Name_Type; -- Returns the object file name corresponding to a source file name + function Object_Name + (Source_File_Name : File_Name_Type; + Source_Index : Int; + Index_Separator : Character; + Object_File_Suffix : Name_Id := No_Name) return File_Name_Type; + -- Returns the object file name corresponding to a unit in a multi-source + -- file. + function Dependency_Name (Source_File_Name : File_Name_Type; Dependency : Dependency_File_Kind) return File_Name_Type; diff --git a/gcc/ada/put_scos.adb b/gcc/ada/put_scos.adb index d7667b85f32..bca3f698815 100644 --- a/gcc/ada/put_scos.adb +++ b/gcc/ada/put_scos.adb @@ -37,21 +37,26 @@ begin Stop : Nat; begin - Write_Info_Initiate ('C'); - Write_Info_Char (' '); - Write_Info_Nat (SUT.Dep_Num); - Write_Info_Char (' '); + Start := SUT.From; + Stop := SUT.To; - for N in SUT.File_Name'Range loop - Write_Info_Char (SUT.File_Name (N)); - end loop; + -- Write unit header (omitted if no SCOs are generated for this unit) + + if Start <= Stop then + Write_Info_Initiate ('C'); + Write_Info_Char (' '); + Write_Info_Nat (SUT.Dep_Num); + Write_Info_Char (' '); - Write_Info_Terminate; + for N in SUT.File_Name'Range loop + Write_Info_Char (SUT.File_Name (N)); + end loop; + + Write_Info_Terminate; + end if; -- Loop through SCO entries for this unit - Start := SUT.From; - Stop := SUT.To; loop exit when Start = Stop + 1; pragma Assert (Start <= Stop); diff --git a/gcc/ada/s-bitops.adb b/gcc/ada/s-bitops.adb index a49ffed7b88..c49b829763d 100644 --- a/gcc/ada/s-bitops.adb +++ b/gcc/ada/s-bitops.adb @@ -29,6 +29,8 @@ -- -- ------------------------------------------------------------------------------ +pragma Compiler_Unit; + with System; use System; with System.Unsigned_Types; use System.Unsigned_Types; diff --git a/gcc/ada/s-crtl.ads b/gcc/ada/s-crtl.ads index f013a418fcb..7d5f1107add 100644 --- a/gcc/ada/s-crtl.ads +++ b/gcc/ada/s-crtl.ads @@ -29,8 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- This package provides the low level interface to the C Run Time Library --- on non-VMS systems. +-- This package provides the low level interface to the C runtime library + +pragma Compiler_Unit; with System.Parameters; @@ -39,6 +40,9 @@ package System.CRTL is subtype chars is System.Address; -- Pointer to null-terminated array of characters + -- Should use Interfaces.C.Strings types instead, but this causes bootstrap + -- issues as i-c contains Ada 2005 specific features, not compatible with + -- older, Ada 95-only base compilers??? subtype DIRs is System.Address; -- Corresponds to the C type DIR* @@ -49,7 +53,7 @@ package System.CRTL is subtype int is Integer; type long is range -(2 ** (System.Parameters.long_bits - 1)) - .. +(2 ** (System.Parameters.long_bits - 1)) - 1; + .. +(2 ** (System.Parameters.long_bits - 1)) - 1; subtype off_t is Long_Integer; @@ -112,8 +116,7 @@ package System.CRTL is function fseek (stream : FILEs; offset : long; - origin : int) - return int; + origin : int) return int; pragma Import (C, fseek, "fseek"); function ftell (stream : FILEs) return long; @@ -131,11 +134,6 @@ package System.CRTL is function malloc (Size : size_t) return System.Address; pragma Import (C, malloc, "malloc"); - function malloc32 (Size : size_t) return System.Address; - pragma Import (C, malloc32, "malloc"); - -- An uncalled alias for malloc except on 64bit systems needing to - -- allocate 32bit memory. - procedure memcpy (S1 : System.Address; S2 : System.Address; N : size_t); pragma Import (C, memcpy, "memcpy"); @@ -155,12 +153,6 @@ package System.CRTL is (Ptr : System.Address; Size : size_t) return System.Address; pragma Import (C, realloc, "realloc"); - function realloc32 - (Ptr : System.Address; Size : size_t) return System.Address; - pragma Import (C, realloc32, "realloc"); - -- An uncalled alias for realloc except on 64bit systems needing to - -- allocate 32bit memory. - procedure rewind (stream : FILEs); pragma Import (C, rewind, "rewind"); @@ -174,8 +166,7 @@ package System.CRTL is (stream : FILEs; buffer : chars; mode : int; - size : size_t) - return int; + size : size_t) return int; pragma Import (C, setvbuf, "setvbuf"); procedure tmpnam (string : chars); @@ -202,7 +193,4 @@ package System.CRTL is function write (fd : int; buffer : chars; nbytes : int) return int; pragma Import (C, write, "write"); - function strerror (errno : int) return chars; - pragma Import (C, strerror, "strerror"); - end System.CRTL; diff --git a/gcc/ada/s-errrep.adb b/gcc/ada/s-errrep.adb deleted file mode 100644 index 783f845d1e4..00000000000 --- a/gcc/ada/s-errrep.adb +++ /dev/null @@ -1,68 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . E R R O R _ R E P O R T I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2006, AdaCore -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package must not depend on anything else, since it may be --- called during elaboration of other packages. - -package body System.Error_Reporting is - - procedure Write (fildes : Integer; buf : System.Address; nbyte : Integer); - pragma Import (C, Write, "write"); - - procedure Prog_Exit (Status : Integer); - pragma No_Return (Prog_Exit); - pragma Import (C, Prog_Exit, "exit"); - - Shutdown_Message : String := "failed run-time assertion : "; - End_Of_Line : String := "" & ASCII.LF; - - -------------- - -- Shutdown -- - -------------- - - function Shutdown (M : String) return Boolean is - begin - Write (2, Shutdown_Message'Address, Shutdown_Message'Length); - Write (2, M'Address, M'Length); - Write (2, End_Of_Line'Address, End_Of_Line'Length); - - -- This call should never return - - Prog_Exit (1); - - -- Return is just to keep Ada happy (return required) - - return False; - end Shutdown; - -end System.Error_Reporting; diff --git a/gcc/ada/s-errrep.ads b/gcc/ada/s-errrep.ads deleted file mode 100644 index 930e0206419..00000000000 --- a/gcc/ada/s-errrep.ads +++ /dev/null @@ -1,45 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . E R R O R _ R E P O R T I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2006, AdaCore -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package must not depend on anything else, since it may be --- called during elaboration of other packages. - -package System.Error_Reporting is - pragma Preelaborate; - - function Shutdown (M : String) return Boolean; - -- Perform emergency shutdown of the entire program. Msg is an error - -- message to be printed to the console. This is to be used only for - -- nonrecoverable errors. - -end System.Error_Reporting; diff --git a/gcc/ada/s-fatgen.adb b/gcc/ada/s-fatgen.adb index 0db154db4ae..cf7e4254b66 100644 --- a/gcc/ada/s-fatgen.adb +++ b/gcc/ada/s-fatgen.adb @@ -232,12 +232,7 @@ package body System.Fat_Gen is end loop; end if; - if X > 0.0 then - Frac := Ax; - else - Frac := -Ax; - end if; - + Frac := (if X > 0.0 then Ax else -Ax); Expo := Ex; end; end if; diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index f93fee25e33..60a96e427cf 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -31,13 +31,12 @@ with Ada.Finalization; use Ada.Finalization; with Ada.IO_Exceptions; use Ada.IO_Exceptions; -with Ada.Unchecked_Conversion; with Interfaces.C; with Interfaces.C.Strings; use Interfaces.C.Strings; with Interfaces.C_Streams; use Interfaces.C_Streams; -with System.CRTL; +with System.CRTL.Runtime; with System.Case_Util; use System.Case_Util; with System.OS_Lib; with System.Soft_Links; @@ -375,16 +374,7 @@ package body System.File_IO is ------------------- function Errno_Message (Errno : Integer := OS_Lib.Errno) return String is - pragma Warnings (Off); - function To_Chars_Ptr is - new Ada.Unchecked_Conversion (System.Address, chars_ptr); - -- On VMS, the compiler warns because System.Address is 64 bits, but - -- chars_ptr is 32 bits. It should be safe, though, because strerror - -- will return a 32-bit pointer. - pragma Warnings (On); - - Message : constant chars_ptr := - To_Chars_Ptr (CRTL.strerror (Errno)); + Message : constant chars_ptr := CRTL.Runtime.strerror (Errno); begin if Message = Null_Ptr then @@ -529,27 +519,17 @@ package body System.File_IO is end if; when Inout_File | Append_File => - if Creat then - Fopstr (1) := 'w'; - else - Fopstr (1) := 'r'; - end if; - + Fopstr (1) := (if Creat then 'w' else 'r'); Fopstr (2) := '+'; Fptr := 3; end case; - -- If text_translation_required is true then we need to append - -- either a t or b to the string to get the right mode + -- If text_translation_required is true then we need to append either a + -- "t" or "b" to the string to get the right mode. if text_translation_required then - if Text then - Fopstr (Fptr) := 't'; - else - Fopstr (Fptr) := 'b'; - end if; - + Fopstr (Fptr) := (if Text then 't' else 'b'); Fptr := Fptr + 1; end if; diff --git a/gcc/ada/s-imgcha.adb b/gcc/ada/s-imgcha.adb index dd3b4d90eaf..7678bf7205a 100644 --- a/gcc/ada/s-imgcha.adb +++ b/gcc/ada/s-imgcha.adb @@ -124,22 +124,13 @@ package body System.Img_Char is if V in C0_Range then S (1 .. 3) := C0 (V); - - if S (3) = ' ' then - P := 2; - else - P := 3; - end if; + P := (if S (3) = ' ' then 2 else 3); elsif V in C1_Range then S (1 .. 3) := C1 (V); if S (1) /= 'r' then - if S (3) = ' ' then - P := 2; - else - P := 3; - end if; + P := (if S (3) = ' ' then 2 else 3); -- Special case, res means RESERVED_nnn where nnn is the three digit -- decimal value corresponding to the code position (more efficient diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 48938d9d9d1..1e8bd520ceb 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -84,12 +84,14 @@ pragma Style_Checks ("M32766"); #define _XOPEN_SOURCE 500 #elif defined (__mips) && defined (__sgi) -/** For IRIX _XOPEN5 must be defined and _XOPEN_IOV_MAX must be used as IOV_MAX, - ** otherwise IOV_MAX is not defined. +/** For IRIX 6, _XOPEN5 must be defined and _XOPEN_IOV_MAX must be used as + ** IOV_MAX, otherwise IOV_MAX is not defined. IRIX 5 has neither. **/ +#ifdef _XOPEN_IOV_MAX #define _XOPEN5 #define IOV_MAX _XOPEN_IOV_MAX #endif +#endif #include <stdlib.h> #include <string.h> @@ -161,6 +163,9 @@ int counter = 0; #define CNS(name,comment) \ printf ("\n->CNS:$%d:" #name ":" name ":" comment, __LINE__); +#define C(sname,type,value,comment)\ + printf ("\n->C:$%d:" sname ":" #type ":" value ":" comment, __LINE__); + #define TXT(text) \ printf ("\n->TXT:$%d:" text, __LINE__); @@ -174,7 +179,12 @@ int counter = 0; #define CNS(name, comment) \ asm volatile("\n->CNS:%0:" #name ":" name ":" comment \ : : "i" (__LINE__)); -/* General expression constant */ +/* General expression named number */ + +#define C(sname, type, value, comment) \ + asm volatile("\n->C:%0:" sname ":" #type ":" value ":" comment \ + : : "i" (__LINE__)); +/* Typed constant */ #define TXT(text) \ asm volatile("\n->TXT:%0:" text \ @@ -183,6 +193,8 @@ int counter = 0; #endif +#define CST(name,comment) C(#name,String,name,comment) + #define STR(x) STR1(x) #define STR1(x) #x @@ -233,10 +245,7 @@ package System.OS_Constants is -- Platform identification -- ----------------------------- -*/ -TXT(" Target_Name : constant String := " STR(TARGET) ";") -/* - type Target_OS_Type is (Windows, VMS, Other_OS); + type OS_Type is (Windows, VMS, Other_OS); */ #if defined (__MINGW32__) # define TARGET_OS "Windows" @@ -245,7 +254,9 @@ TXT(" Target_Name : constant String := " STR(TARGET) ";") #else # define TARGET_OS "Other_OS" #endif -TXT(" Target_OS : constant Target_OS_Type := " TARGET_OS ";") +C("Target_OS", OS_Type, TARGET_OS, "") +#define Target_Name TARGET +CST(Target_Name, "") /* ------------------- @@ -1189,7 +1200,7 @@ CND(SIZEOF_tv_usec, "tv_usec") } /* - -- Sizes of protocol specific address types (for sockaddr.sa_len) + -- Sizes of various data types */ #define SIZEOF_sockaddr_in (sizeof (struct sockaddr_in)) @@ -1201,12 +1212,11 @@ CND(SIZEOF_sockaddr_in, "struct sockaddr_in") #endif CND(SIZEOF_sockaddr_in6, "struct sockaddr_in6") -/* - - -- Size of file descriptor sets -*/ #define SIZEOF_fd_set (sizeof (fd_set)) CND(SIZEOF_fd_set, "fd_set"); + +#define SIZEOF_struct_servent (sizeof (struct servent)) +CND(SIZEOF_struct_servent, "struct servent"); /* -- Fields of struct hostent @@ -1251,7 +1261,7 @@ CND(Has_Sockaddr_Len, "Sockaddr has sa_len field") ** Do not change the format of the line below without also updating the ** MaRTE Makefile. **/ -TXT(" Thread_Blocking_IO : constant Boolean := True;") +C("Thread_Blocking_IO", Boolean, "True", "") /* -- Set False for contexts where socket i/o are process blocking @@ -1262,7 +1272,7 @@ TXT(" Thread_Blocking_IO : constant Boolean := True;") #else # define Inet_Pton_Linkname "__gnat_inet_pton" #endif -TXT(" Inet_Pton_Linkname : constant String := \"" Inet_Pton_Linkname "\";") +CST(Inet_Pton_Linkname, "") #endif /* HAVE_SOCKETS */ diff --git a/gcc/ada/s-osinte-aix.ads b/gcc/ada/s-osinte-aix.ads index b1639a77e3f..64907fb3052 100644 --- a/gcc/ada/s-osinte-aix.ads +++ b/gcc/ada/s-osinte-aix.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -310,7 +310,7 @@ package System.OS_Interface is function Get_Page_Size return size_t; function Get_Page_Size return Address; pragma Import (C, Get_Page_Size, "getpagesize"); - -- Returns the size of a page, or 0 if this is not relevant on this target + -- Returns the size of a page PROT_NONE : constant := 0; PROT_READ : constant := 1; diff --git a/gcc/ada/s-osinte-darwin.ads b/gcc/ada/s-osinte-darwin.ads index 99bdc6d8ea6..ed2f93124a0 100644 --- a/gcc/ada/s-osinte-darwin.ads +++ b/gcc/ada/s-osinte-darwin.ads @@ -294,7 +294,7 @@ package System.OS_Interface is function Get_Page_Size return size_t; function Get_Page_Size return System.Address; pragma Import (C, Get_Page_Size, "getpagesize"); - -- Returns the size of a page, or 0 if this is not relevant on this target + -- Returns the size of a page PROT_NONE : constant := 0; PROT_READ : constant := 1; diff --git a/gcc/ada/s-osinte-freebsd.ads b/gcc/ada/s-osinte-freebsd.ads index c1ed40b7720..c8378292168 100644 --- a/gcc/ada/s-osinte-freebsd.ads +++ b/gcc/ada/s-osinte-freebsd.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -326,7 +326,7 @@ package System.OS_Interface is function Get_Page_Size return size_t; function Get_Page_Size return Address; pragma Import (C, Get_Page_Size, "getpagesize"); - -- returns the size of a page, or 0 if this is not relevant on this target + -- Returns the size of a page PROT_NONE : constant := 0; PROT_READ : constant := 1; diff --git a/gcc/ada/s-osinte-hpux-dce.adb b/gcc/ada/s-osinte-hpux-dce.adb index 45a5ed1dc56..8844d17e0b2 100644 --- a/gcc/ada/s-osinte-hpux-dce.adb +++ b/gcc/ada/s-osinte-hpux-dce.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2007, AdaCore -- +-- Copyright (C) 1995-2009, AdaCore -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -314,11 +314,7 @@ package body System.OS_Interface is begin if pthread_cond_timedwait_base (cond, mutex, abstime) /= 0 then - if errno = EAGAIN then - return ETIMEDOUT; - else - return errno; - end if; + return (if errno = EAGAIN then ETIMEDOUT else errno); else return 0; end if; diff --git a/gcc/ada/s-osinte-hpux.ads b/gcc/ada/s-osinte-hpux.ads index 5c4003d30a3..ea31697a4ed 100644 --- a/gcc/ada/s-osinte-hpux.ads +++ b/gcc/ada/s-osinte-hpux.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -300,7 +300,7 @@ package System.OS_Interface is function Get_Page_Size return size_t; function Get_Page_Size return Address; pragma Import (C, Get_Page_Size, "getpagesize"); - -- Returns the size of a page, or 0 if this is not relevant on this target + -- Returns the size of a page PROT_NONE : constant := 0; PROT_READ : constant := 1; diff --git a/gcc/ada/s-osinte-solaris-posix.ads b/gcc/ada/s-osinte-solaris-posix.ads index c5885e72a9a..517ed52c100 100644 --- a/gcc/ada/s-osinte-solaris-posix.ads +++ b/gcc/ada/s-osinte-solaris-posix.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -294,7 +294,7 @@ package System.OS_Interface is function Get_Page_Size return size_t; function Get_Page_Size return Address; pragma Import (C, Get_Page_Size, "getpagesize"); - -- Returns the size of a page, or 0 if this is not relevant on this target + -- Returns the size of a page PROT_NONE : constant := 0; PROT_READ : constant := 1; diff --git a/gcc/ada/s-osinte-tru64.adb b/gcc/ada/s-osinte-tru64.adb index 8252107a313..ad391bcb473 100644 --- a/gcc/ada/s-osinte-tru64.adb +++ b/gcc/ada/s-osinte-tru64.adb @@ -99,11 +99,10 @@ package body System.OS_Interface is -- Stick a guard page right above the Yellow Zone if it exists if Teb.all.stack_yellow /= Teb.all.stack_guard then - if Hide then - Res := mprotect (Teb.all.stack_yellow, Get_Page_Size, PROT_ON); - else - Res := mprotect (Teb.all.stack_yellow, Get_Page_Size, PROT_OFF); - end if; + Res := + mprotect + (Teb.all.stack_yellow, Get_Page_Size, + prot => (if Hide then PROT_ON else PROT_OFF)); end if; end Hide_Unhide_Yellow_Zone; diff --git a/gcc/ada/s-osinte-tru64.ads b/gcc/ada/s-osinte-tru64.ads index efb739f8f50..e893eedb399 100644 --- a/gcc/ada/s-osinte-tru64.ads +++ b/gcc/ada/s-osinte-tru64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -286,7 +286,7 @@ package System.OS_Interface is function Get_Page_Size return size_t; function Get_Page_Size return Address; pragma Import (C, Get_Page_Size, "getpagesize"); - -- Returns the size of a page, or 0 if this is not relevant on this target + -- Returns the size of a page PROT_NONE : constant := 0; PROT_READ : constant := 1; diff --git a/gcc/ada/s-osprim-mingw.adb b/gcc/ada/s-osprim-mingw.adb index 4a916166535..c818811ed1a 100644 --- a/gcc/ada/s-osprim-mingw.adb +++ b/gcc/ada/s-osprim-mingw.adb @@ -156,15 +156,17 @@ package body System.OS_Primitives is -- Therefore, the elapsed time reported by GetSystemTime between both -- actions should be null. - Max_Elapsed : constant := 0; epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch system_time_ns : constant := 100; -- 100 ns per tick Sec_Unit : constant := 10#1#E9; - Test_Now : aliased Long_Long_Integer; - Loc_Ticks : aliased LARGE_INTEGER; - Loc_Time : aliased Long_Long_Integer; - Elapsed : Long_Long_Integer; - Current_Max : Long_Long_Integer := Long_Long_Integer'Last; + Max_Elapsed : constant LARGE_INTEGER := + LARGE_INTEGER (Tick_Frequency / 100_000); + -- Look for a precision of 0.01 ms + + Loc_Ticks, Ctrl_Ticks : aliased LARGE_INTEGER; + Loc_Time, Ctrl_Time : aliased Long_Long_Integer; + Elapsed : LARGE_INTEGER; + Current_Max : LARGE_INTEGER := LARGE_INTEGER'Last; begin -- Here we must be sure that both of these calls are done in a short @@ -182,8 +184,6 @@ package body System.OS_Primitives is -- during the runs. for K in 1 .. 10 loop - GetSystemTimeAsFileTime (Loc_Time'Access); - if QueryPerformanceCounter (Loc_Ticks'Access) = Win32.FALSE then pragma Assert (Standard.False, @@ -191,17 +191,36 @@ package body System.OS_Primitives is null; end if; - GetSystemTimeAsFileTime (Test_Now'Access); + GetSystemTimeAsFileTime (Ctrl_Time'Access); + + -- Scan for clock tick, will take upto 16ms/1ms depending on PC. + -- This cannot be an infinite loop or the system hardware is badly + -- dammaged. + + loop + GetSystemTimeAsFileTime (Loc_Time'Access); + if QueryPerformanceCounter (Ctrl_Ticks'Access) = Win32.FALSE then + pragma Assert + (Standard.False, + "Could not query high performance counter in Clock"); + null; + end if; + exit when Loc_Time /= Ctrl_Time; + Loc_Ticks := Ctrl_Ticks; + end loop; - Elapsed := Test_Now - Loc_Time; + -- Check elapsed Performance Counter between samples + -- to choose the best one. + + Elapsed := Ctrl_Ticks - Loc_Ticks; if Elapsed < Current_Max then Base_Time := Loc_Time; Base_Ticks := Loc_Ticks; Current_Max := Elapsed; + -- Exit the loop when we have reached the expected precision + exit when Elapsed <= Max_Elapsed; end if; - - exit when Elapsed = Max_Elapsed; end loop; Base_Clock := Duration diff --git a/gcc/ada/s-parame.adb b/gcc/ada/s-parame.adb index 63eae6e2f95..ff61b7ee572 100644 --- a/gcc/ada/s-parame.adb +++ b/gcc/ada/s-parame.adb @@ -31,6 +31,8 @@ -- This is the default (used on all native platforms) version of this package +pragma Compiler_Unit; + package body System.Parameters is ------------------------- diff --git a/gcc/ada/s-parame.ads b/gcc/ada/s-parame.ads index 511951386c6..2110034ec6b 100644 --- a/gcc/ada/s-parame.ads +++ b/gcc/ada/s-parame.ads @@ -46,6 +46,8 @@ -- Note: do not introduce any pragma Inline statements into this unit, since -- otherwise the relinking and rebinding capability would be deactivated. +pragma Compiler_Unit; + package System.Parameters is pragma Pure; diff --git a/gcc/ada/s-restri.adb b/gcc/ada/s-restri.adb index 2db0e794a28..7ce6da9cc46 100644 --- a/gcc/ada/s-restri.adb +++ b/gcc/ada/s-restri.adb @@ -29,6 +29,8 @@ -- -- ------------------------------------------------------------------------------ +pragma Compiler_Unit; + package body System.Restrictions is use Rident; diff --git a/gcc/ada/s-restri.ads b/gcc/ada/s-restri.ads index e9a72aa9f9b..cd447c1b0b4 100644 --- a/gcc/ada/s-restri.ads +++ b/gcc/ada/s-restri.ads @@ -38,6 +38,8 @@ -- with names discarded, so that we do not have image tables for the -- large restriction enumeration types at run time. +pragma Compiler_Unit; + with System.Rident; package System.Restrictions is diff --git a/gcc/ada/s-stausa.adb b/gcc/ada/s-stausa.adb index dfa8a1fc6bb..37dda6fad3c 100644 --- a/gcc/ada/s-stausa.adb +++ b/gcc/ada/s-stausa.adb @@ -609,20 +609,18 @@ package body System.Stack_Usage is -- Take either the label size or the number image size for the -- size of the column "Stack Size". - if Size_Str_Len > Stack_Size_Str'Length then - Max_Stack_Size_Len := Size_Str_Len; - else - Max_Stack_Size_Len := Stack_Size_Str'Length; - end if; + Max_Stack_Size_Len := + (if Size_Str_Len > Stack_Size_Str'Length + then Size_Str_Len + else Stack_Size_Str'Length); -- Take either the label size or the number image size for the - -- size of the column "Stack Usage" + -- size of the column "Stack Usage". - if Result_Str_Len > Actual_Size_Str'Length then - Max_Actual_Use_Len := Result_Str_Len; - else - Max_Actual_Use_Len := Actual_Size_Str'Length; - end if; + Max_Actual_Use_Len := + (if Result_Str_Len > Actual_Size_Str'Length + then Result_Str_Len + else Actual_Size_Str'Length); Output_Result (Analyzer.Result_Id, diff --git a/gcc/ada/s-stchop-vxworks.adb b/gcc/ada/s-stchop-vxworks.adb index 9552d570fc0..152dc920bcf 100644 --- a/gcc/ada/s-stchop-vxworks.adb +++ b/gcc/ada/s-stchop-vxworks.adb @@ -31,7 +31,7 @@ -- This is the VxWorks version of this package. -- This file should be kept synchronized with the general implementation --- provided by s-stchop.adb. +-- provided by s-stchop.adb. This version is for VxWorks 5 and VxWorks MILS. pragma Restrictions (No_Elaboration_Code); -- We want to guarantee the absence of elaboration code because the @@ -44,10 +44,11 @@ with Interfaces.C; package body System.Stack_Checking.Operations is -- In order to have stack checking working appropriately on VxWorks we need - -- to extract the stack size information from the VxWorks kernel itself. It - -- means that the library for showing task-related information needs to be - -- linked into the VxWorks system, when using stack checking. The TaskShow - -- library can be linked into the VxWorks system by either: + -- to extract the stack size information from the VxWorks kernel itself. + + -- For VxWorks 5 the library for showing task-related information needs to + -- be linked into the VxWorks system, when using stack checking. The + -- taskShow library can be linked into the VxWorks system by either: -- * defining INCLUDE_SHOW_ROUTINES in config.h when using -- configuration header files, or @@ -55,6 +56,9 @@ package body System.Stack_Checking.Operations is -- * selecting INCLUDE_TASK_SHOW when using the Tornado project -- facility. + -- VxWorks MILS includes the necessary routine in taskLib, so nothing + -- special needs to be done there. + Stack_Limit : Address := Boolean'Pos (Stack_Grows_Down) * Address'First + Boolean'Pos (not Stack_Grows_Down) * Address'Last; @@ -129,6 +133,9 @@ package body System.Stack_Checking.Operations is Get_Stack_Info (Stack_Info'Access); + -- In s-stchop.adb, we check for overflow in the following operations, + -- but we have no such check in this vxworks version. Why not ??? + if Stack_Grows_Down then Limit := Stack_Info.Base - Storage_Offset (Stack_Info.Size); else diff --git a/gcc/ada/s-stchop.adb b/gcc/ada/s-stchop.adb index 7c62aa5e550..d4aa675a857 100644 --- a/gcc/ada/s-stchop.adb +++ b/gcc/ada/s-stchop.adb @@ -149,11 +149,9 @@ package body System.Stack_Checking.Operations is -- If a stack base address has been registered, honor it. Fallback to -- the address of a local object otherwise. - if My_Stack.Limit /= System.Null_Address then - My_Stack.Base := My_Stack.Limit; - else - My_Stack.Base := Frame_Address; - end if; + My_Stack.Base := + (if My_Stack.Limit /= System.Null_Address + then My_Stack.Limit else Frame_Address); if Stack_Grows_Down then diff --git a/gcc/ada/s-strhas.adb b/gcc/ada/s-strhas.adb index b83823050e6..0e86cb66b31 100644 --- a/gcc/ada/s-strhas.adb +++ b/gcc/ada/s-strhas.adb @@ -29,6 +29,8 @@ -- -- ------------------------------------------------------------------------------ +pragma Compiler_Unit; + package body System.String_Hash is -- Compute a hash value for a key. The approach here is follows the diff --git a/gcc/ada/s-strxdr.adb b/gcc/ada/s-strxdr.adb index 32ee8ee433d..4fca719e25d 100644 --- a/gcc/ada/s-strxdr.adb +++ b/gcc/ada/s-strxdr.adb @@ -1263,11 +1263,9 @@ package body System.Stream_Attributes is else -- Test sign and apply two complement notation - if Item < 0 then - U := XDR_U'Last xor XDR_U (-(Item + 1)); - else - U := XDR_U (Item); - end if; + U := (if Item < 0 + then XDR_U'Last xor XDR_U (-(Item + 1)) + else XDR_U (Item)); for N in reverse S'Range loop S (N) := SE (U mod BB); @@ -1386,8 +1384,7 @@ package body System.Stream_Attributes is X := Long_Unsigned (Item); end if; - -- Compute using machine unsigned - -- rather than long_unsigned. + -- Compute using machine unsigned rather than long_unsigned for N in reverse S'Range loop @@ -1530,8 +1527,7 @@ package body System.Stream_Attributes is X := Long_Long_Unsigned (Item); end if; - -- Compute using machine unsigned - -- rather than long_long_unsigned. + -- Compute using machine unsigned rather than long_long_unsigned for N in reverse S'Range loop @@ -1571,8 +1567,7 @@ package body System.Stream_Attributes is S := Long_Long_Unsigned_To_XDR_S_LLU (Item); else - -- Compute using machine unsigned - -- rather than long_long_unsigned. + -- Compute using machine unsigned rather than long_long_unsigned for N in reverse S'Range loop @@ -1609,8 +1604,7 @@ package body System.Stream_Attributes is S := Long_Long_Unsigned_To_XDR_S_LU (Long_Long_Unsigned (Item)); else - -- Compute using machine unsigned - -- rather than long_unsigned. + -- Compute using machine unsigned rather than long_unsigned for N in reverse S'Range loop @@ -1729,11 +1723,9 @@ package body System.Stream_Attributes is else -- Test sign and apply two complement's notation - if Item < 0 then - U := XDR_SU'Last xor XDR_SU (-(Item + 1)); - else - U := XDR_SU (Item); - end if; + U := (if Item < 0 + then XDR_SU'Last xor XDR_SU (-(Item + 1)) + else XDR_SU (Item)); for N in reverse S'Range loop S (N) := SE (U mod BB); @@ -1766,11 +1758,9 @@ package body System.Stream_Attributes is else -- Test sign and apply two complement's notation - if Item < 0 then - U := XDR_SSU'Last xor XDR_SSU (-(Item + 1)); - else - U := XDR_SSU (Item); - end if; + U := (if Item < 0 + then XDR_SSU'Last xor XDR_SSU (-(Item + 1)) + else XDR_SSU (Item)); S (1) := SE (U); end if; diff --git a/gcc/ada/s-taenca.adb b/gcc/ada/s-taenca.adb index df8a5735333..fba7691e3a2 100644 --- a/gcc/ada/s-taenca.adb +++ b/gcc/ada/s-taenca.adb @@ -165,13 +165,8 @@ package body System.Tasking.Entry_Calls is and then Entry_Call.State = Now_Abortable then Queuing.Dequeue_Call (Entry_Call); - - if Entry_Call.Cancellation_Attempted then - Entry_Call.State := Cancelled; - else - Entry_Call.State := Done; - end if; - + Entry_Call.State := + (if Entry_Call.Cancellation_Attempted then Cancelled else Done); Unlock_And_Update_Server (Self_ID, Entry_Call); else diff --git a/gcc/ada/s-taprop-dummy.adb b/gcc/ada/s-taprop-dummy.adb index 38264ba5c88..645e9fd90ba 100644 --- a/gcc/ada/s-taprop-dummy.adb +++ b/gcc/ada/s-taprop-dummy.adb @@ -38,8 +38,6 @@ pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during tasking -- operations. It causes infinite loops and other problems. -with System.Error_Reporting; - package body System.Task_Primitives.Operations is use System.Tasking; @@ -192,9 +190,7 @@ package body System.Task_Primitives.Operations is procedure Initialize (Environment_Task : Task_Id) is No_Tasking : Boolean; begin - No_Tasking := - System.Error_Reporting.Shutdown - ("Tasking not implemented on this configuration"); + raise Program_Error with "tasking not implemented on this configuration"; end Initialize; procedure Initialize (S : in out Suspension_Object) is diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb index e93b7af4dca..ebc2f9ddc0c 100644 --- a/gcc/ada/s-taprop-hpux-dce.adb +++ b/gcc/ada/s-taprop-hpux-dce.adb @@ -411,16 +411,14 @@ package body System.Task_Primitives.Operations is pragma Unreferenced (Reason); Result : Interfaces.C.int; + begin - if Single_Lock then - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; + Result := + pthread_cond_wait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access)); -- EINTR is not considered a failure @@ -450,11 +448,10 @@ package body System.Task_Primitives.Operations is Timedout := True; Yielded := False; - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; + Abs_Time := + (if Mode = Relative + then Duration'Min (Time, Max_Sensible_Delay) + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); if Abs_Time > Check_Time then Request := To_Timespec (Abs_Time); @@ -462,20 +459,13 @@ package body System.Task_Primitives.Operations is loop exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - if Single_Lock then - Result := - pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, - Request'Access); - - else - Result := - pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, - Request'Access); - end if; + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); exit when Abs_Time <= Monotonic_Clock; @@ -515,11 +505,10 @@ package body System.Task_Primitives.Operations is Write_Lock (Self_ID); - if Mode = Relative then - Abs_Time := Time + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; + Abs_Time := + (if Mode = Relative + then Time + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); if Abs_Time > Check_Time then Request := To_Timespec (Abs_Time); @@ -528,19 +517,13 @@ package body System.Task_Primitives.Operations is loop exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - if Single_Lock then - Result := - pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, - Request'Access); - else - Result := - pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, - Request'Access); - end if; + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); exit when Abs_Time <= Monotonic_Clock; diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb index 83439214259..e73555fb304 100644 --- a/gcc/ada/s-taprop-irix.adb +++ b/gcc/ada/s-taprop-irix.adb @@ -430,15 +430,12 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; begin - if Single_Lock then - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; + Result := + pthread_cond_wait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access)); -- EINTR is not considered a failure @@ -469,11 +466,10 @@ package body System.Task_Primitives.Operations is Timedout := True; Yielded := False; - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; + Abs_Time := + (if Mode = Relative + then Duration'Min (Time, Max_Sensible_Delay) + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); if Abs_Time > Check_Time then Request := To_Timespec (Abs_Time); @@ -481,18 +477,13 @@ package body System.Task_Primitives.Operations is loop exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - if Single_Lock then - Result := - pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, - Request'Access); - - else - Result := - pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, - Request'Access); - end if; + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); Check_Time := Monotonic_Clock; exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; @@ -530,11 +521,10 @@ package body System.Task_Primitives.Operations is Write_Lock (Self_ID); - if Mode = Relative then - Abs_Time := Time + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; + Abs_Time := + (if Mode = Relative + then Time + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); if Abs_Time > Check_Time then Request := To_Timespec (Abs_Time); @@ -543,17 +533,13 @@ package body System.Task_Primitives.Operations is loop exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - if Single_Lock then - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, - Request'Access); - else - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, - Request'Access); - end if; + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); Check_Time := Monotonic_Clock; exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index 0f0773cec5e..5680fa22c76 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -426,15 +426,12 @@ package body System.Task_Primitives.Operations is begin pragma Assert (Self_ID = Self); - if Single_Lock then - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; + Result := + pthread_cond_wait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access)); -- EINTR is not considered a failure @@ -469,11 +466,10 @@ package body System.Task_Primitives.Operations is Timedout := True; Yielded := False; - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; + Abs_Time := + (if Mode = Relative + then Duration'Min (Time, Max_Sensible_Delay) + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); if Abs_Time > Check_Time then Request := To_Timespec (Abs_Time); @@ -481,20 +477,13 @@ package body System.Task_Primitives.Operations is loop exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - if Single_Lock then - Result := - pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, - Request'Access); - - else - Result := - pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, - Request'Access); - end if; + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); Check_Time := Monotonic_Clock; exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; @@ -539,11 +528,10 @@ package body System.Task_Primitives.Operations is Write_Lock (Self_ID); - if Mode = Relative then - Abs_Time := Time + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; + Abs_Time := + (if Mode = Relative + then Time + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); if Abs_Time > Check_Time then Request := To_Timespec (Abs_Time); @@ -552,17 +540,13 @@ package body System.Task_Primitives.Operations is loop exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - if Single_Lock then - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, - Request'Access); - else - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, - Request'Access); - end if; + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); Check_Time := Monotonic_Clock; exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; @@ -1104,6 +1088,7 @@ package body System.Task_Primitives.Operations is SSL.Abort_Undefer.all; raise Program_Error; + else -- Suspend the task if the state is False. Otherwise, the task -- continues its execution, and the state of the suspension object @@ -1118,8 +1103,7 @@ package body System.Task_Primitives.Operations is -- Loop in case pthread_cond_wait returns earlier than expected -- (e.g. in case of EINTR caused by a signal). This should not -- happen with the current Linux implementation of pthread, but - -- POSIX does not guarantee it, so this may change in the - -- future. + -- POSIX does not guarantee it so this may change in future. Result := pthread_cond_wait (S.CV'Access, S.L'Access); pragma Assert (Result = 0 or else Result = EINTR); diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index cb51841a54d..a3b19ab5c5d 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -312,18 +312,17 @@ package body System.Task_Primitives.Operations is Unlock (L, Global_Lock => True); -- No problem if we are interrupted here: if the condition is signaled, - -- WaitForSingleObject will simply not block + -- WaitForSingleObject will simply not block. if Rel_Time <= 0.0 then Timed_Out := True; Wait_Result := 0; else - if Rel_Time >= Duration (Time_Out_Max) / 1000 then - Time_Out := Time_Out_Max; - else - Time_Out := DWORD (Rel_Time * 1000); - end if; + Time_Out := + (if Rel_Time >= Duration (Time_Out_Max) / 1000 + then Time_Out_Max + else DWORD (Rel_Time * 1000)); Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out); diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index db385c8c589..d05bb1cd2d4 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -244,12 +244,9 @@ package body System.Task_Primitives.Operations is Guard_Page_Address := Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size; - if On then - Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_ON); - else - Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_OFF); - end if; - + Res := + mprotect (Guard_Page_Address, Get_Page_Size, + prot => (if On then PROT_ON else PROT_OFF)); pragma Assert (Res = 0); end if; end Stack_Guard; @@ -491,15 +488,12 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; begin - if Single_Lock then - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; + Result := + pthread_cond_wait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access)); -- EINTR is not considered a failure @@ -551,27 +545,19 @@ package body System.Task_Primitives.Operations is end if; if Abs_Time > Check_Time then - if Relative_Timed_Wait then - Request := To_Timespec (Rel_Time); - else - Request := To_Timespec (Abs_Time); - end if; + Request := + To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time); loop exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - if Single_Lock then - Result := - pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, - Request'Access); - - else - Result := - pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, - Request'Access); - end if; + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); Check_Time := Monotonic_Clock; exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; @@ -633,28 +619,20 @@ package body System.Task_Primitives.Operations is end if; if Abs_Time > Check_Time then - if Relative_Timed_Wait then - Request := To_Timespec (Rel_Time); - else - Request := To_Timespec (Abs_Time); - end if; - + Request := + To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time); Self_ID.Common.State := Delay_Sleep; loop exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - if Single_Lock then - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, - Request'Access); - else - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, - Request'Access); - end if; + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); Check_Time := Monotonic_Clock; exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index 1e47b9486ed..5250e0e2c15 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -1226,15 +1226,13 @@ package body System.Task_Primitives.Operations is Timedout := True; Yielded := False; - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; + Abs_Time := + (if Mode = Relative + then Duration'Min (Time, Max_Sensible_Delay) + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); if Abs_Time > Check_Time then Request := To_Timespec (Abs_Time); - loop exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; @@ -1294,11 +1292,10 @@ package body System.Task_Primitives.Operations is Write_Lock (Self_ID); - if Mode = Relative then - Abs_Time := Time + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; + Abs_Time := + (if Mode = Relative + then Time + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); if Abs_Time > Check_Time then Request := To_Timespec (Abs_Time); diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb index c5a68b7a4e2..cd23f16d9ca 100644 --- a/gcc/ada/s-taprop-tru64.adb +++ b/gcc/ada/s-taprop-tru64.adb @@ -440,15 +440,12 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; begin - if Single_Lock then - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; + Result := + pthread_cond_wait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access)); -- EINTR is not considered a failure @@ -482,11 +479,10 @@ package body System.Task_Primitives.Operations is Timedout := True; Yielded := False; - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; + Abs_Time := + (if Mode = Relative + then Duration'Min (Time, Max_Sensible_Delay) + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); if Abs_Time > Check_Time then Request := To_Timespec (Abs_Time); @@ -494,20 +490,13 @@ package body System.Task_Primitives.Operations is loop exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - if Single_Lock then - Result := - pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, - Request'Access); - - else - Result := - pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, - Request'Access); - end if; + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); Check_Time := Monotonic_Clock; exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; @@ -550,11 +539,10 @@ package body System.Task_Primitives.Operations is Write_Lock (Self_ID); - if Mode = Relative then - Abs_Time := Time + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; + Abs_Time := + (if Mode = Relative + then Time + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); if Abs_Time > Check_Time then Request := To_Timespec (Abs_Time); @@ -563,19 +551,13 @@ package body System.Task_Primitives.Operations is loop exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - if Single_Lock then - Result := - pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, - Request'Access); - else - Result := - pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, - Request'Access); - end if; + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); Check_Time := Monotonic_Clock; exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb index eb8c0f1867c..582f88bcbde 100644 --- a/gcc/ada/s-taprop-vms.adb +++ b/gcc/ada/s-taprop-vms.adb @@ -408,15 +408,12 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; begin - if Single_Lock then - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; + Result := + pthread_cond_wait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access)); -- EINTR is not considered a failure @@ -540,19 +537,13 @@ package body System.Task_Primitives.Operations is exit; end if; - if Single_Lock then - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access); - pragma Assert (Result = 0); - else - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; + Result := + pthread_cond_wait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access)); + pragma Assert (Result = 0); Yielded := True; diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 622e3b53230..4cde338bfd3 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -430,12 +430,10 @@ package body System.Task_Primitives.Operations is -- Release the mutex before sleeping - if Single_Lock then - Result := semGive (Single_RTS_Lock.Mutex); - else - Result := semGive (Self_ID.Common.LL.L.Mutex); - end if; - + Result := + semGive (if Single_Lock + then Single_RTS_Lock.Mutex + else Self_ID.Common.LL.L.Mutex); pragma Assert (Result = 0); -- Perform a blocking operation to take the CV semaphore. Note that a @@ -448,12 +446,10 @@ package body System.Task_Primitives.Operations is -- Take the mutex back - if Single_Lock then - Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); - else - Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); - end if; - + Result := + semTake ((if Single_Lock + then Single_RTS_Lock.Mutex + else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER); pragma Assert (Result = 0); end Sleep; @@ -506,12 +502,10 @@ package body System.Task_Primitives.Operations is loop -- Release the mutex before sleeping - if Single_Lock then - Result := semGive (Single_RTS_Lock.Mutex); - else - Result := semGive (Self_ID.Common.LL.L.Mutex); - end if; - + Result := + semGive (if Single_Lock + then Single_RTS_Lock.Mutex + else Self_ID.Common.LL.L.Mutex); pragma Assert (Result = 0); -- Perform a blocking operation to take the CV semaphore. Note @@ -551,12 +545,10 @@ package body System.Task_Primitives.Operations is -- Take the mutex back - if Single_Lock then - Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); - else - Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); - end if; - + Result := + semTake ((if Single_Lock + then Single_RTS_Lock.Mutex + else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER); pragma Assert (Result = 0); exit when Timedout or Wakeup; @@ -623,11 +615,10 @@ package body System.Task_Primitives.Operations is -- Modifying State, locking the TCB - if Single_Lock then - Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); - else - Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); - end if; + Result := + semTake ((if Single_Lock + then Single_RTS_Lock.Mutex + else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER); pragma Assert (Result = 0); @@ -639,11 +630,10 @@ package body System.Task_Primitives.Operations is -- Release the TCB before sleeping - if Single_Lock then - Result := semGive (Single_RTS_Lock.Mutex); - else - Result := semGive (Self_ID.Common.LL.L.Mutex); - end if; + Result := + semGive (if Single_Lock + then Single_RTS_Lock.Mutex + else Self_ID.Common.LL.L.Mutex); pragma Assert (Result = 0); exit when Aborted; @@ -670,11 +660,11 @@ package body System.Task_Primitives.Operations is -- Take back the lock after having slept, to protect further -- access to Self_ID. - if Single_Lock then - Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); - else - Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); - end if; + Result := + semTake + ((if Single_Lock + then Single_RTS_Lock.Mutex + else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER); pragma Assert (Result = 0); @@ -683,11 +673,11 @@ package body System.Task_Primitives.Operations is Self_ID.Common.State := Runnable; - if Single_Lock then - Result := semGive (Single_RTS_Lock.Mutex); - else - Result := semGive (Self_ID.Common.LL.L.Mutex); - end if; + Result := + semGive + (if Single_Lock + then Single_RTS_Lock.Mutex + else Self_ID.Common.LL.L.Mutex); else taskDelay (0); diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb index a29aed78a41..07ddbce8c60 100644 --- a/gcc/ada/s-tarest.adb +++ b/gcc/ada/s-tarest.adb @@ -340,11 +340,10 @@ package body System.Tasking.Restricted.Stages is 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); STPO.Create_Task (C, Task_Wrapper'Address, @@ -477,11 +476,10 @@ package body System.Tasking.Restricted.Stages is pragma Assert (Stack_Address = Null_Address); - 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)); if Single_Lock then Lock_RTS; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index f56614ca7bd..a78b0d8f813 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -743,9 +743,7 @@ package body System.Tasking.Stages is function State (Int : System.Interrupt_Management.Interrupt_ID) return Character; pragma Import (C, State, "__gnat_get_interrupt_state"); - -- Get interrupt state. Defined in a-init.c - -- The input argument is the interrupt number, - -- and the result is one of the following: + -- Get interrupt state for interrupt number Int. Defined in init.c Default : constant Character := 's'; -- 's' Interrupt_State pragma set state to System (use "default" diff --git a/gcc/ada/s-vxwext.adb b/gcc/ada/s-vxwext.adb index b13b07e1641..a0f0e8a5910 100644 --- a/gcc/ada/s-vxwext.adb +++ b/gcc/ada/s-vxwext.adb @@ -31,7 +31,7 @@ -- This package provides vxworks specific support functions needed -- by System.OS_Interface. --- This is the VxWorks 5.x version of this package +-- This is the VxWorks 5 and VxWorks MILS version of this package package body System.VxWorks.Ext is diff --git a/gcc/ada/s-vxwext.ads b/gcc/ada/s-vxwext.ads index f1906a68734..42abdc1f355 100644 --- a/gcc/ada/s-vxwext.ads +++ b/gcc/ada/s-vxwext.ads @@ -29,7 +29,7 @@ -- This package provides vxworks specific support functions needed -- by System.OS_Interface. --- This is the VxWorks 5 version of this package +-- This is the VxWorks 5 and VxWorks MILS version of this package with Interfaces.C; diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads index 4fe0700a4e4..770d53bb59b 100644 --- a/gcc/ada/scans.ads +++ b/gcc/ada/scans.ads @@ -428,7 +428,13 @@ package Scans is -- Valid only when Token = Tok_String_Literal or Tok_Operator_Symbol. Wide_Character_Found : Boolean := False; - -- Set True if wide character found. + -- Set True if wide character found (i.e. a character that does not fit + -- in Character, but fits in Wide_Wide_Character). + -- Valid only when Token = Tok_String_Literal. + + Wide_Wide_Character_Found : Boolean := False; + -- Set True if wide wide character found (i.e. a character that does + -- not fit in Character or Wide_Character). -- Valid only when Token = Tok_String_Literal. Special_Character : Character; diff --git a/gcc/ada/scn.adb b/gcc/ada/scn.adb index 81dc49bb5b5..98485506cba 100644 --- a/gcc/ada/scn.adb +++ b/gcc/ada/scn.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- -- @@ -383,7 +383,10 @@ package body Scn is when Tok_String_Literal => Token_Node := New_Node (N_String_Literal, Token_Ptr); - Set_Has_Wide_Character (Token_Node, Wide_Character_Found); + Set_Has_Wide_Character + (Token_Node, Wide_Character_Found); + Set_Has_Wide_Wide_Character + (Token_Node, Wide_Wide_Character_Found); Set_Strval (Token_Node, String_Literal_Id); when Tok_Operator_Symbol => diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index 30da224d905..af1f3bbc3a0 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -785,12 +785,12 @@ package body Scng is procedure Set_String; -- Procedure used to distinguish between string and operator symbol. - -- On entry the string has been scanned out, and its characters - -- start at Token_Ptr and end one character before Scan_Ptr. On exit - -- Token is set to Tok_String_Literal or Tok_Operator_Symbol as - -- appropriate, and Token_Node is appropriately initialized. In - -- addition, in the operator symbol case, Token_Name is - -- appropriately set. + -- On entry the string has been scanned out, and its characters start + -- at Token_Ptr and end one character before Scan_Ptr. On exit Token + -- is set to Tok_String_Literal/Tok_Operator_Symbol as appropriate, + -- and Token_Node is appropriately initialized. In addition, in the + -- operator symbol case, Token_Name is appropriately set, and the + -- flags [Wide_]Wide_Character_Found are set appropriately. --------------------------- -- Error_Bad_String_Char -- @@ -1016,7 +1016,10 @@ package body Scng is Delimiter := Source (Scan_Ptr); Accumulate_Checksum (Delimiter); + Start_String; + Wide_Character_Found := False; + Wide_Wide_Character_Found := False; Scan_Ptr := Scan_Ptr + 1; -- Loop to scan out characters of string literal @@ -1096,7 +1099,11 @@ package body Scng is Store_String_Char (Code); if not In_Character_Range (Code) then - Wide_Character_Found := True; + if In_Wide_Character_Range (Code) then + Wide_Character_Found := True; + else + Wide_Wide_Character_Found := True; + end if; end if; end loop; diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index c58545f5ec1..cf2fb90392c 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -48,13 +48,17 @@ package SCOs is -- Put_SCO reads the internal tables and generates text lines in the ALI -- format. + -- ??? The specification below for the SCO ALI format and the internal + -- data structures have been modified, but the implementation has not been + -- updated yet to reflect these specification changes. + -------------------- -- SCO ALI Format -- -------------------- -- Source coverage obligations are generated on a unit-by-unit basis in the -- ALI file, using lines that start with the identifying character C. These - -- lines are generated if the -gnatC switch is set. + -- lines are generated if the -gnateS switch is set. -- Sloc Ranges @@ -75,7 +79,7 @@ package SCOs is -- is divided into sections, one section for each unit for which SCO's -- are generated. A SCO section has a header of the form: - -- C dependency-number filename + -- C dependency-number filename -- This header precedes SCO information for the unit identified by -- dependency number and file name. The dependency number is the @@ -102,31 +106,52 @@ package SCOs is -- renaming_declaration -- generic_instantiation + -- and the following regions of the syntax tree: + + -- the part of a case_statement from CASE up to the expression + -- the part of a FOR iteration scheme from FOR up to the + -- loop_parameter_specification + -- the part of an extended_return_statement from RETURN up to the + -- expression (if present) or to the return_subtype_indication (if + -- no expression) + -- Statement lines - -- These lines correspond to a sequence of one or more statements which - -- are always executed in sequence, The first statement may be an entry - -- point (e.g. statement after a label), and the last statement may be - -- an exit point (e.g. an exit statement), but no other entry or exit - -- points may occur within the sequence of statements. The idea is that - -- the sequence can be treated as a single unit from a coverage point of - -- view, if any of the code for the statement sequence is executed, this - -- corresponds to coverage of the entire statement sequence. The form of - -- a statement line in the ALI file is: + -- These lines correspond to one or more successive statements (in the + -- sense of the above list) which are always executed in sequence (in the + -- absence of exceptions or other external interruptions). - -- CS sloc-range + -- Entry points to such sequences are: - -- Exit points + -- the first statement of any sequence_of_statements + -- the first statement after a compound statement + -- the first statement after an EXIT, RAISE or GOTO statement + -- any statement with a label - -- An exit point is a statement that causes transfer of control. Examples - -- are exit statements, raise statements and return statements. The form - -- of an exit point in the ALI file is: + -- Each entry point must appear as the first entry on a CS line. + -- The idea is that if any simple statement on a CS line is known to have + -- been executed, then all statements that appear before it on the same + -- CS line are certain to also have been executed. - -- CT sloc-range + -- The form of a statement line in the ALI file is: - -- Decisions + -- CS *sloc-range [*sloc-range...] + + -- where each sloc-range corresponds to a single statement, and * is + -- one of: + + -- t type declaration + -- s subtype declaration + -- o object declaration + -- r renaming declaration + -- i generic instantiation + -- C CASE statement + -- F FOR loop statement + -- R extended RETURN statement - -- Decisions represent the most significant section of the SCO lines + -- and is omitted for all other cases. + + -- Decisions -- Note: in the following description, logical operator includes the -- short circuited forms (so can be any of AND, OR, XOR, NOT, AND THEN, @@ -136,7 +161,7 @@ package SCOs is -- expresssion that occurs in the context of a control structure in the -- source program, including WHILE, IF, EXIT WHEN. Note that a boolean -- expression in any other context, for example, on the right side of an - -- assignment, is not considered to be a decision. + -- assignment, is not considered to be a simple decision. -- A complex decision is an occurrence of a logical operator which is not -- itself an operand of some other logical operator. If any operand of @@ -160,7 +185,7 @@ package SCOs is -- For each decision, a decision line is generated with the form: - -- C* expression + -- C*sloc expression -- Here * is one of the following characters: @@ -169,15 +194,23 @@ package SCOs is -- W decision in WHILE iteration scheme -- X decision appearing in some other expression context + -- For I, E, W, sloc is the source location of the IF, EXIT or WHILE + -- token. + + -- For X, sloc is omitted. + -- The expression is a prefix polish form indicating the structure of -- the decision, including logical operators and short circuit forms. -- The following is a grammar showing the structure of expression: -- expression ::= term (if expr is not logical operator) - -- expression ::= & term term (if expr is AND or AND THEN) - -- expression ::= | term term (if expr is OR or OR ELSE) - -- expression ::= ^ term term (if expr is XOR) - -- expression ::= !term (if expr is NOT) + -- expression ::= &sloc term term (if expr is AND or AND THEN) + -- expression ::= |sloc term term (if expr is OR or OR ELSE) + -- expression ::= ^sloc term term (if expr is XOR) + -- expression ::= !sloc term (if expr is NOT) + + -- In the last four cases, sloc is the source location of the AND, OR, + -- XOR or NOT token, respectively. -- term ::= element -- term ::= expression @@ -194,15 +227,15 @@ package SCOs is -- the compiler as always being true or false. -- & indicates either AND or AND THEN connecting two conditions. In the - -- context of couverture we only permit AND THEN in the source in any + -- context of Couverture we only permit AND THEN in the source in any -- case, so & can always be understood to be AND THEN. -- | indicates either OR or OR ELSE connection two conditions. In the - -- context of couverture we only permit OR ELSE in the source in any + -- context of Couverture we only permit OR ELSE in the source in any -- case, so | can always be understood to be OR ELSE. -- ^ indicates XOR connecting two conditions. In the context of - -- couverture, we do not permit XOR, so this will never appear. + -- Couverture, we do not permit XOR, so this will never appear. -- ! indicates NOT applied to the expression. @@ -235,41 +268,34 @@ package SCOs is -- The SCO_Table_Entry values appear as follows: -- Statements - -- C1 = 'S' - -- C2 = ' ' + -- C1 = 'S' for entry point, 's' otherwise + -- C2 = 't', 's', 'o', 'r', 'i', 'C', 'F', 'R', ' ' + -- (type/subtype/object/renaming/instantiation/CASE/FOR/RETURN) -- From = starting source location -- To = ending source location - -- Last = unused - - -- Exit - -- C1 = 'T' - -- C2 = ' ' - -- From = starting source location - -- To = ending source location - -- Last = unused + -- Last = False for all but the last entry, True for last entry - -- Simple Decision - -- C1 = 'I', 'E', 'W', 'X' (if/exit/while/expression) - -- C2 = 'c', 't', or 'f' - -- From = starting source location - -- To = ending source location - -- Last = True + -- Note: successive statements (possibly interspersed with entries of + -- other kinds, that are ignored for this purpose), starting with one + -- labeled with C1 = 'S', up to and including the first one labeled with + -- Last=True, indicate the sequence to be output for a sequence of + -- statements on a single CS line. - -- Complex Decision + -- Decision -- C1 = 'I', 'E', 'W', 'X' (if/exit/while/expression) -- C2 = ' ' - -- From = No_Source_Location + -- From = location of IF/EXIT/WHILE token, No_Source_Location for X -- To = No_Source_Location - -- Last = False + -- Last = unused -- Operator -- C1 = '!', '^', '&', '|' -- C2 = ' ' - -- From = No_Source_Location + -- From = location of NOT/XOR/AND/OR token -- To = No_Source_Location -- Last = False - -- Element + -- Element (condition) -- C1 = ' ' -- C2 = 'c', 't', or 'f' (condition/true/false) -- From = starting source location diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 071d38fdb45..caa73a0b82c 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -612,6 +612,7 @@ package body Sem is N_SCIL_Dispatch_Table_Object_Init | N_SCIL_Dispatch_Table_Tag_Init | N_SCIL_Dispatching_Call | + N_SCIL_Membership_Test | N_SCIL_Tag_Init => null; diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 840214d2c64..da260f35c4a 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -239,8 +239,9 @@ package body Sem_Case is " alternatives must cover base type", Expr, Expr); else - Error_Msg_N ("subtype of expression is not static," & - " alternatives must cover base type!", Expr); + Error_Msg_N + ("subtype of expression is not static," + & " alternatives must cover base type!", Expr); end if; -- Otherwise the expression is not static, even if the bounds of the @@ -249,8 +250,8 @@ package body Sem_Case is elsif not Is_Entity_Name (Expr) then Error_Msg_N - ("subtype of expression is not static, " & - "alternatives must cover base type!", Expr); + ("subtype of expression is not static, " + & "alternatives must cover base type!", Expr); end if; end Explain_Non_Static_Bound; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 170f261a36e..2f614080fdc 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -4000,13 +4000,44 @@ package body Sem_Ch10 is -- If the item is a private with-clause on a child unit, the parent -- may have been installed already, but the child unit must remain - -- invisible until installed in a private part or body. + -- invisible until installed in a private part or body, unless there + -- is already a regular with_clause for it in the current unit. elsif Private_Present (Item) then Id := Entity (Name (Item)); if Is_Child_Unit (Id) then - Set_Is_Visible_Child_Unit (Id, False); + declare + Clause : Node_Id; + + function In_Context return Boolean; + -- Scan context of current unit, to check whether there is + -- a with_clause on the same unit as a private with-clause + -- on a parent, in which case child unit is visible. + + function In_Context return Boolean is + begin + Clause := + First (Context_Items (Cunit (Current_Sem_Unit))); + while Present (Clause) loop + if Nkind (Clause) = N_With_Clause + and then Comes_From_Source (Clause) + and then Is_Entity_Name (Name (Clause)) + and then Entity (Name (Clause)) = Id + and then not Private_Present (Clause) + then + return True; + end if; + + Next (Clause); + end loop; + + return False; + end In_Context; + + begin + Set_Is_Visible_Child_Unit (Id, In_Context); + end; end if; end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 7dd9629da6a..1845e80916c 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -9725,11 +9725,12 @@ package body Sem_Ch3 is New_T := Any_Type; end if; - -- If previous full declaration exists, or if a homograph is present, - -- let Enter_Name handle it, either with an error, or with the removal - -- of an overridden implicit subprogram. + -- If previous full declaration or a renaming declaration exists, or if + -- a homograph is present, let Enter_Name handle it, either with an + -- error or with the removal of an overridden implicit subprogram. if Ekind (Prev) /= E_Constant + or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration or else Present (Expression (Parent (Prev))) or else Present (Full_View (Prev)) then @@ -12418,6 +12419,24 @@ package body Sem_Ch3 is Set_Convention (New_Subp, Convention (Parent_Subp)); end if; + -- Predefined controlled operations retain their name even if the parent + -- is hidden (see above), but they are not primitive operations if the + -- ancestor is not visible, for example if the parent is a private + -- extension completed with a controlled extension. Note that a full + -- type that is controlled can break privacy: the flag Is_Controlled is + -- set on both views of the type. + + if Is_Controlled (Parent_Type) + and then + (Chars (Parent_Subp) = Name_Initialize + or else Chars (Parent_Subp) = Name_Adjust + or else Chars (Parent_Subp) = Name_Finalize) + and then Is_Hidden (Parent_Subp) + and then not Is_Visibly_Controlled (Parent_Type) + then + Set_Is_Hidden (New_Subp); + end if; + Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp)); Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp)); @@ -12493,8 +12512,8 @@ package body Sem_Ch3 is then if No (Actual_Subp) then Set_Alias (New_Subp, Visible_Subp); - Set_Is_Abstract_Subprogram - (New_Subp, True); + Set_Is_Abstract_Subprogram (New_Subp, True); + else -- If this is a derivation for an instance of a formal derived -- type, abstractness comes from the primitive operation of the diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 99c24a12a2e..899b1a05878 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -1251,7 +1251,7 @@ package body Sem_Ch4 is Analyze_Expression (Else_Expr); end if; - if not Is_Overloaded (Then_Expr) then + if not Is_Overloaded (Then_Expr) then Set_Etype (N, Etype (Then_Expr)); else declare diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 94ed69e2598..38b3b01a10b 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1994,61 +1994,7 @@ package body Sem_Ch6 is and then Comes_From_Source (N) and then Is_Protected_Type (Current_Scope) then - declare - Decl : Node_Id; - Plist : List_Id; - Formal : Entity_Id; - New_Spec : Node_Id; - - begin - Formal := First_Formal (Body_Id); - - -- The protected operation always has at least one formal, namely - -- the object itself, but it is only placed in the parameter list - -- if expansion is enabled. - - if Present (Formal) - or else Expander_Active - then - Plist := Copy_Parameter_List (Body_Id); - else - Plist := No_List; - end if; - - if Nkind (Body_Spec) = N_Procedure_Specification then - New_Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Sloc (Body_Id), - Chars => Chars (Body_Id)), - Parameter_Specifications => Plist); - else - New_Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Sloc (Body_Id), - Chars => Chars (Body_Id)), - Parameter_Specifications => Plist, - Result_Definition => - New_Occurrence_Of (Etype (Body_Id), Loc)); - end if; - - Decl := - Make_Subprogram_Declaration (Loc, - Specification => New_Spec); - Insert_Before (N, Decl); - Spec_Id := Defining_Unit_Name (New_Spec); - - -- Indicate that the entity comes from source, to ensure that - -- cross-reference information is properly generated. The body - -- itself is rewritten during expansion, and the body entity will - -- not appear in calls to the operation. - - Set_Comes_From_Source (Spec_Id, True); - Analyze (Decl); - Set_Has_Completion (Spec_Id); - Set_Convention (Spec_Id, Convention_Protected); - end; + Spec_Id := Build_Private_Protected_Declaration (N); end if; -- If a separate spec is present, then deal with freezing issues @@ -2708,10 +2654,13 @@ package body Sem_Ch6 is -- If the type of the first formal of the current subprogram is a -- nongeneric tagged private type, mark the subprogram as being a -- private primitive. Ditto if this is a function with controlling - -- result, and the return type is currently private. + -- result, and the return type is currently private. In both cases, + -- the type of the controlling argument or result must be in the + -- current scope for the operation to be primitive. if Has_Controlling_Result (Designator) and then Is_Private_Type (Etype (Designator)) + and then Scope (Etype (Designator)) = Current_Scope and then not Is_Generic_Actual_Type (Etype (Designator)) then Set_Is_Private_Primitive (Designator); @@ -2723,6 +2672,7 @@ package body Sem_Ch6 is begin Set_Is_Private_Primitive (Designator, Is_Tagged_Type (Formal_Typ) + and then Scope (Formal_Typ) = Current_Scope and then Is_Private_Type (Formal_Typ) and then not Is_Generic_Actual_Type (Formal_Typ)); end; @@ -4454,7 +4404,9 @@ package body Sem_Ch6 is end; end if; - if Present (Overridden_Subp) then + if Present (Overridden_Subp) + and then not Is_Hidden (Overridden_Subp) + then if Must_Not_Override (Spec) then Error_Msg_Sloc := Sloc (Overridden_Subp); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 705f428716a..9c9da627ee0 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -48,7 +48,6 @@ with Sem_Eval; use Sem_Eval; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Snames; use Snames; -with Stand; use Stand; with Sinfo; use Sinfo; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -673,27 +672,6 @@ package body Sem_Disp is Has_Dispatching_Parent : Boolean := False; Body_Is_Last_Primitive : Boolean := False; - function Is_Visibly_Controlled (T : Entity_Id) return Boolean; - -- Check whether T is derived from a visibly controlled type. - -- This is true if the root type is declared in Ada.Finalization. - -- If T is derived instead from a private type whose full view - -- is controlled, an explicit Initialize/Adjust/Finalize subprogram - -- does not override the inherited one. - - --------------------------- - -- Is_Visibly_Controlled -- - --------------------------- - - function Is_Visibly_Controlled (T : Entity_Id) return Boolean is - Root : constant Entity_Id := Root_Type (T); - begin - return Chars (Scope (Root)) = Name_Finalization - and then Chars (Scope (Scope (Root))) = Name_Ada - and then Scope (Scope (Scope (Root))) = Standard_Standard; - end Is_Visibly_Controlled; - - -- Start of processing for Check_Dispatching_Operation - begin if Ekind (Subp) /= E_Procedure and then Ekind (Subp) /= E_Function then return; @@ -1030,8 +1008,25 @@ package body Sem_Disp is and then not Is_Visibly_Controlled (Tagged_Type) then Set_Is_Overriding_Operation (Subp, False); - Error_Msg_NE - ("operation does not override inherited&?", Subp, Subp); + + -- If the subprogram specification carries an overriding + -- indicator, no need for the warning: it is either redundant, + -- or else an error will be reported. + + if Nkind (Parent (Subp)) = N_Procedure_Specification + and then + (Must_Override (Parent (Subp)) + or else Must_Not_Override (Parent (Subp))) + then + null; + + -- Here we need the warning + + else + Error_Msg_NE + ("operation does not override inherited&?", Subp, Subp); + end if; + else Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp); Set_Is_Overriding_Operation (Subp); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 4d56d36ee39..daa08b4e95f 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -596,11 +596,13 @@ package body Sem_Prag is procedure Process_Compile_Time_Warning_Or_Error; -- Common processing for Compile_Time_Error and Compile_Time_Warning - procedure Process_Convention (C : out Convention_Id; E : out Entity_Id); + procedure Process_Convention + (C : out Convention_Id; + Ent : out Entity_Id); -- Common processing for Convention, Interface, Import and Export. -- Checks first two arguments of pragma, and sets the appropriate -- convention value in the specified entity or entities. On return - -- C is the convention, E is the referenced entity. + -- C is the convention, Ent is the referenced entity. procedure Process_Extended_Import_Export_Exception_Pragma (Arg_Internal : Node_Id; @@ -1152,6 +1154,14 @@ package body Sem_Prag is String_Val : constant String_Id := Strval (Nam); begin + -- We allow duplicated export names in CIL, as they are always + -- enclosed in a namespace that differentiates them, and overloaded + -- entities are supported by the VM. + + if VM_Target = CLI_Target then + return; + end if; + -- We are only interested in the export case, and in the case of -- generics, it is the instance, not the template, that is the -- problem (the template will generate a warning in any case). @@ -2347,10 +2357,11 @@ package body Sem_Prag is ------------------------ procedure Process_Convention - (C : out Convention_Id; - E : out Entity_Id) + (C : out Convention_Id; + Ent : out Entity_Id) is Id : Node_Id; + E : Entity_Id; E1 : Entity_Id; Cname : Name_Id; Comp_Unit : Unit_Number_Type; @@ -2482,6 +2493,10 @@ package body Sem_Prag is E := Entity (Id); + -- Set entity to return + + Ent := E; + -- Go to renamed subprogram if present, since convention applies to -- the actual renamed entity, not to the renaming entity. If the -- subprogram is inherited, go to parent subprogram. @@ -2504,6 +2519,10 @@ package body Sem_Prag is and then Scope (E) = Scope (Alias (E)) then E := Alias (E); + + -- Return the parent subprogram the entity was inherited from + + Ent := E; end if; end if; @@ -2617,7 +2636,9 @@ package body Sem_Prag is Generate_Reference (E, Id, 'b'); end if; - E1 := E; + -- Loop through the homonyms of the pragma argument's entity + + E1 := Ent; loop E1 := Homonym (E1); exit when No (E1) or else Scope (E1) /= Current_Scope; @@ -2642,7 +2663,7 @@ package body Sem_Prag is Set_Convention_From_Pragma (E1); if Prag_Id = Pragma_Import then - Generate_Reference (E, Id, 'b'); + Generate_Reference (E1, Id, 'b'); end if; end if; end loop; @@ -3459,6 +3480,8 @@ package body Sem_Prag is else Set_Imported (Def_Id); + -- Reject an Import applied to an abstract subprogram + if Is_Subprogram (Def_Id) and then Is_Abstract_Subprogram (Def_Id) then @@ -5212,9 +5235,13 @@ package body Sem_Prag is -- Annotate -- -------------- - -- pragma Annotate (IDENTIFIER {, ARG}); + -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]); -- ARG ::= NAME | EXPRESSION + -- The first two arguments are by convention intended to refer to an + -- external tool and a tool-specific function. These arguments are + -- not analyzed. + when Pragma_Annotate => Annotate : begin GNAT_Pragma; Check_At_Least_N_Arguments (1); @@ -5225,26 +5252,33 @@ package body Sem_Prag is Exp : Node_Id; begin - Arg := Arg2; - while Present (Arg) loop - Exp := Expression (Arg); - Analyze (Exp); + -- Second unanalyzed parameter is optional - if Is_Entity_Name (Exp) then - null; + if No (Arg2) then + null; + else + Arg := Next (Arg2); + while Present (Arg) loop + Exp := Expression (Arg); + Analyze (Exp); - elsif Nkind (Exp) = N_String_Literal then - Resolve (Exp, Standard_String); + if Is_Entity_Name (Exp) then + null; - elsif Is_Overloaded (Exp) then - Error_Pragma_Arg ("ambiguous argument for pragma%", Exp); + elsif Nkind (Exp) = N_String_Literal then + Resolve (Exp, Standard_String); - else - Resolve (Exp); - end if; + elsif Is_Overloaded (Exp) then + Error_Pragma_Arg + ("ambiguous argument for pragma%", Exp); - Next (Arg); - end loop; + else + Resolve (Exp); + end if; + + Next (Arg); + end loop; + end if; end; end Annotate; @@ -10658,8 +10692,24 @@ package body Sem_Prag is when Pragma_Reviewable => Check_Ada_83_Warning; Check_Arg_Count (0); + + -- Call dummy debugging function rv. This is done to assist front + -- end debugging. By placing a Reviewable pragma in the source + -- program, a breakpoint on rv catches this place in the source, + -- allowing convenient stepping to the point of interest. + rv; + -------------------------- + -- Short_Circuit_And_Or -- + -------------------------- + + when Pragma_Short_Circuit_And_Or => + GNAT_Pragma; + Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + Short_Circuit_And_Or := True; + ------------------- -- Share_Generic -- ------------------- @@ -11979,6 +12029,14 @@ package body Sem_Prag is Check_At_Least_N_Arguments (1); Check_No_Identifiers; + -- If debug flag -gnatd.i is set, pragma is ignored + + if Debug_Flag_Dot_I then + return; + end if; + + -- Process various forms of the pragma + declare Argx : constant Node_Id := Get_Pragma_Arg (Arg1); @@ -12522,6 +12580,7 @@ package body Sem_Prag is Pragma_Restriction_Warnings => -1, Pragma_Restrictions => -1, Pragma_Reviewable => -1, + Pragma_Short_Circuit_And_Or => -1, Pragma_Share_Generic => -1, Pragma_Shared => -1, Pragma_Shared_Passive => -1, diff --git a/gcc/ada/sem_scil.adb b/gcc/ada/sem_scil.adb index cd4e66be554..5adf803fc70 100644 --- a/gcc/ada/sem_scil.adb +++ b/gcc/ada/sem_scil.adb @@ -74,7 +74,9 @@ package body Sem_SCIL is -- Type conversions may involve dispatching calls to functions whose -- associated SCIL dispatching node needs adjustment. - elsif Nkind (Old_Node) = N_Type_Conversion then + elsif Nkind_In (Old_Node, N_Type_Conversion, + N_Unchecked_Type_Conversion) + then null; -- Relocated subprogram call @@ -101,15 +103,58 @@ package body Sem_SCIL is -- Check_SCIL_Node -- --------------------- - -- Is this a good name for the function, given it only deals with - -- N_SCIL_Dispatching_Call case ??? - function Check_SCIL_Node (N : Node_Id) return Traverse_Result is Ctrl_Tag : Node_Id; Ctrl_Typ : Entity_Id; begin - if Nkind (N) = N_SCIL_Dispatching_Call then + if Nkind (N) = N_SCIL_Membership_Test then + + -- Check contents of the boolean expression associated with the + -- membership test. + + pragma Assert (Nkind (SCIL_Related_Node (N)) = N_Identifier + and then Etype (SCIL_Related_Node (N)) = Standard_Boolean); + + -- Check the entity identifier of the associated tagged type (that + -- is, in testing for membership in T'Class, the entity id of the + -- specific type T). + + -- Note: When the SCIL node is generated the private and full-view + -- of the tagged types may have been swapped and hence the node + -- referenced by attribute SCIL_Entity may be the private view. + -- Therefore, in order to uniformily locate the full-view we use + -- attribute Underlying_Type. + + pragma Assert (Is_Tagged_Type (Underlying_Type (SCIL_Entity (N)))); + + -- Interface types are unsupported + + pragma Assert (not Is_Interface (Underlying_Type (SCIL_Entity (N)))); + + -- Check the decoration of the expression that denotes the tag value + -- being tested + + Ctrl_Tag := SCIL_Tag_Value (N); + + case Nkind (Ctrl_Tag) is + + -- For class-wide membership tests the SCIL tag value is the tag + -- of the tested object (i.e. Obj.Tag). + + when N_Selected_Component => + pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag)); + null; + + when others => + pragma Assert (False); + null; + + end case; + + return Skip; + + elsif Nkind (N) = N_SCIL_Dispatching_Call then Ctrl_Tag := SCIL_Controlling_Tag (N); -- SCIL_Related_Node of SCIL dispatching call nodes MUST reference @@ -452,6 +497,7 @@ package body Sem_SCIL is N_SCIL_Dispatch_Table_Object_Init | N_SCIL_Dispatch_Table_Tag_Init | N_SCIL_Dispatching_Call | + N_SCIL_Membership_Test | N_SCIL_Tag_Init => pragma Assert (False); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index cbcbc16588e..e56066b7d4d 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7040,22 +7040,71 @@ package body Sem_Util is function Is_Value_Type (T : Entity_Id) return Boolean is begin return VM_Target = CLI_Target + and then Nkind (T) in N_Has_Chars and then Chars (T) /= No_Name and then Get_Name_String (Chars (T)) = "valuetype"; end Is_Value_Type; ----------------- + -- Is_Delegate -- + ----------------- + + function Is_Delegate (T : Entity_Id) return Boolean is + Desig_Type : Entity_Id; + + begin + if VM_Target /= CLI_Target then + return False; + end if; + + -- Access-to-subprograms are delegates in CIL + + if Ekind (T) = E_Access_Subprogram_Type then + return True; + end if; + + if Ekind (T) not in Access_Kind then + + -- A delegate is a managed pointer. If no designated type is defined + -- it means that it's not a delegate. + + return False; + end if; + + Desig_Type := Etype (Directly_Designated_Type (T)); + + if not Is_Tagged_Type (Desig_Type) then + return False; + end if; + + -- Test if the type is inherited from [mscorlib]System.Delegate + + while Etype (Desig_Type) /= Desig_Type loop + if Chars (Scope (Desig_Type)) /= No_Name + and then Is_Imported (Scope (Desig_Type)) + and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate" + then + return True; + end if; + + Desig_Type := Etype (Desig_Type); + end loop; + + return False; + end Is_Delegate; + + ----------------- -- Is_Variable -- ----------------- function Is_Variable (N : Node_Id) return Boolean is Orig_Node : constant Node_Id := Original_Node (N); - -- We do the test on the original node, since this is basically a - -- test of syntactic categories, so it must not be disturbed by - -- whatever rewriting might have occurred. For example, an aggregate, - -- which is certainly NOT a variable, could be turned into a variable - -- by expansion. + -- We do the test on the original node, since this is basically a test + -- of syntactic categories, so it must not be disturbed by whatever + -- rewriting might have occurred. For example, an aggregate, which is + -- certainly NOT a variable, could be turned into a variable by + -- expansion. function In_Protected_Function (E : Entity_Id) return Boolean; -- Within a protected function, the private components of the @@ -7238,6 +7287,18 @@ package body Sem_Util is end if; end Is_Variable; + --------------------------- + -- Is_Visibly_Controlled -- + --------------------------- + + function Is_Visibly_Controlled (T : Entity_Id) return Boolean is + Root : constant Entity_Id := Root_Type (T); + begin + return Chars (Scope (Root)) = Name_Finalization + and then Chars (Scope (Scope (Root))) = Name_Ada + and then Scope (Scope (Scope (Root))) = Standard_Standard; + end Is_Visibly_Controlled; + ------------------------ -- Is_Volatile_Object -- ------------------------ @@ -11319,7 +11380,15 @@ package body Sem_Util is L : constant Node_Id := Left_Opnd (Op); R : constant Node_Id := Right_Opnd (Op); begin - if Etype (L) = Found_Type + -- The case for the message is when the left operand of the + -- comparison is the same modular type, or when it is an + -- integer literal (or other universal integer expression), + -- which would have been typed as the modular type if the + -- parens had been there. + + if (Etype (L) = Found_Type + or else + Etype (L) = Universal_Integer) and then Is_Integer_Type (Etype (R)) then Error_Msg_N diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 623a72b2782..ed36cf8f3d7 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -210,10 +210,10 @@ package Sem_Util is -- of Old is set and Old has no yet been Frozen (i.e. Is_Frozen is false); function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id; - -- Utility to create a parameter profile for a new subprogram spec, - -- when the subprogram has a body that acts as spec. This is done for - -- some cases of inlining, and for private protected ops. Also used - -- to create bodies for stubbed subprograms. + -- Utility to create a parameter profile for a new subprogram spec, when + -- the subprogram has a body that acts as spec. This is done for some cases + -- of inlining, and for private protected ops. Also used to create bodies + -- for stubbed subprograms. function Current_Entity (N : Node_Id) return Entity_Id; -- Find the currently visible definition for a given identifier, that is to @@ -230,9 +230,9 @@ package Sem_Util is function Current_Subprogram return Entity_Id; -- Returns current enclosing subprogram. If Current_Scope is a subprogram, - -- then that is what is returned, otherwise the Enclosing_Subprogram of - -- the Current_Scope is returned. The returned value is Empty if this - -- is called from a library package which is not within any subprogram. + -- then that is what is returned, otherwise the Enclosing_Subprogram of the + -- Current_Scope is returned. The returned value is Empty if this is called + -- from a library package which is not within any subprogram. function Defining_Entity (N : Node_Id) return Entity_Id; -- Given a declaration N, returns the associated defining entity. If @@ -619,10 +619,9 @@ package Sem_Util is -- corresponding private part must not. procedure Insert_Explicit_Dereference (N : Node_Id); - -- In a context that requires a composite or subprogram type and - -- where a prefix is an access type, rewrite the access type node - -- N (which is the prefix, e.g. of an indexed component) as an - -- explicit dereference. + -- In a context that requires a composite or subprogram type and where a + -- prefix is an access type, rewrite the access type node N (which is the + -- prefix, e.g. of an indexed component) as an explicit dereference. procedure Inspect_Deferred_Constant_Completion (Decls : List_Id); -- Examine all deferred constants in the declaration list Decls and check @@ -630,13 +629,12 @@ package Sem_Util is -- Import pragma. Emit the error message if that is not the case. function Is_AAMP_Float (E : Entity_Id) return Boolean; - -- Defined for all type entities. Returns True only for the base type - -- of float types with AAMP format. The particular format is determined - -- by the Digits_Value value which is 6 for the 32-bit floating point type, - -- or 9 for the 48-bit type. This is not an attribute function (like - -- VAX_Float) in order to not use up an extra flag and to prevent - -- the dependency of Einfo on Targparm which would be required for a - -- synthesized attribute. + -- Defined for all type entities. Returns True only for the base type of + -- float types with AAMP format. The particular format is determined by the + -- Digits_Value value which is 6 for the 32-bit floating point type, or 9 + -- for the 48-bit type. This is not an attribute function (like VAX_Float) + -- in order to not use up an extra flag and to prevent the dependency of + -- Einfo on Targparm which would be required for a synthesized attribute. function Is_Actual_Out_Parameter (N : Node_Id) return Boolean; -- Determines if N is an actual parameter of out mode in a subprogram call @@ -677,10 +675,10 @@ package Sem_Util is -- False. The nodes passed to this function are assumed to denote objects. function Is_Dereferenced (N : Node_Id) return Boolean; - -- N is a subexpression node of an access type. This function returns - -- true if N appears as the prefix of a node that does a dereference - -- of the access value (selected/indexed component, explicit dereference - -- or a slice), and false otherwise. + -- N is a subexpression node of an access type. This function returns true + -- if N appears as the prefix of a node that does a dereference of the + -- access value (selected/indexed component, explicit dereference or a + -- slice), and false otherwise. function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean; -- Returns True if type T1 is a descendent of type T2, and false otherwise. @@ -721,8 +719,8 @@ package Sem_Util is -- i.e. a library unit or an entity declared in a library package. function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean; - -- Determines whether Expr is a reference to a variable or IN OUT - -- mode parameter of the current enclosing subprogram. + -- Determines whether Expr is a reference to a variable or IN OUT mode + -- parameter of the current enclosing subprogram. -- Why are OUT parameters not considered here ??? function Is_Object_Reference (N : Node_Id) return Boolean; @@ -737,12 +735,11 @@ package Sem_Util is -- target are considered view conversions and hence variables. function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean; - -- Typ is a type entity. This function returns true if this type is - -- partly initialized, meaning that an object of the type is at least - -- partly initialized (in particular in the record case, that at least - -- one component has an initialization expression). Note that - -- initialization resulting from the use of pragma Normalized_Scalars does - -- not count. + -- Typ is a type entity. This function returns true if this type is partly + -- initialized, meaning that an object of the type is at least partly + -- initialized (in particular in the record case, that at least one + -- component has an initialization expression). Note that initialization + -- resulting from the use of pragma Normalized_Scalars does not count. function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean; -- Determines if type T is a potentially persistent type. A potentially @@ -799,24 +796,35 @@ package Sem_Util is function Is_Value_Type (T : Entity_Id) return Boolean; -- Returns true if type T represents a value type. This is only relevant to - -- CIL, will always return false for other targets. - -- What is a "value type", since this is not an Ada term, it should be - -- defined here ??? + -- CIL, will always return false for other targets. A value type is a CIL + -- object that is accessed directly, as opposed to the other CIL objects + -- that are accessed through managed pointers. + + function Is_Delegate (T : Entity_Id) return Boolean; + -- Returns true if type T represents a delegate. A Delegate is the CIL + -- object used to represent access-to-subprogram types. This is only + -- relevant to CIL, will always return false for other targets. function Is_Variable (N : Node_Id) return Boolean; - -- Determines if the tree referenced by N represents a variable, i.e. - -- can appear on the left side of an assignment. There is one situation, - -- namely formal parameters, in which non-tagged type conversions are - -- also considered variables, but Is_Variable returns False for such - -- cases, since it has no knowledge of the context. Note that this is - -- the point at which Assignment_OK is checked, and True is returned - -- for any tree thus marked. + -- Determines if the tree referenced by N represents a variable, i.e. can + -- appear on the left side of an assignment. There is one situation (formal + -- parameters) in which non-tagged type conversions are also considered + -- variables, but Is_Variable returns False for such cases, since it has + -- no knowledge of the context. Note that this is the point at which + -- Assignment_OK is checked, and True is returned for any tree thus marked. + + function Is_Visibly_Controlled (T : Entity_Id) return Boolean; + -- Check whether T is derived from a visibly controlled type. This is true + -- if the root type is declared in Ada.Finalization. If T is derived + -- instead from a private type whose full view is controlled, an explicit + -- Initialize/Adjust/Finalize subprogram does not override the inherited + -- one. function Is_Volatile_Object (N : Node_Id) return Boolean; - -- Determines if the given node denotes an volatile object in the sense - -- of the legality checks described in RM C.6(12). Note that the test - -- here is for something actually declared as volatile, not for an object - -- that gets treated as volatile (see Einfo.Treat_As_Volatile). + -- Determines if the given node denotes an volatile object in the sense of + -- the legality checks described in RM C.6(12). Note that the test here is + -- for something actually declared as volatile, not for an object that gets + -- treated as volatile (see Einfo.Treat_As_Volatile). procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False); -- This procedure is called to clear all constant indications from all @@ -854,8 +862,8 @@ package Sem_Util is procedure Kill_Size_Check_Code (E : Entity_Id); -- Called when an address clause or pragma Import is applied to an entity. -- If the entity is a variable or a constant, and size check code is - -- present, this size check code is killed, since the object will not - -- be allocated by the program. + -- present, this size check code is killed, since the object will not be + -- allocated by the program. function Known_To_Be_Assigned (N : Node_Id) return Boolean; -- The node N is an entity reference. This function determines whether the diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index abfdf1ff668..580ba9aedc0 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -2992,8 +2992,10 @@ package body Sem_Warn is Warn_On_Object_Renames_Function := True; Warn_On_Obsolescent_Feature := True; Warn_On_Overlap := True; + Warn_On_Parameter_Order := True; Warn_On_Questionable_Missing_Parens := True; Warn_On_Redundant_Constructs := True; + Warn_On_Reverse_Bit_Order := True; Warn_On_Unchecked_Conversion := True; Warn_On_Unrecognized_Pragma := True; Warn_On_Unrepped_Components := True; @@ -3032,6 +3034,12 @@ package body Sem_Warn is when 'R' => Warn_On_Object_Renames_Function := False; + when 'v' => + Warn_On_Reverse_Bit_Order := True; + + when 'V' => + Warn_On_Reverse_Bit_Order := False; + when 'w' => Warn_On_Warnings_Off := True; @@ -3084,6 +3092,7 @@ package body Sem_Warn is Warn_On_Obsolescent_Feature := True; Warn_On_Questionable_Missing_Parens := True; Warn_On_Redundant_Constructs := True; + Warn_On_Reverse_Bit_Order := False; Warn_On_Object_Renames_Function := True; Warn_On_Unchecked_Conversion := True; Warn_On_Unrecognized_Pragma := True; @@ -3120,11 +3129,13 @@ package body Sem_Warn is Warn_On_Parameter_Order := True; Warn_On_Questionable_Missing_Parens := True; Warn_On_Redundant_Constructs := True; + Warn_On_Reverse_Bit_Order := True; Warn_On_Unchecked_Conversion := True; Warn_On_Unrecognized_Pragma := True; Warn_On_Unrepped_Components := True; when 'A' => + Address_Clause_Overlay_Warnings := False; Check_Unreferenced := False; Check_Unreferenced_Formals := False; Check_Withs := False; @@ -3133,6 +3144,7 @@ package body Sem_Warn is Implementation_Unit_Warnings := False; Ineffective_Inline_Warnings := False; Warn_On_Ada_2005_Compatibility := False; + Warn_On_All_Unread_Out_Parameters := False; Warn_On_Assertion_Failure := False; Warn_On_Assumed_Low_Bound := False; Warn_On_Bad_Fixed_Value := False; @@ -3145,13 +3157,13 @@ package body Sem_Warn is Warn_On_Modified_Unread := False; Warn_On_No_Value_Assigned := False; Warn_On_Non_Local_Exception := False; + Warn_On_Object_Renames_Function := False; Warn_On_Obsolescent_Feature := False; Warn_On_Overlap := False; - Warn_On_All_Unread_Out_Parameters := False; Warn_On_Parameter_Order := False; Warn_On_Questionable_Missing_Parens := False; Warn_On_Redundant_Constructs := False; - Warn_On_Object_Renames_Function := False; + Warn_On_Reverse_Bit_Order := False; Warn_On_Unchecked_Conversion := False; Warn_On_Unrecognized_Pragma := False; Warn_On_Unrepped_Components := False; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index dd4aaafce9a..f4c171cebf7 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1481,6 +1481,14 @@ package body Sinfo is return Flag11 (N); end Has_Wide_Character; + function Has_Wide_Wide_Character + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_String_Literal); + return Flag13 (N); + end Has_Wide_Wide_Character; + function Hidden_By_Use_Clause (N : Node_Id) return Elist_Id is begin @@ -1588,7 +1596,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Parameter_Association); - return Flag12 (N); + return Flag13 (N); end Is_Accessibility_Actual; function Is_Asynchronous_Call_Block @@ -2556,6 +2564,7 @@ package body Sinfo is or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init or else NT (N).Nkind = N_SCIL_Dispatching_Call + or else NT (N).Nkind = N_SCIL_Membership_Test or else NT (N).Nkind = N_SCIL_Tag_Init); return Node4 (N); end SCIL_Entity; @@ -2567,10 +2576,19 @@ package body Sinfo is or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init or else NT (N).Nkind = N_SCIL_Dispatching_Call + or else NT (N).Nkind = N_SCIL_Membership_Test or else NT (N).Nkind = N_SCIL_Tag_Init); return Node1 (N); end SCIL_Related_Node; + function SCIL_Tag_Value + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_SCIL_Membership_Test); + return Node5 (N); + end SCIL_Tag_Value; + function SCIL_Target_Prim (N : Node_Id) return Node_Id is begin @@ -4341,6 +4359,14 @@ package body Sinfo is Set_Flag11 (N, Val); end Set_Has_Wide_Character; + procedure Set_Has_Wide_Wide_Character + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_String_Literal); + Set_Flag13 (N, Val); + end Set_Has_Wide_Wide_Character; + procedure Set_Hidden_By_Use_Clause (N : Node_Id; Val : Elist_Id) is begin @@ -4448,7 +4474,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Parameter_Association); - Set_Flag12 (N, Val); + Set_Flag13 (N, Val); end Set_Is_Accessibility_Actual; procedure Set_Is_Asynchronous_Call_Block @@ -5416,6 +5442,7 @@ package body Sinfo is or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init or else NT (N).Nkind = N_SCIL_Dispatching_Call + or else NT (N).Nkind = N_SCIL_Membership_Test or else NT (N).Nkind = N_SCIL_Tag_Init); Set_Node4 (N, Val); -- semantic field, no parent set end Set_SCIL_Entity; @@ -5427,10 +5454,19 @@ package body Sinfo is or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init or else NT (N).Nkind = N_SCIL_Dispatching_Call + or else NT (N).Nkind = N_SCIL_Membership_Test or else NT (N).Nkind = N_SCIL_Tag_Init); Set_Node1 (N, Val); -- semantic field, no parent set end Set_SCIL_Related_Node; + procedure Set_SCIL_Tag_Value + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_SCIL_Membership_Test); + Set_Node5 (N, Val); -- semantic field, no parent set + end Set_SCIL_Tag_Value; + procedure Set_SCIL_Target_Prim (N : Node_Id; Val : Node_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 2e666c49a64..bb6012904a9 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -462,10 +462,18 @@ package Sinfo is -- reasons. -- Comes_From_Source (Flag2) - -- This flag is on for any nodes built by the scanner or parser from the - -- source program, and off for any nodes built by the analyzer or - -- expander. It indicates that a node comes from the original source. - -- This flag is defined in Atree. + -- This flag is set if the node comes directly from an explicit construct + -- in the source. It is normally on for any nodes built by the scanner or + -- parser from the source program, with the exception that in a few cases + -- the parser adds nodes to normalize the representation (in particular + -- a null statement is added to a package body if there is no begin/end + -- initialization section. + -- + -- Most nodes inserted by the analyzer or expander are not considered + -- as coming from source, so the flag is off for such nodes. In a few + -- cases, the expander constructs nodes closely equivalent to nodes + -- from the source program (e.g. the allocator built for build-in-place + -- case), and the Comes_From_Source flag is deliberately set. -- Error_Posted (Flag3) -- This flag is used to avoid multiple error messages being posted on or @@ -1149,7 +1157,13 @@ package Sinfo is -- Has_Wide_Character (Flag11-Sem) -- Present in string literals, set if any wide character (i.e. character - -- code outside the Character range) appears in the string. + -- code outside the Character range but within Wide_Character range) + -- appears in the string. Used to implement pragma preference rules. + + -- Has_Wide_Wide_Character (Flag13-Sem) + -- Present in string literals, set if any wide character (i.e. character + -- code outside the Wide_Character range) appears in the string. Used to + -- implement pragma preference rules. -- Hidden_By_Use_Clause (Elist4-Sem) -- An entity list present in use clauses that appear within @@ -1608,6 +1622,10 @@ package Sinfo is -- Present in N_SCIL_Dispatching_Call nodes. Used to reference the -- controlling tag of a dispatching call. + -- SCIL_Tag_Value (Node5-Sem) + -- Present in N_SCIL_Membership_Test nodes. Used to reference the tag + -- value that is being tested. + -- SCIL_Target_Prim (Node2-Sem) -- Present in N_SCIL_Dispatching_Call nodes. Used to reference the tagged -- type primitive associated with the SCIL node. @@ -1933,6 +1951,7 @@ package Sinfo is -- Sloc points to literal -- Strval (Str3) contains Id of string value -- Has_Wide_Character (Flag11-Sem) + -- Has_Wide_Wide_Character (Flag13-Sem) -- Is_Folded_In_Parser (Flag4) -- plus fields for expression @@ -4457,7 +4476,7 @@ package Sinfo is -- Selector_Name (Node2) (always non-Empty) -- Explicit_Actual_Parameter (Node3) -- Next_Named_Actual (Node4-Sem) - -- Is_Accessibility_Actual (Flag12-Sem) + -- Is_Accessibility_Actual (Flag13-Sem) --------------------------- -- 6.4 Actual Parameter -- @@ -6886,6 +6905,12 @@ package Sinfo is -- SCIL_Entity (Node4-Sem) -- SCIL_Controlling_Tag (Node5-Sem) + -- N_SCIL_Membership_Test + -- Sloc references the node of a membership test + -- SCIL_Related_Node (Node1-Sem) + -- SCIL_Tag_Value (Node5-Sem) + -- SCIL_Entity (Node4-Sem) + -- N_SCIL_Tag_Init -- Sloc references the node of a tag component initialization -- SCIL_Related_Node (Node1-Sem) @@ -7333,6 +7358,7 @@ package Sinfo is N_SCIL_Dispatch_Table_Object_Init, N_SCIL_Dispatch_Table_Tag_Init, N_SCIL_Dispatching_Call, + N_SCIL_Membership_Test, N_SCIL_Tag_Init, -- Other nodes (not part of any subtype class) @@ -8048,6 +8074,9 @@ package Sinfo is function Has_Wide_Character (N : Node_Id) return Boolean; -- Flag11 + function Has_Wide_Wide_Character + (N : Node_Id) return Boolean; -- Flag13 + function Hidden_By_Use_Clause (N : Node_Id) return Elist_Id; -- Elist4 @@ -8079,7 +8108,7 @@ package Sinfo is (N : Node_Id) return Uint; -- Uint3 function Is_Accessibility_Actual - (N : Node_Id) return Boolean; -- Flag12 + (N : Node_Id) return Boolean; -- Flag13 function Is_Asynchronous_Call_Block (N : Node_Id) return Boolean; -- Flag7 @@ -8390,6 +8419,9 @@ package Sinfo is function SCIL_Related_Node (N : Node_Id) return Node_Id; -- Node1 + function SCIL_Tag_Value + (N : Node_Id) return Node_Id; -- Node5 + function SCIL_Target_Prim (N : Node_Id) return Node_Id; -- Node2 @@ -8960,6 +8992,9 @@ package Sinfo is procedure Set_Has_Wide_Character (N : Node_Id; Val : Boolean := True); -- Flag11 + procedure Set_Has_Wide_Wide_Character + (N : Node_Id; Val : Boolean := True); -- Flag13 + procedure Set_Hidden_By_Use_Clause (N : Node_Id; Val : Elist_Id); -- Elist4 @@ -8991,7 +9026,7 @@ package Sinfo is (N : Node_Id; Val : Uint); -- Uint3 procedure Set_Is_Accessibility_Actual - (N : Node_Id; Val : Boolean := True); -- Flag12 + (N : Node_Id; Val : Boolean := True); -- Flag13 procedure Set_Is_Asynchronous_Call_Block (N : Node_Id; Val : Boolean := True); -- Flag7 @@ -9302,6 +9337,9 @@ package Sinfo is procedure Set_SCIL_Related_Node (N : Node_Id; Val : Node_Id); -- Node1 + procedure Set_SCIL_Tag_Value + (N : Node_Id; Val : Node_Id); -- Node5 + procedure Set_SCIL_Target_Prim (N : Node_Id; Val : Node_Id); -- Node2 @@ -11056,6 +11094,13 @@ package Sinfo is 4 => False, -- SCIL_Entity (Node4-Sem) 5 => False), -- SCIL_Controlling_Tag (Node5-Sem) + N_SCIL_Membership_Test => + (1 => False, -- SCIL_Related_Node (Node1-Sem) + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- SCIL_Entity (Node4-Sem) + 5 => False), -- SCIL_Tag_Value (Node5-Sem) + N_SCIL_Tag_Init => (1 => False, -- SCIL_Related_Node (Node1-Sem) 2 => False, -- unused @@ -11250,6 +11295,7 @@ package Sinfo is pragma Inline (Has_Task_Info_Pragma); pragma Inline (Has_Task_Name_Pragma); pragma Inline (Has_Wide_Character); + pragma Inline (Has_Wide_Wide_Character); pragma Inline (Hidden_By_Use_Clause); pragma Inline (High_Bound); pragma Inline (Identifier); @@ -11364,6 +11410,7 @@ package Sinfo is pragma Inline (SCIL_Controlling_Tag); pragma Inline (SCIL_Entity); pragma Inline (SCIL_Related_Node); + pragma Inline (SCIL_Tag_Value); pragma Inline (SCIL_Target_Prim); pragma Inline (Scope); pragma Inline (Select_Alternatives); @@ -11550,6 +11597,7 @@ package Sinfo is pragma Inline (Set_Has_Task_Info_Pragma); pragma Inline (Set_Has_Task_Name_Pragma); pragma Inline (Set_Has_Wide_Character); + pragma Inline (Set_Has_Wide_Wide_Character); pragma Inline (Set_Hidden_By_Use_Clause); pragma Inline (Set_High_Bound); pragma Inline (Set_Identifier); @@ -11664,6 +11712,7 @@ package Sinfo is pragma Inline (Set_SCIL_Controlling_Tag); pragma Inline (Set_SCIL_Entity); pragma Inline (Set_SCIL_Related_Node); + pragma Inline (Set_SCIL_Tag_Value); pragma Inline (Set_SCIL_Target_Prim); pragma Inline (Set_Scope); pragma Inline (Set_Select_Alternatives); diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 9057759cb3f..8195cdbb5e2 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -383,6 +383,7 @@ package Snames is Name_Restrictions : constant Name_Id := N + $; Name_Restriction_Warnings : constant Name_Id := N + $; -- GNAT Name_Reviewable : constant Name_Id := N + $; + Name_Short_Circuit_And_Or : constant Name_Id := N + $; -- GNAT Name_Source_File_Name : constant Name_Id := N + $; -- GNAT Name_Source_File_Name_Project : constant Name_Id := N + $; -- GNAT Name_Style_Checks : constant Name_Id := N + $; -- GNAT @@ -1033,10 +1034,12 @@ package Snames is Name_Compiler : constant Name_Id := N + $; Name_Compiler_Command : constant Name_Id := N + $; -- GPR Name_Config_Body_File_Name : constant Name_Id := N + $; + Name_Config_Body_File_Name_Index : constant Name_Id := N + $; Name_Config_Body_File_Name_Pattern : constant Name_Id := N + $; Name_Config_File_Switches : constant Name_Id := N + $; Name_Config_File_Unique : constant Name_Id := N + $; Name_Config_Spec_File_Name : constant Name_Id := N + $; + Name_Config_Spec_File_Name_Index : constant Name_Id := N + $; Name_Config_Spec_File_Name_Pattern : constant Name_Id := N + $; Name_Configuration : constant Name_Id := N + $; Name_Cross_Reference : constant Name_Id := N + $; @@ -1103,6 +1106,8 @@ package Snames is Name_Mapping_Body_Suffix : constant Name_Id := N + $; Name_Max_Command_Line_Length : constant Name_Id := N + $; Name_Metrics : constant Name_Id := N + $; + Name_Multi_Unit_Object_Separator : constant Name_Id := N + $; + Name_Multi_Unit_Switches : constant Name_Id := N + $; Name_Naming : constant Name_Id := N + $; Name_None : constant Name_Id := N + $; Name_Object_File_Suffix : constant Name_Id := N + $; @@ -1450,6 +1455,7 @@ package Snames is Pragma_Restrictions, Pragma_Restriction_Warnings, Pragma_Reviewable, + Pragma_Short_Circuit_And_Or, Pragma_Source_File_Name, Pragma_Source_File_Name_Project, Pragma_Style_Checks, diff --git a/gcc/ada/socket.c b/gcc/ada/socket.c index df3b1206428..76755643161 100644 --- a/gcc/ada/socket.c +++ b/gcc/ada/socket.c @@ -35,11 +35,24 @@ #ifdef VMS /* * For VMS, gsocket.h can't include sockets-related DEC C header files - * when building the runtime (because these files are in DEC C archives, - * not accessable to GCC). So, we generate a separate header file along - * with s-oscons.ads and include it here. + * when building the runtime (because these files are in a DEC C text library + * (DECC$RTLDEF.TLB) not accessable to GCC). So, we generate a separate header + * file along with s-oscons.ads and include it here. */ # include "s-oscons.h" + +/* + * We also need the declaration of struct servent, which s-oscons can't + * provide, so we copy it manually here. This needs to be kept in synch + * with the definition of that structure in the DEC C headers, which + * hopefully won't change frequently. + */ +struct servent { + char *s_name; /* official service name */ + char **s_aliases; /* alias list */ + int s_port; /* port # */ + char *s_proto; /* protocol to use */ +}; #endif #if defined(HAVE_SOCKETS) @@ -74,6 +87,14 @@ extern void __gnat_remove_socket_from_set (fd_set *, int); extern void __gnat_reset_socket_set (fd_set *); extern int __gnat_get_h_errno (void); extern int __gnat_socket_ioctl (int, int, int *); +extern char * __gnat_servent_s_name (struct servent *); +extern char ** __gnat_servent_s_aliases (struct servent *); +extern int __gnat_servent_s_port (struct servent *); +extern char * __gnat_servent_s_proto (struct servent *); +extern void __gnat_servent_set_s_name (struct servent *, char *); +extern void __gnat_servent_set_s_aliases (struct servent *, char **); +extern void __gnat_servent_set_s_port (struct servent *, int); +extern void __gnat_servent_set_s_proto (struct servent *, char *); #if defined (__vxworks) || defined (_WIN32) extern int __gnat_inet_pton (int, const char *, void *); #endif @@ -488,6 +509,88 @@ __gnat_inet_pton (int af, const char *src, void *dst) { } #endif +/* + * Accessor functions for struct servent. + * + * These are needed because servent has different representations on different + * platforms, and we don't want to deal with that on the Ada side. For example, + * on Linux, we have (see /usr/include netdb.h): + * + * struct servent + * { + * char *s_name; + * char **s_aliases; + * int s_port; + * char *s_proto; + * }; + * + * and on Windows (see mingw's socket.h): + * + * struct servent { + * char *s_name; + * char **s_aliases; + * #ifdef _WIN64 + * char *s_proto; + * short s_port; + * #else + * short s_port; + * char *s_proto; + * #endif + * }; + */ + +/* Getters */ + +char * +__gnat_servent_s_name (struct servent * s) +{ + return s->s_name; +} + +char ** +__gnat_servent_s_aliases (struct servent * s) +{ + return s->s_aliases; +} + +int +__gnat_servent_s_port (struct servent * s) +{ + return s->s_port; +} + +char * +__gnat_servent_s_proto (struct servent * s) +{ + return s->s_proto; +} + +/* Setters */ + +void +__gnat_servent_set_s_name (struct servent * s, char * s_name) +{ + s->s_name = s_name; +} + +void +__gnat_servent_set_s_aliases (struct servent * s, char ** s_aliases) +{ + s->s_aliases = s_aliases; +} + +void +__gnat_servent_set_s_port (struct servent * s, int s_port) +{ + s->s_port = s_port; +} + +void +__gnat_servent_set_s_proto (struct servent * s, char * s_proto) +{ + s->s_proto = s_proto; +} + #else # warning Sockets are not supported on this platform #endif /* defined(HAVE_SOCKETS) */ diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index e73d204d758..cc9d5a081f1 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -35,6 +35,7 @@ with Nlists; use Nlists; with Opt; use Opt; with Output; use Output; with Rtsfind; use Rtsfind; +with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinput; use Sinput; @@ -526,7 +527,7 @@ package body Sprint is Write_Eol; end Underline; - -- Start of processing for Tree_Dump + -- Start of processing for Source_Dump begin Dump_Generated_Only := Debug_Flag_G or @@ -2651,6 +2652,9 @@ package body Sprint is when N_SCIL_Dispatching_Call => Write_Indent_Str ("[N_SCIL_Dispatching_Node]"); + when N_SCIL_Membership_Test => + Write_Indent_Str ("[N_SCIL_Membership_Test]"); + when N_SCIL_Tag_Init => Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]"); @@ -3961,7 +3965,7 @@ package body Sprint is when E_String_Literal_Subtype => declare LB : constant Uint := - Intval (String_Literal_Low_Bound (Typ)); + Expr_Value (String_Literal_Low_Bound (Typ)); Len : constant Uint := String_Literal_Length (Typ); begin diff --git a/gcc/ada/switch-m.ads b/gcc/ada/switch-m.ads index a7301761f93..6a800234083 100644 --- a/gcc/ada/switch-m.ads +++ b/gcc/ada/switch-m.ads @@ -43,8 +43,9 @@ package Switch.M is -- consists of one small letter causes a fatal error exit and control does -- not return. For all other not recognized switches, Success is set to -- False, so that the switch may be passed to the compiler. + -- -- Project_Node_Tree is used to store tree-specific parameters like the - -- project path + -- project path. procedure Normalize_Compiler_Switches (Switch_Chars : String; diff --git a/gcc/ada/system-vxworks-ppc.ads b/gcc/ada/system-vxworks-ppc.ads index d355bae9700..38a9def0f6e 100644 --- a/gcc/ada/system-vxworks-ppc.ads +++ b/gcc/ada/system-vxworks-ppc.ads @@ -5,7 +5,7 @@ -- S Y S T E M -- -- -- -- S p e c -- --- (VxWorks 5 Version PPC) -- +-- (VxWorks 5 and MILS Version PPC) -- -- -- -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 541496c5df8..8b0d0cba4e3 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -38,10 +38,10 @@ procedure Usage is procedure Write_Switch_Char (Sw : String; Prefix : String := "gnat"); -- Output two spaces followed by the switch character minus followed - -- Prefix, followed by the string given as the argument, and then - -- enough blanks to tab to column 13, i.e. assuming Sw is not longer - -- than 5 characters, the maximum allowed, Write_Switch_Char will - -- always output exactly 12 characters. + -- Prefix, followed by the string given as the argument, and then enough + -- blanks to tab to column 13, i.e. assuming Sw is not longer than 5 + -- characters, the maximum allowed, Write_Switch_Char will always output + -- exactly 12 characters. ----------------------- -- Write_Switch_Char -- @@ -397,9 +397,9 @@ begin Write_Switch_Char ("wxx"); Write_Line ("Enable selected warning modes, xx = list of parameters:"); - Write_Line (" a turn on all optional warnings " & + Write_Line (" a turn on all optional info/warnings " & "(except dhl.ot.w)"); - Write_Line (" A turn off all optional warnings"); + Write_Line (" A turn off all optional info/warnings"); Write_Line (" .a* turn on warnings for failing assertion"); Write_Line (" .A turn off warnings for failing assertion"); Write_Line (" b turn on warnings for bad fixed value " & @@ -414,8 +414,9 @@ begin Write_Line (" .C* turn off warnings for unrepped components"); Write_Line (" d turn on warnings for implicit dereference"); Write_Line (" D* turn off warnings for implicit dereference"); - Write_Line (" e treat all warnings as errors"); - Write_Line (" .e turn on every optional warning (no exceptions)"); + Write_Line (" e treat all warnings (but not info) as errors"); + Write_Line (" .e turn on every optional info/warning " & + "(no exceptions)"); Write_Line (" f turn on warnings for unreferenced formal"); Write_Line (" F* turn off warnings for unreferenced formal"); Write_Line (" g* turn on warnings for unrecognized pragma"); @@ -465,18 +466,20 @@ begin Write_Line (" R* turn off warnings for redundant construct"); Write_Line (" .r turn on warnings for object renaming function"); Write_Line (" .R* turn off warnings for object renaming function"); - Write_Line (" s suppress all warnings"); + Write_Line (" s suppress all info/warnings"); Write_Line (" t turn on warnings for tracking deleted code"); Write_Line (" T* turn off warnings for tracking deleted code"); Write_Line (" u turn on warnings for unused entity"); Write_Line (" U* turn off warnings for unused entity"); Write_Line (" v* turn on warnings for unassigned variable"); Write_Line (" V turn off warnings for unassigned variable"); + Write_Line (" .v* turn on info messages for reverse bit order"); + Write_Line (" .V turn off info messages for reverse bit order"); Write_Line (" w* turn on warnings for wrong low bound assumption"); Write_Line (" W turn off warnings for wrong low bound " & "assumption"); Write_Line (" .w turn on warnings on pragma Warnings Off"); - Write_Line (" .w* turn off warnings on pragma Warnings Off"); + Write_Line (" .W* turn off warnings on pragma Warnings Off"); Write_Line (" x* turn on warnings for export/import"); Write_Line (" X turn off warnings for export/import"); Write_Line (" .x turn on warnings for non-local exception"); diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index aac1c783c23..6f4ae0f65f0 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -1933,6 +1933,13 @@ package VMS_Data is -- -- Do not look for library files in the system default directory. + S_GCC_NoWarnP : aliased constant S := "/NOWARNING_PRAGMAS " & + "-gnatd.i"; + -- /NOWARNING_PRAGMAS + -- + -- Causes all Warnings pragmas to be ignored. Useful to check if the + -- program has obsolete warnings pragmas that are hiding problems. + S_GCC_Opt : aliased constant S := "/OPTIMIZE=" & "ALL " & "-O2,!-O0,!-O1,!-O3 " & @@ -2976,6 +2983,10 @@ package VMS_Data is "-gnatwv " & "NOVARIABLES_UNINITIALIZED " & "-gnatwV " & + "REVERSE_BIT_ORDER " & + "-gnatw.v " & + "NOREVERSE_BIT_ORDER " & + "-gnatw.V " & "LOWBOUND_ASSUMED " & "-gnatww " & "NOLOWBOUND_ASSUMED " & @@ -3473,6 +3484,7 @@ package VMS_Data is S_GCC_Noload 'Access, S_GCC_Nostinc 'Access, S_GCC_Nostlib 'Access, + S_GCC_NoWarnP 'Access, S_GCC_Opt 'Access, S_GCC_OptX 'Access, S_GCC_Pointer 'Access, diff --git a/gcc/ada/xoscons.adb b/gcc/ada/xoscons.adb index 83b726b6b9b..afe05efd651 100644 --- a/gcc/ada/xoscons.adb +++ b/gcc/ada/xoscons.adb @@ -72,12 +72,15 @@ procedure XOSCons is end record; type Asm_Info_Kind is - (CND, -- Constant (decimal) - CNS, -- Constant (freeform string) + (CND, -- Named number (decimal) + CNS, -- Named number (freeform text) + C, -- Constant object TXT); -- Literal text -- Recognized markers found in assembly file. These markers are produced by -- the same-named macros from the C template. + subtype Named_Number is Asm_Info_Kind range CND .. CNS; + type Asm_Info (Kind : Asm_Info_Kind := TXT) is record Line_Number : Integer; -- Line number in C source file @@ -85,11 +88,14 @@ procedure XOSCons is Constant_Name : String_Access; -- Name of constant to be defined + Constant_Type : String_Access; + -- Type of constant (case of Kind = C) + Value_Len : Natural := 0; -- Length of text representation of constant's value Text_Value : String_Access; - -- Value for CNS constant + -- Value for CNS / C constant Int_Value : Int_Value_Type; -- Value for CND constant @@ -105,8 +111,9 @@ procedure XOSCons is Table_Initial => 100, Table_Increment => 10); - Max_Const_Name_Len : Natural := 0; + Max_Constant_Name_Len : Natural := 0; Max_Constant_Value_Len : Natural := 0; + Max_Constant_Type_Len : Natural := 0; -- Lengths of longest name and longest value type Language is (Lang_Ada, Lang_C); @@ -170,13 +177,22 @@ procedure XOSCons is case Lang is when Lang_Ada => Put (" " & Info.Constant_Name.all); - Put (Spaces (Max_Const_Name_Len - Info.Constant_Name'Length)); + Put (Spaces (Max_Constant_Name_Len + - Info.Constant_Name'Length)); - Put (" : constant := "); + if Info.Kind in Named_Number then + Put (" : constant := "); + else + Put (" : constant " & Info.Constant_Type.all); + Put (Spaces (Max_Constant_Type_Len + - Info.Constant_Type'Length)); + Put (" := "); + end if; when Lang_C => Put ("#define " & Info.Constant_Name.all & " "); - Put (Spaces (Max_Const_Name_Len - Info.Constant_Name'Length)); + Put (Spaces (Max_Constant_Name_Len + - Info.Constant_Name'Length)); end case; if Info.Kind = CND then @@ -185,7 +201,19 @@ procedure XOSCons is end if; Put (Trim (Info.Int_Value.Abs_Value'Img, Side => Left)); else - Put (Info.Text_Value.all); + declare + Is_String : constant Boolean := + Info.Kind = C + and then Info.Constant_Type.all = "String"; + begin + if Is_String then + Put (""""); + end if; + Put (Info.Text_Value.all); + if Is_String then + Put (""""); + end if; + end; end if; if Lang = Lang_Ada then @@ -290,18 +318,28 @@ procedure XOSCons is Integer (Parse_Int (Line (Index1 .. Index2 - 1)).Abs_Value); case Info.Kind is - when CND | CNS => + when CND | CNS | C => Index1 := Index2 + 1; Find_Colon (Index2); Info.Constant_Name := Field_Alloc; - if Info.Constant_Name'Length > Max_Const_Name_Len then - Max_Const_Name_Len := Info.Constant_Name'Length; + if Info.Constant_Name'Length > Max_Constant_Name_Len then + Max_Constant_Name_Len := Info.Constant_Name'Length; end if; Index1 := Index2 + 1; Find_Colon (Index2); + if Info.Kind = C then + Info.Constant_Type := Field_Alloc; + if Info.Constant_Type'Length > Max_Constant_Type_Len then + Max_Constant_Type_Len := Info.Constant_Type'Length; + end if; + + Index1 := Index2 + 1; + Find_Colon (Index2); + end if; + if Info.Kind = CND then Info.Int_Value := Parse_Int (Line (Index1 .. Index2 - 1)); Info.Value_Len := Index2 - Index1 - 1; diff --git a/gcc/cgraph.h b/gcc/cgraph.h index 1017176ff3f..d79d3e4d86b 100644 --- a/gcc/cgraph.h +++ b/gcc/cgraph.h @@ -310,6 +310,8 @@ typedef enum { } cgraph_inline_failed_t; struct GTY((chain_next ("%h.next_caller"), chain_prev ("%h.prev_caller"))) cgraph_edge { + /* Expected number of executions: calculated in profile.c. */ + gcov_type count; struct cgraph_node *caller; struct cgraph_node *callee; struct cgraph_edge *prev_caller; @@ -317,29 +319,27 @@ struct GTY((chain_next ("%h.next_caller"), chain_prev ("%h.prev_caller"))) cgrap struct cgraph_edge *prev_callee; struct cgraph_edge *next_callee; gimple call_stmt; - /* The stmt_uid of this call stmt. This is used by LTO to recover - the call_stmt when the function is serialized in. */ - unsigned int lto_stmt_uid; PTR GTY ((skip (""))) aux; /* When equal to CIF_OK, inline this call. Otherwise, points to the explanation why function was not inlined. */ cgraph_inline_failed_t inline_failed; - /* Expected number of executions: calculated in profile.c. */ - gcov_type count; + /* The stmt_uid of call_stmt. This is used by LTO to recover the call_stmt + when the function is serialized in. */ + unsigned int lto_stmt_uid; /* Expected frequency of executions within the function. When set to CGRAPH_FREQ_BASE, the edge is expected to be called once per function call. The range is 0 to CGRAPH_FREQ_MAX. */ int frequency; + /* Unique id of the edge. */ + int uid; /* Depth of loop nest, 1 means no loop nest. */ - unsigned int loop_nest : 30; + unsigned short int loop_nest; /* Whether this edge describes a call that was originally indirect. */ unsigned int indirect_call : 1; /* True if the corresponding CALL stmt cannot be inlined. */ unsigned int call_stmt_cannot_inline_p : 1; /* Can this call throw externally? */ unsigned int can_throw_external : 1; - /* Unique id of the edge. */ - int uid; }; #define CGRAPH_FREQ_BASE 1000 diff --git a/gcc/cgraphunit.c b/gcc/cgraphunit.c index e3825433d87..51ead06bc4a 100644 --- a/gcc/cgraphunit.c +++ b/gcc/cgraphunit.c @@ -135,6 +135,7 @@ along with GCC; see the file COPYING3. If not see #include "tree-dump.h" #include "output.h" #include "coverage.h" +#include "plugin.h" static void cgraph_expand_all_functions (void); static void cgraph_mark_functions_to_output (void); @@ -1712,6 +1713,8 @@ ipa_passes (void) gimple_register_cfg_hooks (); bitmap_obstack_initialize (NULL); + invoke_plugin_callbacks (PLUGIN_ALL_IPA_PASSES_START, NULL); + if (!in_lto_p) execute_ipa_pass_list (all_small_ipa_passes); @@ -1730,7 +1733,8 @@ ipa_passes (void) current_function_decl = NULL; cgraph_process_new_functions (); - execute_ipa_summary_passes ((struct ipa_opt_pass_d *) all_regular_ipa_passes); + execute_ipa_summary_passes + ((struct ipa_opt_pass_d *) all_regular_ipa_passes); } execute_ipa_summary_passes ((struct ipa_opt_pass_d *) all_lto_gen_passes); @@ -1739,6 +1743,7 @@ ipa_passes (void) if (!flag_ltrans) execute_ipa_pass_list (all_regular_ipa_passes); + invoke_plugin_callbacks (PLUGIN_ALL_IPA_PASSES_END, NULL); bitmap_obstack_release (NULL); } diff --git a/gcc/config.in b/gcc/config.in index fbc9fbb9288..681e4f8bd48 100644 --- a/gcc/config.in +++ b/gcc/config.in @@ -1634,6 +1634,13 @@ #endif +/* Define if you want to generate code by default that assumes that the Cygwin + DLL exports wrappers to support libstdc++ function replacement. */ +#ifndef USED_FOR_TARGET +#undef USE_CYGWIN_LIBSTDCXX_WRAPPERS +#endif + + /* Define to 1 if the 'long long' (or '__int64') is wider than 'long' but still efficiently supported by the host hardware. */ #ifndef USED_FOR_TARGET diff --git a/gcc/config/arm/arm.h b/gcc/config/arm/arm.h index 3f349547a92..691a8600e0a 100644 --- a/gcc/config/arm/arm.h +++ b/gcc/config/arm/arm.h @@ -1275,7 +1275,7 @@ enum reg_class In general this is just CLASS, but for the Thumb core registers and immediate constants we prefer a LO_REGS class or a subset. */ #define PREFERRED_RELOAD_CLASS(X, CLASS) \ - (TARGET_ARM ? (CLASS) : \ + (TARGET_32BIT ? (CLASS) : \ ((CLASS) == GENERAL_REGS || (CLASS) == HI_REGS \ || (CLASS) == NO_REGS || (CLASS) == STACK_REG \ ? LO_REGS : (CLASS))) diff --git a/gcc/config/i386/abmintrin.h b/gcc/config/i386/abmintrin.h new file mode 100644 index 00000000000..b85bdb77348 --- /dev/null +++ b/gcc/config/i386/abmintrin.h @@ -0,0 +1,70 @@ +/* Copyright (C) 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. + + Under Section 7 of GPL version 3, you are granted additional + permissions described in the GCC Runtime Library Exception, version + 3.1, as published by the Free Software Foundation. + + You should have received a copy of the GNU General Public License and + a copy of the GCC Runtime Library Exception along with this program; + see the files COPYING3 and COPYING.RUNTIME respectively. If not, see + <http://www.gnu.org/licenses/>. */ + +#ifndef _X86INTRIN_H_INCLUDED +# error "Never use <abmintrin.h> directly; include <x86intrin.h> instead." +#endif + +#ifndef __ABM__ +# error "ABM instruction set not enabled" +#endif /* __ABM__ */ + +#ifndef _ABMINTRIN_H_INCLUDED +#define _ABMINTRIN_H_INCLUDED + +extern __inline unsigned short __attribute__((__gnu_inline__, __always_inline__, __artificial__)) +__lzcnt16 (unsigned short __X) +{ + return __builtin_clzs (__X); +} + +extern __inline unsigned int __attribute__((__gnu_inline__, __always_inline__, __artificial__)) +__lzcnt (unsigned int __X) +{ + return __builtin_clz (__X); +} + +#ifdef __x86_64__ +extern __inline unsigned long __attribute__((__gnu_inline__, __always_inline__, __artificial__)) +__lzcnt64 (unsigned long __X) +{ + return __builtin_clzl (__X); +} +#endif + +/* Calculate a number of bits set to 1. */ +extern __inline int __attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_popcnt_u32 (unsigned int __X) +{ + return __builtin_popcount (__X); +} + +#ifdef __x86_64__ +extern __inline long long __attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_popcnt_u64 (unsigned long long __X) +{ + return __builtin_popcountll (__X); +} +#endif + +#endif /* _ABMINTRIN_H_INCLUDED */ diff --git a/gcc/config/i386/cygming.opt b/gcc/config/i386/cygming.opt index e845a0d5827..72dfc3401bb 100644 --- a/gcc/config/i386/cygming.opt +++ b/gcc/config/i386/cygming.opt @@ -1,6 +1,6 @@ ; Cygwin- and MinGW-specific options. -; Copyright (C) 2005, 2007 Free Software Foundation, Inc. +; Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. ; ; This file is part of GCC. ; @@ -49,3 +49,7 @@ Create GUI application mpe-aligned-commons Target Var(use_pe_aligned_common) Init(HAVE_GAS_ALIGNED_COMM) Use the GNU extension to the PE format for aligned common data + +muse-libstdc-wrappers +Target Condition({defined (USE_CYGWIN_LIBSTDCXX_WRAPPERS)}) +Compile code that relies on Cygwin DLL wrappers to support C++ operator new/delete replacement diff --git a/gcc/config/i386/cygwin.h b/gcc/config/i386/cygwin.h index 8eb21da4948..86eff635ae6 100644 --- a/gcc/config/i386/cygwin.h +++ b/gcc/config/i386/cygwin.h @@ -85,9 +85,41 @@ along with GCC; see the file COPYING3. If not see %{mwindows:-lgdi32 -lcomdlg32} \ -luser32 -lkernel32 -ladvapi32 -lshell32" +/* To implement C++ function replacement we always wrap the cxx + malloc-like operators. See N2800 #17.6.4.6 [replacement.functions] */ +#define CXX_WRAP_SPEC_LIST "%{!static: %{!static-libstdc++: \ + --wrap _Znwj \ + --wrap _Znaj \ + --wrap _ZdlPv \ + --wrap _ZdaPv \ + --wrap _ZnwjRKSt9nothrow_t \ + --wrap _ZnajRKSt9nothrow_t \ + --wrap _ZdlPvRKSt9nothrow_t \ + --wrap _ZdaPvRKSt9nothrow_t \ + }}" + +#if defined (USE_CYGWIN_LIBSTDCXX_WRAPPERS) + +#if USE_CYGWIN_LIBSTDCXX_WRAPPERS +/* Default on, only explict -mno disables. */ +#define CXX_WRAP_SPEC_OPT "!mno-use-libstdc-wrappers" +#else +/* Default off, only explict -m enables. */ +#define CXX_WRAP_SPEC_OPT "muse-libstdc-wrappers" +#endif + +#define CXX_WRAP_SPEC "%{" CXX_WRAP_SPEC_OPT ":" CXX_WRAP_SPEC_LIST "}" + +#else /* !defined (USE_CYGWIN_LIBSTDCXX_WRAPPERS) */ + +#define CXX_WRAP_SPEC "" + +#endif /* ?defined (USE_CYGWIN_LIBSTDCXX_WRAPPERS) */ + #define LINK_SPEC "\ %{mwindows:--subsystem windows} \ %{mconsole:--subsystem console} \ + " CXX_WRAP_SPEC " \ %{shared: %{mdll: %eshared and mdll are not compatible}} \ %{shared: --shared} %{mdll:--dll} \ %{static:-Bstatic} %{!static:-Bdynamic} \ diff --git a/gcc/config/i386/i386-builtin-types.def b/gcc/config/i386/i386-builtin-types.def index 9f45a13cc31..e9e4d0c4c83 100644 --- a/gcc/config/i386/i386-builtin-types.def +++ b/gcc/config/i386/i386-builtin-types.def @@ -142,6 +142,7 @@ DEF_FUNCTION_TYPE (INT64, INT64) DEF_FUNCTION_TYPE (INT64, V2DF) DEF_FUNCTION_TYPE (INT64, V4SF) DEF_FUNCTION_TYPE (UINT64, INT) +DEF_FUNCTION_TYPE (UINT16, UINT16) DEF_FUNCTION_TYPE (UINT64, PUNSIGNED) DEF_FUNCTION_TYPE (V16QI, PCCHAR) DEF_FUNCTION_TYPE (V16QI, V16QI) @@ -351,6 +352,8 @@ DEF_FUNCTION_TYPE (V2UDI, V2UDI, V2UDI, V2UDI) DEF_FUNCTION_TYPE (V4USI, V4USI, V4USI, V4USI) DEF_FUNCTION_TYPE (V8UHI, V8UHI, V8UHI, V8UHI) DEF_FUNCTION_TYPE (V16UQI, V16UQI, V16UQI, V16UQI) +DEF_FUNCTION_TYPE (V4DF, V4DF, V4DF, V4DI) +DEF_FUNCTION_TYPE (V8SF, V8SF, V8SF, V8SI) DEF_FUNCTION_TYPE (V2DI, V2DI, V2DI, UINT, UINT) DEF_FUNCTION_TYPE (V4HI, HI, HI, HI, HI) diff --git a/gcc/config/i386/i386-c.c b/gcc/config/i386/i386-c.c index 5a5311fba0f..cba9ceb19ae 100644 --- a/gcc/config/i386/i386-c.c +++ b/gcc/config/i386/i386-c.c @@ -236,6 +236,8 @@ ix86_target_macros_internal (int isa_flag, def_or_undef (parse_in, "__XOP__"); if (isa_flag & OPTION_MASK_ISA_LWP) def_or_undef (parse_in, "__LWP__"); + if (isa_flag & OPTION_MASK_ISA_ABM) + def_or_undef (parse_in, "__ABM__"); if ((fpmath & FPMATH_SSE) && (isa_flag & OPTION_MASK_ISA_SSE)) def_or_undef (parse_in, "__SSE_MATH__"); if ((fpmath & FPMATH_SSE) && (isa_flag & OPTION_MASK_ISA_SSE2)) diff --git a/gcc/config/i386/i386-protos.h b/gcc/config/i386/i386-protos.h index 88acc1f82a6..1451e799fa6 100644 --- a/gcc/config/i386/i386-protos.h +++ b/gcc/config/i386/i386-protos.h @@ -48,6 +48,7 @@ extern bool x86_extended_reg_mentioned_p (rtx); extern enum machine_mode ix86_cc_mode (enum rtx_code, rtx, rtx); extern int avx_vpermilp_parallel (rtx par, enum machine_mode mode); +extern int avx_vperm2f128_parallel (rtx par, enum machine_mode mode); extern int ix86_expand_movmem (rtx, rtx, rtx, rtx, rtx, rtx); extern int ix86_expand_setmem (rtx, rtx, rtx, rtx, rtx, rtx); @@ -85,6 +86,7 @@ extern void ix86_expand_binary_operator (enum rtx_code, enum machine_mode, rtx[]); extern int ix86_binary_operator_ok (enum rtx_code, enum machine_mode, rtx[]); extern bool ix86_lea_for_add_ok (enum rtx_code, rtx, rtx[]); +extern bool ix86_vec_interleave_v2df_operator_ok (rtx operands[3], bool high); extern bool ix86_dep_by_shift_count (const_rtx set_insn, const_rtx use_insn); extern bool ix86_agi_dependent (rtx set_insn, rtx use_insn); extern void ix86_expand_unary_operator (enum rtx_code, enum machine_mode, diff --git a/gcc/config/i386/i386.c b/gcc/config/i386/i386.c index 37fe24f6798..462f2d55648 100644 --- a/gcc/config/i386/i386.c +++ b/gcc/config/i386/i386.c @@ -13849,6 +13849,19 @@ ix86_unary_operator_ok (enum rtx_code code ATTRIBUTE_UNUSED, return TRUE; } +/* Return TRUE if the operands to a vec_interleave_{high,low}v2df + are ok, keeping in mind the possible movddup alternative. */ + +bool +ix86_vec_interleave_v2df_operator_ok (rtx operands[3], bool high) +{ + if (MEM_P (operands[0])) + return rtx_equal_p (operands[0], operands[1 + high]); + if (MEM_P (operands[1]) && MEM_P (operands[2])) + return TARGET_SSE3 && rtx_equal_p (operands[1], operands[2]); + return true; +} + /* Post-reload splitter for converting an SF or DFmode value in an SSE register into an unsigned SImode. */ @@ -21047,6 +21060,8 @@ enum ix86_builtins IX86_BUILTIN_VEC_PERM_V4SI_U, IX86_BUILTIN_VEC_PERM_V8HI_U, IX86_BUILTIN_VEC_PERM_V16QI_U, + IX86_BUILTIN_VEC_PERM_V4DF, + IX86_BUILTIN_VEC_PERM_V8SF, /* FMA4 and XOP instructions. */ IX86_BUILTIN_VFMADDSS, @@ -21239,6 +21254,8 @@ enum ix86_builtins IX86_BUILTIN_LWPINS32, IX86_BUILTIN_LWPINS64, + IX86_BUILTIN_CLZS, + IX86_BUILTIN_MAX }; @@ -21478,11 +21495,11 @@ static const struct builtin_description bdesc_special_args[] = { OPTION_MASK_ISA_AVX, CODE_FOR_avx_vzeroall, "__builtin_ia32_vzeroall", IX86_BUILTIN_VZEROALL, UNKNOWN, (int) VOID_FTYPE_VOID }, { OPTION_MASK_ISA_AVX, CODE_FOR_avx_vzeroupper, "__builtin_ia32_vzeroupper", IX86_BUILTIN_VZEROUPPER, UNKNOWN, (int) VOID_FTYPE_VOID }, - { OPTION_MASK_ISA_AVX, CODE_FOR_avx_vbroadcastss, "__builtin_ia32_vbroadcastss", IX86_BUILTIN_VBROADCASTSS, UNKNOWN, (int) V4SF_FTYPE_PCFLOAT }, - { OPTION_MASK_ISA_AVX, CODE_FOR_avx_vbroadcastsd256, "__builtin_ia32_vbroadcastsd256", IX86_BUILTIN_VBROADCASTSD256, UNKNOWN, (int) V4DF_FTYPE_PCDOUBLE }, - { OPTION_MASK_ISA_AVX, CODE_FOR_avx_vbroadcastss256, "__builtin_ia32_vbroadcastss256", IX86_BUILTIN_VBROADCASTSS256, UNKNOWN, (int) V8SF_FTYPE_PCFLOAT }, - { OPTION_MASK_ISA_AVX, CODE_FOR_avx_vbroadcastf128_pd256, "__builtin_ia32_vbroadcastf128_pd256", IX86_BUILTIN_VBROADCASTPD256, UNKNOWN, (int) V4DF_FTYPE_PCV2DF }, - { OPTION_MASK_ISA_AVX, CODE_FOR_avx_vbroadcastf128_ps256, "__builtin_ia32_vbroadcastf128_ps256", IX86_BUILTIN_VBROADCASTPS256, UNKNOWN, (int) V8SF_FTYPE_PCV4SF }, + { OPTION_MASK_ISA_AVX, CODE_FOR_vec_dupv4sf, "__builtin_ia32_vbroadcastss", IX86_BUILTIN_VBROADCASTSS, UNKNOWN, (int) V4SF_FTYPE_PCFLOAT }, + { OPTION_MASK_ISA_AVX, CODE_FOR_vec_dupv4df, "__builtin_ia32_vbroadcastsd256", IX86_BUILTIN_VBROADCASTSD256, UNKNOWN, (int) V4DF_FTYPE_PCDOUBLE }, + { OPTION_MASK_ISA_AVX, CODE_FOR_vec_dupv8sf, "__builtin_ia32_vbroadcastss256", IX86_BUILTIN_VBROADCASTSS256, UNKNOWN, (int) V8SF_FTYPE_PCFLOAT }, + { OPTION_MASK_ISA_AVX, CODE_FOR_avx_vbroadcastf128_v4df, "__builtin_ia32_vbroadcastf128_pd256", IX86_BUILTIN_VBROADCASTPD256, UNKNOWN, (int) V4DF_FTYPE_PCV2DF }, + { OPTION_MASK_ISA_AVX, CODE_FOR_avx_vbroadcastf128_v8sf, "__builtin_ia32_vbroadcastf128_ps256", IX86_BUILTIN_VBROADCASTPS256, UNKNOWN, (int) V8SF_FTYPE_PCV4SF }, { OPTION_MASK_ISA_AVX, CODE_FOR_avx_movupd256, "__builtin_ia32_loadupd256", IX86_BUILTIN_LOADUPD256, UNKNOWN, (int) V4DF_FTYPE_PCDOUBLE }, { OPTION_MASK_ISA_AVX, CODE_FOR_avx_movups256, "__builtin_ia32_loadups256", IX86_BUILTIN_LOADUPS256, UNKNOWN, (int) V8SF_FTYPE_PCFLOAT }, @@ -21520,6 +21537,8 @@ static const struct builtin_description bdesc_special_args[] = { OPTION_MASK_ISA_LWP, CODE_FOR_lwp_lwpinssi3, "__builtin_ia32_lwpins32", IX86_BUILTIN_LWPINS64, UNKNOWN, (int) UCHAR_FTYPE_UINT_UINT_UINT }, { OPTION_MASK_ISA_LWP, CODE_FOR_lwp_lwpinsdi3, "__builtin_ia32_lwpins64", IX86_BUILTIN_LWPINS64, UNKNOWN, (int) UCHAR_FTYPE_UINT64_UINT_UINT }, + { OPTION_MASK_ISA_ABM, CODE_FOR_clzhi2_abm, "__builtin_clzs", IX86_BUILTIN_CLZS, UNKNOWN, (int) UINT16_FTYPE_UINT16 }, + }; /* Builtins with variable number of arguments. */ @@ -21722,7 +21741,7 @@ static const struct builtin_description bdesc_args[] = { OPTION_MASK_ISA_SSE2, CODE_FOR_sse2_shufpd, "__builtin_ia32_shufpd", IX86_BUILTIN_SHUFPD, UNKNOWN, (int) V2DF_FTYPE_V2DF_V2DF_INT }, { OPTION_MASK_ISA_SSE2, CODE_FOR_nothing, "__builtin_ia32_vec_perm_v2df", IX86_BUILTIN_VEC_PERM_V2DF, UNKNOWN, (int) V2DF_FTYPE_V2DF_V2DF_V2DI }, - { OPTION_MASK_ISA_SSE2, CODE_FOR_nothing, "__builtin_ia32_vec_perm_v4sf", IX86_BUILTIN_VEC_PERM_V4SF, UNKNOWN, (int) V4SF_FTYPE_V4SF_V4SF_V4SI }, + { OPTION_MASK_ISA_SSE, CODE_FOR_nothing, "__builtin_ia32_vec_perm_v4sf", IX86_BUILTIN_VEC_PERM_V4SF, UNKNOWN, (int) V4SF_FTYPE_V4SF_V4SF_V4SI }, { OPTION_MASK_ISA_SSE2, CODE_FOR_nothing, "__builtin_ia32_vec_perm_v2di", IX86_BUILTIN_VEC_PERM_V2DI, UNKNOWN, (int) V2DI_FTYPE_V2DI_V2DI_V2DI }, { OPTION_MASK_ISA_SSE2, CODE_FOR_nothing, "__builtin_ia32_vec_perm_v4si", IX86_BUILTIN_VEC_PERM_V4SI, UNKNOWN, (int) V4SI_FTYPE_V4SI_V4SI_V4SI }, { OPTION_MASK_ISA_SSE2, CODE_FOR_nothing, "__builtin_ia32_vec_perm_v8hi", IX86_BUILTIN_VEC_PERM_V8HI, UNKNOWN, (int) V8HI_FTYPE_V8HI_V8HI_V8HI }, @@ -21731,6 +21750,8 @@ static const struct builtin_description bdesc_args[] = { OPTION_MASK_ISA_SSE2, CODE_FOR_nothing, "__builtin_ia32_vec_perm_v4si_u", IX86_BUILTIN_VEC_PERM_V4SI_U, UNKNOWN, (int) V4USI_FTYPE_V4USI_V4USI_V4USI }, { OPTION_MASK_ISA_SSE2, CODE_FOR_nothing, "__builtin_ia32_vec_perm_v8hi_u", IX86_BUILTIN_VEC_PERM_V8HI_U, UNKNOWN, (int) V8UHI_FTYPE_V8UHI_V8UHI_V8UHI }, { OPTION_MASK_ISA_SSE2, CODE_FOR_nothing, "__builtin_ia32_vec_perm_v16qi_u", IX86_BUILTIN_VEC_PERM_V16QI_U, UNKNOWN, (int) V16UQI_FTYPE_V16UQI_V16UQI_V16UQI }, + { OPTION_MASK_ISA_AVX, CODE_FOR_nothing, "__builtin_ia32_vec_perm_v4df", IX86_BUILTIN_VEC_PERM_V4DF, UNKNOWN, (int) V4DF_FTYPE_V4DF_V4DF_V4DI }, + { OPTION_MASK_ISA_AVX, CODE_FOR_nothing, "__builtin_ia32_vec_perm_v8sf", IX86_BUILTIN_VEC_PERM_V8SF, UNKNOWN, (int) V8SF_FTYPE_V8SF_V8SF_V8SI }, { OPTION_MASK_ISA_SSE2, CODE_FOR_sse2_movmskpd, "__builtin_ia32_movmskpd", IX86_BUILTIN_MOVMSKPD, UNKNOWN, (int) INT_FTYPE_V2DF }, { OPTION_MASK_ISA_SSE2, CODE_FOR_sse2_pmovmskb, "__builtin_ia32_pmovmskb128", IX86_BUILTIN_PMOVMSKB128, UNKNOWN, (int) INT_FTYPE_V16QI }, @@ -23342,6 +23363,7 @@ ix86_expand_args_builtin (const struct builtin_description *d, case FLOAT_FTYPE_FLOAT: case INT_FTYPE_INT: case UINT64_FTYPE_INT: + case UINT16_FTYPE_UINT16: case INT64_FTYPE_INT64: case INT64_FTYPE_V4SF: case INT64_FTYPE_V2DF: @@ -24151,6 +24173,8 @@ ix86_expand_builtin (tree exp, rtx target, rtx subtarget ATTRIBUTE_UNUSED, case IX86_BUILTIN_VEC_PERM_V4SI_U: case IX86_BUILTIN_VEC_PERM_V8HI_U: case IX86_BUILTIN_VEC_PERM_V16QI_U: + case IX86_BUILTIN_VEC_PERM_V4DF: + case IX86_BUILTIN_VEC_PERM_V8SF: return ix86_expand_vec_perm_builtin (exp); case IX86_BUILTIN_INFQ: @@ -24591,7 +24615,7 @@ avx_vpermilp_parallel (rtx par, enum machine_mode mode) if (!CONST_INT_P (er)) return 0; ei = INTVAL (er); - if (ei >= nelt) + if (ei >= 2 * nelt) return 0; ipar[i] = ei; } @@ -24640,6 +24664,58 @@ avx_vpermilp_parallel (rtx par, enum machine_mode mode) /* Make sure success has a non-zero value by adding one. */ return mask + 1; } + +/* Helper for avx_vperm2f128_v4df_operand et al. This is also used by + the expansion functions to turn the parallel back into a mask. + The return value is 0 for no match and the imm8+1 for a match. */ + +int +avx_vperm2f128_parallel (rtx par, enum machine_mode mode) +{ + unsigned i, nelt = GET_MODE_NUNITS (mode), nelt2 = nelt / 2; + unsigned mask = 0; + unsigned char ipar[8]; + + if (XVECLEN (par, 0) != (int) nelt) + return 0; + + /* Validate that all of the elements are constants, and not totally + out of range. Copy the data into an integral array to make the + subsequent checks easier. */ + for (i = 0; i < nelt; ++i) + { + rtx er = XVECEXP (par, 0, i); + unsigned HOST_WIDE_INT ei; + + if (!CONST_INT_P (er)) + return 0; + ei = INTVAL (er); + if (ei >= 2 * nelt) + return 0; + ipar[i] = ei; + } + + /* Validate that the halves of the permute are halves. */ + for (i = 0; i < nelt2 - 1; ++i) + if (ipar[i] + 1 != ipar[i + 1]) + return 0; + for (i = nelt2; i < nelt - 1; ++i) + if (ipar[i] + 1 != ipar[i + 1]) + return 0; + + /* Reconstruct the mask. */ + for (i = 0; i < 2; ++i) + { + unsigned e = ipar[i * nelt2]; + if (e % nelt2) + return 0; + e /= nelt2; + mask |= e << (i * 4); + } + + /* Make sure success has a non-zero value by adding one. */ + return mask + 1; +} /* Store OPERAND to the memory after reload is completed. This means @@ -25655,6 +25731,16 @@ ix86_rtx_costs (rtx x, int code, int outer_code_i, int *total, bool speed) *total = 0; return false; + case VEC_SELECT: + case VEC_CONCAT: + case VEC_MERGE: + case VEC_DUPLICATE: + /* ??? Assume all of these vector manipulation patterns are + recognizable. In which case they all pretty much have the + same cost. */ + *total = COSTS_N_INSNS (1); + return true; + default: return false; } @@ -26489,16 +26575,43 @@ x86_emit_floatuns (rtx operands[2]) emit_label (donelab); } +/* AVX does not support 32-byte integer vector operations, + thus the longest vector we are faced with is V16QImode. */ +#define MAX_VECT_LEN 16 + +struct expand_vec_perm_d +{ + rtx target, op0, op1; + unsigned char perm[MAX_VECT_LEN]; + enum machine_mode vmode; + unsigned char nelt; + bool testing_p; +}; + +static bool expand_vec_perm_1 (struct expand_vec_perm_d *d); +static bool expand_vec_perm_broadcast_1 (struct expand_vec_perm_d *d); + +/* Get a vector mode of the same size as the original but with elements + twice as wide. This is only guaranteed to apply to integral vectors. */ + +static inline enum machine_mode +get_mode_wider_vector (enum machine_mode o) +{ + /* ??? Rely on the ordering that genmodes.c gives to vectors. */ + enum machine_mode n = GET_MODE_WIDER_MODE (o); + gcc_assert (GET_MODE_NUNITS (o) == GET_MODE_NUNITS (n) * 2); + gcc_assert (GET_MODE_SIZE (o) == GET_MODE_SIZE (n)); + return n; +} + /* A subroutine of ix86_expand_vector_init. Store into TARGET a vector with all elements equal to VAR. Return true if successful. */ -/* ??? Call into the vec_perm support to implement the broadcast. */ static bool ix86_expand_vector_init_duplicate (bool mmx_ok, enum machine_mode mode, rtx target, rtx val) { - enum machine_mode hmode, smode, wsmode, wvmode; - rtx x; + bool ok; switch (mode) { @@ -26508,13 +26621,28 @@ ix86_expand_vector_init_duplicate (bool mmx_ok, enum machine_mode mode, return false; /* FALLTHRU */ + case V4DFmode: + case V4DImode: + case V8SFmode: + case V8SImode: case V2DFmode: case V2DImode: case V4SFmode: case V4SImode: - val = force_reg (GET_MODE_INNER (mode), val); - x = gen_rtx_VEC_DUPLICATE (mode, val); - emit_insn (gen_rtx_SET (VOIDmode, target, x)); + { + rtx insn, dup; + + /* First attempt to recognize VAL as-is. */ + dup = gen_rtx_VEC_DUPLICATE (mode, val); + insn = emit_insn (gen_rtx_SET (VOIDmode, target, dup)); + if (recog_memoized (insn) < 0) + { + /* If that fails, force VAL into a register. */ + XEXP (dup, 0) = force_reg (GET_MODE_INNER (mode), val); + ok = recog_memoized (insn) >= 0; + gcc_assert (ok); + } + } return true; case V4HImode: @@ -26522,130 +26650,87 @@ ix86_expand_vector_init_duplicate (bool mmx_ok, enum machine_mode mode, return false; if (TARGET_SSE || TARGET_3DNOW_A) { + rtx x; + val = gen_lowpart (SImode, val); x = gen_rtx_TRUNCATE (HImode, val); x = gen_rtx_VEC_DUPLICATE (mode, x); emit_insn (gen_rtx_SET (VOIDmode, target, x)); return true; } - else - { - smode = HImode; - wsmode = SImode; - wvmode = V2SImode; - goto widen; - } + goto widen; case V8QImode: if (!mmx_ok) return false; - smode = QImode; - wsmode = HImode; - wvmode = V4HImode; goto widen; + case V8HImode: if (TARGET_SSE2) { + struct expand_vec_perm_d dperm; rtx tmp1, tmp2; - /* Extend HImode to SImode using a paradoxical SUBREG. */ + + permute: + memset (&dperm, 0, sizeof (dperm)); + dperm.target = target; + dperm.vmode = mode; + dperm.nelt = GET_MODE_NUNITS (mode); + dperm.op0 = dperm.op1 = gen_reg_rtx (mode); + + /* Extend to SImode using a paradoxical SUBREG. */ tmp1 = gen_reg_rtx (SImode); emit_move_insn (tmp1, gen_lowpart (SImode, val)); - /* Insert the SImode value as low element of V4SImode vector. */ - tmp2 = gen_reg_rtx (V4SImode); - tmp1 = gen_rtx_VEC_MERGE (V4SImode, - gen_rtx_VEC_DUPLICATE (V4SImode, tmp1), - CONST0_RTX (V4SImode), - const1_rtx); - emit_insn (gen_rtx_SET (VOIDmode, tmp2, tmp1)); - /* Cast the V4SImode vector back to a V8HImode vector. */ - tmp1 = gen_reg_rtx (V8HImode); - emit_move_insn (tmp1, gen_lowpart (V8HImode, tmp2)); - /* Duplicate the low short through the whole low SImode word. */ - emit_insn (gen_vec_interleave_lowv8hi (tmp1, tmp1, tmp1)); - /* Cast the V8HImode vector back to a V4SImode vector. */ - tmp2 = gen_reg_rtx (V4SImode); - emit_move_insn (tmp2, gen_lowpart (V4SImode, tmp1)); - /* Replicate the low element of the V4SImode vector. */ - emit_insn (gen_sse2_pshufd (tmp2, tmp2, const0_rtx)); - /* Cast the V2SImode back to V8HImode, and store in target. */ - emit_move_insn (target, gen_lowpart (V8HImode, tmp2)); - return true; + + /* Insert the SImode value as low element of a V4SImode vector. */ + tmp2 = gen_lowpart (V4SImode, dperm.op0); + emit_insn (gen_vec_setv4si_0 (tmp2, CONST0_RTX (V4SImode), tmp1)); + + ok = (expand_vec_perm_1 (&dperm) + || expand_vec_perm_broadcast_1 (&dperm)); + gcc_assert (ok); + return ok; } - smode = HImode; - wsmode = SImode; - wvmode = V4SImode; goto widen; + case V16QImode: if (TARGET_SSE2) - { - rtx tmp1, tmp2; - /* Extend QImode to SImode using a paradoxical SUBREG. */ - tmp1 = gen_reg_rtx (SImode); - emit_move_insn (tmp1, gen_lowpart (SImode, val)); - /* Insert the SImode value as low element of V4SImode vector. */ - tmp2 = gen_reg_rtx (V4SImode); - tmp1 = gen_rtx_VEC_MERGE (V4SImode, - gen_rtx_VEC_DUPLICATE (V4SImode, tmp1), - CONST0_RTX (V4SImode), - const1_rtx); - emit_insn (gen_rtx_SET (VOIDmode, tmp2, tmp1)); - /* Cast the V4SImode vector back to a V16QImode vector. */ - tmp1 = gen_reg_rtx (V16QImode); - emit_move_insn (tmp1, gen_lowpart (V16QImode, tmp2)); - /* Duplicate the low byte through the whole low SImode word. */ - emit_insn (gen_vec_interleave_lowv16qi (tmp1, tmp1, tmp1)); - emit_insn (gen_vec_interleave_lowv16qi (tmp1, tmp1, tmp1)); - /* Cast the V16QImode vector back to a V4SImode vector. */ - tmp2 = gen_reg_rtx (V4SImode); - emit_move_insn (tmp2, gen_lowpart (V4SImode, tmp1)); - /* Replicate the low element of the V4SImode vector. */ - emit_insn (gen_sse2_pshufd (tmp2, tmp2, const0_rtx)); - /* Cast the V2SImode back to V16QImode, and store in target. */ - emit_move_insn (target, gen_lowpart (V16QImode, tmp2)); - return true; - } - smode = QImode; - wsmode = HImode; - wvmode = V8HImode; + goto permute; goto widen; + widen: /* Replicate the value once into the next wider mode and recurse. */ - val = convert_modes (wsmode, smode, val, true); - x = expand_simple_binop (wsmode, ASHIFT, val, - GEN_INT (GET_MODE_BITSIZE (smode)), - NULL_RTX, 1, OPTAB_LIB_WIDEN); - val = expand_simple_binop (wsmode, IOR, val, x, x, 1, OPTAB_LIB_WIDEN); - - x = gen_reg_rtx (wvmode); - if (!ix86_expand_vector_init_duplicate (mmx_ok, wvmode, x, val)) - gcc_unreachable (); - emit_move_insn (target, gen_lowpart (mode, x)); - return true; + { + enum machine_mode smode, wsmode, wvmode; + rtx x; + + smode = GET_MODE_INNER (mode); + wvmode = get_mode_wider_vector (mode); + wsmode = GET_MODE_INNER (wvmode); + + val = convert_modes (wsmode, smode, val, true); + x = expand_simple_binop (wsmode, ASHIFT, val, + GEN_INT (GET_MODE_BITSIZE (smode)), + NULL_RTX, 1, OPTAB_LIB_WIDEN); + val = expand_simple_binop (wsmode, IOR, val, x, x, 1, OPTAB_LIB_WIDEN); + + x = gen_lowpart (wvmode, target); + ok = ix86_expand_vector_init_duplicate (mmx_ok, wvmode, x, val); + gcc_assert (ok); + return ok; + } - case V4DFmode: - hmode = V2DFmode; - goto half; - case V4DImode: - hmode = V2DImode; - goto half; - case V8SFmode: - hmode = V4SFmode; - goto half; - case V8SImode: - hmode = V4SImode; - goto half; case V16HImode: - hmode = V8HImode; - goto half; case V32QImode: - hmode = V16QImode; - goto half; -half: { - rtx tmp = gen_reg_rtx (hmode); - ix86_expand_vector_init_duplicate (mmx_ok, hmode, tmp, val); - emit_insn (gen_rtx_SET (VOIDmode, target, - gen_rtx_VEC_CONCAT (mode, tmp, tmp))); + enum machine_mode hvmode = (mode == V16HImode ? V8HImode : V16QImode); + rtx x = gen_reg_rtx (hvmode); + + ok = ix86_expand_vector_init_duplicate (false, hvmode, x, val); + gcc_assert (ok); + + x = gen_rtx_VEC_CONCAT (mode, x, x); + emit_insn (gen_rtx_SET (VOIDmode, target, x)); } return true; @@ -28976,21 +29061,33 @@ ix86_vectorize_builtin_vec_perm (tree vec_type, tree *mask_type) { tree itype = TREE_TYPE (vec_type); bool u = TYPE_UNSIGNED (itype); + enum machine_mode vmode = TYPE_MODE (vec_type); enum ix86_builtins fcode; + bool ok = TARGET_SSE2; - if (!TARGET_SSE2) - return NULL_TREE; - - switch (TYPE_MODE (vec_type)) + switch (vmode) { + case V4DFmode: + ok = TARGET_AVX; + fcode = IX86_BUILTIN_VEC_PERM_V4DF; + goto get_di; case V2DFmode: - itype = ix86_get_builtin_type (IX86_BT_DI); fcode = IX86_BUILTIN_VEC_PERM_V2DF; + get_di: + itype = ix86_get_builtin_type (IX86_BT_DI); break; + + case V8SFmode: + ok = TARGET_AVX; + fcode = IX86_BUILTIN_VEC_PERM_V8SF; + goto get_si; case V4SFmode: - itype = ix86_get_builtin_type (IX86_BT_SI); + ok = TARGET_SSE; fcode = IX86_BUILTIN_VEC_PERM_V4SF; + get_si: + itype = ix86_get_builtin_type (IX86_BT_SI); break; + case V2DImode: fcode = u ? IX86_BUILTIN_VEC_PERM_V2DI_U : IX86_BUILTIN_VEC_PERM_V2DI; break; @@ -29004,26 +29101,17 @@ ix86_vectorize_builtin_vec_perm (tree vec_type, tree *mask_type) fcode = u ? IX86_BUILTIN_VEC_PERM_V16QI_U : IX86_BUILTIN_VEC_PERM_V16QI; break; default: - return NULL_TREE; + ok = false; + break; } + if (!ok) + return NULL_TREE; + *mask_type = itype; return ix86_builtins[(int) fcode]; } -/* AVX does not support 32-byte integer vector operations, - thus the longest vector we are faced with is V16QImode. */ -#define MAX_VECT_LEN 16 - -struct expand_vec_perm_d -{ - rtx target, op0, op1; - unsigned char perm[MAX_VECT_LEN]; - enum machine_mode vmode; - unsigned char nelt; - bool testing_p; -}; - /* Return a vector mode with twice as many elements as VMODE. */ /* ??? Consider moving this to a table generated by genmodes.c. */ @@ -29619,8 +29707,9 @@ expand_vec_perm_pshufb2 (struct expand_vec_perm_d *d) rtx rperm[2][16], vperm, l, h, op, m128; unsigned int i, nelt, eltsz; - if (!TARGET_SSSE3) + if (!TARGET_SSSE3 || GET_MODE_SIZE (d->vmode) != 16) return false; + gcc_assert (d->op0 != d->op1); nelt = d->nelt; eltsz = GET_MODE_SIZE (GET_MODE_INNER (d->vmode)); @@ -29664,8 +29753,8 @@ expand_vec_perm_pshufb2 (struct expand_vec_perm_d *d) return true; } -/* A subroutine of ix86_expand_vec_perm_builtin_1. Pattern match - extract-even and extract-odd permutations. */ +/* A subroutine of ix86_expand_vec_perm_builtin_1. Implement extract-even + and extract-odd permutations. */ static bool expand_vec_perm_even_odd_1 (struct expand_vec_perm_d *d, unsigned odd) @@ -29780,6 +29869,9 @@ expand_vec_perm_even_odd_1 (struct expand_vec_perm_d *d, unsigned odd) return true; } +/* A subroutine of ix86_expand_vec_perm_builtin_1. Pattern match + extract-even and extract-odd permutations. */ + static bool expand_vec_perm_even_odd (struct expand_vec_perm_d *d) { @@ -29796,6 +29888,84 @@ expand_vec_perm_even_odd (struct expand_vec_perm_d *d) return expand_vec_perm_even_odd_1 (d, odd); } +/* A subroutine of ix86_expand_vec_perm_builtin_1. Implement broadcast + permutations. We assume that expand_vec_perm_1 has already failed. */ + +static bool +expand_vec_perm_broadcast_1 (struct expand_vec_perm_d *d) +{ + unsigned elt = d->perm[0], nelt2 = d->nelt / 2; + enum machine_mode vmode = d->vmode; + unsigned char perm2[4]; + rtx op0 = d->op0; + bool ok; + + switch (vmode) + { + case V4DFmode: + case V8SFmode: + /* These are special-cased in sse.md so that we can optionally + use the vbroadcast instruction. They expand to two insns + if the input happens to be in a register. */ + gcc_unreachable (); + + case V2DFmode: + case V2DImode: + case V4SFmode: + case V4SImode: + /* These are always implementable using standard shuffle patterns. */ + gcc_unreachable (); + + case V8HImode: + case V16QImode: + /* These can be implemented via interleave. We save one insn by + stopping once we have promoted to V4SImode and then use pshufd. */ + do + { + optab otab = vec_interleave_low_optab; + + if (elt >= nelt2) + { + otab = vec_interleave_high_optab; + elt -= nelt2; + } + nelt2 /= 2; + + op0 = expand_binop (vmode, otab, op0, op0, NULL, 0, OPTAB_DIRECT); + vmode = get_mode_wider_vector (vmode); + op0 = gen_lowpart (vmode, op0); + } + while (vmode != V4SImode); + + memset (perm2, elt, 4); + ok = expand_vselect (gen_lowpart (V4SImode, d->target), op0, perm2, 4); + gcc_assert (ok); + return true; + + default: + gcc_unreachable (); + } +} + +/* A subroutine of ix86_expand_vec_perm_builtin_1. Pattern match + broadcast permutations. */ + +static bool +expand_vec_perm_broadcast (struct expand_vec_perm_d *d) +{ + unsigned i, elt, nelt = d->nelt; + + if (d->op0 != d->op1) + return false; + + elt = d->perm[0]; + for (i = 1; i < nelt; ++i) + if (d->perm[i] != elt) + return false; + + return expand_vec_perm_broadcast_1 (d); +} + /* The guts of ix86_expand_vec_perm_builtin, also used by the ok hook. With all of the interface bits taken care of, perform the expansion in D and return true on success. */ @@ -29803,8 +29973,7 @@ expand_vec_perm_even_odd (struct expand_vec_perm_d *d) static bool ix86_expand_vec_perm_builtin_1 (struct expand_vec_perm_d *d) { - /* First things first -- check if the instruction is implementable - with a single instruction. */ + /* Try a single instruction expansion. */ if (expand_vec_perm_1 (d)) return true; @@ -29819,13 +29988,16 @@ ix86_expand_vec_perm_builtin_1 (struct expand_vec_perm_d *d) if (expand_vec_perm_interleave2 (d)) return true; + if (expand_vec_perm_broadcast (d)) + return true; + /* Try sequences of three instructions. */ if (expand_vec_perm_pshufb2 (d)) return true; /* ??? Look for narrow permutations whose element orderings would - allow the promition to a wider mode. */ + allow the promotion to a wider mode. */ /* ??? Look for sequences of interleave or a wider permute that place the data into the correct lanes for a half-vector shuffle like @@ -29837,8 +30009,6 @@ ix86_expand_vec_perm_builtin_1 (struct expand_vec_perm_d *d) if (expand_vec_perm_even_odd (d)) return true; - /* ??? Pattern match broadcast. */ - return false; } diff --git a/gcc/config/i386/i386.md b/gcc/config/i386/i386.md index d401f92950f..851061dcd8d 100644 --- a/gcc/config/i386/i386.md +++ b/gcc/config/i386/i386.md @@ -747,6 +747,9 @@ ;; All single word integer modes. (define_mode_iterator SWI [QI HI SI (DI "TARGET_64BIT")]) +;; Single word integer modes without DImode. +(define_mode_iterator SWI124 [QI HI SI]) + ;; Single word integer modes without QImode. (define_mode_iterator SWI248 [HI SI (DI "TARGET_64BIT")]) @@ -21169,18 +21172,14 @@ } [(set_attr "type" "multi")]) -(define_mode_iterator CRC32MODE [QI HI SI]) -(define_mode_attr crc32modesuffix [(QI "{b}") (HI "{w}") (SI "{l}")]) -(define_mode_attr crc32modeconstraint [(QI "qm") (HI "rm") (SI "rm")]) - (define_insn "sse4_2_crc32<mode>" [(set (match_operand:SI 0 "register_operand" "=r") (unspec:SI [(match_operand:SI 1 "register_operand" "0") - (match_operand:CRC32MODE 2 "nonimmediate_operand" "<crc32modeconstraint>")] + (match_operand:SWI124 2 "nonimmediate_operand" "<r>m")] UNSPEC_CRC32))] "TARGET_SSE4_2 || TARGET_CRC32" - "crc32<crc32modesuffix>\t{%2, %0|%0, %2}" + "crc32{<imodesuffix>}\t{%2, %0|%0, %2}" [(set_attr "type" "sselog1") (set_attr "prefix_rep" "1") (set_attr "prefix_extra" "1") diff --git a/gcc/config/i386/predicates.md b/gcc/config/i386/predicates.md index 7200a6a2167..8f901cd8754 100644 --- a/gcc/config/i386/predicates.md +++ b/gcc/config/i386/predicates.md @@ -1227,3 +1227,34 @@ (define_predicate "avx_vpermilp_v2df_operand" (and (match_code "parallel") (match_test "avx_vpermilp_parallel (op, V2DFmode)"))) + +;; Return 1 if OP is a parallel for a vperm2f128 permute. + +(define_predicate "avx_vperm2f128_v8sf_operand" + (and (match_code "parallel") + (match_test "avx_vperm2f128_parallel (op, V8SFmode)"))) + +(define_predicate "avx_vperm2f128_v8si_operand" + (and (match_code "parallel") + (match_test "avx_vperm2f128_parallel (op, V8SImode)"))) + +(define_predicate "avx_vperm2f128_v4df_operand" + (and (match_code "parallel") + (match_test "avx_vperm2f128_parallel (op, V4DFmode)"))) + +;; Return 1 if OP is a parallel for a vbroadcast permute. + +(define_predicate "avx_vbroadcast_operand" + (and (match_code "parallel") + (match_code "const_int" "a")) +{ + rtx elt = XVECEXP (op, 0, 0); + int i, nelt = XVECLEN (op, 0); + + /* Don't bother checking there are the right number of operands, + merely that they're all identical. */ + for (i = 1; i < nelt; ++i) + if (XVECEXP (op, 0, i) != elt) + return false; + return true; +}) diff --git a/gcc/config/i386/sse.md b/gcc/config/i386/sse.md index 27c7a8b4842..08a3b5b5c89 100644 --- a/gcc/config/i386/sse.md +++ b/gcc/config/i386/sse.md @@ -54,6 +54,7 @@ (define_mode_iterator AVX256MODEF2P [V8SF V4DF]) (define_mode_iterator AVX256MODE2P [V8SI V8SF V4DF]) +(define_mode_iterator AVX256MODE24P [V8SI V8SF V4DI V4DF]) (define_mode_iterator AVX256MODE4P [V4DI V4DF]) (define_mode_iterator AVX256MODE8P [V8SI V8SF]) (define_mode_iterator AVXMODEF2P [V4SF V2DF V8SF V4DF]) @@ -96,6 +97,8 @@ (define_mode_attr ssemodesuffixf2c [(V4SF "s") (V2DF "d")]) +(define_mode_attr ssescalarmodesuffix2s [(V4SF "ss") (V4SI "d")]) + ;; Mapping of the max integer size for xop rotate immediate constraint (define_mode_attr sserotatemax [(V16QI "7") (V8HI "15") (V4SI "31") (V2DI "63")]) @@ -125,17 +128,18 @@ [(V16QI "V4SF") (V8HI "V4SF") (V4SI "V4SF") (V2DI "V4SF") (V32QI "V8SF") (V16HI "V8SF") (V8SI "V8SF") (V4DI "V8SF")]) (define_mode_attr avxhalfvecmode - [(V4SF "V2SF") (V32QI "V16QI") (V16HI "V8HI") (V8SI "V4SI") - (V4DI "V2DI") (V8SF "V4SF") (V4DF "V2DF")]) + [(V32QI "V16QI") (V16HI "V8HI") (V8SI "V4SI") (V4DI "V2DI") + (V8SF "V4SF") (V4DF "V2DF") + (V16QI "V8QI") (V8HI "V4HI") (V4SI "V2SI") (V4SF "V2SF")]) (define_mode_attr avxscalarmode - [(V16QI "QI") (V8HI "HI") (V4SI "SI") (V4SF "SF") (V2DF "DF") - (V8SF "SF") (V4DF "DF")]) + [(V16QI "QI") (V8HI "HI") (V4SI "SI") (V2DI "DI") (V4SF "SF") (V2DF "DF") + (V32QI "QI") (V16HI "HI") (V8SI "SI") (V4DI "DI") (V8SF "SF") (V4DF "DF")]) (define_mode_attr avxcvtvecmode [(V4SF "V4SI") (V8SF "V8SI") (V4SI "V4SF") (V8SI "V8SF")]) (define_mode_attr avxpermvecmode [(V2DF "V2DI") (V4SF "V4SI") (V4DF "V4DI") (V8SF "V8SI")]) (define_mode_attr avxmodesuffixf2c - [(V4SF "s") (V2DF "d") (V8SF "s") (V4DF "d")]) + [(V4SF "s") (V2DF "d") (V8SI "s") (V8SF "s") (V4DI "d") (V4DF "d")]) (define_mode_attr avxmodesuffixp [(V2DF "pd") (V4SI "si") (V4SF "ps") (V8SF "ps") (V8SI "si") (V4DF "pd")]) @@ -4012,14 +4016,27 @@ [(set_attr "type" "ssemov") (set_attr "mode" "SF")]) +(define_expand "vec_dupv4sf" + [(set (match_operand:V4SF 0 "register_operand" "") + (vec_duplicate:V4SF + (match_operand:SF 1 "nonimmediate_operand" "")))] + "TARGET_SSE" +{ + if (!TARGET_AVX) + operands[1] = force_reg (V4SFmode, operands[1]); +}) + (define_insn "*vec_dupv4sf_avx" - [(set (match_operand:V4SF 0 "register_operand" "=x") + [(set (match_operand:V4SF 0 "register_operand" "=x,x") (vec_duplicate:V4SF - (match_operand:SF 1 "register_operand" "x")))] + (match_operand:SF 1 "nonimmediate_operand" "x,m")))] "TARGET_AVX" - "vshufps\t{$0, %1, %1, %0|%0, %1, %1, 0}" - [(set_attr "type" "sselog1") - (set_attr "length_immediate" "1") + "@ + vshufps\t{$0, %1, %1, %0|%0, %1, %1, 0} + vbroadcastss\t{%1, %0|%0, %1}" + [(set_attr "type" "sselog1,ssemov") + (set_attr "length_immediate" "1,0") + (set_attr "prefix_extra" "0,1") (set_attr "prefix" "vex") (set_attr "mode" "V4SF")]) @@ -4125,35 +4142,78 @@ DONE; }) -(define_insn "*vec_setv4sf_0_avx" - [(set (match_operand:V4SF 0 "nonimmediate_operand" "=x,x,x,m") - (vec_merge:V4SF - (vec_duplicate:V4SF - (match_operand:SF 2 "general_operand" " x,m,*r,x*rfF")) - (match_operand:V4SF 1 "vector_move_operand" " x,C,C ,0") +(define_insn "*vec_set<mode>_0_avx" + [(set (match_operand:SSEMODE4S 0 "nonimmediate_operand" "=x,x, x,x, x,m") + (vec_merge:SSEMODE4S + (vec_duplicate:SSEMODE4S + (match_operand:<ssescalarmode> 2 + "general_operand" " x,m,*r,x,*rm,x*rfF")) + (match_operand:SSEMODE4S 1 "vector_move_operand" " C,C, C,x, x,0") (const_int 1)))] "TARGET_AVX" "@ - vmovss\t{%2, %1, %0|%0, %1, %2} - vmovss\t{%2, %0|%0, %2} + vinsertps\t{$0xe, %2, %2, %0|%0, %2, %2, 0xe} + vmov<ssescalarmodesuffix2s>\t{%2, %0|%0, %2} vmovd\t{%2, %0|%0, %2} + vmovss\t{%2, %1, %0|%0, %1, %2} + vpinsrd\t{$0, %2, %1, %0|%0, %1, %2, 0} + #" + [(set_attr "type" "sselog,ssemov,ssemov,ssemov,sselog,*") + (set_attr "prefix_extra" "*,*,*,*,1,*") + (set_attr "length_immediate" "*,*,*,*,1,*") + (set_attr "prefix" "vex") + (set_attr "mode" "SF,<ssescalarmode>,SI,SF,TI,*")]) + +(define_insn "*vec_set<mode>_0_sse4_1" + [(set (match_operand:SSEMODE4S 0 "nonimmediate_operand" "=x,x, x,x, x,m") + (vec_merge:SSEMODE4S + (vec_duplicate:SSEMODE4S + (match_operand:<ssescalarmode> 2 + "general_operand" " x,m,*r,x,*rm,*rfF")) + (match_operand:SSEMODE4S 1 "vector_move_operand" " C,C, C,0, 0,0") + (const_int 1)))] + "TARGET_SSE4_1" + "@ + insertps\t{$0xe, %2, %0|%0, %2, 0xe} + mov<ssescalarmodesuffix2s>\t{%2, %0|%0, %2} + movd\t{%2, %0|%0, %2} + movss\t{%2, %0|%0, %2} + pinsrd\t{$0, %2, %0|%0, %2, 0} + #" + [(set_attr "type" "sselog,ssemov,ssemov,ssemov,sselog,*") + (set_attr "prefix_extra" "*,*,*,*,1,*") + (set_attr "length_immediate" "*,*,*,*,1,*") + (set_attr "mode" "SF,<ssescalarmode>,SI,SF,TI,*")]) + +(define_insn "*vec_set<mode>_0_sse2" + [(set (match_operand:SSEMODE4S 0 "nonimmediate_operand" "=x, x,x,m") + (vec_merge:SSEMODE4S + (vec_duplicate:SSEMODE4S + (match_operand:<ssescalarmode> 2 + "general_operand" " m,*r,x,x*rfF")) + (match_operand:SSEMODE4S 1 "vector_move_operand" " C, C,0,0") + (const_int 1)))] + "TARGET_SSE2" + "@ + mov<ssescalarmodesuffix2s>\t{%2, %0|%0, %2} + movd\t{%2, %0|%0, %2} + movss\t{%2, %0|%0, %2} #" [(set_attr "type" "ssemov") - (set_attr "prefix" "vex") - (set_attr "mode" "SF")]) - -(define_insn "vec_setv4sf_0" - [(set (match_operand:V4SF 0 "nonimmediate_operand" "=x,x,Y2,m") - (vec_merge:V4SF - (vec_duplicate:V4SF - (match_operand:SF 2 "general_operand" " x,m,*r,x*rfF")) - (match_operand:V4SF 1 "vector_move_operand" " 0,C,C ,0") + (set_attr "mode" "<ssescalarmode>,SI,SF,*")]) + +(define_insn "vec_set<mode>_0" + [(set (match_operand:SSEMODE4S 0 "nonimmediate_operand" "=x,x,m") + (vec_merge:SSEMODE4S + (vec_duplicate:SSEMODE4S + (match_operand:<ssescalarmode> 2 + "general_operand" " m,x,x*rfF")) + (match_operand:SSEMODE4S 1 "vector_move_operand" " C,0,0") (const_int 1)))] "TARGET_SSE" "@ movss\t{%2, %0|%0, %2} movss\t{%2, %0|%0, %2} - movd\t{%2, %0|%0, %2} #" [(set_attr "type" "ssemov") (set_attr "mode" "SF")]) @@ -4484,7 +4544,7 @@ (set_attr "mode" "V4DF")]) (define_expand "vec_interleave_highv2df" - [(set (match_operand:V2DF 0 "nonimmediate_operand" "") + [(set (match_operand:V2DF 0 "register_operand" "") (vec_select:V2DF (vec_concat:V4DF (match_operand:V2DF 1 "nonimmediate_operand" "") @@ -4492,24 +4552,46 @@ (parallel [(const_int 1) (const_int 3)])))] "TARGET_SSE2" - "ix86_fixup_binary_operands (UNKNOWN, V2DFmode, operands);") +{ + if (!ix86_vec_interleave_v2df_operator_ok (operands, 1)) + operands[2] = force_reg (V2DFmode, operands[2]); +}) (define_insn "*avx_interleave_highv2df" - [(set (match_operand:V2DF 0 "nonimmediate_operand" "=x,x,m") + [(set (match_operand:V2DF 0 "nonimmediate_operand" "=x,x,x,m") (vec_select:V2DF (vec_concat:V4DF - (match_operand:V2DF 1 "nonimmediate_operand" " x,o,x") - (match_operand:V2DF 2 "nonimmediate_operand" " x,x,0")) + (match_operand:V2DF 1 "nonimmediate_operand" " x,o,o,x") + (match_operand:V2DF 2 "nonimmediate_operand" " x,1,x,0")) (parallel [(const_int 1) (const_int 3)])))] - "TARGET_AVX && !(MEM_P (operands[1]) && MEM_P (operands[2]))" + "TARGET_AVX && ix86_vec_interleave_v2df_operator_ok (operands, 1)" "@ vunpckhpd\t{%2, %1, %0|%0, %1, %2} + vmovddup\t{%H1, %0|%0, %H1} vmovlpd\t{%H1, %2, %0|%0, %2, %H1} vmovhpd\t{%1, %0|%0, %1}" - [(set_attr "type" "sselog,ssemov,ssemov") + [(set_attr "type" "sselog,sselog,ssemov,ssemov") (set_attr "prefix" "vex") - (set_attr "mode" "V2DF,V1DF,V1DF")]) + (set_attr "mode" "V2DF,V2DF,V1DF,V1DF")]) + +(define_insn "*sse3_interleave_highv2df" + [(set (match_operand:V2DF 0 "nonimmediate_operand" "=x,x,x,m") + (vec_select:V2DF + (vec_concat:V4DF + (match_operand:V2DF 1 "nonimmediate_operand" " 0,o,o,x") + (match_operand:V2DF 2 "nonimmediate_operand" " x,1,0,0")) + (parallel [(const_int 1) + (const_int 3)])))] + "TARGET_SSE3 && ix86_vec_interleave_v2df_operator_ok (operands, 1)" + "@ + unpckhpd\t{%2, %0|%0, %2} + movddup\t{%H1, %0|%0, %H1} + movlpd\t{%H1, %0|%0, %H1} + movhpd\t{%1, %0|%0, %1}" + [(set_attr "type" "sselog,sselog,ssemov,ssemov") + (set_attr "prefix_data16" "*,*,1,1") + (set_attr "mode" "V2DF,V2DF,V1DF,V1DF")]) (define_insn "*sse2_interleave_highv2df" [(set (match_operand:V2DF 0 "nonimmediate_operand" "=x,x,m") @@ -4519,7 +4601,7 @@ (match_operand:V2DF 2 "nonimmediate_operand" " x,0,0")) (parallel [(const_int 1) (const_int 3)])))] - "TARGET_SSE2 && !(MEM_P (operands[1]) && MEM_P (operands[2]))" + "TARGET_SSE2 && ix86_vec_interleave_v2df_operator_ok (operands, 1)" "@ unpckhpd\t{%2, %0|%0, %2} movlpd\t{%H1, %0|%0, %H1} @@ -4528,85 +4610,48 @@ (set_attr "prefix_data16" "*,1,1") (set_attr "mode" "V2DF,V1DF,V1DF")]) -(define_insn "avx_movddup256" - [(set (match_operand:V4DF 0 "register_operand" "=x") +;; Recall that the 256-bit unpck insns only shuffle within their lanes. +(define_expand "avx_movddup256" + [(set (match_operand:V4DF 0 "register_operand" "") (vec_select:V4DF (vec_concat:V8DF - (match_operand:V4DF 1 "nonimmediate_operand" "xm") + (match_operand:V4DF 1 "nonimmediate_operand" "") (match_dup 1)) - (parallel [(const_int 0) (const_int 2) - (const_int 4) (const_int 6)])))] + (parallel [(const_int 0) (const_int 4) + (const_int 2) (const_int 6)])))] "TARGET_AVX" - "vmovddup\t{%1, %0|%0, %1}" - [(set_attr "type" "sselog1") - (set_attr "prefix" "vex") - (set_attr "mode" "V4DF")]) - -(define_insn "*avx_movddup" - [(set (match_operand:V2DF 0 "nonimmediate_operand" "=x,o") - (vec_select:V2DF - (vec_concat:V4DF - (match_operand:V2DF 1 "nonimmediate_operand" "xm,x") - (match_dup 1)) - (parallel [(const_int 0) - (const_int 2)])))] - "TARGET_AVX && !(MEM_P (operands[0]) && MEM_P (operands[1]))" - "@ - vmovddup\t{%1, %0|%0, %1} - #" - [(set_attr "type" "sselog1,ssemov") - (set_attr "prefix" "vex") - (set_attr "mode" "V2DF")]) - -(define_insn "*sse3_movddup" - [(set (match_operand:V2DF 0 "nonimmediate_operand" "=x,o") - (vec_select:V2DF - (vec_concat:V4DF - (match_operand:V2DF 1 "nonimmediate_operand" "xm,x") - (match_dup 1)) - (parallel [(const_int 0) - (const_int 2)])))] - "TARGET_SSE3 && !(MEM_P (operands[0]) && MEM_P (operands[1]))" - "@ - movddup\t{%1, %0|%0, %1} - #" - [(set_attr "type" "sselog1,ssemov") - (set_attr "mode" "V2DF")]) - -(define_split - [(set (match_operand:V2DF 0 "memory_operand" "") - (vec_select:V2DF - (vec_concat:V4DF - (match_operand:V2DF 1 "register_operand" "") - (match_dup 1)) - (parallel [(const_int 0) - (const_int 2)])))] - "TARGET_SSE3 && reload_completed" - [(const_int 0)] -{ - rtx low = gen_rtx_REG (DFmode, REGNO (operands[1])); - emit_move_insn (adjust_address (operands[0], DFmode, 0), low); - emit_move_insn (adjust_address (operands[0], DFmode, 8), low); - DONE; -}) + "") -;; Recall that the 256-bit unpck insns only shuffle within their lanes. -(define_insn "avx_unpcklpd256" - [(set (match_operand:V4DF 0 "register_operand" "=x") +(define_expand "avx_unpcklpd256" + [(set (match_operand:V4DF 0 "register_operand" "") (vec_select:V4DF (vec_concat:V8DF - (match_operand:V4DF 1 "register_operand" "x") - (match_operand:V4DF 2 "nonimmediate_operand" "xm")) + (match_operand:V4DF 1 "register_operand" "") + (match_operand:V4DF 2 "nonimmediate_operand" "")) (parallel [(const_int 0) (const_int 4) (const_int 2) (const_int 6)])))] "TARGET_AVX" - "vunpcklpd\t{%2, %1, %0|%0, %1, %2}" + "") + +(define_insn "*avx_unpcklpd256" + [(set (match_operand:V4DF 0 "register_operand" "=x,x") + (vec_select:V4DF + (vec_concat:V8DF + (match_operand:V4DF 1 "nonimmediate_operand" "xm,x") + (match_operand:V4DF 2 "nonimmediate_operand" " 1,xm")) + (parallel [(const_int 0) (const_int 4) + (const_int 2) (const_int 6)])))] + "TARGET_AVX + && (!MEM_P (operands[1]) || rtx_equal_p (operands[1], operands[2]))" + "@ + vmovddup\t{%1, %0|%0, %1} + vunpcklpd\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "sselog") (set_attr "prefix" "vex") (set_attr "mode" "V4DF")]) (define_expand "vec_interleave_lowv2df" - [(set (match_operand:V2DF 0 "nonimmediate_operand" "") + [(set (match_operand:V2DF 0 "register_operand" "") (vec_select:V2DF (vec_concat:V4DF (match_operand:V2DF 1 "nonimmediate_operand" "") @@ -4614,24 +4659,46 @@ (parallel [(const_int 0) (const_int 2)])))] "TARGET_SSE2" - "ix86_fixup_binary_operands (UNKNOWN, V2DFmode, operands);") +{ + if (!ix86_vec_interleave_v2df_operator_ok (operands, 0)) + operands[1] = force_reg (V2DFmode, operands[1]); +}) (define_insn "*avx_interleave_lowv2df" - [(set (match_operand:V2DF 0 "nonimmediate_operand" "=x,x,o") + [(set (match_operand:V2DF 0 "nonimmediate_operand" "=x,x,x,o") (vec_select:V2DF (vec_concat:V4DF - (match_operand:V2DF 1 "nonimmediate_operand" " x,x,0") - (match_operand:V2DF 2 "nonimmediate_operand" " x,m,x")) + (match_operand:V2DF 1 "nonimmediate_operand" " x,m,x,0") + (match_operand:V2DF 2 "nonimmediate_operand" " x,1,m,x")) (parallel [(const_int 0) (const_int 2)])))] - "TARGET_AVX && !(MEM_P (operands[1]) && MEM_P (operands[2]))" + "TARGET_AVX && ix86_vec_interleave_v2df_operator_ok (operands, 0)" "@ vunpcklpd\t{%2, %1, %0|%0, %1, %2} + vmovddup\t{%1, %0|%0, %1} vmovhpd\t{%2, %1, %0|%0, %1, %2} vmovlpd\t{%2, %H0|%H0, %2}" - [(set_attr "type" "sselog,ssemov,ssemov") + [(set_attr "type" "sselog,sselog,ssemov,ssemov") (set_attr "prefix" "vex") - (set_attr "mode" "V2DF,V1DF,V1DF")]) + (set_attr "mode" "V2DF,V2DF,V1DF,V1DF")]) + +(define_insn "*sse3_interleave_lowv2df" + [(set (match_operand:V2DF 0 "nonimmediate_operand" "=x,x,x,o") + (vec_select:V2DF + (vec_concat:V4DF + (match_operand:V2DF 1 "nonimmediate_operand" " 0,m,0,0") + (match_operand:V2DF 2 "nonimmediate_operand" " x,1,m,x")) + (parallel [(const_int 0) + (const_int 2)])))] + "TARGET_SSE3 && ix86_vec_interleave_v2df_operator_ok (operands, 0)" + "@ + unpcklpd\t{%2, %0|%0, %2} + movddup\t{%1, %0|%0, %1} + movhpd\t{%2, %0|%0, %2} + movlpd\t{%2, %H0|%H0, %2}" + [(set_attr "type" "sselog,sselog,ssemov,ssemov") + (set_attr "prefix_data16" "*,*,1,1") + (set_attr "mode" "V2DF,V2DF,V1DF,V1DF")]) (define_insn "*sse2_interleave_lowv2df" [(set (match_operand:V2DF 0 "nonimmediate_operand" "=x,x,o") @@ -4641,7 +4708,7 @@ (match_operand:V2DF 2 "nonimmediate_operand" " x,m,x")) (parallel [(const_int 0) (const_int 2)])))] - "TARGET_SSE2 && !(MEM_P (operands[1]) && MEM_P (operands[2]))" + "TARGET_SSE2 && ix86_vec_interleave_v2df_operator_ok (operands, 0)" "@ unpcklpd\t{%2, %0|%0, %2} movhpd\t{%2, %0|%0, %2} @@ -4650,6 +4717,37 @@ (set_attr "prefix_data16" "*,1,1") (set_attr "mode" "V2DF,V1DF,V1DF")]) +(define_split + [(set (match_operand:V2DF 0 "memory_operand" "") + (vec_select:V2DF + (vec_concat:V4DF + (match_operand:V2DF 1 "register_operand" "") + (match_dup 1)) + (parallel [(const_int 0) + (const_int 2)])))] + "TARGET_SSE3 && reload_completed" + [(const_int 0)] +{ + rtx low = gen_rtx_REG (DFmode, REGNO (operands[1])); + emit_move_insn (adjust_address (operands[0], DFmode, 0), low); + emit_move_insn (adjust_address (operands[0], DFmode, 8), low); + DONE; +}) + +(define_split + [(set (match_operand:V2DF 0 "register_operand" "") + (vec_select:V2DF + (vec_concat:V4DF + (match_operand:V2DF 1 "memory_operand" "") + (match_dup 1)) + (parallel [(match_operand:SI 2 "const_0_to_1_operand" "") + (match_operand:SI 3 "const_int_operand" "")])))] + "TARGET_SSE3 && INTVAL (operands[2]) + 2 == INTVAL (operands[3])" + [(set (match_dup 0) (vec_duplicate:V2DF (match_dup 1)))] +{ + operands[1] = adjust_address (operands[1], DFmode, INTVAL (operands[2]) * 8); +}) + (define_expand "avx_shufpd256" [(match_operand:V4DF 0 "register_operand" "") (match_operand:V4DF 1 "register_operand" "") @@ -7408,6 +7506,20 @@ [(set_attr "type" "ssemov") (set_attr "mode" "V2SF,V4SF,V2SF")]) +(define_insn "*vec_dupv4si_avx" + [(set (match_operand:V4SI 0 "register_operand" "=x,x") + (vec_duplicate:V4SI + (match_operand:SI 1 "register_operand" "x,m")))] + "TARGET_AVX" + "@ + vpshufd\t{$0, %1, %0|%0, %1, 0} + vbroadcastss\t{%1, %0|%0, %1}" + [(set_attr "type" "sselog1,ssemov") + (set_attr "length_immediate" "1,0") + (set_attr "prefix_extra" "0,1") + (set_attr "prefix" "vex") + (set_attr "mode" "TI,V4SF")]) + (define_insn "*vec_dupv4si" [(set (match_operand:V4SI 0 "register_operand" "=Y2,x") (vec_duplicate:V4SI @@ -7417,19 +7529,31 @@ %vpshufd\t{$0, %1, %0|%0, %1, 0} shufps\t{$0, %0, %0|%0, %0, 0}" [(set_attr "type" "sselog1") - (set_attr "prefix" "maybe_vex,orig") (set_attr "length_immediate" "1") (set_attr "mode" "TI,V4SF")]) (define_insn "*vec_dupv2di_avx" - [(set (match_operand:V2DI 0 "register_operand" "=x") + [(set (match_operand:V2DI 0 "register_operand" "=x,x") (vec_duplicate:V2DI - (match_operand:DI 1 "register_operand" "x")))] + (match_operand:DI 1 "nonimmediate_operand" " x,m")))] "TARGET_AVX" - "vpunpcklqdq\t{%1, %1, %0|%0, %1, %1}" + "@ + vpunpcklqdq\t{%1, %1, %0|%0, %1, %1} + vmovddup\t{%1, %0|%0, %1}" [(set_attr "type" "sselog1") (set_attr "prefix" "vex") - (set_attr "mode" "TI")]) + (set_attr "mode" "TI,DF")]) + +(define_insn "*vec_dupv2di_sse3" + [(set (match_operand:V2DI 0 "register_operand" "=x,x") + (vec_duplicate:V2DI + (match_operand:DI 1 "nonimmediate_operand" " 0,m")))] + "TARGET_SSE3" + "@ + punpcklqdq\t%0, %0 + movddup\t{%1, %0|%0, %1}" + [(set_attr "type" "sselog1") + (set_attr "mode" "TI,DF")]) (define_insn "*vec_dupv2di" [(set (match_operand:V2DI 0 "register_operand" "=Y2,x") @@ -11838,6 +11962,108 @@ (set_attr "prefix" "vex") (set_attr "mode" "OI")]) +(define_insn_and_split "vec_dup<mode>" + [(set (match_operand:AVX256MODE24P 0 "register_operand" "=x,x") + (vec_duplicate:AVX256MODE24P + (match_operand:<avxscalarmode> 1 "nonimmediate_operand" "m,?x")))] + "TARGET_AVX" + "@ + vbroadcasts<avxmodesuffixf2c>\t{%1, %0|%0, %1} + #" + "&& reload_completed && REG_P (operands[1])" + [(set (match_dup 2) (vec_duplicate:<avxhalfvecmode> (match_dup 1))) + (set (match_dup 0) (vec_concat:AVX256MODE24P (match_dup 2) (match_dup 2)))] +{ + operands[2] = gen_rtx_REG (<avxhalfvecmode>mode, REGNO (operands[0])); +} + [(set_attr "type" "ssemov") + (set_attr "prefix_extra" "1") + (set_attr "prefix" "vex") + (set_attr "mode" "V8SF")]) + +(define_insn "avx_vbroadcastf128_<mode>" + [(set (match_operand:AVX256MODE 0 "register_operand" "=x,x,x") + (vec_concat:AVX256MODE + (match_operand:<avxhalfvecmode> 1 "nonimmediate_operand" "m,0,?x") + (match_dup 1)))] + "TARGET_AVX" + "@ + vbroadcastf128\t{%1, %0|%0, %1} + vinsertf128\t{$1, %1, %0, %0|%0, %0, %1, 1} + vperm2f128\t{$0, %t1, %t1, %0|%0, %t1, %t1, 0}" + [(set_attr "type" "ssemov,sselog1,sselog1") + (set_attr "prefix_extra" "1") + (set_attr "length_immediate" "0,1,1") + (set_attr "prefix" "vex") + (set_attr "mode" "V4SF,V8SF,V8SF")]) + +;; Recognize broadcast as a vec_select as produced by builtin_vec_perm. +;; If it so happens that the input is in memory, use vbroadcast. +;; Otherwise use vpermilp (and in the case of 256-bit modes, vperm2f128). +(define_insn "*avx_vperm_broadcast_v4sf" + [(set (match_operand:V4SF 0 "register_operand" "=x,x,x") + (vec_select:V4SF + (match_operand:V4SF 1 "nonimmediate_operand" "m,o,x") + (match_parallel 2 "avx_vbroadcast_operand" + [(match_operand 3 "const_int_operand" "C,n,n")])))] + "TARGET_AVX" +{ + int elt = INTVAL (operands[3]); + switch (which_alternative) + { + case 0: + case 1: + operands[1] = adjust_address_nv (operands[1], SFmode, elt * 4); + return "vbroadcastss\t{%1, %0|%0, %1}"; + case 2: + operands[2] = GEN_INT (elt * 0x55); + return "vpermilps\t{%2, %1, %0|%0, %1, %2}"; + default: + gcc_unreachable (); + } +} + [(set_attr "type" "ssemov,ssemov,sselog1") + (set_attr "prefix_extra" "1") + (set_attr "length_immediate" "0,0,1") + (set_attr "prefix" "vex") + (set_attr "mode" "SF,SF,V4SF")]) + +(define_insn_and_split "*avx_vperm_broadcast_<mode>" + [(set (match_operand:AVX256MODEF2P 0 "register_operand" "=x,x,x") + (vec_select:AVX256MODEF2P + (match_operand:AVX256MODEF2P 1 "nonimmediate_operand" "m,o,?x") + (match_parallel 2 "avx_vbroadcast_operand" + [(match_operand 3 "const_int_operand" "C,n,n")])))] + "TARGET_AVX" + "#" + "&& reload_completed" + [(set (match_dup 0) (vec_duplicate:AVX256MODEF2P (match_dup 1)))] +{ + rtx op0 = operands[0], op1 = operands[1]; + int elt = INTVAL (operands[3]); + + if (REG_P (op1)) + { + int mask; + + /* Shuffle element we care about into all elements of the 128-bit lane. + The other lane gets shuffled too, but we don't care. */ + if (<MODE>mode == V4DFmode) + mask = (elt & 1 ? 15 : 0); + else + mask = (elt & 3) * 0x55; + emit_insn (gen_avx_vpermil<mode> (op0, op1, GEN_INT (mask))); + + /* Shuffle the lane we care about into both lanes of the dest. */ + mask = (elt / (<ssescalarnum> / 2)) * 0x11; + emit_insn (gen_avx_vperm2f128<mode>3 (op0, op0, op0, GEN_INT (mask))); + DONE; + } + + operands[1] = adjust_address_nv (op1, <avxscalarmode>mode, + elt * GET_MODE_SIZE (<avxscalarmode>mode)); +}) + (define_expand "avx_vpermil<mode>" [(set (match_operand:AVXMODEFDP 0 "register_operand" "") (vec_select:AVXMODEFDP @@ -11917,7 +12143,44 @@ (set_attr "prefix" "vex") (set_attr "mode" "<MODE>")]) -(define_insn "avx_vperm2f128<mode>3" +(define_expand "avx_vperm2f128<mode>3" + [(set (match_operand:AVX256MODE2P 0 "register_operand" "") + (unspec:AVX256MODE2P + [(match_operand:AVX256MODE2P 1 "register_operand" "") + (match_operand:AVX256MODE2P 2 "nonimmediate_operand" "") + (match_operand:SI 3 "const_0_to_255_operand" "")] + UNSPEC_VPERMIL2F128))] + "TARGET_AVX" +{ + int mask = INTVAL (operands[2]); + if ((mask & 0x88) == 0) + { + rtx perm[<ssescalarnum>], t1, t2; + int i, base, nelt = <ssescalarnum>, nelt2 = nelt / 2; + + base = (mask & 3) * nelt2; + for (i = 0; i < nelt2; ++i) + perm[i] = GEN_INT (base + i); + + base = ((mask >> 4) & 3) * nelt2; + for (i = 0; i < nelt2; ++i) + perm[i + nelt2] = GEN_INT (base + i); + + t2 = gen_rtx_VEC_CONCAT (<ssedoublesizemode>mode, + operands[1], operands[2]); + t1 = gen_rtx_PARALLEL (VOIDmode, gen_rtvec_v (nelt, perm)); + t2 = gen_rtx_VEC_SELECT (<MODE>mode, t2, t1); + t2 = gen_rtx_SET (VOIDmode, operands[0], t2); + emit_insn (t2); + DONE; + } +}) + +;; Note that bits 7 and 3 of the imm8 allow lanes to be zeroed, which +;; means that in order to represent this properly in rtl we'd have to +;; nest *another* vec_concat with a zero operand and do the select from +;; a 4x wide vector. That doesn't seem very nice. +(define_insn "*avx_vperm2f128<mode>_full" [(set (match_operand:AVX256MODE2P 0 "register_operand" "=x") (unspec:AVX256MODE2P [(match_operand:AVX256MODE2P 1 "register_operand" "x") @@ -11932,57 +12195,25 @@ (set_attr "prefix" "vex") (set_attr "mode" "V8SF")]) -(define_insn "avx_vbroadcasts<avxmodesuffixf2c><avxmodesuffix>" - [(set (match_operand:AVXMODEF4P 0 "register_operand" "=x") - (vec_concat:AVXMODEF4P - (vec_concat:<avxhalfvecmode> - (match_operand:<avxscalarmode> 1 "memory_operand" "m") - (match_dup 1)) - (vec_concat:<avxhalfvecmode> - (match_dup 1) - (match_dup 1))))] - "TARGET_AVX" - "vbroadcasts<avxmodesuffixf2c>\t{%1, %0|%0, %1}" - [(set_attr "type" "ssemov") - (set_attr "prefix_extra" "1") - (set_attr "prefix" "vex") - (set_attr "mode" "<avxscalarmode>")]) - -(define_insn "avx_vbroadcastss256" - [(set (match_operand:V8SF 0 "register_operand" "=x") - (vec_concat:V8SF - (vec_concat:V4SF - (vec_concat:V2SF - (match_operand:SF 1 "memory_operand" "m") - (match_dup 1)) - (vec_concat:V2SF - (match_dup 1) - (match_dup 1))) - (vec_concat:V4SF - (vec_concat:V2SF - (match_dup 1) - (match_dup 1)) - (vec_concat:V2SF - (match_dup 1) - (match_dup 1)))))] - "TARGET_AVX" - "vbroadcastss\t{%1, %0|%0, %1}" - [(set_attr "type" "ssemov") - (set_attr "prefix_extra" "1") - (set_attr "prefix" "vex") - (set_attr "mode" "SF")]) - -(define_insn "avx_vbroadcastf128_p<avxmodesuffixf2c>256" - [(set (match_operand:AVX256MODEF2P 0 "register_operand" "=x") - (vec_concat:AVX256MODEF2P - (match_operand:<avxhalfvecmode> 1 "memory_operand" "m") - (match_dup 1)))] +(define_insn "*avx_vperm2f128<mode>_nozero" + [(set (match_operand:AVX256MODE2P 0 "register_operand" "=x") + (vec_select:AVX256MODE2P + (vec_concat:<ssedoublesizemode> + (match_operand:AVX256MODE2P 1 "register_operand" "x") + (match_operand:AVX256MODE2P 2 "nonimmediate_operand" "xm")) + (match_parallel 3 "avx_vperm2f128_<mode>_operand" + [(match_operand 4 "const_int_operand" "")])))] "TARGET_AVX" - "vbroadcastf128\t{%1, %0|%0, %1}" - [(set_attr "type" "ssemov") +{ + int mask = avx_vperm2f128_parallel (operands[3], <MODE>mode) - 1; + operands[3] = GEN_INT (mask); + return "vperm2f128\t{%3, %2, %1, %0|%0, %1, %2, %3}"; +} + [(set_attr "type" "sselog") (set_attr "prefix_extra" "1") + (set_attr "length_immediate" "1") (set_attr "prefix" "vex") - (set_attr "mode" "V4SF")]) + (set_attr "mode" "V8SF")]) (define_expand "avx_vinsertf128<mode>" [(match_operand:AVX256MODE 0 "register_operand" "") diff --git a/gcc/config/i386/winnt.c b/gcc/config/i386/winnt.c index f8dcaa9673a..a6bd1e4f739 100644 --- a/gcc/config/i386/winnt.c +++ b/gcc/config/i386/winnt.c @@ -603,6 +603,64 @@ i386_pe_maybe_record_exported_symbol (tree decl, const char *name, int is_data) export_head = p; } +#ifdef CXX_WRAP_SPEC_LIST + +/* Hash table equality helper function. */ + +static int +wrapper_strcmp (const void *x, const void *y) +{ + return !strcmp ((const char *) x, (const char *) y); +} + +/* Search for a function named TARGET in the list of library wrappers + we are using, returning a pointer to it if found or NULL if not. + This function might be called on quite a few symbols, and we only + have the list of names of wrapped functions available to us as a + spec string, so first time round we lazily initialise a hash table + to make things quicker. */ + +static const char * +i386_find_on_wrapper_list (const char *target) +{ + static char first_time = 1; + static htab_t wrappers; + + if (first_time) + { + /* Beware that this is not a complicated parser, it assumes + that any sequence of non-whitespace beginning with an + underscore is one of the wrapped symbols. For now that's + adequate to distinguish symbols from spec substitutions + and command-line options. */ + static char wrapper_list_buffer[] = CXX_WRAP_SPEC_LIST; + char *bufptr; + /* Breaks up the char array into separated strings + strings and enter them into the hash table. */ + wrappers = htab_create_alloc (8, htab_hash_string, wrapper_strcmp, + 0, xcalloc, free); + for (bufptr = wrapper_list_buffer; *bufptr; ++bufptr) + { + char *found = NULL; + if (ISSPACE (*bufptr)) + continue; + if (*bufptr == '_') + found = bufptr; + while (*bufptr && !ISSPACE (*bufptr)) + ++bufptr; + if (*bufptr) + *bufptr = 0; + if (found) + *htab_find_slot (wrappers, found, INSERT) = found; + } + first_time = 0; + } + + return (const char *) htab_find (wrappers, target); +} + +#endif /* CXX_WRAP_SPEC_LIST */ + /* This is called at the end of assembly. For each external function which has not been defined, we output a declaration now. We also output the .drectve section. */ @@ -624,6 +682,15 @@ i386_pe_file_end (void) if (! TREE_ASM_WRITTEN (decl) && TREE_SYMBOL_REFERENCED (DECL_ASSEMBLER_NAME (decl))) { +#ifdef CXX_WRAP_SPEC_LIST + /* To ensure the DLL that provides the corresponding real + functions is still loaded at runtime, we must reference + the real function so that an (unused) import is created. */ + const char *realsym = i386_find_on_wrapper_list (p->name); + if (realsym) + i386_pe_declare_function_type (asm_out_file, + concat ("__real_", realsym, NULL), TREE_PUBLIC (decl)); +#endif /* CXX_WRAP_SPEC_LIST */ TREE_ASM_WRITTEN (decl) = 1; i386_pe_declare_function_type (asm_out_file, p->name, TREE_PUBLIC (decl)); diff --git a/gcc/config/i386/x86intrin.h b/gcc/config/i386/x86intrin.h index ac7e21fd6f7..63252bf95c8 100644 --- a/gcc/config/i386/x86intrin.h +++ b/gcc/config/i386/x86intrin.h @@ -77,4 +77,8 @@ #include <lwpintrin.h> #endif +#ifdef __ABM__ +#include <abmintrin.h> +#endif + #endif /* _X86INTRIN_H_INCLUDED */ diff --git a/gcc/config/mips/mips-dsp.md b/gcc/config/mips/mips-dsp.md index ff2004ccb54..dd2459ebcaf 100644 --- a/gcc/config/mips/mips-dsp.md +++ b/gcc/config/mips/mips-dsp.md @@ -1066,7 +1066,7 @@ (define_insn "mips_lhx_<mode>" [(set (match_operand:SI 0 "register_operand" "=d") - (zero_extend:SI + (sign_extend:SI (mem:HI (plus:P (match_operand:P 1 "register_operand" "d") (match_operand:P 2 "register_operand" "d")))))] "ISA_HAS_DSP" diff --git a/gcc/config/sh/sh-protos.h b/gcc/config/sh/sh-protos.h index 8157221c0c6..7335efcd0a1 100644 --- a/gcc/config/sh/sh-protos.h +++ b/gcc/config/sh/sh-protos.h @@ -163,7 +163,7 @@ extern rtx sh_function_arg (CUMULATIVE_ARGS *, enum machine_mode, tree, int); extern void sh_function_arg_advance (CUMULATIVE_ARGS *, enum machine_mode, tree, int); extern int sh_pass_in_reg_p (CUMULATIVE_ARGS *, enum machine_mode, tree); extern void sh_init_cumulative_args (CUMULATIVE_ARGS *, tree, rtx, tree, signed int, enum machine_mode); -extern bool sh_promote_prototypes (const_tree); +extern bool sh_function_value_regno_p (const unsigned int); extern rtx sh_dwarf_register_span (rtx); extern rtx replace_n_hard_rtx (rtx, rtx *, int , int); diff --git a/gcc/config/sh/sh.c b/gcc/config/sh/sh.c index 26bceea670d..5fe752eac20 100644 --- a/gcc/config/sh/sh.c +++ b/gcc/config/sh/sh.c @@ -251,6 +251,8 @@ static struct save_entry_s *sh5_schedule_saves (HARD_REG_SET *, struct save_schedule_s *, int); static rtx sh_struct_value_rtx (tree, int); +static rtx sh_function_value (const_tree, const_tree, bool); +static rtx sh_libcall_value (enum machine_mode, const_rtx); static bool sh_return_in_memory (const_tree, const_tree); static rtx sh_builtin_saveregs (void); static void sh_setup_incoming_varargs (CUMULATIVE_ARGS *, enum machine_mode, tree, int *, int); @@ -259,6 +261,7 @@ static bool sh_pretend_outgoing_varargs_named (CUMULATIVE_ARGS *); static tree sh_build_builtin_va_list (void); static void sh_va_start (tree, rtx); static tree sh_gimplify_va_arg_expr (tree, tree, gimple_seq *, gimple_seq *); +static bool sh_promote_prototypes (const_tree); static enum machine_mode sh_promote_function_mode (const_tree type, enum machine_mode, int *punsignedp, @@ -451,6 +454,10 @@ static const struct attribute_spec sh_attribute_table[] = #undef TARGET_PROMOTE_FUNCTION_MODE #define TARGET_PROMOTE_FUNCTION_MODE sh_promote_function_mode +#undef TARGET_FUNCTION_VALUE +#define TARGET_FUNCTION_VALUE sh_function_value +#undef TARGET_LIBCALL_VALUE +#define TARGET_LIBCALL_VALUE sh_libcall_value #undef TARGET_STRUCT_VALUE_RTX #define TARGET_STRUCT_VALUE_RTX sh_struct_value_rtx #undef TARGET_RETURN_IN_MEMORY @@ -7947,7 +7954,7 @@ sh_promote_function_mode (const_tree type, enum machine_mode mode, return mode; } -bool +static bool sh_promote_prototypes (const_tree type) { if (TARGET_HITACHI) @@ -8306,6 +8313,54 @@ sh_struct_value_rtx (tree fndecl, int incoming ATTRIBUTE_UNUSED) return gen_rtx_REG (Pmode, 2); } +/* Worker function for TARGET_FUNCTION_VALUE. + + For the SH, this is like LIBCALL_VALUE, except that we must change the + mode like PROMOTE_MODE does. + ??? PROMOTE_MODE is ignored for non-scalar types. The set of types + tested here has to be kept in sync with the one in explow.c:promote_mode. +*/ + +static rtx +sh_function_value (const_tree valtype, + const_tree fn_decl_or_type, + bool outgoing ATTRIBUTE_UNUSED) +{ + if (fn_decl_or_type + && !DECL_P (fn_decl_or_type)) + fn_decl_or_type = NULL; + + return gen_rtx_REG ( + ((GET_MODE_CLASS (TYPE_MODE (valtype)) == MODE_INT + && GET_MODE_SIZE (TYPE_MODE (valtype)) < 4 + && (TREE_CODE (valtype) == INTEGER_TYPE + || TREE_CODE (valtype) == ENUMERAL_TYPE + || TREE_CODE (valtype) == BOOLEAN_TYPE + || TREE_CODE (valtype) == REAL_TYPE + || TREE_CODE (valtype) == OFFSET_TYPE)) + && sh_promote_prototypes (fn_decl_or_type) + ? (TARGET_SHMEDIA64 ? DImode : SImode) : TYPE_MODE (valtype)), + BASE_RETURN_VALUE_REG (TYPE_MODE (valtype))); +} + +/* Worker function for TARGET_LIBCALL_VALUE. */ + +static rtx +sh_libcall_value (enum machine_mode mode, const_rtx fun ATTRIBUTE_UNUSED) +{ + return gen_rtx_REG (mode, BASE_RETURN_VALUE_REG (mode)); +} + +/* Worker function for FUNCTION_VALUE_REGNO_P. */ + +bool +sh_function_value_regno_p (const unsigned int regno) +{ + return ((regno) == FIRST_RET_REG + || (TARGET_SH2E && (regno) == FIRST_FP_RET_REG) + || (TARGET_SHMEDIA_FPU && (regno) == FIRST_FP_RET_REG)); +} + /* Worker function for TARGET_RETURN_IN_MEMORY. */ static bool diff --git a/gcc/config/sh/sh.h b/gcc/config/sh/sh.h index c24555f9796..697138f57ce 100644 --- a/gcc/config/sh/sh.h +++ b/gcc/config/sh/sh.h @@ -1453,37 +1453,7 @@ extern enum reg_class regno_reg_class[FIRST_PSEUDO_REGISTER]; ? FIRST_FP_PARM_REG \ : FIRST_PARM_REG) -/* Define how to find the value returned by a function. - VALTYPE is the data type of the value (as a tree). - If the precise function being called is known, FUNC is its FUNCTION_DECL; - otherwise, FUNC is 0. - For the SH, this is like LIBCALL_VALUE, except that we must change the - mode like PROMOTE_MODE does. - ??? PROMOTE_MODE is ignored for non-scalar types. The set of types - tested here has to be kept in sync with the one in explow.c:promote_mode. */ - -#define FUNCTION_VALUE(VALTYPE, FUNC) \ - gen_rtx_REG ( \ - ((GET_MODE_CLASS (TYPE_MODE (VALTYPE)) == MODE_INT \ - && GET_MODE_SIZE (TYPE_MODE (VALTYPE)) < 4 \ - && (TREE_CODE (VALTYPE) == INTEGER_TYPE \ - || TREE_CODE (VALTYPE) == ENUMERAL_TYPE \ - || TREE_CODE (VALTYPE) == BOOLEAN_TYPE \ - || TREE_CODE (VALTYPE) == REAL_TYPE \ - || TREE_CODE (VALTYPE) == OFFSET_TYPE)) \ - && sh_promote_prototypes (FUNC) \ - ? (TARGET_SHMEDIA64 ? DImode : SImode) : TYPE_MODE (VALTYPE)), \ - BASE_RETURN_VALUE_REG (TYPE_MODE (VALTYPE))) - -/* Define how to find the value returned by a library function - assuming the value has mode MODE. */ -#define LIBCALL_VALUE(MODE) \ - gen_rtx_REG ((MODE), BASE_RETURN_VALUE_REG (MODE)); - -/* 1 if N is a possible register number for a function value. */ -#define FUNCTION_VALUE_REGNO_P(REGNO) \ - ((REGNO) == FIRST_RET_REG || (TARGET_SH2E && (REGNO) == FIRST_FP_RET_REG) \ - || (TARGET_SHMEDIA_FPU && (REGNO) == FIRST_FP_RET_REG)) +#define FUNCTION_VALUE_REGNO_P(REGNO) sh_function_value_regno_p (REGNO) /* 1 if N is a possible register number for function argument passing. */ /* ??? There are some callers that pass REGNO as int, and others that pass diff --git a/gcc/config/stormy16/stormy16-lib2-count-leading-zeros.c b/gcc/config/stormy16/stormy16-lib2-count-leading-zeros.c deleted file mode 100644 index 1b98d30c18b..00000000000 --- a/gcc/config/stormy16/stormy16-lib2-count-leading-zeros.c +++ /dev/null @@ -1,2 +0,0 @@ -#define XSTORMY16_COUNT_LEADING_ZEROS -#include "stormy16-lib2.c" diff --git a/gcc/config/stormy16/stormy16-lib2.c b/gcc/config/stormy16/stormy16-lib2.c index 91c3c3dd2ca..0c99cdd3e90 100644 --- a/gcc/config/stormy16/stormy16-lib2.c +++ b/gcc/config/stormy16/stormy16-lib2.c @@ -253,14 +253,24 @@ __parityhi2 (UHWtype x) #endif #ifdef XSTORMY16_CLZHI2 -/* Returns the number of leading zero bits in X. - FIXME: The return type really should be "unsigned int" - but this is not how the builtin is prototyped. */ - +/* Returns the number of zero-bits from the most significant bit to the + first nonzero bit in X. Returns 16 for X == 0. Implemented as a + simple for loop in order to save space by removing the need for + the __clz_tab array. + FIXME: The return type really should be "unsigned int" but this is + not how the builtin is prototyped. */ +#undef unsigned int __clzhi2 (UHWtype x) { - return __stormy16_count_leading_zeros (x); + unsigned int i; + unsigned int c; + unsigned int value = x; + + for (c = 0, i = 1 << 15; i; i >>= 1, c++) + if (i & value) + break; + return c; } #endif @@ -278,7 +288,7 @@ __ctzhi2 (UHWtype x) bits. */ x &= - x; - return 15 - __stormy16_count_leading_zeros (x); + return 15 - __builtin_clz (x); } #endif @@ -296,26 +306,6 @@ __ffshi2 (UHWtype u) if (u == 0) return 0; - return 16 - __stormy16_count_leading_zeros (u & - u); + return 16 - __builtin_clz (u & - u); } #endif - -#ifdef XSTORMY16_COUNT_LEADING_ZEROS -#undef unsigned -/* Count the number of zero-bits from the most significant bit to the - first nonzero bit in VALUE. Returns 16 for VALUE == 0. Implemented - as a simple for loop in order to save space by removing the need for - the __clz_tab array. */ - -unsigned int -__stormy16_count_leading_zeros (unsigned int value) -{ - unsigned int i; - unsigned int c; - - for (c = 0, i = 1 << 15; i; i >>= 1, c++) - if (i & value) - break; - return c; -} -#endif /* XSTORMY16_COUNT_LEADING_ZEROS */ diff --git a/gcc/config/stormy16/t-stormy16 b/gcc/config/stormy16/t-stormy16 index b103f88a1df..8959e64ab5e 100644 --- a/gcc/config/stormy16/t-stormy16 +++ b/gcc/config/stormy16/t-stormy16 @@ -18,8 +18,7 @@ # along with GCC; see the file COPYING3. If not see # <http://www.gnu.org/licenses/>. -# SImode routines - +# SImode arithmetic and logical routines, HImode bit counting routines. LIB2FUNCS_EXTRA = \ $(srcdir)/config/stormy16/stormy16-lib2-udivmodsi4.c \ $(srcdir)/config/stormy16/stormy16-lib2-divsi3.c \ @@ -33,12 +32,9 @@ LIB2FUNCS_EXTRA = \ $(srcdir)/config/stormy16/stormy16-lib2-parityhi2.c \ $(srcdir)/config/stormy16/stormy16-lib2-clzhi2.c \ $(srcdir)/config/stormy16/stormy16-lib2-ctzhi2.c \ - $(srcdir)/config/stormy16/stormy16-lib2-ffshi2.c \ - $(srcdir)/config/stormy16/stormy16-lib2-count-leading-zeros.c - - -# floating point emulation libraries + $(srcdir)/config/stormy16/stormy16-lib2-ffshi2.c +# Floating point emulation libraries. FPBIT = fp-bit.c DPBIT = dp-bit.c diff --git a/gcc/configure b/gcc/configure index 1ea172a0d35..ec8d682425a 100755 --- a/gcc/configure +++ b/gcc/configure @@ -22705,6 +22705,32 @@ fi i[34567]86-*-* | x86_64-*-*) case $target_os in + cygwin*) + # Full C++ conformance when using a shared libstdc++-v3 requires some + # support from the Cygwin DLL, which in more recent versions exports + # wrappers to aid in interposing and redirecting operators new, delete, + # etc., as per n2800 #17.6.4.6 [replacement.functions]. Check if we + # are configuring for a version of Cygwin that exports the wrappers. + if test x$host = x$target; then + ac_fn_c_check_func "$LINENO" "__wrap__Znaj" "ac_cv_func___wrap__Znaj" +if test "x$ac_cv_func___wrap__Znaj" = x""yes; then : + gcc_ac_cygwin_dll_wrappers=yes +else + gcc_ac_cygwin_dll_wrappers=no +fi + + else + # Can't check presence of libc functions during cross-compile, so + # we just have to assume we're building for an up-to-date target. + gcc_ac_cygwin_dll_wrappers=yes + fi + +cat >>confdefs.h <<_ACEOF +#define USE_CYGWIN_LIBSTDCXX_WRAPPERS `if test $gcc_ac_cygwin_dll_wrappers = yes; then echo 1; else echo 0; fi` +_ACEOF + + esac + case $target_os in cygwin* | pe | mingw32*) # Recent binutils allows the three-operand form of ".comm" on PE. This # definition is used unconditionally to initialise the default state of diff --git a/gcc/configure.ac b/gcc/configure.ac index 17cfe835b8c..5accd597c91 100644 --- a/gcc/configure.ac +++ b/gcc/configure.ac @@ -3000,6 +3000,25 @@ changequote(,)dnl i[34567]86-*-* | x86_64-*-*) changequote([,])dnl case $target_os in + cygwin*) + # Full C++ conformance when using a shared libstdc++-v3 requires some + # support from the Cygwin DLL, which in more recent versions exports + # wrappers to aid in interposing and redirecting operators new, delete, + # etc., as per n2800 #17.6.4.6 [replacement.functions]. Check if we + # are configuring for a version of Cygwin that exports the wrappers. + if test x$host = x$target; then + AC_CHECK_FUNC([__wrap__Znaj],[gcc_ac_cygwin_dll_wrappers=yes],[gcc_ac_cygwin_dll_wrappers=no]) + else + # Can't check presence of libc functions during cross-compile, so + # we just have to assume we're building for an up-to-date target. + gcc_ac_cygwin_dll_wrappers=yes + fi + AC_DEFINE_UNQUOTED(USE_CYGWIN_LIBSTDCXX_WRAPPERS, + [`if test $gcc_ac_cygwin_dll_wrappers = yes; then echo 1; else echo 0; fi`], + [Define if you want to generate code by default that assumes that the + Cygwin DLL exports wrappers to support libstdc++ function replacement.]) + esac + case $target_os in cygwin* | pe | mingw32*) # Recent binutils allows the three-operand form of ".comm" on PE. This # definition is used unconditionally to initialise the default state of diff --git a/gcc/cp/ChangeLog b/gcc/cp/ChangeLog index 57ce3cd58ff..3a086021776 100644 --- a/gcc/cp/ChangeLog +++ b/gcc/cp/ChangeLog @@ -1,3 +1,37 @@ +2009-12-01 Taras Glek <taras@mozilla.com> + + * parser.c (cp_parser_class_specifier): Set class location to that + of IDENTIFIER_NODE instead of '{' when possible. + +2009-12-01 Taras Glek <taras@mozilla.com> + + * semantics.c (begin_class_definition): Do not overide locations with less precise ones. + +2009-12-01 Jason Merrill <jason@redhat.com> + + PR c++/41611 + * decl2.c (get_guard): Copy DECL_COMDAT. + (comdat_linkage): Set DECL_COMDAT unconditionally. + +2009-12-01 Jakub Jelinek <jakub@redhat.com> + + PR c++/3187 + * optimize.c (cdtor_comdat_group): New function. + (maybe_clone_body): Also optimize DECL_COMDAT base/complete cdtors + and in that case put also the deleting dtor in the same comdat group + as base and complete dtor if dtor is virtual. + +2009-11-30 Paolo Carlini <paolo.carlini@oracle.com> + + PR c++/40371 + * call.c (add_template_candidate_real): Early return NULL if + the arglist length is smaller than skip_without_in_chrg; tidy. + +2009-11-30 Dodji Seketeli <dodji@redhat.com> + + PR c++/42069 + * pt.c (convert_template_argument): Strip typedefs from SCOPE_REFs. + 2009-11-29 Dodji Seketeli <dodji@redhat.com> PR c++/36408 diff --git a/gcc/cp/call.c b/gcc/cp/call.c index 70a5b1efbf5..837a65d8079 100644 --- a/gcc/cp/call.c +++ b/gcc/cp/call.c @@ -2457,9 +2457,10 @@ add_template_candidate_real (struct z_candidate **candidates, tree tmpl, { int ntparms = DECL_NTPARMS (tmpl); tree targs = make_tree_vec (ntparms); - unsigned int nargs; - int skip_without_in_chrg; - tree first_arg_without_in_chrg; + unsigned int len = VEC_length (tree, arglist); + unsigned int nargs = (first_arg == NULL_TREE ? 0 : 1) + len; + unsigned int skip_without_in_chrg = 0; + tree first_arg_without_in_chrg = first_arg; tree *args_without_in_chrg; unsigned int nargs_without_in_chrg; unsigned int ia, ix; @@ -2468,12 +2469,6 @@ add_template_candidate_real (struct z_candidate **candidates, tree tmpl, int i; tree fn; - nargs = (first_arg == NULL_TREE ? 0 : 1) + VEC_length (tree, arglist); - - skip_without_in_chrg = 0; - - first_arg_without_in_chrg = first_arg; - /* We don't do deduction on the in-charge parameter, the VTT parameter or 'this'. */ if (DECL_NONSTATIC_MEMBER_FUNCTION_P (tmpl)) @@ -2494,9 +2489,11 @@ add_template_candidate_real (struct z_candidate **candidates, tree tmpl, ++skip_without_in_chrg; } + if (len < skip_without_in_chrg) + return NULL; + nargs_without_in_chrg = ((first_arg_without_in_chrg != NULL_TREE ? 1 : 0) - + (VEC_length (tree, arglist) - - skip_without_in_chrg)); + + (len - skip_without_in_chrg)); args_without_in_chrg = XALLOCAVEC (tree, nargs_without_in_chrg); ia = 0; if (first_arg_without_in_chrg != NULL_TREE) diff --git a/gcc/cp/decl2.c b/gcc/cp/decl2.c index c0febad2515..1cd2ded03a3 100644 --- a/gcc/cp/decl2.c +++ b/gcc/cp/decl2.c @@ -1574,8 +1574,7 @@ comdat_linkage (tree decl) } } - if (DECL_LANG_SPECIFIC (decl)) - DECL_COMDAT (decl) = 1; + DECL_COMDAT (decl) = 1; } /* For win32 we also want to put explicit instantiations in @@ -2555,6 +2554,7 @@ get_guard (tree decl) TREE_PUBLIC (guard) = TREE_PUBLIC (decl); TREE_STATIC (guard) = TREE_STATIC (decl); DECL_COMMON (guard) = DECL_COMMON (decl); + DECL_COMDAT (guard) = DECL_COMDAT (decl); DECL_COMDAT_GROUP (guard) = DECL_COMDAT_GROUP (decl); if (TREE_PUBLIC (decl)) DECL_WEAK (guard) = DECL_WEAK (decl); diff --git a/gcc/cp/optimize.c b/gcc/cp/optimize.c index 838a7305a71..5a67431cc1f 100644 --- a/gcc/cp/optimize.c +++ b/gcc/cp/optimize.c @@ -142,6 +142,46 @@ build_delete_destructor_body (tree delete_dtor, tree complete_dtor) } } +/* Return name of comdat group for complete and base ctor (or dtor) + that have the same body. If dtor is virtual, deleting dtor goes + into this comdat group as well. */ + +static tree +cdtor_comdat_group (tree complete, tree base) +{ + tree complete_name = DECL_COMDAT_GROUP (complete); + tree base_name = DECL_COMDAT_GROUP (base); + char *grp_name; + const char *p, *q; + bool diff_seen = false; + size_t idx; + if (complete_name == NULL) + complete_name = cxx_comdat_group (complete); + if (base_name == NULL) + base_name = cxx_comdat_group (base); + gcc_assert (IDENTIFIER_LENGTH (complete_name) + == IDENTIFIER_LENGTH (base_name)); + grp_name = XALLOCAVEC (char, IDENTIFIER_LENGTH (complete_name) + 1); + p = IDENTIFIER_POINTER (complete_name); + q = IDENTIFIER_POINTER (base_name); + for (idx = 0; idx < IDENTIFIER_LENGTH (complete_name); idx++) + if (p[idx] == q[idx]) + grp_name[idx] = p[idx]; + else + { + gcc_assert (!diff_seen + && idx > 0 + && (p[idx - 1] == 'C' || p[idx - 1] == 'D') + && p[idx] == '1' + && q[idx] == '2'); + grp_name[idx] = '5'; + diff_seen = true; + } + grp_name[idx] = '\0'; + gcc_assert (diff_seen); + return get_identifier (grp_name); +} + /* FN is a function that has a complete body. Clone the body as necessary. Returns nonzero if there's no longer any need to process the main body. */ @@ -149,6 +189,7 @@ build_delete_destructor_body (tree delete_dtor, tree complete_dtor) bool maybe_clone_body (tree fn) { + tree comdat_group = NULL_TREE; tree clone; tree fns[3]; bool first = true; @@ -248,10 +289,26 @@ maybe_clone_body (tree fn) && idx == 1 && !flag_use_repository && DECL_INTERFACE_KNOWN (fns[0]) - && !DECL_ONE_ONLY (fns[0]) + && (SUPPORTS_ONE_ONLY || !DECL_WEAK (fns[0])) + && (!DECL_ONE_ONLY (fns[0]) + || (HAVE_COMDAT_GROUP + && DECL_WEAK (fns[0]) + /* Don't optimize synthetized virtual dtors, because then + the deleting and other dtors are emitted when needed + and so it is not certain we would emit both + deleting and complete/base dtors in the comdat group. */ + && (fns[2] == NULL || !DECL_ARTIFICIAL (fn)))) && cgraph_same_body_alias (clone, fns[0])) { alias = true; + if (DECL_ONE_ONLY (fns[0])) + { + /* For comdat base and complete cdtors put them + into the same, *[CD]5* comdat group instead of + *[CD][12]*. */ + comdat_group = cdtor_comdat_group (fns[1], fns[0]); + DECL_COMDAT_GROUP (fns[0]) = comdat_group; + } emit_associated_thunks (clone); } @@ -333,6 +390,15 @@ maybe_clone_body (tree fn) } pop_from_top_level (); + if (comdat_group) + { + DECL_COMDAT_GROUP (fns[1]) = comdat_group; + if (fns[2]) + /* If *[CD][12]* dtors go into the *[CD]5* comdat group and dtor is + virtual, it goes into the same comdat group as well. */ + DECL_COMDAT_GROUP (fns[2]) = comdat_group; + } + /* We don't need to process the original function any further. */ return 1; } diff --git a/gcc/cp/parser.c b/gcc/cp/parser.c index 5c8dbcb155e..f50d1c0bb8d 100644 --- a/gcc/cp/parser.c +++ b/gcc/cp/parser.c @@ -16388,6 +16388,8 @@ cp_parser_class_head (cp_parser* parser, end_specialization (); --parser->num_template_parameter_lists; } + + DECL_SOURCE_LOCATION (TYPE_NAME (type)) = type_start_token->location; *attributes_p = attributes; return type; } diff --git a/gcc/cp/pt.c b/gcc/cp/pt.c index dd86ceeb682..9fd06b3433f 100644 --- a/gcc/cp/pt.c +++ b/gcc/cp/pt.c @@ -5526,6 +5526,13 @@ convert_template_argument (tree parm, if (TYPE_P (val)) val = strip_typedefs (val); } + else if (TREE_CODE (orig_arg) == SCOPE_REF) + { + /* Strip typedefs from the SCOPE_REF. */ + tree type = strip_typedefs (TREE_TYPE (orig_arg)); + tree scope = strip_typedefs (TREE_OPERAND (orig_arg, 0)); + val = build2 (SCOPE_REF, type, scope, TREE_OPERAND (orig_arg, 1)); + } else { tree t = tsubst (TREE_TYPE (parm), args, complain, in_decl); diff --git a/gcc/cp/semantics.c b/gcc/cp/semantics.c index 4a9bee71624..aa79b22a33f 100644 --- a/gcc/cp/semantics.c +++ b/gcc/cp/semantics.c @@ -2386,9 +2386,6 @@ begin_class_definition (tree t, tree attributes) pushtag (make_anon_name (), t, /*tag_scope=*/ts_current); } - /* Update the location of the decl. */ - DECL_SOURCE_LOCATION (TYPE_NAME (t)) = input_location; - if (TYPE_BEING_DEFINED (t)) { t = make_class_type (TREE_CODE (t)); diff --git a/gcc/doc/contrib.texi b/gcc/doc/contrib.texi index 6ee5b5001d7..1515b5c876d 100644 --- a/gcc/doc/contrib.texi +++ b/gcc/doc/contrib.texi @@ -326,6 +326,10 @@ Stu Grossman for gdb hacking, allowing GCJ developers to debug Java code. Michael K. Gschwind contributed the port to the PDP-11. @item +Richard Guenther for his ongoing middle-end contributions and bug fixes +and for release management. + +@item Ron Guilmette implemented the @command{protoize} and @command{unprotoize} tools, the support for Dwarf symbolic debugging information, and much of the support for System V Release 4. He has also worked heavily on the diff --git a/gcc/doc/plugins.texi b/gcc/doc/plugins.texi index eb1008e8f2c..8aac0f7b65c 100644 --- a/gcc/doc/plugins.texi +++ b/gcc/doc/plugins.texi @@ -156,18 +156,42 @@ enum plugin_event PLUGIN_ATTRIBUTES, /* Called during attribute registration */ PLUGIN_START_UNIT, /* Called before processing a translation unit. */ PLUGIN_PRAGMAS, /* Called during pragma registration. */ - PLUGIN_EVENT_LAST /* Dummy event used for indexing callback + /* Called before first pass from all_passes. */ + PLUGIN_ALL_PASSES_START, + /* Called after last pass from all_passes. */ + PLUGIN_ALL_PASSES_END, + /* Called before first ipa pass. */ + PLUGIN_ALL_IPA_PASSES_START, + /* Called after last ipa pass. */ + PLUGIN_ALL_IPA_PASSES_END, + /* Allows to override pass gate decision for current_pass. */ + PLUGIN_OVERRIDE_GATE, + /* Called before executing a pass. */ + PLUGIN_PASS_EXECUTION, + /* Called before executing subpasses of a GIMPLE_PASS in + execute_ipa_pass_list. */ + PLUGIN_EARLY_GIMPLE_PASSES_START, + /* Called after executing subpasses of a GIMPLE_PASS in + execute_ipa_pass_list. */ + PLUGIN_EARLY_GIMPLE_PASSES_END, + /* Called when a pass is first instantiated. */ + PLUGIN_NEW_PASS, + + PLUGIN_EVENT_FIRST_DYNAMIC /* Dummy event used for indexing callback array. */ @}; @end smallexample +In addition, plugins can also look up the enumerator of a named event, +and / or generate new events dynamically, by calling the function +@code{get_named_event_id}. To register a callback, the plugin calls @code{register_callback} with the arguments: @itemize @item @code{char *name}: Plugin name. -@item @code{enum plugin_event event}: The event code. +@item @code{int event}: The event code. @item @code{plugin_callback_func callback}: The function that handles @code{event}. @item @code{void *user_data}: Pointer to plugin-specific data. @end itemize @@ -337,6 +361,41 @@ It is suggested to pass @code{"GCCPLUGIN"} (or a short name identifying your plugin) as the ``space'' argument of your pragma. +@section Recording information about pass execution + +The event PLUGIN_PASS_EXECUTION passes the pointer to the executed pass +(the same as current_pass) as @code{gcc_data} to the callback. You can also +inspect cfun to find out about which function this pass is executed for. +Note that this event will only be invoked if the gate check (if +applicable, modified by PLUGIN_OVERRIDE_GATE) succeeds. +You can use other hooks, like @code{PLUGIN_ALL_PASSES_START}, +@code{PLUGIN_ALL_PASSES_END}, @code{PLUGIN_ALL_IPA_PASSES_START}, +@code{PLUGIN_ALL_IPA_PASSES_END}, @code{PLUGIN_EARLY_GIMPLE_PASSES_START}, +and/or @code{PLUGIN_EARLY_GIMPLE_PASSES_END} to manipulate global state +in your plugin(s) in order to get context for the pass execution. + + +@section Controlling which passes are being run + +After the original gate function for a pass is called, its result +- the gate status - is stored as an integer. +Then the event @code{PLUGIN_OVERRIDE_GATE} is invoked, with a pointer +to the gate status in the @code{gcc_data} parameter to the callback function. +A nonzero value of the gate status means that the pass is to be executed. +You can both read and write the gate status via the passed pointer. + + +@section Keeping track of available passes + +When your plugin is loaded, you can inspect the various +pass lists to determine what passes are available. However, other +plugins might add new passes. Also, future changes to GCC might cause +generic passes to be added after plugin loading. +When a pass is first added to one of the pass lists, the event +@code{PLUGIN_NEW_PASS} is invoked, with the callback parameter +@code{gcc_data} pointing to the new pass. + + @section Building GCC plugins If plugins are enabled, GCC installs the headers needed to build a diff --git a/gcc/expr.c b/gcc/expr.c index 75c17923cd0..13ae5fffc9f 100644 --- a/gcc/expr.c +++ b/gcc/expr.c @@ -6840,9 +6840,8 @@ expand_expr_addr_expr_1 (tree exp, rtx target, enum machine_mode tmode, return expand_expr (TREE_OPERAND (exp, 0), target, tmode, modifier); case CONST_DECL: - /* Recurse and make the output_constant_def clause above handle this. */ - return expand_expr_addr_expr_1 (DECL_INITIAL (exp), target, - tmode, modifier, as); + /* Expand the initializer like constants above. */ + return XEXP (expand_expr_constant (DECL_INITIAL (exp), 0, modifier), 0); case REALPART_EXPR: /* The real part of the complex number is always first, therefore diff --git a/gcc/final.c b/gcc/final.c index 5d037f53933..0d19562acbf 100644 --- a/gcc/final.c +++ b/gcc/final.c @@ -4382,6 +4382,8 @@ rest_of_clean_state (void) : ""); flag_dump_noaddr = flag_dump_unnumbered = 1; + if (flag_compare_debug_opt || flag_compare_debug) + dump_flags |= TDF_NOUID; for (insn = get_insns (); insn; insn = NEXT_INSN (insn)) if (LABEL_P (insn)) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8b6c4ce6a9c..b39afe173f7 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,85 @@ +2009-12-01 Janne Blomqvist <jb@gcc.gnu.org> + + * PR fortran/42131 + * trans-stmt.c (gfc_trans_do): Sign test using ternary operator. + +2009-11-30 Janus Weil <janus@gcc.gnu.org> + + PR fortran/42053 + * resolve.c (resolve_select_type): Check for duplicate CLASS IS blocks. + +2009-11-30 Janus Weil <janus@gcc.gnu.org> + + PR fortran/41631 + * decl.c (gfc_match_derived_decl): Set extension level. + * gfortran.h (symbol_attribute): Expand 'extension' bit field to 8 bit. + * iresolve.c (gfc_resolve_extends_type_of): Return value of + 'is_extension_of' has kind=4. + * match.c (select_type_set_tmp,gfc_match_class_is): Create temporary + for CLASS IS blocks. + * module.c (MOD_VERSION): Bump module version. + (ab_attribute,attr_bits): Remove AB_EXTENSION. + (mio_symbol_attribute): Handle expanded 'extension' field. + * resolve.c (resolve_select_type): Implement CLASS IS blocks. + (resolve_fl_variable_derived): Show correct type name. + * symbol.c (gfc_build_class_symbol): Set extension level. + +2009-11-30 Janus Weil <janus@gcc.gnu.org> + + * intrinsic.h (gfc_resolve_extends_type_of): Add prototype. + * intrinsic.c (add_functions): Use 'gfc_resolve_extends_type_of'. + * iresolve.c (gfc_resolve_extends_type_of): New function, which + replaces the call to EXTENDS_TYPE_OF by the library function + 'is_extension_of' and modifies the arguments. + * trans-intrinsic.c (gfc_conv_extends_type_of): Removed. + (gfc_conv_intrinsic_function): FOR EXTENDS_TYPE_OF, don't call + gfc_conv_extends_type_of but gfc_conv_intrinsic_funcall. + +2009-11-30 Paul Thomas <pault@gcc.gnu.org> + Janus Weil <janus@gcc.gnu.org> + + * decl.c (encapsulate_class_symbol): Replaced by + 'gfc_build_class_symbol'. + (build_sym,build_struct): Call 'gfc_build_class_symbol'. + (gfc_match_derived_decl): Replace vindex by hash_value. + * dump-parse-tree.c (show_symbol): Replace vindex by hash_value. + * gfortran.h (symbol_attribute): Add field 'vtab'. + (gfc_symbol): Replace vindex by hash_value. + (gfc_class_esym_list): Ditto. + (gfc_get_derived_type,gfc_build_class_symbol,gfc_find_derived_vtab): + New prototypes. + * module.c (mio_symbol): Replace vindex by hash_value. + * resolve.c (vindex_expr): Rename to 'hash_value_expr'. + (resolve_class_compcall,resolve_class_typebound_call): Renamed + 'vindex_expr'. + (resolve_select_type): Replace $vindex by $vptr->$hash. + * symbol.c (gfc_add_save): Handle vtab symbols. + (gfc_type_compatible): Rewrite. + (gfc_build_class_symbol): New function which replaces + 'encapsulate_class_symbol'. + (gfc_find_derived_vtab): New function to set up a vtab symbol for a + derived type. + * trans-decl.c (gfc_create_module_variable): Handle vtab symbols. + * trans-expr.c (select_class_proc): Replace vindex by hash_value. + (gfc_conv_derived_to_class): New function to construct a temporary + CLASS variable from a derived type expression. + (gfc_conv_procedure_call): Call 'gfc_conv_derived_to_class'. + (gfc_conv_structure): Initialize the $extends and $size fields of + vtab symbols. + (gfc_trans_class_assign): Replace $vindex by $vptr. Remove the $size + assignment. + * trans-intrinsic.c (gfc_conv_same_type_as): Replace $vindex by + $vptr->$hash, and replace vindex by hash_value. + * trans-stmt.c (gfc_trans_allocate): Insert $vptr references, replace + $vindex by $vptr. Remove the $size assignment. + * trans-types.c (gfc_get_derived_type): Make it non-static. + +2009-11-30 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/42131 + * trans-stmt.c (gfc_trans_do): Calculate loop count + without if statements. + 2009-11-28 Jakub Jelinek <jakub@redhat.com> * trans-common.c (create_common): Remove unused offset variable. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 23ac5c39424..90f30b32175 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1025,88 +1025,6 @@ verify_c_interop_param (gfc_symbol *sym) } -/* Build a polymorphic CLASS entity, using the symbol that comes from build_sym. - A CLASS entity is represented by an encapsulating type, which contains the - declared type as '$data' component, plus an integer component '$vindex' - which determines the dynamic type, and another integer '$size', which - contains the size of the dynamic type structure. */ - -static gfc_try -encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr, - gfc_array_spec **as) -{ - char name[GFC_MAX_SYMBOL_LEN + 5]; - gfc_symbol *fclass; - gfc_component *c; - - /* Determine the name of the encapsulating type. */ - if ((*as) && (*as)->rank && attr->allocatable) - sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank); - else if ((*as) && (*as)->rank) - sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank); - else if (attr->allocatable) - sprintf (name, ".class.%s.a", ts->u.derived->name); - else - sprintf (name, ".class.%s", ts->u.derived->name); - - gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass); - if (fclass == NULL) - { - gfc_symtree *st; - /* If not there, create a new symbol. */ - fclass = gfc_new_symbol (name, ts->u.derived->ns); - st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name); - st->n.sym = fclass; - gfc_set_sym_referenced (fclass); - fclass->refs++; - fclass->ts.type = BT_UNKNOWN; - fclass->vindex = ts->u.derived->vindex; - fclass->attr.abstract = ts->u.derived->attr.abstract; - if (ts->u.derived->f2k_derived) - fclass->f2k_derived = gfc_get_namespace (NULL, 0); - if (gfc_add_flavor (&fclass->attr, FL_DERIVED, - NULL, &gfc_current_locus) == FAILURE) - return FAILURE; - - /* Add component '$data'. */ - if (gfc_add_component (fclass, "$data", &c) == FAILURE) - return FAILURE; - c->ts = *ts; - c->ts.type = BT_DERIVED; - c->attr.access = ACCESS_PRIVATE; - c->ts.u.derived = ts->u.derived; - c->attr.pointer = attr->pointer || attr->dummy; - c->attr.allocatable = attr->allocatable; - c->attr.dimension = attr->dimension; - c->attr.abstract = ts->u.derived->attr.abstract; - c->as = (*as); - c->initializer = gfc_get_expr (); - c->initializer->expr_type = EXPR_NULL; - - /* Add component '$vindex'. */ - if (gfc_add_component (fclass, "$vindex", &c) == FAILURE) - return FAILURE; - c->ts.type = BT_INTEGER; - c->ts.kind = 4; - c->attr.access = ACCESS_PRIVATE; - c->initializer = gfc_int_expr (0); - - /* Add component '$size'. */ - if (gfc_add_component (fclass, "$size", &c) == FAILURE) - return FAILURE; - c->ts.type = BT_INTEGER; - c->ts.kind = 4; - c->attr.access = ACCESS_PRIVATE; - c->initializer = gfc_int_expr (0); - } - - fclass->attr.extension = 1; - fclass->attr.is_class = 1; - ts->u.derived = fclass; - attr->allocatable = attr->pointer = attr->dimension = 0; - (*as) = NULL; /* XXX */ - return SUCCESS; -} /* Function called by variable_decl() that adds a name to the symbol table. */ @@ -1185,7 +1103,7 @@ build_sym (const char *name, gfc_charlen *cl, sym->attr.class_ok = (sym->attr.dummy || sym->attr.pointer || sym->attr.allocatable) ? 1 : 0; - encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as); + gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as); } return SUCCESS; @@ -1594,7 +1512,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, scalar: if (c->ts.type == BT_CLASS) - encapsulate_class_symbol (&c->ts, &c->attr, &c->as); + gfc_build_class_symbol (&c->ts, &c->attr, &c->as); return t; } @@ -6926,13 +6844,23 @@ gfc_match_derived_decl (void) /* Add the extended derived type as the first component. */ gfc_add_component (sym, parent, &p); - sym->attr.extension = attr.extension; extended->refs++; gfc_set_sym_referenced (extended); p->ts.type = BT_DERIVED; p->ts.u.derived = extended; p->initializer = gfc_default_initializer (&p->ts); + + /* Set extension level. */ + if (extended->attr.extension == 255) + { + /* Since the extension field is 8 bit wide, we can only have + up to 255 extension levels. */ + gfc_error ("Maximum extension level reached with type '%s' at %L", + extended->name, &extended->declared_at); + return MATCH_ERROR; + } + sym->attr.extension = extended->attr.extension + 1; /* Provide the links between the extended type and its extension. */ if (!extended->f2k_derived) @@ -6941,9 +6869,9 @@ gfc_match_derived_decl (void) st->n.sym = sym; } - if (!sym->vindex) - /* Set the vindex for this type. */ - sym->vindex = hash_value (sym); + if (!sym->hash_value) + /* Set the hash for the compound name for this type. */ + sym->hash_value = hash_value (sym); /* Take over the ABSTRACT attribute. */ sym->attr.abstract = attr.abstract; diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 32ff298d6e0..97289c26aa5 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -827,8 +827,8 @@ show_symbol (gfc_symbol *sym) if (sym->f2k_derived) { show_indent (); - if (sym->vindex) - fprintf (dumpfile, "vindex: %d", sym->vindex); + if (sym->hash_value) + fprintf (dumpfile, "hash: %d", sym->hash_value); show_f2k_derived (sym->f2k_derived); } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index cc3ccf5527c..e552203cb91 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -670,9 +670,10 @@ typedef struct unsigned untyped:1; /* No implicit type could be found. */ unsigned is_bind_c:1; /* say if is bound to C. */ - unsigned extension:1; /* extends a derived type. */ + unsigned extension:8; /* extension level of a derived type. */ unsigned is_class:1; /* is a CLASS container. */ unsigned class_ok:1; /* is a CLASS object with correct attributes. */ + unsigned vtab:1; /* is a derived type vtab. */ /* These flags are both in the typespec and attribute. The attribute list is what gets read from/written to a module file. The typespec @@ -1137,8 +1138,8 @@ typedef struct gfc_symbol int entry_id; /* Used in resolve.c for entries. */ - /* CLASS vindex for declared and dynamic types in the class. */ - int vindex; + /* CLASS hashed name for declared and dynamic types in the class. */ + int hash_value; struct gfc_symbol *common_next; /* Links for COMMON syms */ @@ -1599,7 +1600,7 @@ typedef struct gfc_class_esym_list { gfc_symbol *derived; gfc_symbol *esym; - struct gfc_expr *vindex; + struct gfc_expr *hash_value; struct gfc_class_esym_list *next; } gfc_class_esym_list; @@ -2380,6 +2381,7 @@ gfc_try gfc_check_any_c_kind (gfc_typespec *); int gfc_validate_kind (bt, int, bool); int gfc_get_int_kind_from_width_isofortranenv (int size); int gfc_get_real_kind_from_width_isofortranenv (int size); +tree gfc_get_derived_type (gfc_symbol * derived); extern int gfc_index_integer_kind; extern int gfc_default_integer_kind; extern int gfc_max_integer_kind; @@ -2517,6 +2519,9 @@ void gfc_free_dt_list (void); gfc_gsymbol *gfc_get_gsymbol (const char *); gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *); +gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *, + gfc_array_spec **); +gfc_symbol *gfc_find_derived_vtab (gfc_symbol *); gfc_typebound_proc* gfc_get_typebound_proc (void); gfc_symbol* gfc_get_derived_super_type (gfc_symbol*); gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*); diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index a62dd92375b..859fd4b7abf 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1601,7 +1601,7 @@ add_functions (void) add_sym_2 ("extends_type_of", GFC_ISYM_EXTENDS_TYPE_OF, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003, - gfc_check_same_type_as, NULL, NULL, + gfc_check_same_type_as, NULL, gfc_resolve_extends_type_of, a, BT_UNKNOWN, 0, REQUIRED, mo, BT_UNKNOWN, 0, REQUIRED); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index acd3f7896d0..cf436db37fd 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -390,6 +390,7 @@ void gfc_resolve_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, void gfc_resolve_etime_sub (gfc_code *); void gfc_resolve_exp (gfc_expr *, gfc_expr *); void gfc_resolve_exponent (gfc_expr *, gfc_expr *); +void gfc_resolve_extends_type_of (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_fdate (gfc_expr *); void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_fnum (gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 960be088531..7e8bdfb0cea 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -806,6 +806,57 @@ gfc_resolve_exponent (gfc_expr *f, gfc_expr *x) } +/* Resolve the EXTENDS_TYPE_OF intrinsic function. */ + +void +gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo) +{ + gfc_symbol *vtab; + gfc_symtree *st; + + /* Prevent double resolution. */ + if (f->ts.type == BT_LOGICAL) + return; + + /* Replace the first argument with the corresponding vtab. */ + if (a->ts.type == BT_CLASS) + gfc_add_component_ref (a, "$vptr"); + else if (a->ts.type == BT_DERIVED) + { + vtab = gfc_find_derived_vtab (a->ts.u.derived); + /* Clear the old expr. */ + gfc_free_ref_list (a->ref); + memset (a, '\0', sizeof (gfc_expr)); + /* Construct a new one. */ + a->expr_type = EXPR_VARIABLE; + st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); + a->symtree = st; + a->ts = vtab->ts; + } + + /* Replace the second argument with the corresponding vtab. */ + if (mo->ts.type == BT_CLASS) + gfc_add_component_ref (mo, "$vptr"); + else if (mo->ts.type == BT_DERIVED) + { + vtab = gfc_find_derived_vtab (mo->ts.u.derived); + /* Clear the old expr. */ + gfc_free_ref_list (mo->ref); + memset (mo, '\0', sizeof (gfc_expr)); + /* Construct a new one. */ + mo->expr_type = EXPR_VARIABLE; + st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); + mo->symtree = st; + mo->ts = vtab->ts; + } + + f->ts.type = BT_LOGICAL; + f->ts.kind = 4; + /* Call library function. */ + f->value.function.name = gfc_get_string (PREFIX ("is_extension_of")); +} + + void gfc_resolve_fdate (gfc_expr *f) { diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 153dfdb3073..9e76818badc 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -3968,13 +3968,25 @@ select_type_set_tmp (gfc_typespec *ts) { char name[GFC_MAX_SYMBOL_LEN]; gfc_symtree *tmp; + + if (!gfc_type_is_extensible (ts->u.derived)) + return; - sprintf (name, "tmp$%s", ts->u.derived->name); + if (ts->type == BT_CLASS) + sprintf (name, "tmp$class$%s", ts->u.derived->name); + else + sprintf (name, "tmp$type$%s", ts->u.derived->name); gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); gfc_add_type (tmp->n.sym, ts, NULL); gfc_set_sym_referenced (tmp->n.sym); gfc_add_pointer (&tmp->n.sym->attr, NULL); gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); + if (ts->type == BT_CLASS) + { + gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr, + &tmp->n.sym->as); + tmp->n.sym->attr.class_ok = 1; + } select_type_stack->tmp = tmp; } @@ -4228,8 +4240,9 @@ gfc_match_class_is (void) new_st.op = EXEC_SELECT_TYPE; new_st.ext.case_list = c; - - gfc_error_now ("CLASS IS specification at %C is not yet supported"); + + /* Create temporary variable. */ + select_type_set_tmp (&c->ts); return MATCH_YES; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 36095a2b722..d732b66da58 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -77,7 +77,7 @@ along with GCC; see the file COPYING3. If not see /* Don't put any single quote (') in MOD_VERSION, if yout want it to be recognized. */ -#define MOD_VERSION "3" +#define MOD_VERSION "4" /* Structure that describes a position within a module file. */ @@ -1671,7 +1671,7 @@ typedef enum AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP, AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP, - AB_EXTENSION, AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER + AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER } ab_attribute; @@ -1711,7 +1711,6 @@ static const mstring attr_bits[] = minit ("ZERO_COMP", AB_ZERO_COMP), minit ("PROTECTED", AB_PROTECTED), minit ("ABSTRACT", AB_ABSTRACT), - minit ("EXTENSION", AB_EXTENSION), minit ("IS_CLASS", AB_IS_CLASS), minit ("PROCEDURE", AB_PROCEDURE), minit ("PROC_POINTER", AB_PROC_POINTER), @@ -1771,7 +1770,7 @@ static void mio_symbol_attribute (symbol_attribute *attr) { atom_type t; - unsigned ext_attr; + unsigned ext_attr,extension_level; mio_lparen (); @@ -1780,10 +1779,15 @@ mio_symbol_attribute (symbol_attribute *attr) attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures); attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types); attr->save = MIO_NAME (save_state) (attr->save, save_status); + ext_attr = attr->ext_attr; mio_integer ((int *) &ext_attr); attr->ext_attr = ext_attr; + extension_level = attr->extension; + mio_integer ((int *) &extension_level); + attr->extension = extension_level; + if (iomode == IO_OUTPUT) { if (attr->allocatable) @@ -1858,8 +1862,6 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits); if (attr->zero_comp) MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits); - if (attr->extension) - MIO_NAME (ab_attribute) (AB_EXTENSION, attr_bits); if (attr->is_class) MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits); if (attr->procedure) @@ -1984,9 +1986,6 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_ZERO_COMP: attr->zero_comp = 1; break; - case AB_EXTENSION: - attr->extension = 1; - break; case AB_IS_CLASS: attr->is_class = 1; break; @@ -3574,7 +3573,7 @@ mio_symbol (gfc_symbol *sym) mio_integer (&(sym->intmod_sym_id)); if (sym->attr.flavor == FL_DERIVED) - mio_integer (&(sym->vindex)); + mio_integer (&(sym->hash_value)); mio_rparen (); } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index b6853129d59..bf705c6a09a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5218,41 +5218,35 @@ resolve_class_esym (gfc_expr *e) } -/* Generate an expression for the vindex, given the reference to +/* Generate an expression for the hash value, given the reference to the class of the final expression (class_ref), the base of the full reference list (new_ref), the declared type and the class object (st). */ static gfc_expr* -vindex_expr (gfc_ref *class_ref, gfc_ref *new_ref, - gfc_symbol *declared, gfc_symtree *st) +hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st) { - gfc_expr *vindex; - gfc_ref *ref; + gfc_expr *hash_value; - /* Build an expression for the correct vindex; ie. that of the last + /* Build an expression for the correct hash_value; ie. that of the last CLASS reference. */ - ref = gfc_get_ref(); - ref->type = REF_COMPONENT; - ref->u.c.component = declared->components->next; - ref->u.c.sym = declared; - ref->next = NULL; if (class_ref) { - class_ref->next = ref; + class_ref->next = NULL; } else { gfc_free_ref_list (new_ref); - new_ref = ref; + new_ref = NULL; } - vindex = gfc_get_expr (); - vindex->expr_type = EXPR_VARIABLE; - vindex->symtree = st; - vindex->symtree->n.sym->refs++; - vindex->ts = ref->u.c.component->ts; - vindex->ref = new_ref; + hash_value = gfc_get_expr (); + hash_value->expr_type = EXPR_VARIABLE; + hash_value->symtree = st; + hash_value->symtree->n.sym->refs++; + hash_value->ref = new_ref; + gfc_add_component_ref (hash_value, "$vptr"); + gfc_add_component_ref (hash_value, "$hash"); - return vindex; + return hash_value; } @@ -5352,10 +5346,10 @@ resolve_class_compcall (gfc_expr* e) resolve_class_esym (e); /* More than one typebound procedure so transmit an expression for - the vindex as the selector. */ + the hash_value as the selector. */ if (e->value.function.class_esym != NULL) - e->value.function.class_esym->vindex - = vindex_expr (class_ref, new_ref, declared, st); + e->value.function.class_esym->hash_value + = hash_value_expr (class_ref, new_ref, st); return class_try; } @@ -5407,10 +5401,10 @@ resolve_class_typebound_call (gfc_code *code) resolve_class_esym (code->expr1); /* More than one typebound procedure so transmit an expression for - the vindex as the selector. */ + the hash_value as the selector. */ if (code->expr1->value.function.class_esym != NULL) - code->expr1->value.function.class_esym->vindex - = vindex_expr (class_ref, new_ref, declared, st); + code->expr1->value.function.class_esym->hash_value + = hash_value_expr (class_ref, new_ref, st); return class_try; } @@ -6862,11 +6856,13 @@ static void resolve_select_type (gfc_code *code) { gfc_symbol *selector_type; - gfc_code *body, *new_st; - gfc_case *c, *default_case; + gfc_code *body, *new_st, *if_st, *tail; + gfc_code *class_is = NULL, *default_case = NULL; + gfc_case *c; gfc_symtree *st; char name[GFC_MAX_SYMBOL_LEN]; gfc_namespace *ns; + int error = 0; ns = code->ext.ns; gfc_resolve (ns); @@ -6876,9 +6872,6 @@ resolve_select_type (gfc_code *code) else selector_type = code->expr1->ts.u.derived->components->ts.u.derived; - /* Assume there is no DEFAULT case. */ - default_case = NULL; - /* Loop over TYPE IS / CLASS IS cases. */ for (body = code->block; body; body = body->block) { @@ -6890,6 +6883,7 @@ resolve_select_type (gfc_code *code) { gfc_error ("Derived type '%s' at %L must be extensible", c->ts.u.derived->name, &c->where); + error++; continue; } @@ -6899,6 +6893,7 @@ resolve_select_type (gfc_code *code) { gfc_error ("Derived type '%s' at %L must be an extension of '%s'", c->ts.u.derived->name, &c->where, selector_type->name); + error++; continue; } @@ -6906,15 +6901,21 @@ resolve_select_type (gfc_code *code) if (c->ts.type == BT_UNKNOWN) { /* Check F03:C818. */ - if (default_case != NULL) - gfc_error ("The DEFAULT CASE at %L cannot be followed " - "by a second DEFAULT CASE at %L", - &default_case->where, &c->where); + if (default_case) + { + gfc_error ("The DEFAULT CASE at %L cannot be followed " + "by a second DEFAULT CASE at %L", + &default_case->ext.case_list->where, &c->where); + error++; + continue; + } else - default_case = c; - continue; + default_case = body; } } + + if (error>0) + return; if (code->expr2) { @@ -6944,45 +6945,153 @@ resolve_select_type (gfc_code *code) /* Transform to EXEC_SELECT. */ code->op = EXEC_SELECT; - gfc_add_component_ref (code->expr1, "$vindex"); + gfc_add_component_ref (code->expr1, "$vptr"); + gfc_add_component_ref (code->expr1, "$hash"); /* Loop over TYPE IS / CLASS IS cases. */ for (body = code->block; body; body = body->block) { c = body->ext.case_list; + if (c->ts.type == BT_DERIVED) - c->low = c->high = gfc_int_expr (c->ts.u.derived->vindex); - else if (c->ts.type == BT_CLASS) - /* Currently IS CLASS blocks are simply ignored. - TODO: Implement IS CLASS. */ - c->unreachable = 1; - - if (c->ts.type != BT_DERIVED) + c->low = c->high = gfc_int_expr (c->ts.u.derived->hash_value); + else if (c->ts.type == BT_UNKNOWN) continue; + /* Assign temporary to selector. */ - sprintf (name, "tmp$%s", c->ts.u.derived->name); + if (c->ts.type == BT_CLASS) + sprintf (name, "tmp$class$%s", c->ts.u.derived->name); + else + sprintf (name, "tmp$type$%s", c->ts.u.derived->name); st = gfc_find_symtree (ns->sym_root, name); new_st = gfc_get_code (); - new_st->op = EXEC_POINTER_ASSIGN; new_st->expr1 = gfc_get_variable_expr (st); new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree); - gfc_add_component_ref (new_st->expr2, "$data"); + if (c->ts.type == BT_DERIVED) + { + new_st->op = EXEC_POINTER_ASSIGN; + gfc_add_component_ref (new_st->expr2, "$data"); + } + else + new_st->op = EXEC_POINTER_ASSIGN; new_st->next = body->next; body->next = new_st; } + + /* Take out CLASS IS cases for separate treatment. */ + body = code; + while (body && body->block) + { + if (body->block->ext.case_list->ts.type == BT_CLASS) + { + /* Add to class_is list. */ + if (class_is == NULL) + { + class_is = body->block; + tail = class_is; + } + else + { + for (tail = class_is; tail->block; tail = tail->block) ; + tail->block = body->block; + tail = tail->block; + } + /* Remove from EXEC_SELECT list. */ + body->block = body->block->block; + tail->block = NULL; + } + else + body = body->block; + } - /* Eliminate dead blocks. */ - for (body = code; body && body->block; body = body->block) + if (class_is) { - if (body->block->ext.case_list->unreachable) + gfc_symbol *vtab; + + if (!default_case) + { + /* Add a default case to hold the CLASS IS cases. */ + for (tail = code; tail->block; tail = tail->block) ; + tail->block = gfc_get_code (); + tail = tail->block; + tail->op = EXEC_SELECT_TYPE; + tail->ext.case_list = gfc_get_case (); + tail->ext.case_list->ts.type = BT_UNKNOWN; + tail->next = NULL; + default_case = tail; + } + + /* More than one CLASS IS block? */ + if (class_is->block) { - /* Cut the unreachable block from the code chain. */ - gfc_code *cd = body->block; - body->block = cd->block; - /* Kill the dead block, but not the blocks below it. */ - cd->block = NULL; - gfc_free_statements (cd); + gfc_code **c1,*c2; + bool swapped; + /* Sort CLASS IS blocks by extension level. */ + do + { + swapped = false; + for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block)) + { + c2 = (*c1)->block; + /* F03:C817 (check for doubles). */ + if ((*c1)->ext.case_list->ts.u.derived->hash_value + == c2->ext.case_list->ts.u.derived->hash_value) + { + gfc_error ("Double CLASS IS block in SELECT TYPE " + "statement at %L", &c2->ext.case_list->where); + return; + } + if ((*c1)->ext.case_list->ts.u.derived->attr.extension + < c2->ext.case_list->ts.u.derived->attr.extension) + { + /* Swap. */ + (*c1)->block = c2->block; + c2->block = *c1; + *c1 = c2; + swapped = true; + } + } + } + while (swapped); } + + /* Generate IF chain. */ + if_st = gfc_get_code (); + if_st->op = EXEC_IF; + new_st = if_st; + for (body = class_is; body; body = body->block) + { + new_st->block = gfc_get_code (); + new_st = new_st->block; + new_st->op = EXEC_IF; + /* Set up IF condition: Call _gfortran_is_extension_of. */ + new_st->expr1 = gfc_get_expr (); + new_st->expr1->expr_type = EXPR_FUNCTION; + new_st->expr1->ts.type = BT_LOGICAL; + new_st->expr1->ts.kind = 4; + new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of")); + new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym); + new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF; + /* Set up arguments. */ + new_st->expr1->value.function.actual = gfc_get_actual_arglist (); + new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree); + gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr"); + vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived); + st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); + new_st->expr1->value.function.actual->next = gfc_get_actual_arglist (); + new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st); + new_st->next = body->next; + } + if (default_case->next) + { + new_st->block = gfc_get_code (); + new_st = new_st->block; + new_st->op = EXEC_IF; + new_st->next = default_case->next; + } + + /* Replace CLASS DEFAULT code by the IF chain. */ + default_case->next = if_st; } resolve_select (code); @@ -8751,7 +8860,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived)) { gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible", - sym->ts.u.derived->name, sym->name, &sym->declared_at); + sym->ts.u.derived->components->ts.u.derived->name, + sym->name, &sym->declared_at); return FAILURE; } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index c1b39b0d9f1..6dd0a8afa0f 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1045,7 +1045,7 @@ gfc_add_save (symbol_attribute *attr, const char *name, locus *where) return FAILURE; } - if (attr->save == SAVE_EXPLICIT) + if (attr->save == SAVE_EXPLICIT && !attr->vtab) { if (gfc_notify_std (GFC_STD_LEGACY, "Duplicate SAVE attribute specified at %L", @@ -4592,22 +4592,228 @@ gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2) bool gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) { - if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS) - && (ts2->type == BT_DERIVED || ts2->type == BT_CLASS)) + gfc_component *cmp1, *cmp2; + + bool is_class1 = (ts1->type == BT_CLASS); + bool is_class2 = (ts2->type == BT_CLASS); + bool is_derived1 = (ts1->type == BT_DERIVED); + bool is_derived2 = (ts2->type == BT_DERIVED); + + if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2) + return (ts1->type == ts2->type); + + if (is_derived1 && is_derived2) + return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); + + cmp1 = cmp2 = NULL; + + if (is_class1) { - if (ts1->type == BT_CLASS && ts2->type == BT_DERIVED) - return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, - ts2->u.derived); - else if (ts1->type == BT_CLASS && ts2->type == BT_CLASS) - return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, - ts2->u.derived->components->ts.u.derived); - else if (ts2->type != BT_CLASS) - return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); - else + cmp1 = gfc_find_component (ts1->u.derived, "$data", true, false); + if (cmp1 == NULL) return 0; } + + if (is_class2) + { + cmp2 = gfc_find_component (ts2->u.derived, "$data", true, false); + if (cmp2 == NULL) + return 0; + } + + if (is_class1 && is_derived2) + return gfc_type_is_extension_of (cmp1->ts.u.derived, ts2->u.derived); + + else if (is_class1 && is_class2) + return gfc_type_is_extension_of (cmp1->ts.u.derived, cmp2->ts.u.derived); + else - return (ts1->type == ts2->type); + return 0; +} + + +/* Build a polymorphic CLASS entity, using the symbol that comes from + build_sym. A CLASS entity is represented by an encapsulating type, + which contains the declared type as '$data' component, plus a pointer + component '$vptr' which determines the dynamic type. */ + +gfc_try +gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, + gfc_array_spec **as) +{ + char name[GFC_MAX_SYMBOL_LEN + 5]; + gfc_symbol *fclass; + gfc_symbol *vtab; + gfc_component *c; + + /* Determine the name of the encapsulating type. */ + if ((*as) && (*as)->rank && attr->allocatable) + sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank); + else if ((*as) && (*as)->rank) + sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank); + else if (attr->allocatable) + sprintf (name, ".class.%s.a", ts->u.derived->name); + else + sprintf (name, ".class.%s", ts->u.derived->name); + + gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass); + if (fclass == NULL) + { + gfc_symtree *st; + /* If not there, create a new symbol. */ + fclass = gfc_new_symbol (name, ts->u.derived->ns); + st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name); + st->n.sym = fclass; + gfc_set_sym_referenced (fclass); + fclass->refs++; + fclass->ts.type = BT_UNKNOWN; + fclass->attr.abstract = ts->u.derived->attr.abstract; + if (ts->u.derived->f2k_derived) + fclass->f2k_derived = gfc_get_namespace (NULL, 0); + if (gfc_add_flavor (&fclass->attr, FL_DERIVED, + NULL, &gfc_current_locus) == FAILURE) + return FAILURE; + + /* Add component '$data'. */ + if (gfc_add_component (fclass, "$data", &c) == FAILURE) + return FAILURE; + c->ts = *ts; + c->ts.type = BT_DERIVED; + c->attr.access = ACCESS_PRIVATE; + c->ts.u.derived = ts->u.derived; + c->attr.pointer = attr->pointer || attr->dummy; + c->attr.allocatable = attr->allocatable; + c->attr.dimension = attr->dimension; + c->attr.abstract = ts->u.derived->attr.abstract; + c->as = (*as); + c->initializer = gfc_get_expr (); + c->initializer->expr_type = EXPR_NULL; + + /* Add component '$vptr'. */ + if (gfc_add_component (fclass, "$vptr", &c) == FAILURE) + return FAILURE; + c->ts.type = BT_DERIVED; + vtab = gfc_find_derived_vtab (ts->u.derived); + gcc_assert (vtab); + c->ts.u.derived = vtab->ts.u.derived; + c->attr.pointer = 1; + c->initializer = gfc_get_expr (); + c->initializer->expr_type = EXPR_NULL; + } + + /* Since the extension field is 8 bit wide, we can only have + up to 255 extension levels. */ + if (ts->u.derived->attr.extension == 255) + { + gfc_error ("Maximum extension level reached with type '%s' at %L", + ts->u.derived->name, &ts->u.derived->declared_at); + return FAILURE; + } + + fclass->attr.extension = ts->u.derived->attr.extension + 1; + fclass->attr.is_class = 1; + ts->u.derived = fclass; + attr->allocatable = attr->pointer = attr->dimension = 0; + (*as) = NULL; /* XXX */ + return SUCCESS; +} + + +/* Find the symbol for a derived type's vtab. */ + +gfc_symbol * +gfc_find_derived_vtab (gfc_symbol *derived) +{ + gfc_namespace *ns; + gfc_symbol *vtab = NULL, *vtype = NULL; + char name[2 * GFC_MAX_SYMBOL_LEN + 8]; + + ns = gfc_current_ns; + + for (; ns; ns = ns->parent) + if (!ns->parent) + break; + + if (ns) + { + sprintf (name, "vtab$%s", derived->name); + gfc_find_symbol (name, ns, 0, &vtab); + + if (vtab == NULL) + { + gfc_get_symbol (name, ns, &vtab); + vtab->ts.type = BT_DERIVED; + vtab->attr.flavor = FL_VARIABLE; + vtab->attr.target = 1; + vtab->attr.save = SAVE_EXPLICIT; + vtab->attr.vtab = 1; + vtab->refs++; + gfc_set_sym_referenced (vtab); + sprintf (name, "vtype$%s", derived->name); + + gfc_find_symbol (name, ns, 0, &vtype); + if (vtype == NULL) + { + gfc_component *c; + gfc_symbol *parent = NULL, *parent_vtab = NULL; + + gfc_get_symbol (name, ns, &vtype); + if (gfc_add_flavor (&vtype->attr, FL_DERIVED, + NULL, &gfc_current_locus) == FAILURE) + return NULL; + vtype->refs++; + gfc_set_sym_referenced (vtype); + + /* Add component '$hash'. */ + if (gfc_add_component (vtype, "$hash", &c) == FAILURE) + return NULL; + c->ts.type = BT_INTEGER; + c->ts.kind = 4; + c->attr.access = ACCESS_PRIVATE; + c->initializer = gfc_int_expr (derived->hash_value); + + /* Add component '$size'. */ + if (gfc_add_component (vtype, "$size", &c) == FAILURE) + return NULL; + c->ts.type = BT_INTEGER; + c->ts.kind = 4; + c->attr.access = ACCESS_PRIVATE; + /* Remember the derived type in ts.u.derived, + so that the correct initializer can be set later on + (in gfc_conv_structure). */ + c->ts.u.derived = derived; + c->initializer = gfc_int_expr (0); + + /* Add component $extends. */ + if (gfc_add_component (vtype, "$extends", &c) == FAILURE) + return NULL; + c->attr.pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->initializer = gfc_get_expr (); + parent = gfc_get_derived_super_type (derived); + if (parent) + { + parent_vtab = gfc_find_derived_vtab (parent); + c->ts.type = BT_DERIVED; + c->ts.u.derived = parent_vtab->ts.u.derived; + c->initializer->expr_type = EXPR_VARIABLE; + gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0, + &c->initializer->symtree); + } + else + { + c->ts.type = BT_DERIVED; + c->ts.u.derived = vtype; + c->initializer->expr_type = EXPR_NULL; + } + } + vtab->ts.u.derived = vtype; + + vtab->value = gfc_default_initializer (&vtab->ts); + } + } + + return vtab; } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 200c3f5654c..2e3fedd0ed3 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3405,7 +3405,7 @@ gfc_create_module_variable (gfc_symbol * sym) && (sym->equiv_built || sym->attr.in_equivalence)) return; - if (sym->backend_decl) + if (sym->backend_decl && !sym->attr.vtab) internal_error ("backend decl for module variable %s already exists", sym->name); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 77de6bd5773..acca306a2ff 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1530,16 +1530,16 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, tree end_label; tree label; tree tmp; - tree vindex; + tree hash; stmtblock_t body; gfc_class_esym_list *next_elist, *tmp_elist; gfc_se tmpse; - /* Convert the vindex expression. */ + /* Convert the hash expression. */ gfc_init_se (&tmpse, NULL); - gfc_conv_expr (&tmpse, elist->vindex); + gfc_conv_expr (&tmpse, elist->hash_value); gfc_add_block_to_block (&se->pre, &tmpse.pre); - vindex = gfc_evaluate_now (tmpse.expr, &se->pre); + hash = gfc_evaluate_now (tmpse.expr, &se->pre); gfc_add_block_to_block (&se->post, &tmpse.post); /* Fix the function type to be that of the declared type method. */ @@ -1566,9 +1566,9 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, if (elist->esym != tmp_elist->esym) continue; - cval = build_int_cst (TREE_TYPE (vindex), - elist->derived->vindex); - /* Build a label for the vindex value. */ + cval = build_int_cst (TREE_TYPE (hash), + elist->derived->hash_value); + /* Build a label for the hash value. */ label = gfc_build_label_decl (NULL_TREE); tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, cval, NULL_TREE, label); @@ -1601,8 +1601,8 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, segfaults because it occurs too early and too often. */ free_elist: next_elist = elist->next; - if (elist->vindex) - gfc_free_expr (elist->vindex); + if (elist->hash_value) + gfc_free_expr (elist->hash_value); gfc_free (elist); elist = NULL; } @@ -1613,12 +1613,12 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, NULL_TREE, NULL_TREE, label); gfc_add_expr_to_block (&body, tmp); tmp = gfc_trans_runtime_error (true, &expr->where, - "internal error: bad vindex in dynamic dispatch"); + "internal error: bad hash value in dynamic dispatch"); gfc_add_expr_to_block (&body, tmp); /* Write the switch expression. */ tmp = gfc_finish_block (&body); - tmp = build3_v (SWITCH_EXPR, vindex, tmp, NULL_TREE); + tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE); gfc_add_expr_to_block (&se->pre, tmp); tmp = build1_v (LABEL_EXPR, end_label); @@ -2531,6 +2531,60 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name) } +/* Takes a derived type expression and returns the address of a temporary + class object of the 'declared' type. */ +static void +gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, + gfc_typespec class_ts) +{ + gfc_component *cmp; + gfc_symbol *vtab; + gfc_symbol *declared = class_ts.u.derived; + gfc_ss *ss; + tree ctree; + tree var; + tree tmp; + + /* The derived type needs to be converted to a temporary + CLASS object. */ + tmp = gfc_typenode_for_spec (&class_ts); + var = gfc_create_var (tmp, "class"); + + /* Set the vptr. */ + cmp = gfc_find_component (declared, "$vptr", true, true); + ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), + var, cmp->backend_decl, NULL_TREE); + + /* Remember the vtab corresponds to the derived type + not to the class declared type. */ + vtab = gfc_find_derived_vtab (e->ts.u.derived); + gcc_assert (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify (&parmse->pre, ctree, + fold_convert (TREE_TYPE (ctree), tmp)); + + /* Now set the data field. */ + cmp = gfc_find_component (declared, "$data", true, true); + ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), + var, cmp->backend_decl, NULL_TREE); + ss = gfc_walk_expr (e); + if (ss == gfc_ss_terminator) + { + gfc_conv_expr_reference (parmse, e); + tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); + gfc_add_modify (&parmse->pre, ctree, tmp); + } + else + { + gfc_conv_expr (parmse, e); + gfc_add_modify (&parmse->pre, ctree, parmse->expr); + } + + /* Pass the address of the class object. */ + parmse->expr = gfc_build_addr_expr (NULL_TREE, var); +} + + /* The following routine generates code for the intrinsic procedures from the ISO_C_BINDING module: * C_LOC (function) @@ -2800,53 +2854,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_DERIVED) { - tree data; - tree vindex; - tree size; - /* The derived type needs to be converted to a temporary CLASS object. */ gfc_init_se (&parmse, se); - type = gfc_typenode_for_spec (&fsym->ts); - var = gfc_create_var (type, "class"); - - /* Get the components. */ - tmp = fsym->ts.u.derived->components->backend_decl; - data = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), - var, tmp, NULL_TREE); - tmp = fsym->ts.u.derived->components->next->backend_decl; - vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), - var, tmp, NULL_TREE); - tmp = fsym->ts.u.derived->components->next->next->backend_decl; - size = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), - var, tmp, NULL_TREE); - - /* Set the vindex. */ - tmp = build_int_cst (TREE_TYPE (vindex), e->ts.u.derived->vindex); - gfc_add_modify (&parmse.pre, vindex, tmp); - - /* Set the size. */ - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e->ts)); - gfc_add_modify (&parmse.pre, size, - fold_convert (TREE_TYPE (size), tmp)); - - /* Now set the data field. */ - argss = gfc_walk_expr (e); - if (argss == gfc_ss_terminator) - { - gfc_conv_expr_reference (&parmse, e); - tmp = fold_convert (TREE_TYPE (data), - parmse.expr); - gfc_add_modify (&parmse.pre, data, tmp); - } - else - { - gfc_conv_expr (&parmse, e); - gfc_add_modify (&parmse.pre, data, parmse.expr); - } - - /* Pass the address of the class object. */ - parmse.expr = gfc_build_addr_expr (NULL_TREE, var); + gfc_conv_derived_to_class (&parmse, e, fsym->ts); } else if (se->ss && se->ss->useflags) { @@ -4240,14 +4251,27 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) if (cm->ts.type == BT_CLASS) { + gfc_component *data; + data = gfc_find_component (cm->ts.u.derived, "$data", true, true); val = gfc_conv_initializer (c->expr, &cm->ts, - TREE_TYPE (cm->ts.u.derived->components->backend_decl), - cm->ts.u.derived->components->attr.dimension, - cm->ts.u.derived->components->attr.pointer); + TREE_TYPE (data->backend_decl), + data->attr.dimension, + data->attr.pointer); - /* Append it to the constructor list. */ - CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->backend_decl, - val); + CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val); + } + else if (strcmp (cm->name, "$size") == 0) + { + val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived)); + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); + } + else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL + && strcmp (cm->name, "$extends") == 0) + { + gfc_symbol *vtabs; + vtabs = cm->initializer->symtree->n.sym; + val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs)); + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); } else { @@ -5366,47 +5390,37 @@ gfc_trans_class_assign (gfc_code *code) { stmtblock_t block; tree tmp; + gfc_expr *lhs; + gfc_expr *rhs; gfc_start_block (&block); if (code->expr2->ts.type != BT_CLASS) { - /* Insert an additional assignment which sets the '$vindex' field. */ - gfc_expr *lhs,*rhs; + /* Insert an additional assignment which sets the '$vptr' field. */ lhs = gfc_copy_expr (code->expr1); - gfc_add_component_ref (lhs, "$vindex"); - if (code->expr2->ts.type == BT_DERIVED) - /* vindex is constant, determined at compile time. */ - rhs = gfc_int_expr (code->expr2->ts.u.derived->vindex); - else if (code->expr2->expr_type == EXPR_NULL) - rhs = gfc_int_expr (0); - else - gcc_unreachable (); - tmp = gfc_trans_assignment (lhs, rhs, false); - gfc_add_expr_to_block (&block, tmp); - - /* Insert another assignment which sets the '$size' field. */ - lhs = gfc_copy_expr (code->expr1); - gfc_add_component_ref (lhs, "$size"); + gfc_add_component_ref (lhs, "$vptr"); if (code->expr2->ts.type == BT_DERIVED) { - /* Size is fixed at compile time. */ - gfc_se lse; - gfc_init_se (&lse, NULL); - gfc_conv_expr (&lse, lhs); - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts)); - gfc_add_modify (&block, lse.expr, - fold_convert (TREE_TYPE (lse.expr), tmp)); + gfc_symbol *vtab; + gfc_symtree *st; + vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived); + gcc_assert (vtab); + + rhs = gfc_get_expr (); + rhs->expr_type = EXPR_VARIABLE; + gfc_find_sym_tree (vtab->name, NULL, 1, &st); + rhs->symtree = st; + rhs->ts = vtab->ts; } else if (code->expr2->expr_type == EXPR_NULL) - { - rhs = gfc_int_expr (0); - tmp = gfc_trans_assignment (lhs, rhs, false); - gfc_add_expr_to_block (&block, tmp); - } + rhs = gfc_int_expr (0); else gcc_unreachable (); + tmp = gfc_trans_pointer_assignment (lhs, rhs); + gfc_add_expr_to_block (&block, tmp); + gfc_free_expr (lhs); gfc_free_expr (rhs); } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 4273b8226e8..208a3b5a8d7 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -4715,14 +4715,20 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) b = expr->value.function.actual->next->expr; if (a->ts.type == BT_CLASS) - gfc_add_component_ref (a, "$vindex"); + { + gfc_add_component_ref (a, "$vptr"); + gfc_add_component_ref (a, "$hash"); + } else if (a->ts.type == BT_DERIVED) - a = gfc_int_expr (a->ts.u.derived->vindex); + a = gfc_int_expr (a->ts.u.derived->hash_value); if (b->ts.type == BT_CLASS) - gfc_add_component_ref (b, "$vindex"); + { + gfc_add_component_ref (b, "$vptr"); + gfc_add_component_ref (b, "$hash"); + } else if (b->ts.type == BT_DERIVED) - b = gfc_int_expr (b->ts.u.derived->vindex); + b = gfc_int_expr (b->ts.u.derived->hash_value); gfc_conv_expr (&se1, a); gfc_conv_expr (&se2, b); @@ -4733,21 +4739,6 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) } -/* Generate code for the EXTENDS_TYPE_OF intrinsic. */ - -static void -gfc_conv_extends_type_of (gfc_se *se, gfc_expr *expr) -{ - gfc_expr *e; - /* TODO: Implement EXTENDS_TYPE_OF. */ - gfc_error ("Intrinsic EXTENDS_TYPE_OF at %L not yet implemented", - &expr->where); - /* Just return 'false' for now. */ - e = gfc_logical_expr (false, &expr->where); - gfc_conv_expr (se, e); -} - - /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */ static void @@ -5157,10 +5148,6 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_same_type_as (se, expr); break; - case GFC_ISYM_EXTENDS_TYPE_OF: - gfc_conv_extends_type_of (se, expr); - break; - case GFC_ISYM_ABS: gfc_conv_intrinsic_abs (se, expr); break; @@ -5538,6 +5525,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_CHMOD: case GFC_ISYM_DTIME: case GFC_ISYM_ETIME: + case GFC_ISYM_EXTENDS_TYPE_OF: case GFC_ISYM_FGET: case GFC_ISYM_FGETC: case GFC_ISYM_FNUM: diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 9b2a6230853..32c6efc0c3c 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1009,44 +1009,57 @@ gfc_trans_do (gfc_code * code) /* Initialize loop count and jump to exit label if the loop is empty. This code is executed before we enter the loop body. We generate: + step_sign = sign(1,step); if (step > 0) { - if (to < from) goto exit_label; - countm1 = (to - from) / step; + if (to < from) + goto exit_label; } else { - if (to > from) goto exit_label; - countm1 = (from - to) / -step; - } */ + if (to > from) + goto exit_label; + } + countm1 = (to*step_sign - from*step_sign) / (step*step_sign); + + */ + if (TREE_CODE (type) == INTEGER_TYPE) { - tree pos, neg; + tree pos, neg, step_sign, to2, from2, step2; + + /* Calculate SIGN (1,step), as (step < 0 ? -1 : 1) */ + + tmp = fold_build2 (LT_EXPR, boolean_type_node, step, + build_int_cst (TREE_TYPE (step), 0)); + step_sign = fold_build3 (COND_EXPR, type, tmp, + build_int_cst (type, -1), + build_int_cst (type, 1)); tmp = fold_build2 (LT_EXPR, boolean_type_node, to, from); pos = fold_build3 (COND_EXPR, void_type_node, tmp, build1_v (GOTO_EXPR, exit_label), build_empty_stmt (input_location)); - tmp = fold_build2 (MINUS_EXPR, type, to, from); - tmp = fold_convert (utype, tmp); - tmp = fold_build2 (TRUNC_DIV_EXPR, utype, tmp, - fold_convert (utype, step)); - tmp = fold_build2 (MODIFY_EXPR, void_type_node, countm1, tmp); - pos = fold_build2 (COMPOUND_EXPR, void_type_node, pos, tmp); tmp = fold_build2 (GT_EXPR, boolean_type_node, to, from); neg = fold_build3 (COND_EXPR, void_type_node, tmp, build1_v (GOTO_EXPR, exit_label), build_empty_stmt (input_location)); - tmp = fold_build2 (MINUS_EXPR, type, from, to); + tmp = fold_build3 (COND_EXPR, void_type_node, pos_step, pos, neg); + + gfc_add_expr_to_block (&block, tmp); + + /* Calculate the loop count. to-from can overflow, so + we cast to unsigned. */ + + to2 = fold_build2 (MULT_EXPR, type, step_sign, to); + from2 = fold_build2 (MULT_EXPR, type, step_sign, from); + step2 = fold_build2 (MULT_EXPR, type, step_sign, step); + step2 = fold_convert (utype, step2); + tmp = fold_build2 (MINUS_EXPR, type, to2, from2); tmp = fold_convert (utype, tmp); - tmp = fold_build2 (TRUNC_DIV_EXPR, utype, tmp, - fold_convert (utype, fold_build1 (NEGATE_EXPR, - type, step))); + tmp = fold_build2 (TRUNC_DIV_EXPR, utype, tmp, step2); tmp = fold_build2 (MODIFY_EXPR, void_type_node, countm1, tmp); - neg = fold_build2 (COMPOUND_EXPR, void_type_node, neg, tmp); - - tmp = fold_build3 (COND_EXPR, void_type_node, pos_step, pos, neg); gfc_add_expr_to_block (&block, tmp); } else @@ -4029,6 +4042,7 @@ gfc_trans_allocate (gfc_code * code) gfc_expr *sz; gfc_se se_sz; sz = gfc_copy_expr (code->expr3); + gfc_add_component_ref (sz, "$vptr"); gfc_add_component_ref (sz, "$size"); gfc_init_se (&se_sz, NULL); gfc_conv_expr (&se_sz, sz); @@ -4124,42 +4138,49 @@ gfc_trans_allocate (gfc_code * code) { gfc_expr *lhs,*rhs; gfc_se lse; - /* Initialize VINDEX for CLASS objects. */ + + /* Initialize VPTR for CLASS objects. */ lhs = gfc_expr_to_initialize (expr); - gfc_add_component_ref (lhs, "$vindex"); + gfc_add_component_ref (lhs, "$vptr"); + rhs = NULL; if (code->expr3 && code->expr3->ts.type == BT_CLASS) { - /* vindex must be determined at run time. */ + /* VPTR must be determined at run time. */ rhs = gfc_copy_expr (code->expr3); - gfc_add_component_ref (rhs, "$vindex"); + gfc_add_component_ref (rhs, "$vptr"); + tmp = gfc_trans_pointer_assignment (lhs, rhs); + gfc_add_expr_to_block (&block, tmp); + gfc_free_expr (rhs); } else { - /* vindex is fixed at compile time. */ - int vindex; + /* VPTR is fixed at compile time. */ + gfc_symbol *vtab; + gfc_typespec *ts; if (code->expr3) - vindex = code->expr3->ts.u.derived->vindex; + ts = &code->expr3->ts; + else if (expr->ts.type == BT_DERIVED) + ts = &expr->ts; else if (code->ext.alloc.ts.type == BT_DERIVED) - vindex = code->ext.alloc.ts.u.derived->vindex; + ts = &code->ext.alloc.ts; else if (expr->ts.type == BT_CLASS) - vindex = expr->ts.u.derived->components->ts.u.derived->vindex; + ts = &expr->ts.u.derived->components->ts; else - vindex = expr->ts.u.derived->vindex; - rhs = gfc_int_expr (vindex); - } - tmp = gfc_trans_assignment (lhs, rhs, false); - gfc_free_expr (lhs); - gfc_free_expr (rhs); - gfc_add_expr_to_block (&block, tmp); + ts = &expr->ts; - /* Initialize SIZE for CLASS objects. */ - lhs = gfc_expr_to_initialize (expr); - gfc_add_component_ref (lhs, "$size"); - gfc_init_se (&lse, NULL); - gfc_conv_expr (&lse, lhs); - gfc_add_modify (&block, lse.expr, - fold_convert (TREE_TYPE (lse.expr), memsz)); - gfc_free_expr (lhs); + if (ts->type == BT_DERIVED) + { + vtab = gfc_find_derived_vtab (ts->u.derived); + gcc_assert (vtab); + gfc_init_se (&lse, NULL); + lse.want_pointer = 1; + gfc_conv_expr (&lse, lhs); + tmp = gfc_build_addr_expr (NULL_TREE, + gfc_get_symbol_decl (vtab)); + gfc_add_modify (&block, lse.expr, + fold_convert (TREE_TYPE (lse.expr), tmp)); + } + } } } diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 18644779fc1..278ae27a458 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -53,8 +53,6 @@ along with GCC; see the file COPYING3. If not see /* array of structs so we don't have to worry about xmalloc or free */ CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER]; -static tree gfc_get_derived_type (gfc_symbol * derived); - tree gfc_array_index_type; tree gfc_array_range_type; tree gfc_character1_type_node; @@ -1941,7 +1939,7 @@ gfc_get_ppc_type (gfc_component* c) at the same time. If an equal derived type has been built in a parent namespace, this is used. */ -static tree +tree gfc_get_derived_type (gfc_symbol * derived) { tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL; diff --git a/gcc/function.c b/gcc/function.c index 88e036c0857..b8042d08551 100644 --- a/gcc/function.c +++ b/gcc/function.c @@ -1598,7 +1598,13 @@ instantiate_virtual_regs_in_insn (rtx insn) if (!safe_insn_predicate (insn_code, i, x)) { start_sequence (); - x = force_reg (insn_data[insn_code].operand[i].mode, x); + if (REG_P (x)) + { + gcc_assert (REGNO (x) <= LAST_VIRTUAL_REGISTER); + x = copy_to_reg (x); + } + else + x = force_reg (insn_data[insn_code].operand[i].mode, x); seq = get_insns (); end_sequence (); if (seq) diff --git a/gcc/gcc-plugin.h b/gcc/gcc-plugin.h index 2e36f486262..ec12265417d 100644 --- a/gcc/gcc-plugin.h +++ b/gcc/gcc-plugin.h @@ -26,29 +26,19 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "highlev-plugin-common.h" +#include "hashtab.h" -/* Event names. Keep in sync with plugin_event_name[]. */ +/* Event names. */ enum plugin_event { - PLUGIN_PASS_MANAGER_SETUP, /* To hook into pass manager. */ - PLUGIN_FINISH_TYPE, /* After finishing parsing a type. */ - PLUGIN_FINISH_UNIT, /* Useful for summary processing. */ - PLUGIN_CXX_CP_PRE_GENERICIZE, /* Allows to see low level AST in C++ FE. */ - PLUGIN_FINISH, /* Called before GCC exits. */ - PLUGIN_INFO, /* Information about the plugin. */ - PLUGIN_GGC_START, /* Called at start of GCC Garbage Collection. */ - PLUGIN_GGC_MARKING, /* Extend the GGC marking. */ - PLUGIN_GGC_END, /* Called at end of GGC. */ - PLUGIN_REGISTER_GGC_ROOTS, /* Register an extra GGC root table. */ - PLUGIN_REGISTER_GGC_CACHES, /* Register an extra GGC cache table. */ - PLUGIN_ATTRIBUTES, /* Called during attribute registration. */ - PLUGIN_START_UNIT, /* Called before processing a translation unit. */ - PLUGIN_PRAGMAS, /* Called during pragma registration. */ - PLUGIN_EVENT_LAST /* Dummy event used for indexing callback - array. */ +# define DEFEVENT(NAME) NAME, +# include "plugin.def" +# undef DEFEVENT + PLUGIN_EVENT_FIRST_DYNAMIC }; -extern const char *plugin_event_name[]; +extern const char **plugin_event_name; struct plugin_argument { @@ -127,14 +117,22 @@ typedef void (*plugin_callback_func) (void *gcc_data, void *user_data); USER_DATA - plugin-provided data. */ +/* Number of event ids / names registered so far. */ + +extern int get_event_last (void); + +int get_named_event_id (const char *name, enum insert_option insert); + /* This is also called without a callback routine for the PLUGIN_PASS_MANAGER_SETUP, PLUGIN_INFO, PLUGIN_REGISTER_GGC_ROOTS and PLUGIN_REGISTER_GGC_CACHES pseudo-events, with a specific user_data. */ extern void register_callback (const char *plugin_name, - enum plugin_event event, + int event, plugin_callback_func callback, void *user_data); +extern int unregister_callback (const char *plugin_name, int event); + #endif /* GCC_PLUGIN_H */ diff --git a/gcc/graphite-clast-to-gimple.c b/gcc/graphite-clast-to-gimple.c index 3f3bb3bb434..93138b6bd89 100644 --- a/gcc/graphite-clast-to-gimple.c +++ b/gcc/graphite-clast-to-gimple.c @@ -66,6 +66,106 @@ graphite_verify (void) #endif } +/* Stores the INDEX in a vector for a given clast NAME. */ + +typedef struct clast_name_index { + int index; + const char *name; +} *clast_name_index_p; + +/* Returns a pointer to a new element of type clast_name_index_p built + from NAME and INDEX. */ + +static inline clast_name_index_p +new_clast_name_index (const char *name, int index) +{ + clast_name_index_p res = XNEW (struct clast_name_index); + + res->name = name; + res->index = index; + return res; +} + +/* For a given clast NAME, returns -1 if it does not correspond to any + parameter, or otherwise, returns the index in the PARAMS or + SCATTERING_DIMENSIONS vector. */ + +static inline int +clast_name_to_index (const char *name, htab_t index_table) +{ + struct clast_name_index tmp; + PTR *slot; + + tmp.name = name; + slot = htab_find_slot (index_table, &tmp, NO_INSERT); + + if (slot && *slot) + return ((struct clast_name_index *) *slot)->index; + + return -1; +} + +/* Records in INDEX_TABLE the INDEX for NAME. */ + +static inline void +save_clast_name_index (htab_t index_table, const char *name, int index) +{ + struct clast_name_index tmp; + PTR *slot; + + tmp.name = name; + slot = htab_find_slot (index_table, &tmp, INSERT); + + if (slot) + *slot = new_clast_name_index (name, index); +} + +/* Print to stderr the element ELT. */ + +static inline void +debug_clast_name_index (clast_name_index_p elt) +{ + fprintf (stderr, "(index = %d, name = %s)\n", elt->index, elt->name); +} + +/* Helper function for debug_rename_map. */ + +static inline int +debug_clast_name_indexes_1 (void **slot, void *s ATTRIBUTE_UNUSED) +{ + struct clast_name_index *entry = (struct clast_name_index *) *slot; + debug_clast_name_index (entry); + return 1; +} + +/* Print to stderr all the elements of MAP. */ + +void +debug_clast_name_indexes (htab_t map) +{ + htab_traverse (map, debug_clast_name_indexes_1, NULL); +} + +/* Computes a hash function for database element ELT. */ + +static inline hashval_t +clast_name_index_elt_info (const void *elt) +{ + return htab_hash_pointer (((const struct clast_name_index *) elt)->name); +} + +/* Compares database elements E1 and E2. */ + +static inline int +eq_clast_name_indexes (const void *e1, const void *e2) +{ + const struct clast_name_index *elt1 = (const struct clast_name_index *) e1; + const struct clast_name_index *elt2 = (const struct clast_name_index *) e2; + + return (elt1->name == elt2->name); +} + + /* For a given loop DEPTH in the loop nest of the original black box PBB, return the old induction variable associated to that loop. */ @@ -95,11 +195,10 @@ newivs_to_depth_to_newiv (VEC (tree, heap) *newivs, int depth) static tree clast_name_to_gcc (const char *name, sese region, VEC (tree, heap) *newivs, - htab_t newivs_index) + htab_t newivs_index, htab_t params_index) { int index; VEC (tree, heap) *params = SESE_PARAMS (region); - htab_t params_index = SESE_PARAMS_INDEX (region); if (params && params_index) { @@ -128,7 +227,7 @@ max_precision_type (tree e1, tree e2) static tree clast_to_gcc_expression (tree, struct clast_expr *, sese, VEC (tree, heap) *, - htab_t); + htab_t, htab_t); /* Converts a Cloog reduction expression R with reduction operation OP to a GCC expression tree of type TYPE. */ @@ -137,17 +236,17 @@ static tree clast_to_gcc_expression_red (tree type, enum tree_code op, struct clast_reduction *r, sese region, VEC (tree, heap) *newivs, - htab_t newivs_index) + htab_t newivs_index, htab_t params_index) { int i; tree res = clast_to_gcc_expression (type, r->elts[0], region, newivs, - newivs_index); + newivs_index, params_index); tree operand_type = (op == POINTER_PLUS_EXPR) ? sizetype : type; for (i = 1; i < r->n; i++) { tree t = clast_to_gcc_expression (operand_type, r->elts[i], region, - newivs, newivs_index); + newivs, newivs_index, params_index); res = fold_build2 (op, type, res, t); } @@ -160,7 +259,7 @@ clast_to_gcc_expression_red (tree type, enum tree_code op, static tree clast_to_gcc_expression (tree type, struct clast_expr *e, sese region, VEC (tree, heap) *newivs, - htab_t newivs_index) + htab_t newivs_index, htab_t params_index) { switch (e->type) { @@ -173,21 +272,21 @@ clast_to_gcc_expression (tree type, struct clast_expr *e, if (value_one_p (t->val)) { tree name = clast_name_to_gcc (t->var, region, newivs, - newivs_index); + newivs_index, params_index); return fold_convert (type, name); } else if (value_mone_p (t->val)) { tree name = clast_name_to_gcc (t->var, region, newivs, - newivs_index); + newivs_index, params_index); name = fold_convert (type, name); return fold_build1 (NEGATE_EXPR, type, name); } else { tree name = clast_name_to_gcc (t->var, region, newivs, - newivs_index); + newivs_index, params_index); tree cst = gmp_cst_to_tree (type, t->val); name = fold_convert (type, name); return fold_build2 (MULT_EXPR, type, cst, name); @@ -206,15 +305,17 @@ clast_to_gcc_expression (tree type, struct clast_expr *e, case clast_red_sum: return clast_to_gcc_expression_red (type, POINTER_TYPE_P (type) ? POINTER_PLUS_EXPR : PLUS_EXPR, - r, region, newivs, newivs_index); + r, region, newivs, newivs_index, params_index); case clast_red_min: return clast_to_gcc_expression_red (type, MIN_EXPR, r, region, - newivs, newivs_index); + newivs, newivs_index, + params_index); case clast_red_max: return clast_to_gcc_expression_red (type, MAX_EXPR, r, region, - newivs, newivs_index); + newivs, newivs_index, + params_index); default: gcc_unreachable (); @@ -227,7 +328,7 @@ clast_to_gcc_expression (tree type, struct clast_expr *e, struct clast_binary *b = (struct clast_binary *) e; struct clast_expr *lhs = (struct clast_expr *) b->LHS; tree tl = clast_to_gcc_expression (type, lhs, region, newivs, - newivs_index); + newivs_index, params_index); tree tr = gmp_cst_to_tree (type, b->RHS); switch (b->type) @@ -261,7 +362,7 @@ clast_to_gcc_expression (tree type, struct clast_expr *e, static tree gcc_type_for_clast_expr (struct clast_expr *e, sese region, VEC (tree, heap) *newivs, - htab_t newivs_index) + htab_t newivs_index, htab_t params_index) { switch (e->type) { @@ -271,7 +372,7 @@ gcc_type_for_clast_expr (struct clast_expr *e, if (t->var) return TREE_TYPE (clast_name_to_gcc (t->var, region, newivs, - newivs_index)); + newivs_index, params_index)); else return NULL_TREE; } @@ -282,14 +383,15 @@ gcc_type_for_clast_expr (struct clast_expr *e, if (r->n == 1) return gcc_type_for_clast_expr (r->elts[0], region, newivs, - newivs_index); + newivs_index, params_index); else { int i; for (i = 0; i < r->n; i++) { tree type = gcc_type_for_clast_expr (r->elts[i], region, - newivs, newivs_index); + newivs, newivs_index, + params_index); if (type) return type; } @@ -302,7 +404,7 @@ gcc_type_for_clast_expr (struct clast_expr *e, struct clast_binary *b = (struct clast_binary *) e; struct clast_expr *lhs = (struct clast_expr *) b->LHS; return gcc_type_for_clast_expr (lhs, region, newivs, - newivs_index); + newivs_index, params_index); } default: @@ -317,14 +419,15 @@ gcc_type_for_clast_expr (struct clast_expr *e, static tree gcc_type_for_clast_eq (struct clast_equation *cleq, sese region, VEC (tree, heap) *newivs, - htab_t newivs_index) + htab_t newivs_index, htab_t params_index) { tree type = gcc_type_for_clast_expr (cleq->LHS, region, newivs, - newivs_index); + newivs_index, params_index); if (type) return type; - return gcc_type_for_clast_expr (cleq->RHS, region, newivs, newivs_index); + return gcc_type_for_clast_expr (cleq->RHS, region, newivs, newivs_index, + params_index); } /* Translates a clast equation CLEQ to a tree. */ @@ -333,14 +436,15 @@ static tree graphite_translate_clast_equation (sese region, struct clast_equation *cleq, VEC (tree, heap) *newivs, - htab_t newivs_index) + htab_t newivs_index, htab_t params_index) { enum tree_code comp; - tree type = gcc_type_for_clast_eq (cleq, region, newivs, newivs_index); + tree type = gcc_type_for_clast_eq (cleq, region, newivs, newivs_index, + params_index); tree lhs = clast_to_gcc_expression (type, cleq->LHS, region, newivs, - newivs_index); + newivs_index, params_index); tree rhs = clast_to_gcc_expression (type, cleq->RHS, region, newivs, - newivs_index); + newivs_index, params_index); if (cleq->sign == 0) comp = EQ_EXPR; @@ -359,7 +463,7 @@ graphite_translate_clast_equation (sese region, static tree graphite_create_guard_cond_expr (sese region, struct clast_guard *stmt, VEC (tree, heap) *newivs, - htab_t newivs_index) + htab_t newivs_index, htab_t params_index) { tree cond = NULL; int i; @@ -367,7 +471,8 @@ graphite_create_guard_cond_expr (sese region, struct clast_guard *stmt, for (i = 0; i < stmt->n; i++) { tree eq = graphite_translate_clast_equation (region, &stmt->eq[i], - newivs, newivs_index); + newivs, newivs_index, + params_index); if (cond) cond = fold_build2 (TRUTH_AND_EXPR, TREE_TYPE (eq), cond, eq); @@ -384,10 +489,10 @@ static edge graphite_create_new_guard (sese region, edge entry_edge, struct clast_guard *stmt, VEC (tree, heap) *newivs, - htab_t newivs_index) + htab_t newivs_index, htab_t params_index) { tree cond_expr = graphite_create_guard_cond_expr (region, stmt, newivs, - newivs_index); + newivs_index, params_index); edge exit_edge = create_empty_if_region_on_edge (entry_edge, cond_expr); return exit_edge; } @@ -460,13 +565,13 @@ static struct loop * graphite_create_new_loop (sese region, edge entry_edge, struct clast_for *stmt, loop_p outer, VEC (tree, heap) **newivs, - htab_t newivs_index) + htab_t newivs_index, htab_t params_index) { tree type = gcc_type_for_iv_of_clast_loop (stmt); tree lb = clast_to_gcc_expression (type, stmt->LB, region, *newivs, - newivs_index); + newivs_index, params_index); tree ub = clast_to_gcc_expression (type, stmt->UB, region, *newivs, - newivs_index); + newivs_index, params_index); tree stride = gmp_cst_to_tree (type, stmt->stride); tree ivvar = create_tmp_var (type, "graphite_IV"); tree iv, iv_after_increment; @@ -488,7 +593,8 @@ graphite_create_new_loop (sese region, edge entry_edge, static void build_iv_mapping (htab_t map, sese region, VEC (tree, heap) *newivs, htab_t newivs_index, - struct clast_user_stmt *user_stmt) + struct clast_user_stmt *user_stmt, + htab_t params_index) { struct clast_stmt *t; int index = 0; @@ -500,10 +606,10 @@ build_iv_mapping (htab_t map, sese region, struct clast_expr *expr = (struct clast_expr *) ((struct clast_assignment *)t)->RHS; tree type = gcc_type_for_clast_expr (expr, region, newivs, - newivs_index); + newivs_index, params_index); tree old_name = pbb_to_depth_to_oldiv (pbb, index); tree e = clast_to_gcc_expression (type, expr, region, newivs, - newivs_index); + newivs_index, params_index); set_rename (map, old_name, e); } } @@ -612,135 +718,256 @@ dependency_in_loop_p (loop_p loop, htab_t bb_pbb_mapping, int level) return false; } -/* Translates a CLAST statement STMT to GCC representation in the - context of a SESE. +static edge +translate_clast (sese, struct clast_stmt *, edge, htab_t, VEC (tree, heap) **, + htab_t, htab_t, htab_t); + +/* Translates a clast user statement STMT to gimple. + - REGION is the sese region we used to generate the scop. - NEXT_E is the edge where new generated code should be attached. - - CONTEXT_LOOP is the loop in which the generated code will be placed - RENAME_MAP contains a set of tuples of new names associated to the original variables names. - BB_PBB_MAPPING is is a basic_block and it's related poly_bb_p mapping. -*/ - + - PARAMS_INDEX connects the cloog parameters with the gimple parameters in + the sese region. */ static edge -translate_clast (sese region, struct loop *context_loop, - struct clast_stmt *stmt, edge next_e, - htab_t rename_map, VEC (tree, heap) **newivs, - htab_t newivs_index, htab_t bb_pbb_mapping, int level) +translate_clast_user (sese region, struct clast_user_stmt *stmt, edge next_e, + htab_t rename_map, VEC (tree, heap) **newivs, + htab_t newivs_index, htab_t bb_pbb_mapping, + htab_t params_index) { - if (!stmt) + poly_bb_p pbb = (poly_bb_p) cloog_statement_usr (stmt->statement); + gimple_bb_p gbb = PBB_BLACK_BOX (pbb); + + if (GBB_BB (gbb) == ENTRY_BLOCK_PTR) return next_e; - if (CLAST_STMT_IS_A (stmt, stmt_root)) - return translate_clast (region, context_loop, stmt->next, next_e, - rename_map, newivs, newivs_index, - bb_pbb_mapping, level); + build_iv_mapping (rename_map, region, *newivs, newivs_index, stmt, + params_index); + next_e = copy_bb_and_scalar_dependences (GBB_BB (gbb), region, + next_e, rename_map); + mark_bb_with_pbb (pbb, next_e->src, bb_pbb_mapping); + update_ssa (TODO_update_ssa); - if (CLAST_STMT_IS_A (stmt, stmt_user)) - { - gimple_bb_p gbb; - basic_block new_bb; - CloogStatement *cs = ((struct clast_user_stmt *) stmt)->statement; - poly_bb_p pbb = (poly_bb_p) cloog_statement_usr (cs); - gbb = PBB_BLACK_BOX (pbb); - - if (GBB_BB (gbb) == ENTRY_BLOCK_PTR) - return next_e; - - build_iv_mapping (rename_map, region, *newivs, newivs_index, - (struct clast_user_stmt *) stmt); - next_e = copy_bb_and_scalar_dependences (GBB_BB (gbb), region, - next_e, rename_map); - new_bb = next_e->src; - mark_bb_with_pbb (pbb, new_bb, bb_pbb_mapping); - recompute_all_dominators (); - update_ssa (TODO_update_ssa); - graphite_verify (); - return translate_clast (region, context_loop, stmt->next, next_e, - rename_map, newivs, newivs_index, - bb_pbb_mapping, level); - } + return next_e; +} - if (CLAST_STMT_IS_A (stmt, stmt_for)) - { - struct clast_for *stmtfor = (struct clast_for *)stmt; - struct loop *loop - = graphite_create_new_loop (region, next_e, stmtfor, - context_loop, newivs, newivs_index); - edge last_e = single_exit (loop); - edge to_body = single_succ_edge (loop->header); - basic_block after = to_body->dest; - - /* Create a basic block for loop close phi nodes. */ - last_e = single_succ_edge (split_edge (last_e)); - - /* Translate the body of the loop. */ - next_e = translate_clast - (region, loop, ((struct clast_for *) stmt)->body, - single_succ_edge (loop->header), rename_map, newivs, - newivs_index, bb_pbb_mapping, level + 1); - redirect_edge_succ_nodup (next_e, after); - set_immediate_dominator (CDI_DOMINATORS, next_e->dest, next_e->src); - - /* Remove from rename_map all the tuples containing variables - defined in loop's body. */ - insert_loop_close_phis (rename_map, loop); - - if (flag_loop_parallelize_all - && !dependency_in_loop_p (loop, bb_pbb_mapping, - get_scattering_level (level))) - loop->can_be_parallel = true; - - recompute_all_dominators (); - graphite_verify (); - return translate_clast (region, context_loop, stmt->next, last_e, - rename_map, newivs, newivs_index, - bb_pbb_mapping, level); - } +/* Mark a loop parallel, if the graphite dependency check cannot find any + dependencies. This triggers parallel code generation in the autopar pass. + */ +static void +try_mark_loop_parallel (sese region, loop_p loop, htab_t bb_pbb_mapping) +{ + loop_p outermost_loop = SESE_ENTRY (region)->src->loop_father; + int level = loop_depth (loop) - loop_depth (outermost_loop); - if (CLAST_STMT_IS_A (stmt, stmt_guard)) - { - edge last_e = graphite_create_new_guard (region, next_e, - ((struct clast_guard *) stmt), - *newivs, newivs_index); - edge true_e = get_true_edge_from_guard_bb (next_e->dest); - edge false_e = get_false_edge_from_guard_bb (next_e->dest); - edge exit_true_e = single_succ_edge (true_e->dest); - edge exit_false_e = single_succ_edge (false_e->dest); - htab_t before_guard = htab_create (10, rename_map_elt_info, - eq_rename_map_elts, free); - - htab_traverse (rename_map, copy_renames, before_guard); - next_e = translate_clast (region, context_loop, - ((struct clast_guard *) stmt)->then, - true_e, rename_map, newivs, newivs_index, - bb_pbb_mapping, level); - insert_guard_phis (last_e->src, exit_true_e, exit_false_e, - before_guard, rename_map); - - htab_delete (before_guard); - recompute_all_dominators (); - graphite_verify (); - - return translate_clast (region, context_loop, stmt->next, last_e, - rename_map, newivs, newivs_index, - bb_pbb_mapping, level); - } + if (flag_loop_parallelize_all + && !dependency_in_loop_p (loop, bb_pbb_mapping, + get_scattering_level (level))) + loop->can_be_parallel = true; +} - if (CLAST_STMT_IS_A (stmt, stmt_block)) - { - next_e = translate_clast (region, context_loop, - ((struct clast_block *) stmt)->body, - next_e, rename_map, newivs, newivs_index, - bb_pbb_mapping, level); - recompute_all_dominators (); - graphite_verify (); - return translate_clast (region, context_loop, stmt->next, next_e, - rename_map, newivs, newivs_index, - bb_pbb_mapping, level); - } +static tree gcc_type_for_iv_of_clast_loop (struct clast_for *); - gcc_unreachable (); + +/* Creates a new if region protecting the loop to be executed, if the execution + count is zero (lb > ub). */ +static edge +graphite_create_new_loop_guard (sese region, edge entry_edge, + struct clast_for *stmt, + VEC (tree, heap) *newivs, + htab_t newivs_index, htab_t params_index) +{ + tree cond_expr; + edge exit_edge; + tree type = gcc_type_for_iv_of_clast_loop (stmt); + tree lb = clast_to_gcc_expression (type, stmt->LB, region, newivs, + newivs_index, params_index); + tree ub = clast_to_gcc_expression (type, stmt->UB, region, newivs, + newivs_index, params_index); + + /* XXX: Adding +1 and using LT_EXPR helps with loop latches that have a + loop iteration count of "PARAMETER - 1". For PARAMETER == 0 this becomes + 2^{32|64}, and the condition lb <= ub is true, even if we do not want this. + However lb < ub + 1 is false, as expected. + There might be a problem with cases where ub is 2^32. */ + tree one; + Value gmp_one; + value_init (gmp_one); + value_set_si (gmp_one, 1); + one = gmp_cst_to_tree (type, gmp_one); + value_clear (gmp_one); + + ub = fold_build2 (PLUS_EXPR, type, ub, one); + cond_expr = fold_build2 (LT_EXPR, boolean_type_node, lb, ub); + + exit_edge = create_empty_if_region_on_edge (entry_edge, cond_expr); + + return exit_edge; +} + + +/* Create the loop for a clast for statement. + + - REGION is the sese region we used to generate the scop. + - NEXT_E is the edge where new generated code should be attached. + - RENAME_MAP contains a set of tuples of new names associated to + the original variables names. + - BB_PBB_MAPPING is is a basic_block and it's related poly_bb_p mapping. + - PARAMS_INDEX connects the cloog parameters with the gimple parameters in + the sese region. */ +static edge +translate_clast_for_loop (sese region, struct clast_for *stmt, edge next_e, + htab_t rename_map, VEC (tree, heap) **newivs, + htab_t newivs_index, htab_t bb_pbb_mapping, + htab_t params_index) +{ + loop_p context_loop = next_e->dest->loop_father; + loop_p loop = graphite_create_new_loop (region, next_e, stmt, context_loop, + newivs, newivs_index, params_index); + edge last_e = single_exit (loop); + edge body = single_succ_edge (loop->header); + + next_e = translate_clast (region, stmt->body, body, rename_map, newivs, + newivs_index, bb_pbb_mapping, params_index); + + /* Create a basic block for loop close phi nodes. */ + last_e = single_succ_edge (split_edge (last_e)); + insert_loop_close_phis (rename_map, loop); + + try_mark_loop_parallel (region, loop, bb_pbb_mapping); + + return last_e; +} + +/* Translates a clast for statement STMT to gimple. First a guard is created + protecting the loop, if it is executed zero times. In this guard we create + the real loop structure. + + - REGION is the sese region we used to generate the scop. + - NEXT_E is the edge where new generated code should be attached. + - RENAME_MAP contains a set of tuples of new names associated to + the original variables names. + - BB_PBB_MAPPING is is a basic_block and it's related poly_bb_p mapping. + - PARAMS_INDEX connects the cloog parameters with the gimple parameters in + the sese region. */ +static edge +translate_clast_for (sese region, struct clast_for *stmt, edge next_e, + htab_t rename_map, VEC (tree, heap) **newivs, + htab_t newivs_index, htab_t bb_pbb_mapping, + htab_t params_index) +{ + edge last_e = graphite_create_new_loop_guard (region, next_e, stmt, *newivs, + newivs_index, params_index); + + edge true_e = get_true_edge_from_guard_bb (next_e->dest); + edge false_e = get_false_edge_from_guard_bb (next_e->dest); + edge exit_true_e = single_succ_edge (true_e->dest); + edge exit_false_e = single_succ_edge (false_e->dest); + + htab_t before_guard = htab_create (10, rename_map_elt_info, + eq_rename_map_elts, free); + htab_traverse (rename_map, copy_renames, before_guard); + + next_e = translate_clast_for_loop (region, stmt, true_e, rename_map, newivs, + newivs_index, bb_pbb_mapping, + params_index); + + insert_guard_phis (last_e->src, exit_true_e, exit_false_e, + before_guard, rename_map); + + htab_delete (before_guard); + + return last_e; +} + +/* Translates a clast guard statement STMT to gimple. + + - REGION is the sese region we used to generate the scop. + - NEXT_E is the edge where new generated code should be attached. + - RENAME_MAP contains a set of tuples of new names associated to + the original variables names. + - BB_PBB_MAPPING is is a basic_block and it's related poly_bb_p mapping. + - PARAMS_INDEX connects the cloog parameters with the gimple parameters in + the sese region. */ +static edge +translate_clast_guard (sese region, struct clast_guard *stmt, edge next_e, + htab_t rename_map, VEC (tree, heap) **newivs, + htab_t newivs_index, htab_t bb_pbb_mapping, + htab_t params_index) +{ + edge last_e = graphite_create_new_guard (region, next_e, stmt, *newivs, + newivs_index, params_index); + + edge true_e = get_true_edge_from_guard_bb (next_e->dest); + edge false_e = get_false_edge_from_guard_bb (next_e->dest); + edge exit_true_e = single_succ_edge (true_e->dest); + edge exit_false_e = single_succ_edge (false_e->dest); + + htab_t before_guard = htab_create (10, rename_map_elt_info, + eq_rename_map_elts, free); + htab_traverse (rename_map, copy_renames, before_guard); + + next_e = translate_clast (region, stmt->then, true_e, + rename_map, newivs, newivs_index, bb_pbb_mapping, + params_index); + + insert_guard_phis (last_e->src, exit_true_e, exit_false_e, + before_guard, rename_map); + + htab_delete (before_guard); + + return last_e; +} + +/* Translates a CLAST statement STMT to GCC representation in the + context of a SESE. + + - NEXT_E is the edge where new generated code should be attached. + - RENAME_MAP contains a set of tuples of new names associated to + the original variables names. + - BB_PBB_MAPPING is is a basic_block and it's related poly_bb_p mapping. */ +static edge +translate_clast (sese region, struct clast_stmt *stmt, + edge next_e, htab_t rename_map, VEC (tree, heap) **newivs, + htab_t newivs_index, htab_t bb_pbb_mapping, + htab_t params_index) +{ + if (!stmt) + return next_e; + + if (CLAST_STMT_IS_A (stmt, stmt_root)) + ; /* Do nothing. */ + + else if (CLAST_STMT_IS_A (stmt, stmt_user)) + next_e = translate_clast_user (region, (struct clast_user_stmt *) stmt, + next_e, rename_map, newivs, newivs_index, + bb_pbb_mapping, params_index); + + else if (CLAST_STMT_IS_A (stmt, stmt_for)) + next_e = translate_clast_for (region, + (struct clast_for *) stmt, next_e, rename_map, + newivs, newivs_index, bb_pbb_mapping, + params_index); + + else if (CLAST_STMT_IS_A (stmt, stmt_guard)) + next_e = translate_clast_guard (region, (struct clast_guard *) stmt, next_e, + rename_map, newivs, newivs_index, + bb_pbb_mapping, params_index); + + else if (CLAST_STMT_IS_A (stmt, stmt_block)) + next_e = translate_clast (region, ((struct clast_block *) stmt)->body, + next_e, rename_map, newivs, newivs_index, + bb_pbb_mapping, params_index); + else + gcc_unreachable(); + + recompute_all_dominators (); + graphite_verify (); + + return translate_clast (region, stmt->next, next_e, rename_map, newivs, + newivs_index, bb_pbb_mapping, params_index); } /* Returns the first cloog name used in EXPR. */ @@ -890,14 +1117,30 @@ initialize_cloog_names (scop_p scop, CloogProgram *prog) int i; int nb_iterators = scop_max_loop_depth (scop); int nb_scattering = cloog_program_nb_scattdims (prog); + int nb_parameters = VEC_length (tree, SESE_PARAMS (region)); char **iterators = XNEWVEC (char *, nb_iterators * 2); char **scattering = XNEWVEC (char *, nb_scattering); + char **parameters= XNEWVEC (char *, nb_parameters); cloog_program_set_names (prog, cloog_names_malloc ()); - cloog_names_set_nb_parameters (cloog_program_names (prog), - VEC_length (tree, SESE_PARAMS (region))); - cloog_names_set_parameters (cloog_program_names (prog), - SESE_PARAMS_NAMES (region)); + + for (i = 0; i < nb_parameters; i++) + { + tree param = VEC_index (tree, SESE_PARAMS(region), i); + const char *name = get_name (param); + int len; + + if (!name) + name = "T"; + + len = strlen (name); + len += 17; + parameters[i] = XNEWVEC (char, len + 1); + snprintf (parameters[i], len, "%s_%d", name, SSA_NAME_VERSION (param)); + } + + cloog_names_set_nb_parameters (cloog_program_names (prog), nb_parameters); + cloog_names_set_parameters (cloog_program_names (prog), parameters); for (i = 0; i < nb_iterators; i++) { @@ -1144,6 +1387,20 @@ debug_generated_program (scop_p scop) print_generated_program (stderr, scop); } +/* Add CLooG names to parameter index. The index is used to translate back from + * CLooG names to GCC trees. */ + +static void +create_params_index (htab_t index_table, CloogProgram *prog) { + CloogNames* names = cloog_program_names (prog); + int nb_parameters = cloog_names_nb_parameters (names); + char **parameters = cloog_names_parameters (names); + int i; + + for (i = 0; i < nb_parameters; i++) + save_clast_name_index (index_table, parameters[i], i); +} + /* GIMPLE Loop Generator: generates loops from STMT in GIMPLE form for the given SCOP. Return true if code generation succeeded. BB_PBB_MAPPING is a basic_block and it's related poly_bb_p mapping. @@ -1154,10 +1411,9 @@ gloog (scop_p scop, htab_t bb_pbb_mapping) { edge new_scop_exit_edge = NULL; VEC (tree, heap) *newivs = VEC_alloc (tree, heap, 10); - loop_p context_loop; sese region = SCOP_REGION (scop); ifsese if_region = NULL; - htab_t rename_map, newivs_index; + htab_t rename_map, newivs_index, params_index; cloog_prog_clast pc; timevar_push (TV_GRAPHITE_CODE_GEN); @@ -1179,20 +1435,22 @@ gloog (scop_p scop, htab_t bb_pbb_mapping) if_region->region->exit->src, if_region->false_region->exit, if_region->true_region->exit); - recompute_all_dominators (); graphite_verify (); - context_loop = SESE_ENTRY (region)->src->loop_father; - compute_cloog_iv_types (pc.stmt); + compute_cloog_iv_types (pc.stmt); rename_map = htab_create (10, rename_map_elt_info, eq_rename_map_elts, free); newivs_index = htab_create (10, clast_name_index_elt_info, eq_clast_name_indexes, free); + params_index = htab_create (10, clast_name_index_elt_info, + eq_clast_name_indexes, free); + + create_params_index (params_index, pc.prog); - new_scop_exit_edge = translate_clast (region, context_loop, pc.stmt, + new_scop_exit_edge = translate_clast (region, pc.stmt, if_region->true_region->entry, rename_map, &newivs, newivs_index, - bb_pbb_mapping, 1); + bb_pbb_mapping, params_index); graphite_verify (); sese_adjust_liveout_phis (region, rename_map, if_region->region->exit->src, @@ -1207,6 +1465,7 @@ gloog (scop_p scop, htab_t bb_pbb_mapping) htab_delete (rename_map); htab_delete (newivs_index); + htab_delete (params_index); VEC_free (tree, heap, newivs); cloog_clast_free (pc.stmt); cloog_program_free (pc.prog); diff --git a/gcc/graphite-scop-detection.c b/gcc/graphite-scop-detection.c index 6580252a7fa..02c653b69a6 100644 --- a/gcc/graphite-scop-detection.c +++ b/gcc/graphite-scop-detection.c @@ -1207,24 +1207,6 @@ print_graphite_statistics (FILE* file, VEC (scop_p, heap) *scops) print_graphite_scop_statistics (file, scop); } -/* Version of free_scops special cased for limit_scops. */ - -static void -free_scops_1 (VEC (scop_p, heap) **scops) -{ - int i; - scop_p scop; - - for (i = 0; VEC_iterate (scop_p, *scops, i, scop); i++) - { - sese region = SCOP_REGION (scop); - free (SESE_PARAMS_NAMES (region)); - SESE_PARAMS_NAMES (region) = 0; - } - - free_scops (*scops); -} - /* We limit all SCoPs to SCoPs, that are completely surrounded by a loop. Example: @@ -1278,7 +1260,7 @@ limit_scops (VEC (scop_p, heap) **scops) } } - free_scops_1 (scops); + free_scops (*scops); *scops = VEC_alloc (scop_p, heap, 3); create_sese_edges (regions); diff --git a/gcc/graphite-sese-to-poly.c b/gcc/graphite-sese-to-poly.c index d3a24037954..37b20354d6f 100644 --- a/gcc/graphite-sese-to-poly.c +++ b/gcc/graphite-sese-to-poly.c @@ -746,26 +746,6 @@ scan_tree_for_params_int (tree cst, ppl_Linear_Expression_t expr, Value k) ppl_delete_Coefficient (coef); } -/* Saves in NV at index I a new name for variable P. */ - -static void -save_var_name (char **nv, int i, tree p) -{ - const char *name = get_name (SSA_NAME_VAR (p)); - - if (name) - { - int len = strlen (name) + 16; - nv[i] = XNEWVEC (char, len); - snprintf (nv[i], len, "%s_%d", name, SSA_NAME_VERSION (p)); - } - else - { - nv[i] = XNEWVEC (char, 16); - snprintf (nv[i], 2 + 16, "T_%d", SSA_NAME_VERSION (p)); - } -} - /* When parameter NAME is in REGION, returns its index in SESE_PARAMS. Otherwise returns -1. */ @@ -802,9 +782,6 @@ parameter_index_in_region (tree name, sese region) gcc_assert (SESE_ADD_PARAMS (region)); i = VEC_length (tree, SESE_PARAMS (region)); - save_var_name (SESE_PARAMS_NAMES (region), i, name); - save_clast_name_index (SESE_PARAMS_INDEX (region), - SESE_PARAMS_NAMES (region)[i], i); VEC_safe_push (tree, heap, SESE_PARAMS (region), name); return i; } diff --git a/gcc/ipa-prop.c b/gcc/ipa-prop.c index 6a018f456ea..9387f0e0779 100644 --- a/gcc/ipa-prop.c +++ b/gcc/ipa-prop.c @@ -754,6 +754,7 @@ ipa_note_param_call (struct ipa_node_params *info, int formal_id, note->lto_stmt_uid = gimple_uid (stmt); note->count = bb->count; note->frequency = compute_call_stmt_bb_frequency (current_function_decl, bb); + note->loop_nest = bb->loop_depth; note->next = info->param_calls; info->param_calls = note; @@ -2008,7 +2009,7 @@ ipa_write_node_info (struct output_block *ob, struct cgraph_node *node) int j; struct cgraph_edge *e; struct bitpack_d *bp; - int note_count; + int note_count = 0; struct ipa_param_call_note *note; encoder = ob->decl_state->cgraph_node_encoder; diff --git a/gcc/ipa-prop.h b/gcc/ipa-prop.h index 4dc87d78503..90055e124bc 100644 --- a/gcc/ipa-prop.h +++ b/gcc/ipa-prop.h @@ -139,6 +139,8 @@ struct ipcp_lattice are linked in a list. */ struct ipa_param_call_note { + /* Expected number of executions: calculated in profile.c. */ + gcov_type count; /* Linked list's next */ struct ipa_param_call_note *next; /* Statement that contains the call to the parameter above. */ @@ -147,13 +149,11 @@ struct ipa_param_call_note unsigned int lto_stmt_uid; /* Index of the parameter that is called. */ int formal_id; - /* Expected number of executions: calculated in profile.c. */ - gcov_type count; /* Expected frequency of executions within the function. see cgraph_edge in cgraph.h for more on this. */ int frequency; /* Depth of loop nest, 1 means no loop nest. */ - int loop_nest; + unsigned short int loop_nest; /* Set when we have already found the target to be a compile time constant and turned this into an edge or when the note was found unusable for some reason. */ diff --git a/gcc/ipa-reference.c b/gcc/ipa-reference.c index 032bef278eb..98a4ce7d714 100644 --- a/gcc/ipa-reference.c +++ b/gcc/ipa-reference.c @@ -1389,22 +1389,23 @@ propagate (void) ipa_reference_local_vars_info_t w_l = w_ri->local; fprintf (dump_file, "\n next cycle: %s/%i ", cgraph_node_name (w), w->uid); - fprintf (dump_file, "\n locals read: "); - EXECUTE_IF_SET_IN_BITMAP (w_l->statics_read, - 0, index, bi) - { - fprintf (dump_file, "%s ", - get_static_name (index)); - } + fprintf (dump_file, "\n locals read: "); + if (w_l->statics_read) + EXECUTE_IF_SET_IN_BITMAP (w_l->statics_read, + 0, index, bi) + { + fprintf (dump_file, "%s ", + get_static_name (index)); + } fprintf (dump_file, "\n locals written: "); - EXECUTE_IF_SET_IN_BITMAP (w_l->statics_written, - 0, index, bi) - { - fprintf(dump_file, "%s ", - get_static_name (index)); - } - + if (w_l->statics_written) + EXECUTE_IF_SET_IN_BITMAP (w_l->statics_written, + 0, index, bi) + { + fprintf (dump_file, "%s ", + get_static_name (index)); + } w_info = (struct ipa_dfs_info *) w->aux; w = w_info->next_cycle; diff --git a/gcc/ipa-struct-reorg.c b/gcc/ipa-struct-reorg.c index 0cb7ccca31b..e1dddae999e 100644 --- a/gcc/ipa-struct-reorg.c +++ b/gcc/ipa-struct-reorg.c @@ -569,7 +569,7 @@ static new_var is_in_new_vars_htab (tree decl, htab_t new_vars_htab) { return (new_var) htab_find_with_hash (new_vars_htab, decl, - htab_hash_pointer (decl)); + DECL_UID (decl)); } /* Given original variable ORIG_VAR, this function returns @@ -1962,7 +1962,7 @@ add_to_new_vars_htab (new_var new_node, htab_t new_vars_htab) void **slot; slot = htab_find_slot_with_hash (new_vars_htab, new_node->orig_var, - htab_hash_pointer (new_node->orig_var), + DECL_UID (new_node->orig_var), INSERT); *slot = new_node; } @@ -2254,15 +2254,19 @@ create_new_var (tree var_decl, htab_t new_vars_htab) static hashval_t new_var_hash (const void *x) { - return htab_hash_pointer (((const_new_var)x)->orig_var); + return DECL_UID (((const_new_var)x)->orig_var); } -/* This function returns nonzero if orig_var of new_var X is equal to Y. */ +/* This function returns nonzero if orig_var of new_var X + and tree Y have equal UIDs. */ static int new_var_eq (const void *x, const void *y) { - return ((const_new_var)x)->orig_var == (const_tree)y; + if (DECL_P ((const_tree)y)) + return DECL_UID (((const_new_var)x)->orig_var) == DECL_UID ((const_tree)y); + else + return 0; } /* This function check whether a structure type represented by STR diff --git a/gcc/params.c b/gcc/params.c index d7179c085fc..04eff112055 100644 --- a/gcc/params.c +++ b/gcc/params.c @@ -32,7 +32,6 @@ along with GCC; see the file COPYING3. If not see param_info *compiler_params; /* The number of entries in the table. */ - static size_t num_compiler_params; /* Add the N PARAMS to the current list of compiler parameters. */ @@ -85,3 +84,12 @@ set_param_value (const char *name, int value) /* If we didn't find this parameter, issue an error message. */ error ("invalid parameter %qs", name); } + +/* Return the current value of num_compiler_params, for the benefit of + plugins that use parameters as features. */ + +size_t +get_num_compiler_params (void) +{ + return num_compiler_params; +} diff --git a/gcc/params.h b/gcc/params.h index e0bb4fa7e9b..833fc3bb2f1 100644 --- a/gcc/params.h +++ b/gcc/params.h @@ -65,6 +65,9 @@ typedef struct param_info extern param_info *compiler_params; +/* Returns the number of entries in the table, for the use by plugins. */ +extern size_t get_num_compiler_params (void); + /* Add the N PARAMS to the current list of compiler parameters. */ extern void add_params (const param_info params[], size_t n); diff --git a/gcc/passes.c b/gcc/passes.c index 57b55c08fc9..818adde18e0 100644 --- a/gcc/passes.c +++ b/gcc/passes.c @@ -85,6 +85,7 @@ along with GCC; see the file COPYING3. If not see #include "df.h" #include "predict.h" #include "lto-streamer.h" +#include "plugin.h" #if defined (DWARF2_UNWIND_INFO) || defined (DWARF2_DEBUGGING_INFO) #include "dwarf2out.h" @@ -104,7 +105,8 @@ along with GCC; see the file COPYING3. If not see #endif /* This is used for debugging. It allows the current pass to printed - from anywhere in compilation. */ + from anywhere in compilation. + The variable current_pass is also used for statistics and plugins. */ struct opt_pass *current_pass; /* Call from anywhere to find out what pass this is. Useful for @@ -479,6 +481,8 @@ make_pass_instance (struct opt_pass *pass, bool track_duplicates) { pass->todo_flags_start |= TODO_mark_first_instance; pass->static_pass_number = -1; + + invoke_plugin_callbacks (PLUGIN_NEW_PASS, pass); } return pass; } @@ -1090,9 +1094,9 @@ static GTY ((length ("nnodes"))) struct cgraph_node **order; /* If we are in IPA mode (i.e., current_function_decl is NULL), call function CALLBACK for every function in the call graph. Otherwise, - call CALLBACK on the current function. */ - -static void + call CALLBACK on the current function. + This function is global so that plugins can use it. */ +void do_per_function_toporder (void (*callback) (void *data), void *data) { int i; @@ -1317,8 +1321,9 @@ verify_curr_properties (void *data) #endif /* Initialize pass dump file. */ +/* This is non-static so that the plugins can use it. */ -static bool +bool pass_init_dump_file (struct opt_pass *pass) { /* If a dump file name is present, open it if enabled. */ @@ -1347,8 +1352,9 @@ pass_init_dump_file (struct opt_pass *pass) } /* Flush PASS dump file. */ +/* This is non-static so that plugins can use it. */ -static void +void pass_fini_dump_file (struct opt_pass *pass) { /* Flush and close dump file. */ @@ -1476,12 +1482,14 @@ execute_all_ipa_transforms (void) /* Execute PASS. */ -static bool +bool execute_one_pass (struct opt_pass *pass) { bool initializing_dump; unsigned int todo_after = 0; + bool gate_status; + /* IPA passes are executed on whole program, so cfun should be NULL. Other passes need function context set. */ if (pass->type == SIMPLE_IPA_PASS || pass->type == IPA_PASS) @@ -1491,9 +1499,22 @@ execute_one_pass (struct opt_pass *pass) current_pass = pass; - /* See if we're supposed to run this pass. */ - if (pass->gate && !pass->gate ()) - return false; + /* Check whether gate check should be avoided. + User controls the value of the gate through the parameter "gate_status". */ + gate_status = (pass->gate == NULL) ? true : pass->gate(); + + /* Override gate with plugin. */ + invoke_plugin_callbacks (PLUGIN_OVERRIDE_GATE, &gate_status); + + if (!gate_status) + { + current_pass = NULL; + return false; + } + + /* Pass execution event trigger: useful to identify passes being + executed. */ + invoke_plugin_callbacks (PLUGIN_PASS_EXECUTION, pass); if (!quiet_flag && !cfun) fprintf (stderr, " <%s>", pass->name ? pass->name : ""); @@ -1756,8 +1777,12 @@ execute_ipa_pass_list (struct opt_pass *pass) if (execute_one_pass (pass) && pass->sub) { if (pass->sub->type == GIMPLE_PASS) - do_per_function_toporder ((void (*)(void *))execute_pass_list, - pass->sub); + { + invoke_plugin_callbacks (PLUGIN_EARLY_GIMPLE_PASSES_START, NULL); + do_per_function_toporder ((void (*)(void *))execute_pass_list, + pass->sub); + invoke_plugin_callbacks (PLUGIN_EARLY_GIMPLE_PASSES_END, NULL); + } else if (pass->sub->type == SIMPLE_IPA_PASS || pass->sub->type == IPA_PASS) execute_ipa_pass_list (pass->sub); diff --git a/gcc/plugin.c b/gcc/plugin.c index 750f537a222..673ad07ffc5 100644 --- a/gcc/plugin.c +++ b/gcc/plugin.c @@ -44,30 +44,32 @@ along with GCC; see the file COPYING3. If not see #include "plugin-version.h" #endif +#define GCC_PLUGIN_STRINGIFY0(X) #X +#define GCC_PLUGIN_STRINGIFY1(X) GCC_PLUGIN_STRINGIFY0 (X) + /* Event names as strings. Keep in sync with enum plugin_event. */ -const char *plugin_event_name[] = +static const char *plugin_event_name_init[] = { - "PLUGIN_PASS_MANAGER_SETUP", - "PLUGIN_FINISH_TYPE", - "PLUGIN_FINISH_UNIT", - "PLUGIN_CXX_CP_PRE_GENERICIZE", - "PLUGIN_FINISH", - "PLUGIN_INFO", - "PLUGIN_GGC_START", - "PLUGIN_GGC_MARKING", - "PLUGIN_GGC_END", - "PLUGIN_REGISTER_GGC_ROOTS", - "PLUGIN_REGISTER_GGC_CACHES", - "PLUGIN_ATTRIBUTES", - "PLUGIN_START_UNIT", - "PLUGIN_PRAGMAS", - "PLUGIN_EVENT_LAST" +# define DEFEVENT(NAME) GCC_PLUGIN_STRINGIFY1 (NAME), +# include "plugin.def" +# undef DEFEVENT }; /* a printf format large enough for the largest event above */ #define FMT_FOR_PLUGIN_EVENT "%-26s" /* A printf format large enough for the largest event above. */ -#define FMT_FOR_PLUGIN_EVENT "%-26s" +#define FMT_FOR_PLUGIN_EVENT "%-32s" + +const char **plugin_event_name = plugin_event_name_init; + +/* A hash table to map event names to the position of the names in the + plugin_event_name table. */ +static htab_t event_tab; + +/* Keep track of the limit of allocated events and space ready for + allocating events. */ +static int event_last = PLUGIN_EVENT_FIRST_DYNAMIC; +static int event_horizon = PLUGIN_EVENT_FIRST_DYNAMIC; /* Hash table for the plugin_name_args objects created during command-line parsing. */ @@ -83,7 +85,8 @@ struct callback_info }; /* An array of lists of 'callback_info' objects indexed by the event id. */ -static struct callback_info *plugin_callbacks[PLUGIN_EVENT_LAST] = { NULL }; +static struct callback_info *plugin_callbacks_init[PLUGIN_EVENT_FIRST_DYNAMIC]; +static struct callback_info **plugin_callbacks = plugin_callbacks_init; #ifdef ENABLE_PLUGIN @@ -292,6 +295,71 @@ register_plugin_info (const char* name, struct plugin_info *info) plugin->help = info->help; } +/* Helper function for the event hash table that compares the name of an + existing entry (E1) with the given string (S2). */ + +static int +htab_event_eq (const void *e1, const void *s2) +{ + const char *s1= *(const char * const *) e1; + return !strcmp (s1, (const char *) s2); +} + +/* Look up the event id for NAME. If the name is not found, return -1 + if INSERT is NO_INSERT. */ + +int +get_named_event_id (const char *name, enum insert_option insert) +{ + void **slot; + + if (!event_tab) + { + int i; + + event_tab = htab_create (150, htab_hash_string, htab_event_eq, NULL); + for (i = 0; i < PLUGIN_EVENT_FIRST_DYNAMIC; i++) + { + slot = htab_find_slot (event_tab, plugin_event_name[i], INSERT); + gcc_assert (*slot == HTAB_EMPTY_ENTRY); + *slot = &plugin_event_name[i]; + } + } + slot = htab_find_slot (event_tab, name, insert); + if (slot == NULL) + return -1; + if (*slot != HTAB_EMPTY_ENTRY) + return (const char **) *slot - &plugin_event_name[0]; + + if (event_last >= event_horizon) + { + event_horizon = event_last * 2; + if (plugin_event_name == plugin_event_name_init) + { + plugin_event_name = XNEWVEC (const char *, event_horizon); + memcpy (plugin_event_name, plugin_event_name_init, + sizeof plugin_event_name_init); + plugin_callbacks = XNEWVEC (struct callback_info *, event_horizon); + memcpy (plugin_callbacks, plugin_callbacks_init, + sizeof plugin_callbacks_init); + } + else + { + plugin_event_name + = XRESIZEVEC (const char *, plugin_event_name, event_horizon); + plugin_callbacks = XRESIZEVEC (struct callback_info *, + plugin_callbacks, event_horizon); + } + /* All the pointers in the hash table will need to be updated. */ + htab_delete (event_tab); + event_tab = NULL; + } + else + *slot = &plugin_event_name[event_last]; + plugin_event_name[event_last] = name; + return event_last++; +} + /* Called from the plugin's initialization code. Register a single callback. This function can be called multiple times. @@ -302,7 +370,7 @@ register_plugin_info (const char* name, struct plugin_info *info) void register_callback (const char *plugin_name, - enum plugin_event event, + int event, plugin_callback_func callback, void *user_data) { @@ -324,6 +392,15 @@ register_callback (const char *plugin_name, gcc_assert (!callback); ggc_register_cache_tab ((const struct ggc_cache_tab*) user_data); break; + case PLUGIN_EVENT_FIRST_DYNAMIC: + default: + if (event < PLUGIN_EVENT_FIRST_DYNAMIC || event >= event_last) + { + error ("Unknown callback event registered by plugin %s", + plugin_name); + return; + } + /* Fall through. */ case PLUGIN_FINISH_TYPE: case PLUGIN_START_UNIT: case PLUGIN_FINISH_UNIT: @@ -334,6 +411,15 @@ register_callback (const char *plugin_name, case PLUGIN_ATTRIBUTES: case PLUGIN_PRAGMAS: case PLUGIN_FINISH: + case PLUGIN_ALL_PASSES_START: + case PLUGIN_ALL_PASSES_END: + case PLUGIN_ALL_IPA_PASSES_START: + case PLUGIN_ALL_IPA_PASSES_END: + case PLUGIN_OVERRIDE_GATE: + case PLUGIN_PASS_EXECUTION: + case PLUGIN_EARLY_GIMPLE_PASSES_START: + case PLUGIN_EARLY_GIMPLE_PASSES_END: + case PLUGIN_NEW_PASS: { struct callback_info *new_callback; if (!callback) @@ -350,27 +436,52 @@ register_callback (const char *plugin_name, plugin_callbacks[event] = new_callback; } break; - case PLUGIN_EVENT_LAST: - default: - error ("Unknown callback event registered by plugin %s", - plugin_name); } } +/* Remove a callback for EVENT which has been registered with for a plugin + PLUGIN_NAME. Return PLUGEVT_SUCCESS if a matching callback was + found & removed, PLUGEVT_NO_CALLBACK if the event does not have a matching + callback, and PLUGEVT_NO_SUCH_EVENT if EVENT is invalid. */ +int +unregister_callback (const char *plugin_name, int event) +{ + struct callback_info *callback, **cbp; + + if (event >= event_last) + return PLUGEVT_NO_SUCH_EVENT; + + for (cbp = &plugin_callbacks[event]; (callback = *cbp); cbp = &callback->next) + if (strcmp (callback->plugin_name, plugin_name) == 0) + { + *cbp = callback->next; + return PLUGEVT_SUCCESS; + } + return PLUGEVT_NO_CALLBACK; +} /* Called from inside GCC. Invoke all plug-in callbacks registered with the specified event. + Return PLUGEVT_SUCCESS if at least one callback was called, + PLUGEVT_NO_CALLBACK if there was no callback. EVENT - the event identifier GCC_DATA - event-specific data provided by the compiler */ -void -invoke_plugin_callbacks (enum plugin_event event, void *gcc_data) +int +invoke_plugin_callbacks (int event, void *gcc_data) { + int retval = PLUGEVT_SUCCESS; + timevar_push (TV_PLUGIN_RUN); switch (event) { + case PLUGIN_EVENT_FIRST_DYNAMIC: + default: + gcc_assert (event >= PLUGIN_EVENT_FIRST_DYNAMIC); + gcc_assert (event < event_last); + /* Fall through. */ case PLUGIN_FINISH_TYPE: case PLUGIN_START_UNIT: case PLUGIN_FINISH_UNIT: @@ -381,24 +492,35 @@ invoke_plugin_callbacks (enum plugin_event event, void *gcc_data) case PLUGIN_GGC_START: case PLUGIN_GGC_MARKING: case PLUGIN_GGC_END: + case PLUGIN_ALL_PASSES_START: + case PLUGIN_ALL_PASSES_END: + case PLUGIN_ALL_IPA_PASSES_START: + case PLUGIN_ALL_IPA_PASSES_END: + case PLUGIN_OVERRIDE_GATE: + case PLUGIN_PASS_EXECUTION: + case PLUGIN_EARLY_GIMPLE_PASSES_START: + case PLUGIN_EARLY_GIMPLE_PASSES_END: + case PLUGIN_NEW_PASS: { /* Iterate over every callback registered with this event and call it. */ struct callback_info *callback = plugin_callbacks[event]; + + if (!callback) + retval = PLUGEVT_NO_CALLBACK; for ( ; callback; callback = callback->next) (*callback->func) (gcc_data, callback->user_data); } break; case PLUGIN_PASS_MANAGER_SETUP: - case PLUGIN_EVENT_LAST: case PLUGIN_REGISTER_GGC_ROOTS: case PLUGIN_REGISTER_GGC_CACHES: - default: gcc_assert (false); } timevar_pop (TV_PLUGIN_RUN); + return retval; } #ifdef ENABLE_PLUGIN @@ -623,7 +745,7 @@ plugins_active_p (void) { int event; - for (event = PLUGIN_PASS_MANAGER_SETUP; event < PLUGIN_EVENT_LAST; event++) + for (event = PLUGIN_PASS_MANAGER_SETUP; event < event_last; event++) if (plugin_callbacks[event]) return true; @@ -643,7 +765,7 @@ dump_active_plugins (FILE *file) return; fprintf (file, FMT_FOR_PLUGIN_EVENT " | %s\n", _("Event"), _("Plugins")); - for (event = PLUGIN_PASS_MANAGER_SETUP; event < PLUGIN_EVENT_LAST; event++) + for (event = PLUGIN_PASS_MANAGER_SETUP; event < event_last; event++) if (plugin_callbacks[event]) { struct callback_info *ci; @@ -688,3 +810,13 @@ plugin_default_version_check (struct plugin_gcc_version *gcc_version, return false; return true; } + +/* Return the current value of event_last, so that plugins which provide + additional functionality for events for the benefit of high-level plugins + know how many valid entries plugin_event_name holds. */ + +int +get_event_last (void) +{ + return event_last; +} diff --git a/gcc/plugin.h b/gcc/plugin.h index b610b23ed93..1e1dd594937 100644 --- a/gcc/plugin.h +++ b/gcc/plugin.h @@ -26,7 +26,7 @@ struct attribute_spec; extern void add_new_plugin (const char *); extern void parse_plugin_arg_opt (const char *); -extern void invoke_plugin_callbacks (enum plugin_event, void *); +extern int invoke_plugin_callbacks (int, void *); extern void initialize_plugins (void); extern bool plugins_active_p (void); extern void dump_active_plugins (FILE *); diff --git a/gcc/print-rtl.c b/gcc/print-rtl.c index ff73c4afb05..75f034376cb 100644 --- a/gcc/print-rtl.c +++ b/gcc/print-rtl.c @@ -42,6 +42,7 @@ along with GCC; see the file COPYING3. If not see #include "basic-block.h" #include "diagnostic.h" #include "cselib.h" +#include "tree-pass.h" #endif static FILE *outfile; @@ -78,7 +79,7 @@ void print_mem_expr (FILE *outfile, const_tree expr) { fputc (' ', outfile); - print_generic_expr (outfile, CONST_CAST_TREE (expr), 0); + print_generic_expr (outfile, CONST_CAST_TREE (expr), dump_flags); } #endif @@ -241,7 +242,7 @@ print_rtx (const_rtx in_rtx) { tree decl = SYMBOL_REF_DECL (in_rtx); if (decl) - print_node_brief (outfile, "", decl, 0); + print_node_brief (outfile, "", decl, dump_flags); } #endif else if (i == 4 && NOTE_P (in_rtx)) diff --git a/gcc/print-tree.c b/gcc/print-tree.c index a44d23a8474..eebd1c35ba1 100644 --- a/gcc/print-tree.c +++ b/gcc/print-tree.c @@ -32,6 +32,7 @@ along with GCC; see the file COPYING3. If not see #include "tree-iterator.h" #include "diagnostic.h" #include "tree-flow.h" +#include "tree-pass.h" /* Define the hash table of nodes already seen. Such nodes are not repeated; brief cross-references are used. */ @@ -95,10 +96,22 @@ print_node_brief (FILE *file, const char *prefix, const_tree node, int indent) fprintf (file, " %s", IDENTIFIER_POINTER (DECL_NAME (node))); else if (TREE_CODE (node) == LABEL_DECL && LABEL_DECL_UID (node) != -1) - fprintf (file, " L.%d", (int) LABEL_DECL_UID (node)); + { + if (dump_flags & TDF_NOUID) + fprintf (file, " L.xxxx"); + else + fprintf (file, " L.%d", (int) LABEL_DECL_UID (node)); + } else - fprintf (file, " %c.%u", TREE_CODE (node) == CONST_DECL ? 'C' : 'D', - DECL_UID (node)); + { + if (dump_flags & TDF_NOUID) + fprintf (file, " %c.xxxx", + TREE_CODE (node) == CONST_DECL ? 'C' : 'D'); + else + fprintf (file, " %c.%u", + TREE_CODE (node) == CONST_DECL ? 'C' : 'D', + DECL_UID (node)); + } } else if (tclass == tcc_type) { @@ -260,10 +273,20 @@ print_node (FILE *file, const char *prefix, tree node, int indent) fprintf (file, " %s", IDENTIFIER_POINTER (DECL_NAME (node))); else if (code == LABEL_DECL && LABEL_DECL_UID (node) != -1) - fprintf (file, " L.%d", (int) LABEL_DECL_UID (node)); + { + if (dump_flags & TDF_NOUID) + fprintf (file, " L.xxxx"); + else + fprintf (file, " L.%d", (int) LABEL_DECL_UID (node)); + } else - fprintf (file, " %c.%u", code == CONST_DECL ? 'C' : 'D', - DECL_UID (node)); + { + if (dump_flags & TDF_NOUID) + fprintf (file, " %c.xxxx", code == CONST_DECL ? 'C' : 'D'); + else + fprintf (file, " %c.%u", code == CONST_DECL ? 'C' : 'D', + DECL_UID (node)); + } } else if (tclass == tcc_type) { diff --git a/gcc/sese.c b/gcc/sese.c index 338f482eec1..2c033939b7f 100644 --- a/gcc/sese.c +++ b/gcc/sese.c @@ -332,9 +332,6 @@ new_sese (edge entry, edge exit) SESE_LOOP_NEST (region) = VEC_alloc (loop_p, heap, 3); SESE_ADD_PARAMS (region) = true; SESE_PARAMS (region) = VEC_alloc (tree, heap, 3); - SESE_PARAMS_INDEX (region) = htab_create (10, clast_name_index_elt_info, - eq_clast_name_indexes, free); - SESE_PARAMS_NAMES (region) = XNEWVEC (char *, num_ssa_names); return region; } @@ -350,11 +347,6 @@ free_sese (sese region) VEC_free (tree, heap, SESE_PARAMS (region)); VEC_free (loop_p, heap, SESE_LOOP_NEST (region)); - if (SESE_PARAMS_INDEX (region)) - htab_delete (SESE_PARAMS_INDEX (region)); - - /* Do not free SESE_PARAMS_NAMES: CLooG does that. */ - XDELETE (region); } diff --git a/gcc/sese.h b/gcc/sese.h index c126a6964f8..6763db34c27 100644 --- a/gcc/sese.h +++ b/gcc/sese.h @@ -32,12 +32,6 @@ typedef struct sese_s /* Parameters used within the SCOP. */ VEC (tree, heap) *params; - /* Used to quickly retrieve the index of a parameter in PARAMS. */ - htab_t params_index; - - /* Store the names of the parameters that are passed to CLooG. */ - char **params_names; - /* Loops completely contained in the SCOP. */ bitmap loops; VEC (loop_p, heap) *loop_nest; @@ -53,8 +47,6 @@ typedef struct sese_s #define SESE_EXIT(S) (S->exit) #define SESE_EXIT_BB(S) (S->exit->dest) #define SESE_PARAMS(S) (S->params) -#define SESE_PARAMS_INDEX(S) (S->params_index) -#define SESE_PARAMS_NAMES(S) (S->params_names) #define SESE_LOOPS(S) (S->loops) #define SESE_LOOP_NEST(S) (S->loop_nest) #define SESE_ADD_PARAMS(S) (S->add_params) @@ -222,105 +214,6 @@ block_before_sese (sese sese) return SESE_ENTRY (sese)->src; } -/* Stores the INDEX in a vector for a given clast NAME. */ - -typedef struct clast_name_index { - int index; - const char *name; -} *clast_name_index_p; - -/* Returns a pointer to a new element of type clast_name_index_p built - from NAME and INDEX. */ - -static inline clast_name_index_p -new_clast_name_index (const char *name, int index) -{ - clast_name_index_p res = XNEW (struct clast_name_index); - - res->name = name; - res->index = index; - return res; -} - -/* For a given clast NAME, returns -1 if it does not correspond to any - parameter, or otherwise, returns the index in the PARAMS or - SCATTERING_DIMENSIONS vector. */ - -static inline int -clast_name_to_index (const char *name, htab_t index_table) -{ - struct clast_name_index tmp; - PTR *slot; - - tmp.name = name; - slot = htab_find_slot (index_table, &tmp, NO_INSERT); - - if (slot && *slot) - return ((struct clast_name_index *) *slot)->index; - - return -1; -} - -/* Records in INDEX_TABLE the INDEX for NAME. */ - -static inline void -save_clast_name_index (htab_t index_table, const char *name, int index) -{ - struct clast_name_index tmp; - PTR *slot; - - tmp.name = name; - slot = htab_find_slot (index_table, &tmp, INSERT); - - if (slot) - *slot = new_clast_name_index (name, index); -} - -/* Print to stderr the element ELT. */ - -static inline void -debug_clast_name_index (clast_name_index_p elt) -{ - fprintf (stderr, "(index = %d, name = %s)\n", elt->index, elt->name); -} - -/* Helper function for debug_rename_map. */ - -static inline int -debug_clast_name_indexes_1 (void **slot, void *s ATTRIBUTE_UNUSED) -{ - struct clast_name_index *entry = (struct clast_name_index *) *slot; - debug_clast_name_index (entry); - return 1; -} - -/* Print to stderr all the elements of MAP. */ - -static inline void -debug_clast_name_indexes (htab_t map) -{ - htab_traverse (map, debug_clast_name_indexes_1, NULL); -} - -/* Computes a hash function for database element ELT. */ - -static inline hashval_t -clast_name_index_elt_info (const void *elt) -{ - return htab_hash_pointer (((const struct clast_name_index *) elt)->name); -} - -/* Compares database elements E1 and E2. */ - -static inline int -eq_clast_name_indexes (const void *e1, const void *e2) -{ - const struct clast_name_index *elt1 = (const struct clast_name_index *) e1; - const struct clast_name_index *elt2 = (const struct clast_name_index *) e2; - - return (elt1->name == elt2->name); -} - /* A single entry single exit specialized for conditions. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 5ea107d0a09..2b856c28b8c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,101 @@ +2009-12-01 Jason Merrill <jason@redhat.com> + + PR c++/41611 + * g++.dg/abi/guard1.C: New. + +2009-12-91 Uros Bizjak <ubizjak@gmail.com> + + * gcc.target/i386/vperm-v4sf-1.c (dg-options): Use -msse. + +2009-12-01 Jakub Jelinek <jakub@redhat.com> + + PR c++/42234 + * g++.dg/gomp/pr42234.C: New test. + +2009-12-01 Martin Jambor <mjambor@suse.cz> + + PR tree-optimization/42237 + * gcc.c-torture/compile/pr42237.c: New test. + +2009-12-01 Paolo Carlini <paolo.carlini@oracle.com> + + PR c++/42057 + * g++.dg/parse/crash54.C: New. + +2009-11-30 Chao-ying Fu <fu@mips.com> + + * gcc.target/mips/dsp-lhx.c: New test. + * gcc.target/mips/dsp-no-lhx.c: New test. + +2009-11-30 Dave Korn <dave.korn.cygwin@gmail.com> + + * lib/g++.exp (g++_init): Add host-dependent settings for + LC_ALL and LANG. + * lib/gcc-dg.exp: Likewise. + * lib/options.exp: Likewise. + * lib/objc.exp (objc_init): Likewise. + * lib/gfortran.exp (gfortran_init): Likewise. + +2009-11-30 Paolo Carlini <paolo.carlini@oracle.com> + + PR c++/40371 + * g++.dg/template/crash93.C: New. + +2009-11-30 Steve Ellcey <sje@cup.hp.com> + + * gcc.dg/pr41551.c: New test. + +2009-11-30 Janus Weil <janus@gcc.gnu.org> + + PR fortran/42053 + * gfortran.dg/select_type_9.f03: New. + +2009-11-30 Janus Weil <janus@gcc.gnu.org> + + PR fortran/41631 + * gfortran.dg/extends_type_of_1.f03: Fix invalid test case. + * gfortran.dg/module_md5_1.f90: Adjusted MD5 sum. + * gfortran.dg/select_type_1.f03: Remove FIXMEs. + * gfortran.dg/select_type_2.f03: Ditto. + * gfortran.dg/select_type_8.f03: New test. + +2009-11-30 Janus Weil <janus@gcc.gnu.org> + + * gfortran.dg/extends_type_of_1.f03: New test. + * gfortran.dg/same_type_as_1.f03: Extended. + +2009-11-30 Paul Thomas <pault@gcc.gnu.org> + + * gfortran.dg/class_4c.f03: Add dg-additional-sources. + * gfortran.dg/class_4d.f03: Rename module. Cleanup modules. + +2009-11-30 Janis Johnson <janis187@us.ibm.com> + + PR testsuite/42212 + * gcc.target/powerpc/regnames-1.c: Add missing brace dg-do. + +2009-11-30 Martin Jambor <mjambor@suse.cz> + + PR middle-end/42196 + * gcc.c-torture/compile/pr42196-1.c: New test. + * gcc.c-torture/compile/pr42196-2.c: New test. + * gcc.c-torture/compile/pr42196-3.c: New test. + +2009-11-30 Ira Rosen <irar@il.ibm.com> + + * gfortran.dg/vect/vect-7.f90: New test. + +2009-11-30 Richard Guenther <rguenther@suse.de> + + PR middle-end/42119 + PR fortran/38530 + * gfortran.dg/pr42119.f90: New testcase. + +2009-11-30 Dodji Seketeli <dodji@redhat.com> + + PR c++/42069 + * g++.dg/template/typedef23.C: New test. + 2009-11-29 H.J. Lu <hongjiu.lu@intel.com> PR tree-optimization/41961 diff --git a/gcc/testsuite/g++.dg/abi/guard1.C b/gcc/testsuite/g++.dg/abi/guard1.C new file mode 100644 index 00000000000..76b43d30f36 --- /dev/null +++ b/gcc/testsuite/g++.dg/abi/guard1.C @@ -0,0 +1,10 @@ +// PR c++/41611 +// { dg-final { scan-assembler-not "_ZGVZN1A1fEvE1i" } } + +struct A { + static int f() + { + static int &i = *new int(); + return i; + } +}; diff --git a/gcc/testsuite/gcc.dg/graphite/pr35356-2.c b/gcc/testsuite/gcc.dg/graphite/pr35356-2.c index 5432deec61d..e5b0213768c 100644 --- a/gcc/testsuite/gcc.dg/graphite/pr35356-2.c +++ b/gcc/testsuite/gcc.dg/graphite/pr35356-2.c @@ -25,8 +25,20 @@ foo (int bar, int n, int k) | for (i = max(k+1,0); i < n; i++) | a[i] = i; + XXX: At the moment we generate to protect loops that are executed zero times. + + | if (0 < min (n, k) + 1) + | for (i = 0; i < min (n, k); i++) + | a[i] = i; + | if (k >= 0 && k < n) + | a[k] = 1; + | if (0 < max(n, k) + 1) + | for (i = max(k+1,0); i < n; i++) + | a[i] = i; + */ -/* { dg-final { scan-tree-dump-times "MIN_EXPR" 1 "graphite" } } */ -/* { dg-final { scan-tree-dump-times "MAX_EXPR" 1 "graphite" } } */ + +/* { dg-final { scan-tree-dump-times "MIN_EXPR" 2 "graphite" } } */ +/* { dg-final { scan-tree-dump-times "MAX_EXPR" 2 "graphite" } } */ /* { dg-final { cleanup-tree-dump "graphite" } } */ diff --git a/gcc/testsuite/gcc.target/i386/vperm-v4sf-1.c b/gcc/testsuite/gcc.target/i386/vperm-v4sf-1.c index c52c3ab809c..b9fc9b172fe 100644 --- a/gcc/testsuite/gcc.target/i386/vperm-v4sf-1.c +++ b/gcc/testsuite/gcc.target/i386/vperm-v4sf-1.c @@ -1,5 +1,5 @@ /* { dg-do run } */ -/* { dg-options "-O -msse2" } */ +/* { dg-options "-O -msse" } */ #include "isa-check.h" diff --git a/gcc/testsuite/gcc.target/powerpc/regnames-1.c b/gcc/testsuite/gcc.target/powerpc/regnames-1.c index c814083c6e3..e34e6241daa 100644 --- a/gcc/testsuite/gcc.target/powerpc/regnames-1.c +++ b/gcc/testsuite/gcc.target/powerpc/regnames-1.c @@ -1,4 +1,4 @@ -/* { dg-do compile { target powerpc*-*-linux* } */ +/* { dg-do compile { target powerpc*-*-linux* } } */ /* { dg-options "-mregnames" } */ register double f17 asm ("f17"); diff --git a/gcc/testsuite/gfortran.dg/class_4c.f03 b/gcc/testsuite/gfortran.dg/class_4c.f03 index 7909c0eeda0..c76b3ab6953 100644 --- a/gcc/testsuite/gfortran.dg/class_4c.f03 +++ b/gcc/testsuite/gfortran.dg/class_4c.f03 @@ -1,4 +1,5 @@ ! { dg-do run } +! { dg-additional-sources class_4a.f03 class_4b.f03 } ! ! Test the fix for PR41583, in which the different source files ! would generate the same 'vindex' for different class declared diff --git a/gcc/testsuite/gfortran.dg/class_4d.f03 b/gcc/testsuite/gfortran.dg/class_4d.f03 index 7a962aa01b9..80934b6c125 100644 --- a/gcc/testsuite/gfortran.dg/class_4d.f03 +++ b/gcc/testsuite/gfortran.dg/class_4d.f03 @@ -8,8 +8,8 @@ ! ! Contributed by Tobias Burnus <burnus@gcc.gnu.org> ! -module m +module m3 type t end type t -end module m -! { dg-final { cleanup-modules "m m2" } } +end module m3 +! { dg-final { cleanup-modules "m m2 m3" } } diff --git a/gcc/testsuite/gfortran.dg/module_md5_1.f90 b/gcc/testsuite/gfortran.dg/module_md5_1.f90 index 88002c204bf..e725b4b767e 100644 --- a/gcc/testsuite/gfortran.dg/module_md5_1.f90 +++ b/gcc/testsuite/gfortran.dg/module_md5_1.f90 @@ -10,5 +10,5 @@ program test use foo print *, pi end program test -! { dg-final { scan-module "foo" "MD5:9c43cf4d713824ec6894b83250720e68" } } +! { dg-final { scan-module "foo" "MD5:5632bcd379cf023bf7e663e91d52fa12" } } ! { dg-final { cleanup-modules "foo" } } diff --git a/gcc/testsuite/gfortran.dg/same_type_as_1.f03 b/gcc/testsuite/gfortran.dg/same_type_as_1.f03 index ba13a0b731e..45b5d26627f 100644 --- a/gcc/testsuite/gfortran.dg/same_type_as_1.f03 +++ b/gcc/testsuite/gfortran.dg/same_type_as_1.f03 @@ -1,6 +1,6 @@ ! { dg-do compile } ! -! Error checking for the intrinsic function SAME_TYPE_AS. +! Error checking for the intrinsic functions SAME_TYPE_AS and EXTENDS_TYPE_OF. ! ! Contributed by Janus Weil <janus@gcc.gnu.org> @@ -18,7 +18,10 @@ integer :: i - print *, SAME_TYPE_AS (l,x1) ! { dg-error "must be of a derived type" } + print *, SAME_TYPE_AS (i,x1) ! { dg-error "must be of a derived type" } print *, SAME_TYPE_AS (x1,x2) ! { dg-error "must be of an extensible type" } + print *, EXTENDS_TYPE_OF (i,x1) ! { dg-error "must be of a derived type" } + print *, EXTENDS_TYPE_OF (x1,x2) ! { dg-error "must be of an extensible type" } + end diff --git a/gcc/testsuite/gfortran.dg/select_type_1.f03 b/gcc/testsuite/gfortran.dg/select_type_1.f03 index 6a7db2e8954..0214c51a04f 100644 --- a/gcc/testsuite/gfortran.dg/select_type_1.f03 +++ b/gcc/testsuite/gfortran.dg/select_type_1.f03 @@ -40,16 +40,14 @@ print *,"a is TYPE(t1)" type is (t2) print *,"a is TYPE(t2)" -! FIXME: CLASS IS specification is not yet supported -! class is (ts) ! { FIXME: error "must be extensible" } -! print *,"a is TYPE(ts)" + class is (ts) ! { dg-error "must be extensible" } + print *,"a is TYPE(ts)" type is (t3) ! { dg-error "must be an extension of" } print *,"a is TYPE(t3)" type is (t4) ! { dg-error "is not an accessible derived type" } print *,"a is TYPE(t3)" -! FIXME: CLASS IS specification is not yet supported -! class is (t1) -! print *,"a is CLASS(t1)" + class is (t1) + print *,"a is CLASS(t1)" class is (t2) label ! { dg-error "Syntax error" } print *,"a is CLASS(t2)" class default ! { dg-error "cannot be followed by a second DEFAULT CASE" } diff --git a/gcc/testsuite/gfortran.dg/select_type_2.f03 b/gcc/testsuite/gfortran.dg/select_type_2.f03 index 08ac9fef6e8..d4a5343d7b2 100644 --- a/gcc/testsuite/gfortran.dg/select_type_2.f03 +++ b/gcc/testsuite/gfortran.dg/select_type_2.f03 @@ -30,9 +30,8 @@ i = 1 type is (t2) i = 2 -! FIXME: CLASS IS is not yet supported -! class is (t1) -! i = 3 + class is (t1) + i = 3 end select if (i /= 1) call abort() @@ -45,9 +44,8 @@ i = 1 type is (t2) i = 2 -! FIXME: CLASS IS is not yet supported -! class is (t2) -! i = 3 + class is (t2) + i = 3 end select if (i /= 2) call abort() diff --git a/gcc/testsuite/lib/g++.exp b/gcc/testsuite/lib/g++.exp index a5f26800c1c..df6030b568c 100644 --- a/gcc/testsuite/lib/g++.exp +++ b/gcc/testsuite/lib/g++.exp @@ -193,6 +193,13 @@ proc g++_init { args } { setenv LC_ALL C setenv LANG C + # Many hosts now default to a non-ASCII C locale, however, so + # they can set a charset encoding here if they need. + if { [ishost "*-*-cygwin*"] } { + setenv LC_ALL C.ASCII + setenv LANG C.ASCII + } + if ![info exists GXX_UNDER_TEST] then { if [info exists TOOL_EXECUTABLE] { set GXX_UNDER_TEST $TOOL_EXECUTABLE diff --git a/gcc/testsuite/lib/gcc-dg.exp b/gcc/testsuite/lib/gcc-dg.exp index 4acfdfec8ff..512144a6aa6 100644 --- a/gcc/testsuite/lib/gcc-dg.exp +++ b/gcc/testsuite/lib/gcc-dg.exp @@ -34,6 +34,13 @@ load_lib torture-options.exp setenv LC_ALL C setenv LANG C +# Many hosts now default to a non-ASCII C locale, however, so +# they can set a charset encoding here if they need. +if { [ishost "*-*-cygwin*"] } { + setenv LC_ALL C.ASCII + setenv LANG C.ASCII +} + if [info exists TORTURE_OPTIONS] { set DG_TORTURE_OPTIONS $TORTURE_OPTIONS } else { diff --git a/gcc/testsuite/lib/gfortran.exp b/gcc/testsuite/lib/gfortran.exp index a4d6e2b5d38..56aef298776 100644 --- a/gcc/testsuite/lib/gfortran.exp +++ b/gcc/testsuite/lib/gfortran.exp @@ -136,6 +136,13 @@ proc gfortran_init { args } { setenv LC_ALL C setenv LANG C + # Many hosts now default to a non-ASCII C locale, however, so + # they can set a charset encoding here if they need. + if { [ishost "*-*-cygwin*"] } { + setenv LC_ALL C.ASCII + setenv LANG C.ASCII + } + if ![info exists GFORTRAN_UNDER_TEST] then { if [info exists TOOL_EXECUTABLE] { set GFORTRAN_UNDER_TEST $TOOL_EXECUTABLE diff --git a/gcc/testsuite/lib/objc.exp b/gcc/testsuite/lib/objc.exp index 934f31dabdc..9d7bac0b03b 100644 --- a/gcc/testsuite/lib/objc.exp +++ b/gcc/testsuite/lib/objc.exp @@ -102,6 +102,13 @@ proc objc_init { args } { setenv LC_ALL C setenv LANG C + # Many hosts now default to a non-ASCII C locale, however, so + # they can set a charset encoding here if they need. + if { [ishost "*-*-cygwin*"] } { + setenv LC_ALL C.ASCII + setenv LANG C.ASCII + } + if { $objc_initialized == 1 } { return; } if ![info exists OBJC_UNDER_TEST] then { diff --git a/gcc/testsuite/lib/options.exp b/gcc/testsuite/lib/options.exp index 18359023228..ab4819343f7 100644 --- a/gcc/testsuite/lib/options.exp +++ b/gcc/testsuite/lib/options.exp @@ -18,6 +18,13 @@ setenv LC_ALL C setenv LANG C +# Many hosts now default to a non-ASCII C locale, however, so +# they can set a charset encoding here if they need. +if { [ishost "*-*-cygwin*"] } { + setenv LC_ALL C.ASCII + setenv LANG C.ASCII +} + # Run the LANGUAGE compiler with GCC_OPTIONS and inspect the compiler # output to make sure that they match the newline-separated patterns # in COMPILER_PATTERNS but not the patterns in COMPILER_NON_PATTERNS. diff --git a/gcc/tree-cfgcleanup.c b/gcc/tree-cfgcleanup.c index 495450bf12c..9fb489a743d 100644 --- a/gcc/tree-cfgcleanup.c +++ b/gcc/tree-cfgcleanup.c @@ -1,5 +1,5 @@ /* CFG cleanup for trees. - Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 + Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. This file is part of GCC. @@ -511,7 +511,7 @@ cleanup_omp_return (basic_block bb) control_bb = single_pred (bb); stmt = last_stmt (control_bb); - if (gimple_code (stmt) != GIMPLE_OMP_SECTIONS_SWITCH) + if (stmt == NULL || gimple_code (stmt) != GIMPLE_OMP_SECTIONS_SWITCH) return false; /* The block with the control statement normally has two entry edges -- one diff --git a/gcc/tree-dump.c b/gcc/tree-dump.c index e0512bc80a3..429f915bcc9 100644 --- a/gcc/tree-dump.c +++ b/gcc/tree-dump.c @@ -821,6 +821,7 @@ static const struct dump_option_value_info dump_options[] = {"memsyms", TDF_MEMSYMS}, {"verbose", TDF_VERBOSE}, {"eh", TDF_EH}, + {"nouid", TDF_NOUID}, {"all", ~(TDF_RAW | TDF_SLIM | TDF_LINENO | TDF_TREE | TDF_RTL | TDF_IPA | TDF_STMTADDR | TDF_GRAPH | TDF_DIAGNOSTIC | TDF_VERBOSE | TDF_RHS_ONLY)}, diff --git a/gcc/tree-inline.c b/gcc/tree-inline.c index 10baf62b0c0..3c909419bd2 100644 --- a/gcc/tree-inline.c +++ b/gcc/tree-inline.c @@ -1093,10 +1093,10 @@ copy_tree_body_r (tree *tp, int *walk_subtrees, void *data) /* If EXPR has block defined, map it to newly constructed block. When inlining we want EXPRs without block appear in the block - of function call. */ + of function call if we are not remapping a type. */ if (EXPR_P (*tp)) { - new_block = id->block; + new_block = id->remapping_type_depth == 0 ? id->block : NULL; if (TREE_BLOCK (*tp)) { tree *n; diff --git a/gcc/tree-into-ssa.c b/gcc/tree-into-ssa.c index d6f659c0624..243fe770e17 100644 --- a/gcc/tree-into-ssa.c +++ b/gcc/tree-into-ssa.c @@ -1151,27 +1151,43 @@ static void insert_phi_nodes (bitmap *dfs) { referenced_var_iterator rvi; + bitmap_iterator bi; tree var; + bitmap vars; + unsigned uid; timevar_push (TV_TREE_INSERT_PHI_NODES); + /* Do two stages to avoid code generation differences for UID + differences but no UID ordering differences. */ + + vars = BITMAP_ALLOC (NULL); FOR_EACH_REFERENCED_VAR (var, rvi) { struct def_blocks_d *def_map; - bitmap idf; def_map = find_def_blocks_for (var); if (def_map == NULL) continue; if (get_phi_state (var) != NEED_PHI_STATE_NO) - { - idf = compute_idf (def_map->def_blocks, dfs); - insert_phi_nodes_for (var, idf, false); - BITMAP_FREE (idf); - } + bitmap_set_bit (vars, DECL_UID (var)); } + EXECUTE_IF_SET_IN_BITMAP (vars, 0, uid, bi) + { + tree var = referenced_var (uid); + struct def_blocks_d *def_map; + bitmap idf; + + def_map = find_def_blocks_for (var); + idf = compute_idf (def_map->def_blocks, dfs); + insert_phi_nodes_for (var, idf, false); + BITMAP_FREE (idf); + } + + BITMAP_FREE (vars); + timevar_pop (TV_TREE_INSERT_PHI_NODES); } diff --git a/gcc/tree-optimize.c b/gcc/tree-optimize.c index 23b7046c60d..42e7d10b128 100644 --- a/gcc/tree-optimize.c +++ b/gcc/tree-optimize.c @@ -49,6 +49,7 @@ along with GCC; see the file COPYING3. If not see #include "graph.h" #include "cfgloop.h" #include "except.h" +#include "plugin.h" /* Gate: execute, or not, all of the non-trivial optimizations. */ @@ -405,8 +406,15 @@ tree_rest_of_compilation (tree fndecl) execute_all_ipa_transforms (); /* Perform all tree transforms and optimizations. */ + + /* Signal the start of passes. */ + invoke_plugin_callbacks (PLUGIN_ALL_PASSES_START, NULL); + execute_pass_list (all_passes); + /* Signal the end of passes. */ + invoke_plugin_callbacks (PLUGIN_ALL_PASSES_END, NULL); + bitmap_obstack_release (®_obstack); /* Release the default bitmap obstack. */ diff --git a/gcc/tree-pass.h b/gcc/tree-pass.h index 1bff0bd52ce..b997eb126ec 100644 --- a/gcc/tree-pass.h +++ b/gcc/tree-pass.h @@ -79,6 +79,7 @@ enum tree_dump_index #define TDF_EH (1 << 19) /* display EH region number holding this gimple statement. */ +#define TDF_NOUID (1 << 20) /* omit UIDs from dumps. */ /* In tree-dump.c */ @@ -565,12 +566,16 @@ extern struct opt_pass *all_passes, *all_small_ipa_passes, *all_lowering_passes, extern struct opt_pass *current_pass; extern struct opt_pass * get_pass_for_id (int); +extern bool execute_one_pass (struct opt_pass *); extern void execute_pass_list (struct opt_pass *); extern void execute_ipa_pass_list (struct opt_pass *); extern void execute_ipa_summary_passes (struct ipa_opt_pass_d *); extern void execute_all_ipa_transforms (void); extern void execute_all_ipa_stmt_fixups (struct cgraph_node *, gimple *); +extern bool pass_init_dump_file (struct opt_pass *); +extern void pass_fini_dump_file (struct opt_pass *); +extern const char *get_current_pass_name (void); extern void print_current_pass (FILE *); extern void debug_pass (void); extern void ipa_write_summaries (void); @@ -590,4 +595,7 @@ extern void register_pass (struct register_pass_info *); directly in jump threading, and avoid peeling them next time. */ extern bool first_pass_instance; +/* Declare for plugins. */ +extern void do_per_function_toporder (void (*) (void *), void *); + #endif /* GCC_TREE_PASS_H */ diff --git a/gcc/tree-pretty-print.c b/gcc/tree-pretty-print.c index caa19ac8d6c..44d4a5d9c03 100644 --- a/gcc/tree-pretty-print.c +++ b/gcc/tree-pretty-print.c @@ -182,13 +182,21 @@ dump_decl_name (pretty_printer *buffer, tree node, int flags) if ((flags & TDF_UID) || DECL_NAME (node) == NULL_TREE) { if (TREE_CODE (node) == LABEL_DECL && LABEL_DECL_UID (node) != -1) - pp_printf (buffer, "L.%d", (int) LABEL_DECL_UID (node)); + pp_printf (buffer, "L.%d", (int) LABEL_DECL_UID (node)); else if (TREE_CODE (node) == DEBUG_EXPR_DECL) - pp_printf (buffer, "D#%i", DEBUG_TEMP_UID (node)); + { + if (flags & TDF_NOUID) + pp_string (buffer, "D#xxxx"); + else + pp_printf (buffer, "D#%i", DEBUG_TEMP_UID (node)); + } else { char c = TREE_CODE (node) == CONST_DECL ? 'C' : 'D'; - pp_printf (buffer, "%c.%u", c, DECL_UID (node)); + if (flags & TDF_NOUID) + pp_printf (buffer, "%c.xxxx", c); + else + pp_printf (buffer, "%c.%u", c, DECL_UID (node)); } } } @@ -1030,9 +1038,14 @@ dump_generic_node (pretty_printer *buffer, tree node, int spc, int flags, if (DECL_NAME (node)) dump_decl_name (buffer, node, flags); else if (LABEL_DECL_UID (node) != -1) - pp_printf (buffer, "<L%d>", (int) LABEL_DECL_UID (node)); + pp_printf (buffer, "<L%d>", (int) LABEL_DECL_UID (node)); else - pp_printf (buffer, "<D.%u>", DECL_UID (node)); + { + if (flags & TDF_NOUID) + pp_string (buffer, "<D.xxxx>"); + else + pp_printf (buffer, "<D.%u>", DECL_UID (node)); + } break; case TYPE_DECL: diff --git a/gcc/tree-sra.c b/gcc/tree-sra.c index 34c0d3de893..a6a1a90d757 100644 --- a/gcc/tree-sra.c +++ b/gcc/tree-sra.c @@ -199,6 +199,10 @@ struct access BIT_FIELD_REF? */ unsigned grp_partial_lhs : 1; + /* Does this group contain accesses to different types? (I.e. through a union + or a similar mechanism). */ + unsigned grp_different_types : 1; + /* Set when a scalar replacement should be created for this variable. We do the decision and creation at different places because create_tmp_var cannot be called from within FOR_EACH_REFERENCED_VAR. */ @@ -339,12 +343,14 @@ dump_access (FILE *f, struct access *access, bool grp) fprintf (f, ", grp_write = %d, grp_read = %d, grp_hint = %d, " "grp_covered = %d, grp_unscalarizable_region = %d, " "grp_unscalarized_data = %d, grp_partial_lhs = %d, " - "grp_to_be_replaced = %d\n grp_maybe_modified = %d, " + "grp_different_types = %d, grp_to_be_replaced = %d, " + "grp_maybe_modified = %d, " "grp_not_necessarilly_dereferenced = %d\n", access->grp_write, access->grp_read, access->grp_hint, access->grp_covered, access->grp_unscalarizable_region, access->grp_unscalarized_data, access->grp_partial_lhs, - access->grp_to_be_replaced, access->grp_maybe_modified, + access->grp_different_types, access->grp_to_be_replaced, + access->grp_maybe_modified, access->grp_not_necessarilly_dereferenced); else fprintf (f, ", write = %d, grp_partial_lhs = %d\n", access->write, @@ -1112,14 +1118,25 @@ compare_access_positions (const void *a, const void *b) { /* Put any non-aggregate type before any aggregate type. */ if (!is_gimple_reg_type (f1->type) - && is_gimple_reg_type (f2->type)) + && is_gimple_reg_type (f2->type)) return 1; else if (is_gimple_reg_type (f1->type) && !is_gimple_reg_type (f2->type)) return -1; + /* Put any complex or vector type before any other scalar type. */ + else if (TREE_CODE (f1->type) != COMPLEX_TYPE + && TREE_CODE (f1->type) != VECTOR_TYPE + && (TREE_CODE (f2->type) == COMPLEX_TYPE + || TREE_CODE (f2->type) == VECTOR_TYPE)) + return 1; + else if ((TREE_CODE (f1->type) == COMPLEX_TYPE + || TREE_CODE (f1->type) == VECTOR_TYPE) + && TREE_CODE (f2->type) != COMPLEX_TYPE + && TREE_CODE (f2->type) != VECTOR_TYPE) + return -1; /* Put the integral type with the bigger precision first. */ else if (INTEGRAL_TYPE_P (f1->type) - && INTEGRAL_TYPE_P (f2->type)) + && INTEGRAL_TYPE_P (f2->type)) return TYPE_PRECISION (f1->type) > TYPE_PRECISION (f2->type) ? -1 : 1; /* Put any integral type with non-full precision last. */ else if (INTEGRAL_TYPE_P (f1->type) @@ -1417,6 +1434,7 @@ sort_and_splice_var_accesses (tree var) bool grp_read = !access->write; bool multiple_reads = false; bool grp_partial_lhs = access->grp_partial_lhs; + bool grp_different_types = false; bool first_scalar = is_gimple_reg_type (access->type); bool unscalarizable_region = access->grp_unscalarizable_region; @@ -1448,6 +1466,7 @@ sort_and_splice_var_accesses (tree var) grp_read = true; } grp_partial_lhs |= ac2->grp_partial_lhs; + grp_different_types |= !types_compatible_p (access->type, ac2->type); unscalarizable_region |= ac2->grp_unscalarizable_region; relink_to_new_repr (access, ac2); @@ -1466,6 +1485,7 @@ sort_and_splice_var_accesses (tree var) access->grp_read = grp_read; access->grp_hint = multiple_reads; access->grp_partial_lhs = grp_partial_lhs; + access->grp_different_types = grp_different_types; access->grp_unscalarizable_region = unscalarizable_region; if (access->first_link) add_access_to_work_queue (access); @@ -2112,8 +2132,15 @@ sra_modify_expr (tree *expr, gimple_stmt_iterator *gsi, bool write, access expression to extract the scalar component afterwards. This happens if scalarizing a function return value or parameter like in gcc.c-torture/execute/20041124-1.c, 20050316-1.c and - gcc.c-torture/compile/20011217-1.c. */ - if (!is_gimple_reg_type (type)) + gcc.c-torture/compile/20011217-1.c. + + We also want to use this when accessing a complex or vector which can + be accessed as a different type too, potentially creating a need for + type conversion (see PR42196). */ + if (!is_gimple_reg_type (type) + || (access->grp_different_types + && (TREE_CODE (type) == COMPLEX_TYPE + || TREE_CODE (type) == VECTOR_TYPE))) { tree ref = access->base; bool ok; @@ -3680,12 +3707,22 @@ sra_ipa_modify_assign (gimple *stmt_ptr, gimple_stmt_iterator *gsi, void *data) any |= sra_ipa_modify_expr (lhs_p, gsi, true, data); if (any) { + tree new_rhs = NULL_TREE; + if (!useless_type_conversion_p (TREE_TYPE (*lhs_p), TREE_TYPE (*rhs_p))) + new_rhs = fold_build1_loc (gimple_location (stmt), VIEW_CONVERT_EXPR, + TREE_TYPE (*lhs_p), *rhs_p); + else if (REFERENCE_CLASS_P (*rhs_p) + && is_gimple_reg_type (TREE_TYPE (*lhs_p)) + && !is_gimple_reg (*lhs_p)) + /* This can happen when an assignment in between two single field + structures is turned into an assignment in between two pointers to + scalars (PR 42237). */ + new_rhs = *rhs_p; + + if (new_rhs) { - location_t loc = gimple_location (stmt); - tree vce = fold_build1_loc (loc, VIEW_CONVERT_EXPR, - TREE_TYPE (*lhs_p), *rhs_p); - tree tmp = force_gimple_operand_gsi (gsi, vce, true, NULL_TREE, + tree tmp = force_gimple_operand_gsi (gsi, new_rhs, true, NULL_TREE, true, GSI_SAME_STMT); gimple_assign_set_rhs_from_tree (gsi, tmp); diff --git a/gcc/tree-ssa-live.c b/gcc/tree-ssa-live.c index d75edb5a061..c0ccb4fe20d 100644 --- a/gcc/tree-ssa-live.c +++ b/gcc/tree-ssa-live.c @@ -475,11 +475,7 @@ remove_unused_scope_block_p (tree scope) type is used or not. */ else if (debug_info_level == DINFO_LEVEL_NORMAL - || debug_info_level == DINFO_LEVEL_VERBOSE - /* Removing declarations before inlining is going to affect - DECL_UID that in turn is going to affect hashtables and - code generation. */ - || !cfun->after_inlining) + || debug_info_level == DINFO_LEVEL_VERBOSE) ; else { @@ -527,12 +523,6 @@ remove_unused_scope_block_p (tree scope) eliminated. */ else if (!nsubblocks) ; - /* If there are live subblocks and we still have some unused variables - or types declared, we must keep them. - Before inliing we must not depend on debug info verbosity to keep - DECL_UIDs stable. */ - else if (!cfun->after_inlining && BLOCK_VARS (scope)) - unused = false; /* For terse debug info we can eliminate info on unused variables. */ else if (debug_info_level == DINFO_LEVEL_NONE || debug_info_level == DINFO_LEVEL_TERSE) diff --git a/gcc/tree-vect-stmts.c b/gcc/tree-vect-stmts.c index 7ce91cadb34..99230909d7d 100644 --- a/gcc/tree-vect-stmts.c +++ b/gcc/tree-vect-stmts.c @@ -1809,10 +1809,12 @@ vectorizable_assignment (gimple stmt, gimple_stmt_iterator *gsi, enum vect_def_type dt[2] = {vect_unknown_def_type, vect_unknown_def_type}; int nunits = TYPE_VECTOR_SUBPARTS (vectype); int ncopies; - int i; + int i, j; VEC(tree,heap) *vec_oprnds = NULL; tree vop; bb_vec_info bb_vinfo = STMT_VINFO_BB_VINFO (stmt_info); + gimple new_stmt = NULL; + stmt_vec_info prev_stmt_info = NULL; /* Multiple types in SLP are handled by creating the appropriate number of vectorized stmts for each SLP node. Hence, NCOPIES is always 1 in @@ -1823,8 +1825,6 @@ vectorizable_assignment (gimple stmt, gimple_stmt_iterator *gsi, ncopies = LOOP_VINFO_VECT_FACTOR (loop_vinfo) / nunits; gcc_assert (ncopies >= 1); - if (ncopies > 1) - return false; /* FORNOW */ if (!STMT_VINFO_RELEVANT_P (stmt_info) && !bb_vinfo) return false; @@ -1870,20 +1870,35 @@ vectorizable_assignment (gimple stmt, gimple_stmt_iterator *gsi, vec_dest = vect_create_destination_var (scalar_dest, vectype); /* Handle use. */ - vect_get_vec_defs (op, NULL, stmt, &vec_oprnds, NULL, slp_node); - - /* Arguments are ready. create the new vector stmt. */ - for (i = 0; VEC_iterate (tree, vec_oprnds, i, vop); i++) + for (j = 0; j < ncopies; j++) { - *vec_stmt = gimple_build_assign (vec_dest, vop); - new_temp = make_ssa_name (vec_dest, *vec_stmt); - gimple_assign_set_lhs (*vec_stmt, new_temp); - vect_finish_stmt_generation (stmt, *vec_stmt, gsi); - STMT_VINFO_VEC_STMT (stmt_info) = *vec_stmt; + /* Handle uses. */ + if (j == 0) + vect_get_vec_defs (op, NULL, stmt, &vec_oprnds, NULL, slp_node); + else + vect_get_vec_defs_for_stmt_copy (dt, &vec_oprnds, NULL); + + /* Arguments are ready. create the new vector stmt. */ + for (i = 0; VEC_iterate (tree, vec_oprnds, i, vop); i++) + { + new_stmt = gimple_build_assign (vec_dest, vop); + new_temp = make_ssa_name (vec_dest, new_stmt); + gimple_assign_set_lhs (new_stmt, new_temp); + vect_finish_stmt_generation (stmt, new_stmt, gsi); + if (slp_node) + VEC_quick_push (gimple, SLP_TREE_VEC_STMTS (slp_node), new_stmt); + } if (slp_node) - VEC_quick_push (gimple, SLP_TREE_VEC_STMTS (slp_node), *vec_stmt); - } + continue; + + if (j == 0) + STMT_VINFO_VEC_STMT (stmt_info) = *vec_stmt = new_stmt; + else + STMT_VINFO_RELATED_STMT (prev_stmt_info) = new_stmt; + + prev_stmt_info = vinfo_for_stmt (new_stmt); + } VEC_free (tree, heap, vec_oprnds); return true; diff --git a/gcc/tree.c b/gcc/tree.c index dc4820981ed..f8fb6ce8770 100644 --- a/gcc/tree.c +++ b/gcc/tree.c @@ -4934,7 +4934,7 @@ free_lang_data (void) /* FIXME. Remove after save_debug_info is working. */ if (!(flag_generate_lto - || (!flag_gtoggle && debug_info_level <= DINFO_LEVEL_TERSE))) + || (!flag_gtoggle && debug_info_level == DINFO_LEVEL_NONE))) return 0; /* Traverse the IL resetting language specific information for diff --git a/libffi/ChangeLog b/libffi/ChangeLog index 651a01e0b6e..c0adaa9226b 100644 --- a/libffi/ChangeLog +++ b/libffi/ChangeLog @@ -1,3 +1,32 @@ +2009-11-30 David Edelsohn <edelsohn@gnu.org> + + * src/powerpc/aix.S (ffi_call_AIX): Convert to more standard + register usage. Call ffi_prep_args directly. Add long double + return value support. + * src/powerpc/ffi_darwin.c (ffi_prep_args): Double arg increment + applies to FFI_TYPE_DOUBLE. Correct fpr_base increment typo. + Separate FFI_TYPE_SINT32 and FFI_TYPE_UINT32 cases. + (ffi_prep_cif_machdep): Only 16 byte stack alignment in 64 bit + mode. + (ffi_closure_helper_DARWIN): Remove nf and ng counters. Move temp + into case. + * src/powerpc/aix_closure.S: Maintain 16 byte stack alignment. + Allocate result area between params and FPRs. + +2009-11-30 David Edelsohn <edelsohn@gnu.org> + + PR target/35484 + * src/powerpc/ffitarget.h (POWERPC64): Define for PPC64 Linux and + AIX64. + * src/powerpc/aix.S: Implement AIX64 version. + * src/powerpc/aix_closure.S: Implement AIX64 version. + (ffi_closure_ASM): Use extsb, lha and displament addresses. + * src/powerpc/ffi_darwin.c (ffi_prep_args): Implement AIX64 + support. + (ffi_prep_cif_machdep): Same. + (ffi_call): Same. + (ffi_closure_helper_DARWIN): Same. + 2009-11-02 Andreas Tobler <a.tobler@schweiz.org> PR libffi/41908 diff --git a/libffi/src/powerpc/aix.S b/libffi/src/powerpc/aix.S index 45502f7963e..5b477cad5e8 100644 --- a/libffi/src/powerpc/aix.S +++ b/libffi/src/powerpc/aix.S @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------- - aix.S - Copyright (c) 2002 Free Software Foundation, Inc. + aix.S - Copyright (c) 2002,2009 Free Software Foundation, Inc. based on darwin.S by John Hornkvist PowerPC Assembly glue. @@ -86,9 +86,13 @@ #define L(x) x .file "aix.S" .toc - .csect .text[PR] - .align 2 -.globl ffi_prep_args + + /* void ffi_call_AIX(extended_cif *ecif, unsigned long bytes, + * unsigned int flags, unsigned int *rvalue, + * void (*fn)(), + * void (*prep_args)(extended_cif*, unsigned *const)); + * r3=ecif, r4=bytes, r5=flags, r6=rvalue, r7=fn, r8=prep_args + */ .csect .text[PR] .align 2 @@ -96,10 +100,111 @@ .globl .ffi_call_AIX .csect ffi_call_AIX[DS] ffi_call_AIX: +#ifdef __64BIT__ + .llong .ffi_call_AIX, TOC[tc0], 0 + .csect .text[PR] +.ffi_call_AIX: + /* Save registers we use. */ + mflr r0 + + std r28,-32(r1) + std r29,-24(r1) + std r30,-16(r1) + std r31, -8(r1) + + std r0, 16(r1) + mr r28, r1 /* our AP. */ + stdux r1, r1, r4 + + /* Save arguments over call... */ + mr r31, r5 /* flags, */ + mr r30, r6 /* rvalue, */ + mr r29, r7 /* function address. */ + std r2, 40(r1) + + /* Call ffi_prep_args. */ + mr r4, r1 + bl .ffi_prep_args + + /* Now do the call. */ + ld r0, 0(r29) + ld r2, 8(r29) + /* Set up cr1 with bits 4-7 of the flags. */ + mtcrf 0x40, r31 + mtctr r0 + /* Load all those argument registers. */ + // We have set up a nice stack frame, just load it into registers. + ld r3, 40+(1*8)(r1) + ld r4, 40+(2*8)(r1) + ld r5, 40+(3*8)(r1) + ld r6, 40+(4*8)(r1) + nop + ld r7, 40+(5*8)(r1) + ld r8, 40+(6*8)(r1) + ld r9, 40+(7*8)(r1) + ld r10,40+(8*8)(r1) + +L1: + /* Load all the FP registers. */ + bf 6,L2 // 2f + 0x18 + lfd f1,-32-(13*8)(r28) + lfd f2,-32-(12*8)(r28) + lfd f3,-32-(11*8)(r28) + lfd f4,-32-(10*8)(r28) + nop + lfd f5,-32-(9*8)(r28) + lfd f6,-32-(8*8)(r28) + lfd f7,-32-(7*8)(r28) + lfd f8,-32-(6*8)(r28) + nop + lfd f9,-32-(5*8)(r28) + lfd f10,-32-(4*8)(r28) + lfd f11,-32-(3*8)(r28) + lfd f12,-32-(2*8)(r28) + nop + lfd f13,-32-(1*8)(r28) + +L2: + /* Make the call. */ + bctrl + ld r2, 40(r1) + + /* Now, deal with the return value. */ + mtcrf 0x01, r31 + + bt 30, L(done_return_value) + bt 29, L(fp_return_value) + std r3, 0(r30) + + /* Fall through... */ + +L(done_return_value): + /* Restore the registers we used and return. */ + mr r1, r28 + ld r0, 16(r28) + ld r28,-32(r1) + mtlr r0 + ld r29,-24(r1) + ld r30,-16(r1) + ld r31,-8(r1) + blr + +L(fp_return_value): + bf 28,L(float_return_value) + stfd f1,0(r30) + bf 31,L(done_return_value) + stfd f2,8(r30) + b L(done_return_value) +L(float_return_value): + stfs f1,0(r30) + b L(done_return_value) + +#else /* ! __64BIT__ */ + .long .ffi_call_AIX, TOC[tc0], 0 .csect .text[PR] .ffi_call_AIX: - mr r12,r8 // We only need r12 until the call, so it doesn't have to be saved... + mr r12,r8 // We only need r12 until the call, so it doesn't have to be saved... /* Save the old stack pointer as AP. */ mr r8,r1 @@ -142,15 +247,15 @@ ffi_call_AIX: lwz r2,4(r29) /* Load all those argument registers. */ // We have set up a nice stack frame, just load it into registers. - lwz r3, 20+(1*4)(r1) - lwz r4, 20+(2*4)(r1) - lwz r5, 20+(3*4)(r1) - lwz r6, 20+(4*4)(r1) + lwz r3, 20+(1*4)(r1) + lwz r4, 20+(2*4)(r1) + lwz r5, 20+(3*4)(r1) + lwz r6, 20+(4*4)(r1) nop - lwz r7, 20+(5*4)(r1) - lwz r8, 20+(6*4)(r1) - lwz r9, 20+(7*4)(r1) - lwz r10,20+(8*4)(r1) + lwz r7, 20+(5*4)(r1) + lwz r8, 20+(6*4)(r1) + lwz r9, 20+(7*4)(r1) + lwz r10,20+(8*4)(r1) L1: /* Load all the FP registers. */ @@ -165,17 +270,17 @@ L1: lfd f7,-16-(7*8)(r28) lfd f8,-16-(6*8)(r28) nop - lfd f9,-16-(5*8)(r28) - lfd f10,-16-(4*8)(r28) - lfd f11,-16-(3*8)(r28) - lfd f12,-16-(2*8)(r28) + lfd f9,-16-(5*8)(r28) + lfd f10,-16-(4*8)(r28) + lfd f11,-16-(3*8)(r28) + lfd f12,-16-(2*8)(r28) nop - lfd f13,-16-(1*8)(r28) + lfd f13,-16-(1*8)(r28) L2: /* Make the call. */ bctrl - lwz r2,20(r1) + lwz r2,20(r1) /* Now, deal with the return value. */ mtcrf 0x01,r31 @@ -190,8 +295,8 @@ L2: L(done_return_value): /* Restore the registers we used and return. */ - lwz r9, 8(r28) - lwz r31, -4(r28) + lwz r9,8(r28) + lwz r31,-4(r28) mtlr r9 lwz r30, -8(r28) lwz r29,-12(r28) @@ -206,6 +311,7 @@ L(fp_return_value): L(float_return_value): stfs f1,0(r30) b L(done_return_value) +#endif .long 0 .byte 0,0,0,1,128,4,0,0 //END(ffi_call_AIX) @@ -216,7 +322,11 @@ L(float_return_value): .globl .ffi_call_DARWIN .csect ffi_call_DARWIN[DS] ffi_call_DARWIN: +#ifdef __64BIT__ + .llong .ffi_call_DARWIN, TOC[tc0], 0 +#else .long .ffi_call_DARWIN, TOC[tc0], 0 +#endif .csect .text[PR] .ffi_call_DARWIN: blr diff --git a/libffi/src/powerpc/aix_closure.S b/libffi/src/powerpc/aix_closure.S index 7bf5c656063..70456188092 100644 --- a/libffi/src/powerpc/aix_closure.S +++ b/libffi/src/powerpc/aix_closure.S @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------- - aix_closure.S - Copyright (c) 2002 2003 Free Software Foundation, Inc. + aix_closure.S - Copyright (c) 2002, 2003, 2009 Free Software Foundation, Inc. based on darwin_closure.S PowerPC Assembly glue. @@ -94,8 +94,163 @@ LC..60: .globl ffi_closure_ASM .globl .ffi_closure_ASM .csect ffi_closure_ASM[DS] - ffi_closure_ASM: +#ifdef __64BIT__ + .llong .ffi_closure_ASM, TOC[tc0], 0 + .csect .text[PR] +.ffi_closure_ASM: + + mflr r0 /* extract return address */ + std r0,16(r1) /* save the return address */ + + /* 48 Bytes (Linkage Area) */ + /* 64 Bytes (params) */ + /* 16 Bytes (result) */ + /* 104 Bytes (13*8 from FPR) */ + /* 8 Bytes (alignment) */ + /* 240 Bytes */ + + stdu r1,-240(r1) /* skip over caller save area + keep stack aligned to 16 */ + +/* we want to build up an area for the parameters passed */ +/* in registers (both floating point and integer) */ + + /* we store gpr 3 to gpr 10 (aligned to 4) + in the parents outgoing area */ + std r3, 288+(0*8)(r1) + std r4, 288+(1*8)(r1) + std r5, 288+(2*8)(r1) + std r6, 288+(3*8)(r1) + std r7, 288+(4*8)(r1) + std r8, 288+(5*8)(r1) + std r9, 288+(6*8)(r1) + std r10, 288+(7*8)(r1) + + /* next save fpr 1 to fpr 13 (aligned to 8) */ + stfd f1, 128+(0*8)(r1) + stfd f2, 128+(1*8)(r1) + stfd f3, 128+(2*8)(r1) + stfd f4, 128+(3*8)(r1) + stfd f5, 128+(4*8)(r1) + stfd f6, 128+(5*8)(r1) + stfd f7, 128+(6*8)(r1) + stfd f8, 128+(7*8)(r1) + stfd f9, 128+(8*8)(r1) + stfd f10, 128+(9*8)(r1) + stfd f11, 128+(10*8)(r1) + stfd f12, 128+(11*8)(r1) + stfd f13, 128+(12*8)(r1) + + /* set up registers for the routine that actually does the work */ + /* get the context pointer from the trampoline */ + mr r3,r11 + + /* now load up the pointer to the result storage */ + addi r4,r1,112 + + /* now load up the pointer to the saved gpr registers */ + addi r5,r1,288 + + /* now load up the pointer to the saved fpr registers */ + addi r6,r1,128 + + /* make the call */ + bl .ffi_closure_helper_DARWIN + nop + + /* now r3 contains the return type */ + /* so use it to look up in a table */ + /* so we know how to deal with each type */ + + /* look up the proper starting point in table */ + /* by using return type as offset */ + addi r5,r1,112 /* get pointer to results area */ + ld r4,LC..60(2) /* get address of jump table */ + sldi r3,r3,2 /* now multiply return type by 4 */ + lwzx r3,r4,r3 /* get the contents of that table value */ + add r3,r3,r4 /* add contents of table to table address */ + mtctr r3 + bctr /* jump to it */ + +L..60: + .long L..44-L..60 /* FFI_TYPE_VOID */ + .long L..51-L..60 /* FFI_TYPE_INT */ + .long L..47-L..60 /* FFI_TYPE_FLOAT */ + .long L..46-L..60 /* FFI_TYPE_DOUBLE */ + .long L..45-L..60 /* FFI_TYPE_LONGDOUBLE */ + .long L..56-L..60 /* FFI_TYPE_UINT8 */ + .long L..55-L..60 /* FFI_TYPE_SINT8 */ + .long L..58-L..60 /* FFI_TYPE_UINT16 */ + .long L..57-L..60 /* FFI_TYPE_SINT16 */ + .long L..50-L..60 /* FFI_TYPE_UINT32 */ + .long L..51-L..60 /* FFI_TYPE_SINT32 */ + .long L..48-L..60 /* FFI_TYPE_UINT64 */ + .long L..48-L..60 /* FFI_TYPE_SINT64 */ + .long L..44-L..60 /* FFI_TYPE_STRUCT */ + .long L..48-L..60 /* FFI_TYPE_POINTER */ + + +/* case long double */ +L..45: + lfd f1,0(r5) + lfd f2,8(r5) + b L..44 + +/* case double */ +L..46: + lfd f1,0(r5) + b L..44 + +/* case float */ +L..47: + lfs f1,0(r5) + b L..44 + +/* case long long / pointer */ +L..48: + ld r3,0(r5) + b L..44 + +/* case uint32 */ +L..50: + lwz r3,4(r5) + b L..44 + +/* case int / sint32 */ +L..51: + lwa r3,4(r5) + b L..44 + +/* case signed int8 */ +L..55: + lbz r3,7(r5) + extsb r3,r3 + b L..44 + +/* case unsigned int8 */ +L..56: + lbz r3,7(r5) + b L..44 + +/* case signed int16 */ +L..57: + lha r3,6(r5) + b L..44 + +/* case unsigned int16 */ +L..58: + lhz r3,6(r5) + +/* case void / done */ +L..44: + addi r1,r1,240 /* restore stack pointer */ + ld r0,16(r1) /* get return address */ + mtlr r0 /* reset link register */ + blr + +#else /* ! __64BIT__ */ + .long .ffi_closure_ASM, TOC[tc0], 0 .csect .text[PR] .ffi_closure_ASM: @@ -106,8 +261,8 @@ ffi_closure_ASM: /* 24 Bytes (Linkage Area) */ /* 32 Bytes (params) */ /* 104 Bytes (13*8 from FPR) */ - /* 8 Bytes (result) */ - /* 168 Bytes */ + /* 16 Bytes (result) */ + /* 176 Bytes */ stwu r1,-176(r1) /* skip over caller save area keep stack aligned to 16 */ @@ -177,7 +332,7 @@ L..60: .long L..50-L..60 /* FFI_TYPE_INT */ .long L..47-L..60 /* FFI_TYPE_FLOAT */ .long L..46-L..60 /* FFI_TYPE_DOUBLE */ - .long L..46-L..60 /* FFI_TYPE_LONGDOUBLE */ + .long L..45-L..60 /* FFI_TYPE_LONGDOUBLE */ .long L..56-L..60 /* FFI_TYPE_UINT8 */ .long L..55-L..60 /* FFI_TYPE_SINT8 */ .long L..58-L..60 /* FFI_TYPE_UINT16 */ @@ -190,6 +345,12 @@ L..60: .long L..50-L..60 /* FFI_TYPE_POINTER */ +/* case long double */ +L..45: + lfd f1,0(r5) + lfd f2,8(r5) + b L..44 + /* case double */ L..46: lfd f1,0(r5) @@ -211,31 +372,25 @@ L..50: lwz r3,0(r5) b L..44 -/* case signed int8 */ +/* case signed int8 */ L..55: - addi r5,r5,3 - lbz r3,0(r5) - slwi r3,r3,24 - srawi r3,r3,24 + lbz r3,3(r5) + extsb r3,r3 b L..44 -/* case unsigned int8 */ +/* case unsigned int8 */ L..56: - addi r5,r5,3 - lbz r3,0(r5) + lbz r3,3(r5) b L..44 /* case signed int16 */ L..57: - addi r5,r5,2 - lhz r3,0(r5) - extsh r3,r3 + lha r3,2(r5) b L..44 /* case unsigned int16 */ L..58: - addi r5,r5,2 - lhz r3,0(r5) + lhz r3,2(r5) /* case void / done */ L..44: @@ -243,5 +398,5 @@ L..44: lwz r0,8(r1) /* get return address */ mtlr r0 /* reset link register */ blr - +#endif /* END(ffi_closure_ASM) */ diff --git a/libffi/src/powerpc/ffi_darwin.c b/libffi/src/powerpc/ffi_darwin.c index 501035d75d0..53dbdb2b244 100644 --- a/libffi/src/powerpc/ffi_darwin.c +++ b/libffi/src/powerpc/ffi_darwin.c @@ -3,7 +3,7 @@ Copyright (C) 1998 Geoffrey Keating Copyright (C) 2001 John Hornkvist - Copyright (C) 2002, 2006, 2007 Free Software Foundation, Inc. + Copyright (C) 2002, 2006, 2007, 2009 Free Software Foundation, Inc. FFI support for Darwin and AIX. @@ -80,27 +80,28 @@ enum { ASM_NEEDS_REGISTERS = 4 }; */ -void ffi_prep_args(extended_cif *ecif, unsigned *const stack) +void ffi_prep_args(extended_cif *ecif, unsigned long *const stack) { const unsigned bytes = ecif->cif->bytes; const unsigned flags = ecif->cif->flags; /* 'stacktop' points at the previous backchain pointer. */ - unsigned *const stacktop = stack + (bytes / sizeof(unsigned)); + unsigned long *const stacktop = stack + (bytes / sizeof(unsigned long)); /* 'fpr_base' points at the space for fpr1, and grows upwards as we use FPR registers. */ - double *fpr_base = (double*) (stacktop - ASM_NEEDS_REGISTERS) - NUM_FPR_ARG_REGISTERS; + double *fpr_base = (double *) ((stacktop - ASM_NEEDS_REGISTERS) + - NUM_FPR_ARG_REGISTERS); int fparg_count = 0; /* 'next_arg' grows up as we put parameters in it. */ - unsigned *next_arg = stack + 6; /* 6 reserved positions. */ + unsigned long *next_arg = (unsigned long *) stack + 6; /* 6 reserved positions. */ - int i = ecif->cif->nargs; + int i; double double_tmp; void **p_argv = ecif->avalue; - unsigned gprvalue; + unsigned long gprvalue; ffi_type** ptr = ecif->cif->arg_types; char *dest_cpy; unsigned size_al = 0; @@ -115,12 +116,10 @@ void ffi_prep_args(extended_cif *ecif, unsigned *const stack) Return values are referenced by r3, so r4 is the first parameter. */ if (flags & FLAG_RETVAL_REFERENCE) - *next_arg++ = (unsigned)(char *)ecif->rvalue; + *next_arg++ = (unsigned long)(char *)ecif->rvalue; /* Now for the arguments. */ - for (; - i > 0; - i--, ptr++, p_argv++) + for (i = ecif->cif->nargs; i > 0; i--, ptr++, p_argv++) { switch ((*ptr)->type) { @@ -144,7 +143,11 @@ void ffi_prep_args(extended_cif *ecif, unsigned *const stack) *(double *)next_arg = double_tmp; else *fpr_base++ = double_tmp; +#ifdef POWERPC64 + next_arg++; +#else next_arg += 2; +#endif fparg_count++; FFI_ASSERT(flags & FLAG_FP_ARGUMENTS); break; @@ -152,42 +155,69 @@ void ffi_prep_args(extended_cif *ecif, unsigned *const stack) #if FFI_TYPE_LONGDOUBLE != FFI_TYPE_DOUBLE case FFI_TYPE_LONGDOUBLE: - double_tmp = ((double *)*p_argv)[0]; - if (fparg_count >= NUM_FPR_ARG_REGISTERS) - *(double *)next_arg = double_tmp; +#ifdef POWERPC64 + if (fparg_count < NUM_FPR_ARG_REGISTERS) + *(long double *) fpr_base++ = *(long double *) *p_argv; else - *fpr_base++ = double_tmp; + *(long double *) next_arg = *(long double *) *p_argv; next_arg += 2; - fparg_count++; - double_tmp = ((double *)*p_argv)[1]; - if (fparg_count >= NUM_FPR_ARG_REGISTERS) - *(double *)next_arg = double_tmp; + fparg_count += 2; +#else + double_tmp = *((double *) *p_argv); + if (fparg_count < NUM_FPR_ARG_REGISTERS) + *fpr_base++ = double_tmp; else + *(double *) next_arg = double_tmp; + + double_tmp = ((double *) *p_argv)[1]; + if (fparg_count < NUM_FPR_ARG_REGISTERS) *fpr_base++ = double_tmp; + else + *(double *) next_arg = double_tmp; next_arg += 2; fparg_count++; +#endif FFI_ASSERT(flags & FLAG_FP_ARGUMENTS); break; #endif case FFI_TYPE_UINT64: case FFI_TYPE_SINT64: - *(long long *)next_arg = *(long long *)*p_argv; +#ifdef POWERPC64 + gprvalue = *(long long *) p_argv; + goto putgpr; +#else + *(long long *) next_arg = *(long long *) *p_argv; next_arg+=2; +#endif break; + case FFI_TYPE_POINTER: + gprvalue = *(unsigned long *) *p_argv; + goto putgpr; case FFI_TYPE_UINT8: - gprvalue = *(unsigned char *)*p_argv; + gprvalue = *(unsigned char *) *p_argv; goto putgpr; case FFI_TYPE_SINT8: - gprvalue = *(signed char *)*p_argv; + gprvalue = *(signed char *) *p_argv; goto putgpr; case FFI_TYPE_UINT16: - gprvalue = *(unsigned short *)*p_argv; + gprvalue = *(unsigned short *) *p_argv; goto putgpr; case FFI_TYPE_SINT16: - gprvalue = *(signed short *)*p_argv; + gprvalue = *(signed short *) *p_argv; goto putgpr; case FFI_TYPE_STRUCT: +#ifdef POWERPC64 + dest_cpy = (char *) next_arg; + size_al = (*ptr)->size; + if ((*ptr)->elements[0]->type == 3) + size_al = ALIGN((*ptr)->size, 8); + if (size_al < 3 && ecif->cif->abi == FFI_DARWIN) + dest_cpy += 4 - size_al; + + memcpy ((char *) dest_cpy, (char *) *p_argv, size_al); + next_arg += (size_al + 7) / 8; +#else dest_cpy = (char *) next_arg; /* Structures that match the basic modes (QI 1 byte, HI 2 bytes, @@ -204,13 +234,16 @@ void ffi_prep_args(extended_cif *ecif, unsigned *const stack) memcpy((char *)dest_cpy, (char *)*p_argv, size_al); next_arg += (size_al + 3) / 4; +#endif break; case FFI_TYPE_INT: - case FFI_TYPE_UINT32: case FFI_TYPE_SINT32: - case FFI_TYPE_POINTER: - gprvalue = *(unsigned *)*p_argv; + gprvalue = *(signed int *) *p_argv; + goto putgpr; + + case FFI_TYPE_UINT32: + gprvalue = *(unsigned int *) *p_argv; putgpr: *next_arg++ = gprvalue; break; @@ -324,6 +357,9 @@ ffi_status ffi_prep_cif_machdep(ffi_cif *cif) case FFI_TYPE_UINT64: case FFI_TYPE_SINT64: +#ifdef POWERPC64 + case FFI_TYPE_POINTER: +#endif flags |= FLAG_RETURNS_64BITS; break; @@ -387,11 +423,14 @@ ffi_status ffi_prep_cif_machdep(ffi_cif *cif) case FFI_TYPE_STRUCT: size_al = (*ptr)->size; /* If the first member of the struct is a double, then align - the struct to double-word. - Type 3 is defined in include/ffi.h. #define FFI_TYPE_DOUBLE 3. */ - if ((*ptr)->elements[0]->type == 3) + the struct to double-word. */ + if ((*ptr)->elements[0]->type == FFI_TYPE_DOUBLE) size_al = ALIGN((*ptr)->size, 8); +#ifdef POWERPC64 + intarg_count += (size_al + 7) / 8; +#else intarg_count += (size_al + 3) / 4; +#endif break; default: @@ -410,8 +449,13 @@ ffi_status ffi_prep_cif_machdep(ffi_cif *cif) bytes += NUM_FPR_ARG_REGISTERS * sizeof(double); /* Stack space. */ +#ifdef POWERPC64 + if ((intarg_count + fparg_count) > NUM_GPR_ARG_REGISTERS) + bytes += (intarg_count + fparg_count) * sizeof(long); +#else if ((intarg_count + 2 * fparg_count) > NUM_GPR_ARG_REGISTERS) bytes += (intarg_count + 2 * fparg_count) * sizeof(long); +#endif else bytes += NUM_GPR_ARG_REGISTERS * sizeof(long); @@ -424,9 +468,9 @@ ffi_status ffi_prep_cif_machdep(ffi_cif *cif) return FFI_OK; } -extern void ffi_call_AIX(extended_cif *, unsigned, unsigned, unsigned *, +extern void ffi_call_AIX(extended_cif *, long, unsigned, unsigned *, void (*fn)(void), void (*fn2)(void)); -extern void ffi_call_DARWIN(extended_cif *, unsigned, unsigned, unsigned *, +extern void ffi_call_DARWIN(extended_cif *, long, unsigned, unsigned *, void (*fn)(void), void (*fn2)(void)); void ffi_call(ffi_cif *cif, void (*fn)(void), void *rvalue, void **avalue) @@ -450,11 +494,11 @@ void ffi_call(ffi_cif *cif, void (*fn)(void), void *rvalue, void **avalue) switch (cif->abi) { case FFI_AIX: - ffi_call_AIX(&ecif, -cif->bytes, cif->flags, ecif.rvalue, fn, + ffi_call_AIX(&ecif, -(long)cif->bytes, cif->flags, ecif.rvalue, fn, ffi_prep_args); break; case FFI_DARWIN: - ffi_call_DARWIN(&ecif, -cif->bytes, cif->flags, ecif.rvalue, fn, + ffi_call_DARWIN(&ecif, -(long)cif->bytes, cif->flags, ecif.rvalue, fn, ffi_prep_args); break; default: @@ -645,26 +689,19 @@ int ffi_closure_helper_DARWIN (ffi_closure* closure, void * rvalue, void ** avalue; ffi_type ** arg_types; long i, avn; - long nf; /* number of floating registers already used. */ - long ng; /* number of general registers already used. */ ffi_cif * cif; - double temp; + ffi_dblfl *end_pfr = pfr + NUM_FPR_ARG_REGISTERS; unsigned size_al; - union ldu temp_ld; cif = closure->cif; avalue = alloca(cif->nargs * sizeof(void *)); - nf = 0; - ng = 0; - /* Copy the caller's structure return value address so that the closure returns the data directly to the caller. */ if (cif->rtype->type == FFI_TYPE_STRUCT) { rvalue = (void *) *pgr; pgr++; - ng++; } i = 0; @@ -678,58 +715,82 @@ int ffi_closure_helper_DARWIN (ffi_closure* closure, void * rvalue, { case FFI_TYPE_SINT8: case FFI_TYPE_UINT8: +#ifdef POWERPC64 + avalue[i] = (char *) pgr + 7; +#else avalue[i] = (char *) pgr + 3; - ng++; +#endif pgr++; break; case FFI_TYPE_SINT16: case FFI_TYPE_UINT16: +#ifdef POWERPC64 + avalue[i] = (char *) pgr + 6; +#else avalue[i] = (char *) pgr + 2; - ng++; +#endif pgr++; break; case FFI_TYPE_SINT32: case FFI_TYPE_UINT32: +#ifdef POWERPC64 + avalue[i] = (char *) pgr + 4; +#else case FFI_TYPE_POINTER: avalue[i] = pgr; - ng++; +#endif pgr++; break; case FFI_TYPE_STRUCT: +#ifdef POWERPC64 + size_al = arg_types[i]->size; + if (arg_types[i]->elements[0]->type == FFI_TYPE_DOUBLE) + size_al = ALIGN (arg_types[i]->size, 8); + if (size_al < 3 && cif->abi == FFI_DARWIN) + avalue[i] = (void *) pgr + 8 - size_al; + else + avalue[i] = (void *) pgr; + pgr += (size_al + 7) / 8; +#else /* Structures that match the basic modes (QI 1 byte, HI 2 bytes, SI 4 bytes) are aligned as if they were those modes. */ size_al = arg_types[i]->size; /* If the first member of the struct is a double, then align - the struct to double-word. - Type 3 is defined in include/ffi.h. #define FFI_TYPE_DOUBLE 3. */ - if (arg_types[i]->elements[0]->type == 3) + the struct to double-word. */ + if (arg_types[i]->elements[0]->type == FFI_TYPE_DOUBLE) size_al = ALIGN(arg_types[i]->size, 8); if (size_al < 3 && cif->abi == FFI_DARWIN) avalue[i] = (void*) pgr + 4 - size_al; else avalue[i] = (void*) pgr; - ng += (size_al + 3) / 4; pgr += (size_al + 3) / 4; +#endif break; case FFI_TYPE_SINT64: case FFI_TYPE_UINT64: +#ifdef POWERPC64 + case FFI_TYPE_POINTER: + avalue[i] = pgr; + pgr++; + break; +#else /* Long long ints are passed in two gpr's. */ avalue[i] = pgr; - ng += 2; pgr += 2; break; +#endif case FFI_TYPE_FLOAT: /* A float value consumes a GPR. There are 13 64bit floating point registers. */ - if (nf < NUM_FPR_ARG_REGISTERS) + if (pfr < end_pfr) { - temp = pfr->d; - pfr->f = (float)temp; + double temp = pfr->d; + pfr->f = (float) temp; avalue[i] = pfr; pfr++; } @@ -737,15 +798,13 @@ int ffi_closure_helper_DARWIN (ffi_closure* closure, void * rvalue, { avalue[i] = pgr; } - nf++; - ng++; pgr++; break; case FFI_TYPE_DOUBLE: /* A double value consumes two GPRs. There are 13 64bit floating point registers. */ - if (nf < NUM_FPR_ARG_REGISTERS) + if (pfr < end_pfr) { avalue[i] = pfr; pfr++; @@ -754,17 +813,36 @@ int ffi_closure_helper_DARWIN (ffi_closure* closure, void * rvalue, { avalue[i] = pgr; } - nf++; - ng += 2; +#ifdef POWERPC64 + pgr++; +#else pgr += 2; +#endif break; #if FFI_TYPE_LONGDOUBLE != FFI_TYPE_DOUBLE case FFI_TYPE_LONGDOUBLE: +#ifdef POWERPC64 + if (pfr + 1 < end_pfr) + { + avalue[i] = pfr; + pfr += 2; + } + else + { + if (pfr < end_pfr) + { + *pgr = *(unsigned long *) pfr; + pfr++; + } + avalue[i] = pgr; + } + pgr += 2; +#else /* POWERPC64 */ /* A long double value consumes four GPRs and two FPRs. There are 13 64bit floating point registers. */ - if (nf < NUM_FPR_ARG_REGISTERS - 1) + if (pfr + 1 < end_pfr) { avalue[i] = pfr; pfr += 2; @@ -772,8 +850,9 @@ int ffi_closure_helper_DARWIN (ffi_closure* closure, void * rvalue, /* Here we have the situation where one part of the long double is stored in fpr13 and the other part is already on the stack. We use a union to pass the long double to avalue[i]. */ - else if (nf == NUM_FPR_ARG_REGISTERS - 1) + else if (pfr + 1 == end_pfr) { + union ldu temp_ld; memcpy (&temp_ld.lb[0], pfr, sizeof(ldbits)); memcpy (&temp_ld.lb[1], pgr + 2, sizeof(ldbits)); avalue[i] = &temp_ld.ld; @@ -782,9 +861,8 @@ int ffi_closure_helper_DARWIN (ffi_closure* closure, void * rvalue, { avalue[i] = pgr; } - nf += 2; - ng += 4; pgr += 4; +#endif /* POWERPC64 */ break; #endif default: diff --git a/libffi/src/powerpc/ffitarget.h b/libffi/src/powerpc/ffitarget.h index 269f573987c..b4f992e6df4 100644 --- a/libffi/src/powerpc/ffitarget.h +++ b/libffi/src/powerpc/ffitarget.h @@ -30,7 +30,11 @@ /* ---- System specific configurations ----------------------------------- */ -#if defined (POWERPC) && defined (__powerpc64__) +#if defined (POWERPC) && defined (__powerpc64__) /* linux64 */ +#define POWERPC64 +#elif defined (POWERPC_DARWIN) && defined (__ppc64__) /* Darwin */ +#define POWERPC64 +#elif defined (POWERPC_AIX) && defined (__64BIT__) /* AIX64 */ #define POWERPC64 #endif diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index e4d2578017b..68bf89705d6 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,15 @@ +2009-11-30 Janus Weil <janus@gcc.gnu.org> + + * gfortran.map: Add _gfortran_is_extension_of. + * Makefile.am: Add intrinsics/extends_type_of.c. + * Makefile.in: Regenerated. + * intrinsics/extends_type_of.c: New file. + +2009-11-30 Kai Tietz <Kai.Tietz@onevision.com> + + * io/unix.c (find_file): Add variable id conditionally for + mingw targets. + 2009-11-28 Jakub Jelinek <jakub@redhat.com> * intrinsics/pack_generic.c (pack_internal): Remove unused diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am index db086bbc6c5..bd767a2e679 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -85,6 +85,7 @@ intrinsics/eoshift2.c \ intrinsics/erfc_scaled.c \ intrinsics/etime.c \ intrinsics/exit.c \ +intrinsics/extends_type_of.c \ intrinsics/fnum.c \ intrinsics/gerror.c \ intrinsics/getcwd.c \ diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index 8fca11eaa1c..9bc8f11426d 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -433,15 +433,15 @@ am__libgfortran_la_SOURCES_DIST = runtime/backtrace.c runtime/bounds.c \ intrinsics/date_and_time.c intrinsics/dtime.c intrinsics/env.c \ intrinsics/eoshift0.c intrinsics/eoshift2.c \ intrinsics/erfc_scaled.c intrinsics/etime.c intrinsics/exit.c \ - intrinsics/fnum.c intrinsics/gerror.c intrinsics/getcwd.c \ - intrinsics/getlog.c intrinsics/getXid.c intrinsics/hostnm.c \ - intrinsics/ierrno.c intrinsics/ishftc.c \ - intrinsics/iso_c_generated_procs.c intrinsics/iso_c_binding.c \ - intrinsics/kill.c intrinsics/link.c intrinsics/malloc.c \ - intrinsics/mvbits.c intrinsics/move_alloc.c \ - intrinsics/pack_generic.c intrinsics/perror.c \ - intrinsics/selected_char_kind.c intrinsics/signal.c \ - intrinsics/size.c intrinsics/sleep.c \ + intrinsics/extends_type_of.c intrinsics/fnum.c \ + intrinsics/gerror.c intrinsics/getcwd.c intrinsics/getlog.c \ + intrinsics/getXid.c intrinsics/hostnm.c intrinsics/ierrno.c \ + intrinsics/ishftc.c intrinsics/iso_c_generated_procs.c \ + intrinsics/iso_c_binding.c intrinsics/kill.c intrinsics/link.c \ + intrinsics/malloc.c intrinsics/mvbits.c \ + intrinsics/move_alloc.c intrinsics/pack_generic.c \ + intrinsics/perror.c intrinsics/selected_char_kind.c \ + intrinsics/signal.c intrinsics/size.c intrinsics/sleep.c \ intrinsics/spread_generic.c intrinsics/string_intrinsics.c \ intrinsics/system.c intrinsics/rand.c intrinsics/random.c \ intrinsics/rename.c intrinsics/reshape_generic.c \ @@ -725,15 +725,16 @@ am__objects_36 = associated.lo abort.lo access.lo args.lo \ bit_intrinsics.lo c99_functions.lo chdir.lo chmod.lo clock.lo \ cpu_time.lo cshift0.lo ctime.lo date_and_time.lo dtime.lo \ env.lo eoshift0.lo eoshift2.lo erfc_scaled.lo etime.lo exit.lo \ - fnum.lo gerror.lo getcwd.lo getlog.lo getXid.lo hostnm.lo \ - ierrno.lo ishftc.lo iso_c_generated_procs.lo iso_c_binding.lo \ - kill.lo link.lo malloc.lo mvbits.lo move_alloc.lo \ - pack_generic.lo perror.lo selected_char_kind.lo signal.lo \ - size.lo sleep.lo spread_generic.lo string_intrinsics.lo \ - system.lo rand.lo random.lo rename.lo reshape_generic.lo \ - reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \ - stat.lo symlnk.lo system_clock.lo time.lo transpose_generic.lo \ - umask.lo unlink.lo unpack_generic.lo in_pack_generic.lo \ + extends_type_of.lo fnum.lo gerror.lo getcwd.lo getlog.lo \ + getXid.lo hostnm.lo ierrno.lo ishftc.lo \ + iso_c_generated_procs.lo iso_c_binding.lo kill.lo link.lo \ + malloc.lo mvbits.lo move_alloc.lo pack_generic.lo perror.lo \ + selected_char_kind.lo signal.lo size.lo sleep.lo \ + spread_generic.lo string_intrinsics.lo system.lo rand.lo \ + random.lo rename.lo reshape_generic.lo reshape_packed.lo \ + selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \ + system_clock.lo time.lo transpose_generic.lo umask.lo \ + unlink.lo unpack_generic.lo in_pack_generic.lo \ in_unpack_generic.lo am__objects_37 = am__objects_38 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \ @@ -1030,6 +1031,7 @@ intrinsics/eoshift2.c \ intrinsics/erfc_scaled.c \ intrinsics/etime.c \ intrinsics/exit.c \ +intrinsics/extends_type_of.c \ intrinsics/fnum.c \ intrinsics/gerror.c \ intrinsics/getcwd.c \ @@ -1892,6 +1894,7 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/exponent_r16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/exponent_r4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/exponent_r8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/extends_type_of.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fbuf.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/file_pos.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fmain.Plo@am__quote@ @@ -5478,6 +5481,13 @@ exit.lo: intrinsics/exit.c @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o exit.lo `test -f 'intrinsics/exit.c' || echo '$(srcdir)/'`intrinsics/exit.c +extends_type_of.lo: intrinsics/extends_type_of.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT extends_type_of.lo -MD -MP -MF $(DEPDIR)/extends_type_of.Tpo -c -o extends_type_of.lo `test -f 'intrinsics/extends_type_of.c' || echo '$(srcdir)/'`intrinsics/extends_type_of.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/extends_type_of.Tpo $(DEPDIR)/extends_type_of.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='intrinsics/extends_type_of.c' object='extends_type_of.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o extends_type_of.lo `test -f 'intrinsics/extends_type_of.c' || echo '$(srcdir)/'`intrinsics/extends_type_of.c + fnum.lo: intrinsics/fnum.c @am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT fnum.lo -MD -MP -MF $(DEPDIR)/fnum.Tpo -c -o fnum.lo `test -f 'intrinsics/fnum.c' || echo '$(srcdir)/'`intrinsics/fnum.c @am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/fnum.Tpo $(DEPDIR)/fnum.Plo diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index a149332d071..3541d142a7b 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -1095,6 +1095,7 @@ GFORTRAN_1.2 { global: _gfortran_clz128; _gfortran_ctz128; + _gfortran_is_extension_of; } GFORTRAN_1.1; F2C_1.0 { diff --git a/libgfortran/io/unix.c b/libgfortran/io/unix.c index 011d426471b..8b324759a73 100644 --- a/libgfortran/io/unix.c +++ b/libgfortran/io/unix.c @@ -1287,6 +1287,9 @@ find_file (const char *file, gfc_charlen_type file_len) char path[PATH_MAX + 1]; struct stat st[2]; gfc_unit *u; +#if defined(__MINGW32__) && !HAVE_WORKING_STAT + uint64_t id = 0ULL; +#endif if (unpack_filename (path, file, file_len)) return NULL; @@ -1295,7 +1298,7 @@ find_file (const char *file, gfc_charlen_type file_len) return NULL; #if defined(__MINGW32__) && !HAVE_WORKING_STAT - id_from_path (path); + id = id_from_path (path); #endif __gthread_mutex_lock (&unit_lock); diff --git a/libgomp/ChangeLog b/libgomp/ChangeLog index 070d82f2ac8..175926d3cad 100644 --- a/libgomp/ChangeLog +++ b/libgomp/ChangeLog @@ -1,3 +1,8 @@ +2009-11-30 Dave Korn <dave.korn.cygwin@gmail.com> + + * testsuite/lib/libgomp.exp (libgomp_init): Add host-dependent + settings for LC_ALL and LANG. + 2009-11-25 Jakub Jelinek <jakub@redhat.com> PR fortran/42162 diff --git a/libgomp/testsuite/lib/libgomp.exp b/libgomp/testsuite/lib/libgomp.exp index 972d4a1fdd3..0c8e49f8d85 100644 --- a/libgomp/testsuite/lib/libgomp.exp +++ b/libgomp/testsuite/lib/libgomp.exp @@ -66,6 +66,13 @@ proc libgomp_init { args } { setenv LC_ALL C setenv LANG C + # Many hosts now default to a non-ASCII C locale, however, so + # they can set a charset encoding here if they need. + if { [ishost "*-*-cygwin*"] } { + setenv LC_ALL C.ASCII + setenv LANG C.ASCII + } + if ![info exists GCC_UNDER_TEST] then { if [info exists TOOL_EXECUTABLE] { set GCC_UNDER_TEST $TOOL_EXECUTABLE diff --git a/libjava/ChangeLog b/libjava/ChangeLog index 57b5fe21f0f..11b94ba796f 100644 --- a/libjava/ChangeLog +++ b/libjava/ChangeLog @@ -1,3 +1,13 @@ +2009-12-02 Ben Elliston <bje@au.ibm.com> + + * java/net/natVMURLConnection.cc (guessContentTypeFromBuffer): + Mark `bytes' and `valid' parameters as potentially unused. + +2009-11-30 Dave Korn <dave.korn.cygwin@gmail.com> + + * testsuite/lib/libjava.exp (libjava_init): Add host-dependent + settings for LC_ALL and LANG. + 2009-11-30 Ben Elliston <bje@au.ibm.com> * jni.cc (_Jv_JNI_GetObjectRefType): Mark `object' parameter as diff --git a/libjava/java/net/natVMURLConnection.cc b/libjava/java/net/natVMURLConnection.cc index a683fc6fdaf..0a30a219760 100644 --- a/libjava/java/net/natVMURLConnection.cc +++ b/libjava/java/net/natVMURLConnection.cc @@ -61,8 +61,8 @@ java::net::VMURLConnection::init () } ::java::lang::String * -java::net::VMURLConnection::guessContentTypeFromBuffer (jbyteArray bytes, - jint valid) +java::net::VMURLConnection::guessContentTypeFromBuffer (jbyteArray bytes __attribute__ ((unused)), + jint valid __attribute__ ((unused))) { #if defined (HAVE_MAGIC_T) && defined (HAVE_MAGIC_H) && defined (USE_LTDL) const char *result; diff --git a/libjava/testsuite/lib/libjava.exp b/libjava/testsuite/lib/libjava.exp index 510e4ac80d8..b05c56843cc 100644 --- a/libjava/testsuite/lib/libjava.exp +++ b/libjava/testsuite/lib/libjava.exp @@ -145,6 +145,13 @@ proc libjava_init { args } { setenv LC_ALL C setenv LANG C + # Many hosts now default to a non-ASCII C locale, however, so + # they can set a charset encoding here if they need. + if { [ishost "*-*-cygwin*"] } { + setenv LC_ALL C.ASCII + setenv LANG C.ASCII + } + if { $libjava_initialized == 1 } { return; } if ![info exists GCJ_UNDER_TEST] { diff --git a/libstdc++-v3/ChangeLog b/libstdc++-v3/ChangeLog index a6ff6266e06..768e207c528 100644 --- a/libstdc++-v3/ChangeLog +++ b/libstdc++-v3/ChangeLog @@ -1,3 +1,58 @@ +2009-11-30 Dave Korn <dave.korn.cygwin@gmail.com> + + * testsuite/lib/libstdc++.exp (libstdc++_init): Add host-dependent + settings for LC_ALL and LANG. + +2009-11-30 Dave Korn <dave.korn.cygwin@gmail.com> + + * libstdc++-v3/acinclude.m4 (GLIBCXX_ENABLE_SYMVERS): Don't disable + on PE targets. + * libstdc++-v3/configure: Regenerate. + * libstdc++-v3/configure.host: Add libtool DLL options for Cygwin + and MinGW platforms. + + * libstdc++-v3/include/bits/c++config (_GLIBCXX_VISIBILITY_ATTR): On + platforms that don't support visibility, allow them to declare a macro + _GLIBCXX_PSEUDO_VISIBILITY that is applied in place of visibility. + (_GLIBCXX_PSEUDO_VISIBILITY): Supply empty default if not declared by + CPU- or OS-specific headers. + + * libstdc++-v3/config/os/newlib/os_defines.h + (_GLIBCXX_PSEUDO_VISIBILITY_default): New macro for dllimport. + (_GLIBCXX_PSEUDO_VISIBILITY_hidden): New empty macro. + (_GLIBCXX_PSEUDO_VISIBILITY): Evaluate to one of the above. + * libstdc++-v3/config/os/mingw32/os_defines.h + (_GLIBCXX_PSEUDO_VISIBILITY_default, + _GLIBCXX_PSEUDO_VISIBILITY_hidden, + _GLIBCXX_PSEUDO_VISIBILITY): Likewise. + +2009-11-30 Paolo Carlini <paolo.carlini@oracle.com> + + * include/tr1_impl/functional: Remove file, copy its contents, + trivially adjusted... + * include/std/functional: ... here, and... + * include/tr1/functional: ... here. + * include/Makefile.am: Adjust. + * include/Makefile.in: Regenerate. + +2009-11-30 Jonathan Wakely <jwakely.gcc@gmail.com> + + * include/tr1_impl/functional (function): Add rvalue support and + tweak doxygen markup. + * testsuite/20_util/function/assign/move.cc: New. + * testsuite/20_util/function/cons/move.cc: New. + * testsuite/20_util/function/invoke/move_only.cc: New. + * testsuite/20_util/function/cmp/cmp_neg.cc: New. + * testsuite/20_util/function/1.cc: Copy from testsuite/tr1/. + * testsuite/20_util/function/2.cc: Likewise. + * testsuite/20_util/function/3.cc: Likewise. + * testsuite/20_util/function/4.cc: Likewise. + * testsuite/20_util/function/5.cc: Likewise. + * testsuite/20_util/function/6.cc: Likewise. + * testsuite/20_util/function/7.cc: Likewise. + * testsuite/20_util/function/8.cc: Likewise. + * testsuite/20_util/function/9.cc: Likewise. + 2009-11-29 Jonathan Wakely <jwakely.gcc@gmail.com> * doc/doxygen/user.cfg.in: Add __GXX_RTTI to PREDEFINED macros. diff --git a/libstdc++-v3/acinclude.m4 b/libstdc++-v3/acinclude.m4 index aba9a1b2f52..e0c698d75c2 100644 --- a/libstdc++-v3/acinclude.m4 +++ b/libstdc++-v3/acinclude.m4 @@ -2737,7 +2737,7 @@ if test x$enable_symvers = xyes ; then else if test $with_gnu_ld = yes ; then case ${target_os} in - cygwin* | pe | mingw32* | hpux*) + hpux*) enable_symvers=no ;; *) enable_symvers=gnu ;; diff --git a/libstdc++-v3/config/os/mingw32/os_defines.h b/libstdc++-v3/config/os/mingw32/os_defines.h index 7b4e8066457..5435ce9ae84 100644 --- a/libstdc++-v3/config/os/mingw32/os_defines.h +++ b/libstdc++-v3/config/os/mingw32/os_defines.h @@ -45,6 +45,15 @@ #undef NOMINMAX #define NOMINMAX 1 +#if defined (_GLIBCXX_DLL) +#define _GLIBCXX_PSEUDO_VISIBILITY_default __attribute__ ((__dllimport__)) +#else +#define _GLIBCXX_PSEUDO_VISIBILITY_default +#endif +#define _GLIBCXX_PSEUDO_VISIBILITY_hidden + +#define _GLIBCXX_PSEUDO_VISIBILITY(V) _GLIBCXX_PSEUDO_VISIBILITY_ ## V + // See libstdc++/20806. #define _GLIBCXX_HAVE_DOS_BASED_FILESYSTEM 1 diff --git a/libstdc++-v3/config/os/newlib/os_defines.h b/libstdc++-v3/config/os/newlib/os_defines.h index fbc886365ff..1ff3d4846cb 100644 --- a/libstdc++-v3/config/os/newlib/os_defines.h +++ b/libstdc++-v3/config/os/newlib/os_defines.h @@ -36,6 +36,15 @@ #ifdef __CYGWIN__ #define _GLIBCXX_GTHREAD_USE_WEAK 0 +#if defined (_GLIBCXX_DLL) +#define _GLIBCXX_PSEUDO_VISIBILITY_default __attribute__ ((__dllimport__)) +#else +#define _GLIBCXX_PSEUDO_VISIBILITY_default +#endif +#define _GLIBCXX_PSEUDO_VISIBILITY_hidden + +#define _GLIBCXX_PSEUDO_VISIBILITY(V) _GLIBCXX_PSEUDO_VISIBILITY_ ## V + // See libstdc++/20806. #define _GLIBCXX_HAVE_DOS_BASED_FILESYSTEM 1 #endif diff --git a/libstdc++-v3/configure b/libstdc++-v3/configure index 75adc589e12..4f5d51783d6 100755 --- a/libstdc++-v3/configure +++ b/libstdc++-v3/configure @@ -58050,7 +58050,7 @@ if test x$enable_symvers = xyes ; then else if test $with_gnu_ld = yes ; then case ${target_os} in - cygwin* | pe | mingw32* | hpux*) + hpux*) enable_symvers=no ;; *) enable_symvers=gnu ;; diff --git a/libstdc++-v3/configure.host b/libstdc++-v3/configure.host index de7745a1286..02292b016d0 100644 --- a/libstdc++-v3/configure.host +++ b/libstdc++-v3/configure.host @@ -209,6 +209,7 @@ case "${host_os}" in ;; cygwin*) os_include_dir="os/newlib" + OPT_LDFLAGS="${OPT_LDFLAGS} -no-undefined -bindir \$(bindir)" ;; darwin | darwin[1-7] | darwin[1-7].*) # On Darwin, performance is improved if libstdc++ is single-module. @@ -258,6 +259,7 @@ case "${host_os}" in mingw32*) os_include_dir="os/mingw32" error_constants_dir="os/mingw32" + OPT_LDFLAGS="${OPT_LDFLAGS} -no-undefined -bindir \$(bindir)" ;; netbsd*) os_include_dir="os/bsd/netbsd" diff --git a/libstdc++-v3/include/Makefile.am b/libstdc++-v3/include/Makefile.am index 47253e681c9..8d4ece7ee44 100644 --- a/libstdc++-v3/include/Makefile.am +++ b/libstdc++-v3/include/Makefile.am @@ -609,7 +609,6 @@ tr1_impl_headers = \ ${tr1_impl_srcdir}/cstdlib \ ${tr1_impl_srcdir}/cwchar \ ${tr1_impl_srcdir}/cwctype \ - ${tr1_impl_srcdir}/functional \ ${tr1_impl_srcdir}/hashtable \ ${tr1_impl_srcdir}/hashtable_policy.h \ ${tr1_impl_srcdir}/regex \ diff --git a/libstdc++-v3/include/Makefile.in b/libstdc++-v3/include/Makefile.in index 71e7489be36..221ae557530 100644 --- a/libstdc++-v3/include/Makefile.in +++ b/libstdc++-v3/include/Makefile.in @@ -849,7 +849,6 @@ tr1_impl_headers = \ ${tr1_impl_srcdir}/cstdlib \ ${tr1_impl_srcdir}/cwchar \ ${tr1_impl_srcdir}/cwctype \ - ${tr1_impl_srcdir}/functional \ ${tr1_impl_srcdir}/hashtable \ ${tr1_impl_srcdir}/hashtable_policy.h \ ${tr1_impl_srcdir}/regex \ diff --git a/libstdc++-v3/include/bits/c++config b/libstdc++-v3/include/bits/c++config index f4f1f8b901f..3746696458a 100644 --- a/libstdc++-v3/include/bits/c++config +++ b/libstdc++-v3/include/bits/c++config @@ -42,7 +42,9 @@ #if _GLIBCXX_HAVE_ATTRIBUTE_VISIBILITY # define _GLIBCXX_VISIBILITY_ATTR(V) __attribute__ ((__visibility__ (#V))) #else -# define _GLIBCXX_VISIBILITY_ATTR(V) +// If this is not supplied by the OS-specific or CPU-specific +// headers included below, it will be defined to an empty default. +# define _GLIBCXX_VISIBILITY_ATTR(V) _GLIBCXX_PSEUDO_VISIBILITY(V) #endif // Macros for deprecated. @@ -275,6 +277,12 @@ namespace std // Pick up any CPU-specific definitions. #include <bits/cpu_defines.h> +// If platform uses neither visibility nor psuedo-visibility, +// specify empty default for namespace annotation macros. +#ifndef _GLIBCXX_PSEUDO_VISIBILITY +#define _GLIBCXX_PSEUDO_VISIBILITY(V) +#endif + // Allow use of "export template." This is currently not a feature // that g++ supports. // #define _GLIBCXX_EXPORT_TEMPLATE 1 diff --git a/libstdc++-v3/include/std/functional b/libstdc++-v3/include/std/functional index e46a27df12a..eb10b348ad1 100644 --- a/libstdc++-v3/include/std/functional +++ b/libstdc++-v3/include/std/functional @@ -50,28 +50,2145 @@ #include <bits/stl_function.h> #ifdef __GXX_EXPERIMENTAL_CXX0X__ -# if defined(_GLIBCXX_INCLUDE_AS_TR1) -# error C++0x header cannot be included from TR1 header -# endif -# include <typeinfo> -# include <new> -# include <tuple> -# include <type_traits> -# include <bits/functional_hash.h> -# include <ext/type_traits.h> -# if defined(_GLIBCXX_INCLUDE_AS_CXX0X) -# include <tr1_impl/functional> -# else -# define _GLIBCXX_INCLUDE_AS_CXX0X -# define _GLIBCXX_BEGIN_NAMESPACE_TR1 -# define _GLIBCXX_END_NAMESPACE_TR1 -# define _GLIBCXX_TR1 -# include <tr1_impl/functional> -# undef _GLIBCXX_TR1 -# undef _GLIBCXX_END_NAMESPACE_TR1 -# undef _GLIBCXX_BEGIN_NAMESPACE_TR1 -# undef _GLIBCXX_INCLUDE_AS_CXX0X -# endif + +#include <typeinfo> +#include <new> +#include <tuple> +#include <type_traits> +#include <bits/functional_hash.h> +#include <ext/type_traits.h> + +namespace std +{ + template<typename _MemberPointer> + class _Mem_fn; + + /** + * Actual implementation of _Has_result_type, which uses SFINAE to + * determine if the type _Tp has a publicly-accessible member type + * result_type. + */ + template<typename _Tp> + class _Has_result_type_helper : __sfinae_types + { + template<typename _Up> + struct _Wrap_type + { }; + + template<typename _Up> + static __one __test(_Wrap_type<typename _Up::result_type>*); + + template<typename _Up> + static __two __test(...); + + public: + static const bool value = sizeof(__test<_Tp>(0)) == 1; + }; + + template<typename _Tp> + struct _Has_result_type + : integral_constant<bool, + _Has_result_type_helper<typename remove_cv<_Tp>::type>::value> + { }; + + /** + * + */ + /// If we have found a result_type, extract it. + template<bool _Has_result_type, typename _Functor> + struct _Maybe_get_result_type + { }; + + template<typename _Functor> + struct _Maybe_get_result_type<true, _Functor> + { + typedef typename _Functor::result_type result_type; + }; + + /** + * Base class for any function object that has a weak result type, as + * defined in 3.3/3 of TR1. + */ + template<typename _Functor> + struct _Weak_result_type_impl + : _Maybe_get_result_type<_Has_result_type<_Functor>::value, _Functor> + { + }; + + /// Retrieve the result type for a function type. + template<typename _Res, typename... _ArgTypes> + struct _Weak_result_type_impl<_Res(_ArgTypes...)> + { + typedef _Res result_type; + }; + + /// Retrieve the result type for a function reference. + template<typename _Res, typename... _ArgTypes> + struct _Weak_result_type_impl<_Res(&)(_ArgTypes...)> + { + typedef _Res result_type; + }; + + /// Retrieve the result type for a function pointer. + template<typename _Res, typename... _ArgTypes> + struct _Weak_result_type_impl<_Res(*)(_ArgTypes...)> + { + typedef _Res result_type; + }; + + /// Retrieve result type for a member function pointer. + template<typename _Res, typename _Class, typename... _ArgTypes> + struct _Weak_result_type_impl<_Res (_Class::*)(_ArgTypes...)> + { + typedef _Res result_type; + }; + + /// Retrieve result type for a const member function pointer. + template<typename _Res, typename _Class, typename... _ArgTypes> + struct _Weak_result_type_impl<_Res (_Class::*)(_ArgTypes...) const> + { + typedef _Res result_type; + }; + + /// Retrieve result type for a volatile member function pointer. + template<typename _Res, typename _Class, typename... _ArgTypes> + struct _Weak_result_type_impl<_Res (_Class::*)(_ArgTypes...) volatile> + { + typedef _Res result_type; + }; + + /// Retrieve result type for a const volatile member function pointer. + template<typename _Res, typename _Class, typename... _ArgTypes> + struct _Weak_result_type_impl<_Res (_Class::*)(_ArgTypes...)const volatile> + { + typedef _Res result_type; + }; + + /** + * Strip top-level cv-qualifiers from the function object and let + * _Weak_result_type_impl perform the real work. + */ + template<typename _Functor> + struct _Weak_result_type + : _Weak_result_type_impl<typename remove_cv<_Functor>::type> + { + }; + + template<typename _Signature> + class result_of; + + /** + * Actual implementation of result_of. When _Has_result_type is + * true, gets its result from _Weak_result_type. Otherwise, uses + * the function object's member template result to extract the + * result type. + */ + template<bool _Has_result_type, typename _Signature> + struct _Result_of_impl; + + // Handle member data pointers using _Mem_fn's logic + template<typename _Res, typename _Class, typename _T1> + struct _Result_of_impl<false, _Res _Class::*(_T1)> + { + typedef typename _Mem_fn<_Res _Class::*> + ::template _Result_type<_T1>::type type; + }; + + /** + * Determine whether we can determine a result type from @c Functor + * alone. + */ + template<typename _Functor, typename... _ArgTypes> + class result_of<_Functor(_ArgTypes...)> + : public _Result_of_impl< + _Has_result_type<_Weak_result_type<_Functor> >::value, + _Functor(_ArgTypes...)> + { + }; + + /// We already know the result type for @c Functor; use it. + template<typename _Functor, typename... _ArgTypes> + struct _Result_of_impl<true, _Functor(_ArgTypes...)> + { + typedef typename _Weak_result_type<_Functor>::result_type type; + }; + + /** + * We need to compute the result type for this invocation the hard + * way. + */ + template<typename _Functor, typename... _ArgTypes> + struct _Result_of_impl<false, _Functor(_ArgTypes...)> + { + typedef typename _Functor + ::template result<_Functor(_ArgTypes...)>::type type; + }; + + /** + * It is unsafe to access ::result when there are zero arguments, so we + * return @c void instead. + */ + template<typename _Functor> + struct _Result_of_impl<false, _Functor()> + { + typedef void type; + }; + + /// Determines if the type _Tp derives from unary_function. + template<typename _Tp> + struct _Derives_from_unary_function : __sfinae_types + { + private: + template<typename _T1, typename _Res> + static __one __test(const volatile unary_function<_T1, _Res>*); + + // It's tempting to change "..." to const volatile void*, but + // that fails when _Tp is a function type. + static __two __test(...); + + public: + static const bool value = sizeof(__test((_Tp*)0)) == 1; + }; + + /// Determines if the type _Tp derives from binary_function. + template<typename _Tp> + struct _Derives_from_binary_function : __sfinae_types + { + private: + template<typename _T1, typename _T2, typename _Res> + static __one __test(const volatile binary_function<_T1, _T2, _Res>*); + + // It's tempting to change "..." to const volatile void*, but + // that fails when _Tp is a function type. + static __two __test(...); + + public: + static const bool value = sizeof(__test((_Tp*)0)) == 1; + }; + + /// Turns a function type into a function pointer type + template<typename _Tp, bool _IsFunctionType = is_function<_Tp>::value> + struct _Function_to_function_pointer + { + typedef _Tp type; + }; + + template<typename _Tp> + struct _Function_to_function_pointer<_Tp, true> + { + typedef _Tp* type; + }; + + /** + * Invoke a function object, which may be either a member pointer or a + * function object. The first parameter will tell which. + */ + template<typename _Functor, typename... _Args> + inline + typename __gnu_cxx::__enable_if< + (!is_member_pointer<_Functor>::value + && !is_function<_Functor>::value + && !is_function<typename remove_pointer<_Functor>::type>::value), + typename result_of<_Functor(_Args...)>::type + >::__type + __invoke(_Functor& __f, _Args&... __args) + { + return __f(__args...); + } + + template<typename _Functor, typename... _Args> + inline + typename __gnu_cxx::__enable_if< + (is_member_pointer<_Functor>::value + && !is_function<_Functor>::value + && !is_function<typename remove_pointer<_Functor>::type>::value), + typename result_of<_Functor(_Args...)>::type + >::__type + __invoke(_Functor& __f, _Args&... __args) + { + return mem_fn(__f)(__args...); + } + + // To pick up function references (that will become function pointers) + template<typename _Functor, typename... _Args> + inline + typename __gnu_cxx::__enable_if< + (is_pointer<_Functor>::value + && is_function<typename remove_pointer<_Functor>::type>::value), + typename result_of<_Functor(_Args...)>::type + >::__type + __invoke(_Functor __f, _Args&... __args) + { + return __f(__args...); + } + + /** + * Knowing which of unary_function and binary_function _Tp derives + * from, derives from the same and ensures that reference_wrapper + * will have a weak result type. See cases below. + */ + template<bool _Unary, bool _Binary, typename _Tp> + struct _Reference_wrapper_base_impl; + + // Not a unary_function or binary_function, so try a weak result type. + template<typename _Tp> + struct _Reference_wrapper_base_impl<false, false, _Tp> + : _Weak_result_type<_Tp> + { }; + + // unary_function but not binary_function + template<typename _Tp> + struct _Reference_wrapper_base_impl<true, false, _Tp> + : unary_function<typename _Tp::argument_type, + typename _Tp::result_type> + { }; + + // binary_function but not unary_function + template<typename _Tp> + struct _Reference_wrapper_base_impl<false, true, _Tp> + : binary_function<typename _Tp::first_argument_type, + typename _Tp::second_argument_type, + typename _Tp::result_type> + { }; + + // Both unary_function and binary_function. Import result_type to + // avoid conflicts. + template<typename _Tp> + struct _Reference_wrapper_base_impl<true, true, _Tp> + : unary_function<typename _Tp::argument_type, + typename _Tp::result_type>, + binary_function<typename _Tp::first_argument_type, + typename _Tp::second_argument_type, + typename _Tp::result_type> + { + typedef typename _Tp::result_type result_type; + }; + + /** + * Derives from unary_function or binary_function when it + * can. Specializations handle all of the easy cases. The primary + * template determines what to do with a class type, which may + * derive from both unary_function and binary_function. + */ + template<typename _Tp> + struct _Reference_wrapper_base + : _Reference_wrapper_base_impl< + _Derives_from_unary_function<_Tp>::value, + _Derives_from_binary_function<_Tp>::value, + _Tp> + { }; + + // - a function type (unary) + template<typename _Res, typename _T1> + struct _Reference_wrapper_base<_Res(_T1)> + : unary_function<_T1, _Res> + { }; + + // - a function type (binary) + template<typename _Res, typename _T1, typename _T2> + struct _Reference_wrapper_base<_Res(_T1, _T2)> + : binary_function<_T1, _T2, _Res> + { }; + + // - a function pointer type (unary) + template<typename _Res, typename _T1> + struct _Reference_wrapper_base<_Res(*)(_T1)> + : unary_function<_T1, _Res> + { }; + + // - a function pointer type (binary) + template<typename _Res, typename _T1, typename _T2> + struct _Reference_wrapper_base<_Res(*)(_T1, _T2)> + : binary_function<_T1, _T2, _Res> + { }; + + // - a pointer to member function type (unary, no qualifiers) + template<typename _Res, typename _T1> + struct _Reference_wrapper_base<_Res (_T1::*)()> + : unary_function<_T1*, _Res> + { }; + + // - a pointer to member function type (binary, no qualifiers) + template<typename _Res, typename _T1, typename _T2> + struct _Reference_wrapper_base<_Res (_T1::*)(_T2)> + : binary_function<_T1*, _T2, _Res> + { }; + + // - a pointer to member function type (unary, const) + template<typename _Res, typename _T1> + struct _Reference_wrapper_base<_Res (_T1::*)() const> + : unary_function<const _T1*, _Res> + { }; + + // - a pointer to member function type (binary, const) + template<typename _Res, typename _T1, typename _T2> + struct _Reference_wrapper_base<_Res (_T1::*)(_T2) const> + : binary_function<const _T1*, _T2, _Res> + { }; + + // - a pointer to member function type (unary, volatile) + template<typename _Res, typename _T1> + struct _Reference_wrapper_base<_Res (_T1::*)() volatile> + : unary_function<volatile _T1*, _Res> + { }; + + // - a pointer to member function type (binary, volatile) + template<typename _Res, typename _T1, typename _T2> + struct _Reference_wrapper_base<_Res (_T1::*)(_T2) volatile> + : binary_function<volatile _T1*, _T2, _Res> + { }; + + // - a pointer to member function type (unary, const volatile) + template<typename _Res, typename _T1> + struct _Reference_wrapper_base<_Res (_T1::*)() const volatile> + : unary_function<const volatile _T1*, _Res> + { }; + + // - a pointer to member function type (binary, const volatile) + template<typename _Res, typename _T1, typename _T2> + struct _Reference_wrapper_base<_Res (_T1::*)(_T2) const volatile> + : binary_function<const volatile _T1*, _T2, _Res> + { }; + + /// reference_wrapper + template<typename _Tp> + class reference_wrapper + : public _Reference_wrapper_base<typename remove_cv<_Tp>::type> + { + // If _Tp is a function type, we can't form result_of<_Tp(...)>, + // so turn it into a function pointer type. + typedef typename _Function_to_function_pointer<_Tp>::type + _M_func_type; + + _Tp* _M_data; + public: + typedef _Tp type; + + explicit + reference_wrapper(_Tp& __indata): _M_data(&__indata) + { } + + reference_wrapper(const reference_wrapper<_Tp>& __inref): + _M_data(__inref._M_data) + { } + + reference_wrapper& + operator=(const reference_wrapper<_Tp>& __inref) + { + _M_data = __inref._M_data; + return *this; + } + + operator _Tp&() const + { return this->get(); } + + _Tp& + get() const + { return *_M_data; } + + template<typename... _Args> + typename result_of<_M_func_type(_Args...)>::type + operator()(_Args&... __args) const + { + return __invoke(get(), __args...); + } + }; + + + // Denotes a reference should be taken to a variable. + template<typename _Tp> + inline reference_wrapper<_Tp> + ref(_Tp& __t) + { return reference_wrapper<_Tp>(__t); } + + // Denotes a const reference should be taken to a variable. + template<typename _Tp> + inline reference_wrapper<const _Tp> + cref(const _Tp& __t) + { return reference_wrapper<const _Tp>(__t); } + + template<typename _Tp> + inline reference_wrapper<_Tp> + ref(reference_wrapper<_Tp> __t) + { return ref(__t.get()); } + + template<typename _Tp> + inline reference_wrapper<const _Tp> + cref(reference_wrapper<_Tp> __t) + { return cref(__t.get()); } + + template<typename _Tp, bool> + struct _Mem_fn_const_or_non + { + typedef const _Tp& type; + }; + + template<typename _Tp> + struct _Mem_fn_const_or_non<_Tp, false> + { + typedef _Tp& type; + }; + + /** + * Derives from @c unary_function or @c binary_function, or perhaps + * nothing, depending on the number of arguments provided. The + * primary template is the basis case, which derives nothing. + */ + template<typename _Res, typename... _ArgTypes> + struct _Maybe_unary_or_binary_function { }; + + /// Derives from @c unary_function, as appropriate. + template<typename _Res, typename _T1> + struct _Maybe_unary_or_binary_function<_Res, _T1> + : std::unary_function<_T1, _Res> { }; + + /// Derives from @c binary_function, as appropriate. + template<typename _Res, typename _T1, typename _T2> + struct _Maybe_unary_or_binary_function<_Res, _T1, _T2> + : std::binary_function<_T1, _T2, _Res> { }; + + /// Implementation of @c mem_fn for member function pointers. + template<typename _Res, typename _Class, typename... _ArgTypes> + class _Mem_fn<_Res (_Class::*)(_ArgTypes...)> + : public _Maybe_unary_or_binary_function<_Res, _Class*, _ArgTypes...> + { + typedef _Res (_Class::*_Functor)(_ArgTypes...); + + template<typename _Tp> + _Res + _M_call(_Tp& __object, const volatile _Class *, + _ArgTypes... __args) const + { return (__object.*__pmf)(__args...); } + + template<typename _Tp> + _Res + _M_call(_Tp& __ptr, const volatile void *, _ArgTypes... __args) const + { return ((*__ptr).*__pmf)(__args...); } + + public: + typedef _Res result_type; + + explicit _Mem_fn(_Functor __pmf) : __pmf(__pmf) { } + + // Handle objects + _Res + operator()(_Class& __object, _ArgTypes... __args) const + { return (__object.*__pmf)(__args...); } + + // Handle pointers + _Res + operator()(_Class* __object, _ArgTypes... __args) const + { return (__object->*__pmf)(__args...); } + + // Handle smart pointers, references and pointers to derived + template<typename _Tp> + _Res + operator()(_Tp& __object, _ArgTypes... __args) const + { return _M_call(__object, &__object, __args...); } + + private: + _Functor __pmf; + }; + + /// Implementation of @c mem_fn for const member function pointers. + template<typename _Res, typename _Class, typename... _ArgTypes> + class _Mem_fn<_Res (_Class::*)(_ArgTypes...) const> + : public _Maybe_unary_or_binary_function<_Res, const _Class*, + _ArgTypes...> + { + typedef _Res (_Class::*_Functor)(_ArgTypes...) const; + + template<typename _Tp> + _Res + _M_call(_Tp& __object, const volatile _Class *, + _ArgTypes... __args) const + { return (__object.*__pmf)(__args...); } + + template<typename _Tp> + _Res + _M_call(_Tp& __ptr, const volatile void *, _ArgTypes... __args) const + { return ((*__ptr).*__pmf)(__args...); } + + public: + typedef _Res result_type; + + explicit _Mem_fn(_Functor __pmf) : __pmf(__pmf) { } + + // Handle objects + _Res + operator()(const _Class& __object, _ArgTypes... __args) const + { return (__object.*__pmf)(__args...); } + + // Handle pointers + _Res + operator()(const _Class* __object, _ArgTypes... __args) const + { return (__object->*__pmf)(__args...); } + + // Handle smart pointers, references and pointers to derived + template<typename _Tp> + _Res operator()(_Tp& __object, _ArgTypes... __args) const + { return _M_call(__object, &__object, __args...); } + + private: + _Functor __pmf; + }; + + /// Implementation of @c mem_fn for volatile member function pointers. + template<typename _Res, typename _Class, typename... _ArgTypes> + class _Mem_fn<_Res (_Class::*)(_ArgTypes...) volatile> + : public _Maybe_unary_or_binary_function<_Res, volatile _Class*, + _ArgTypes...> + { + typedef _Res (_Class::*_Functor)(_ArgTypes...) volatile; + + template<typename _Tp> + _Res + _M_call(_Tp& __object, const volatile _Class *, + _ArgTypes... __args) const + { return (__object.*__pmf)(__args...); } + + template<typename _Tp> + _Res + _M_call(_Tp& __ptr, const volatile void *, _ArgTypes... __args) const + { return ((*__ptr).*__pmf)(__args...); } + + public: + typedef _Res result_type; + + explicit _Mem_fn(_Functor __pmf) : __pmf(__pmf) { } + + // Handle objects + _Res + operator()(volatile _Class& __object, _ArgTypes... __args) const + { return (__object.*__pmf)(__args...); } + + // Handle pointers + _Res + operator()(volatile _Class* __object, _ArgTypes... __args) const + { return (__object->*__pmf)(__args...); } + + // Handle smart pointers, references and pointers to derived + template<typename _Tp> + _Res + operator()(_Tp& __object, _ArgTypes... __args) const + { return _M_call(__object, &__object, __args...); } + + private: + _Functor __pmf; + }; + + /// Implementation of @c mem_fn for const volatile member function pointers. + template<typename _Res, typename _Class, typename... _ArgTypes> + class _Mem_fn<_Res (_Class::*)(_ArgTypes...) const volatile> + : public _Maybe_unary_or_binary_function<_Res, const volatile _Class*, + _ArgTypes...> + { + typedef _Res (_Class::*_Functor)(_ArgTypes...) const volatile; + + template<typename _Tp> + _Res + _M_call(_Tp& __object, const volatile _Class *, + _ArgTypes... __args) const + { return (__object.*__pmf)(__args...); } + + template<typename _Tp> + _Res + _M_call(_Tp& __ptr, const volatile void *, _ArgTypes... __args) const + { return ((*__ptr).*__pmf)(__args...); } + + public: + typedef _Res result_type; + + explicit _Mem_fn(_Functor __pmf) : __pmf(__pmf) { } + + // Handle objects + _Res + operator()(const volatile _Class& __object, _ArgTypes... __args) const + { return (__object.*__pmf)(__args...); } + + // Handle pointers + _Res + operator()(const volatile _Class* __object, _ArgTypes... __args) const + { return (__object->*__pmf)(__args...); } + + // Handle smart pointers, references and pointers to derived + template<typename _Tp> + _Res operator()(_Tp& __object, _ArgTypes... __args) const + { return _M_call(__object, &__object, __args...); } + + private: + _Functor __pmf; + }; + + + template<typename _Res, typename _Class> + class _Mem_fn<_Res _Class::*> + { + // This bit of genius is due to Peter Dimov, improved slightly by + // Douglas Gregor. + template<typename _Tp> + _Res& + _M_call(_Tp& __object, _Class *) const + { return __object.*__pm; } + + template<typename _Tp, typename _Up> + _Res& + _M_call(_Tp& __object, _Up * const *) const + { return (*__object).*__pm; } + + template<typename _Tp, typename _Up> + const _Res& + _M_call(_Tp& __object, const _Up * const *) const + { return (*__object).*__pm; } + + template<typename _Tp> + const _Res& + _M_call(_Tp& __object, const _Class *) const + { return __object.*__pm; } + + template<typename _Tp> + const _Res& + _M_call(_Tp& __ptr, const volatile void*) const + { return (*__ptr).*__pm; } + + template<typename _Tp> static _Tp& __get_ref(); + + template<typename _Tp> + static __sfinae_types::__one __check_const(_Tp&, _Class*); + template<typename _Tp, typename _Up> + static __sfinae_types::__one __check_const(_Tp&, _Up * const *); + template<typename _Tp, typename _Up> + static __sfinae_types::__two __check_const(_Tp&, const _Up * const *); + template<typename _Tp> + static __sfinae_types::__two __check_const(_Tp&, const _Class*); + template<typename _Tp> + static __sfinae_types::__two __check_const(_Tp&, const volatile void*); + + public: + template<typename _Tp> + struct _Result_type + : _Mem_fn_const_or_non<_Res, + (sizeof(__sfinae_types::__two) + == sizeof(__check_const<_Tp>(__get_ref<_Tp>(), (_Tp*)0)))> + { }; + + template<typename _Signature> + struct result; + + template<typename _CVMem, typename _Tp> + struct result<_CVMem(_Tp)> + : public _Result_type<_Tp> { }; + + template<typename _CVMem, typename _Tp> + struct result<_CVMem(_Tp&)> + : public _Result_type<_Tp> { }; + + explicit + _Mem_fn(_Res _Class::*__pm) : __pm(__pm) { } + + // Handle objects + _Res& + operator()(_Class& __object) const + { return __object.*__pm; } + + const _Res& + operator()(const _Class& __object) const + { return __object.*__pm; } + + // Handle pointers + _Res& + operator()(_Class* __object) const + { return __object->*__pm; } + + const _Res& + operator()(const _Class* __object) const + { return __object->*__pm; } + + // Handle smart pointers and derived + template<typename _Tp> + typename _Result_type<_Tp>::type + operator()(_Tp& __unknown) const + { return _M_call(__unknown, &__unknown); } + + private: + _Res _Class::*__pm; + }; + + /** + * @brief Returns a function object that forwards to the member + * pointer @a pm. + */ + template<typename _Tp, typename _Class> + inline _Mem_fn<_Tp _Class::*> + mem_fn(_Tp _Class::* __pm) + { + return _Mem_fn<_Tp _Class::*>(__pm); + } + + /** + * @brief Determines if the given type _Tp is a function object + * should be treated as a subexpression when evaluating calls to + * function objects returned by bind(). [TR1 3.6.1] + */ + template<typename _Tp> + struct is_bind_expression + { static const bool value = false; }; + + template<typename _Tp> + const bool is_bind_expression<_Tp>::value; + + /** + * @brief Determines if the given type _Tp is a placeholder in a + * bind() expression and, if so, which placeholder it is. [TR1 3.6.2] + */ + template<typename _Tp> + struct is_placeholder + { static const int value = 0; }; + + template<typename _Tp> + const int is_placeholder<_Tp>::value; + + /// The type of placeholder objects defined by libstdc++. + template<int _Num> struct _Placeholder { }; + + /** @namespace std::placeholders + * @brief ISO C++ 0x entities sub namespace for functional. + * + * Define a large number of placeholders. There is no way to + * simplify this with variadic templates, because we're introducing + * unique names for each. + */ + namespace placeholders + { + namespace + { + _Placeholder<1> _1; + _Placeholder<2> _2; + _Placeholder<3> _3; + _Placeholder<4> _4; + _Placeholder<5> _5; + _Placeholder<6> _6; + _Placeholder<7> _7; + _Placeholder<8> _8; + _Placeholder<9> _9; + _Placeholder<10> _10; + _Placeholder<11> _11; + _Placeholder<12> _12; + _Placeholder<13> _13; + _Placeholder<14> _14; + _Placeholder<15> _15; + _Placeholder<16> _16; + _Placeholder<17> _17; + _Placeholder<18> _18; + _Placeholder<19> _19; + _Placeholder<20> _20; + _Placeholder<21> _21; + _Placeholder<22> _22; + _Placeholder<23> _23; + _Placeholder<24> _24; + _Placeholder<25> _25; + _Placeholder<26> _26; + _Placeholder<27> _27; + _Placeholder<28> _28; + _Placeholder<29> _29; + } + } + + /** + * Partial specialization of is_placeholder that provides the placeholder + * number for the placeholder objects defined by libstdc++. + */ + template<int _Num> + struct is_placeholder<_Placeholder<_Num> > + { static const int value = _Num; }; + + template<int _Num> + const int is_placeholder<_Placeholder<_Num> >::value; + + /** + * Stores a tuple of indices. Used by bind() to extract the elements + * in a tuple. + */ + template<int... _Indexes> + struct _Index_tuple { }; + + /// Builds an _Index_tuple<0, 1, 2, ..., _Num-1>. + template<std::size_t _Num, typename _Tuple = _Index_tuple<> > + struct _Build_index_tuple; + + template<std::size_t _Num, int... _Indexes> + struct _Build_index_tuple<_Num, _Index_tuple<_Indexes...> > + : _Build_index_tuple<_Num - 1, + _Index_tuple<_Indexes..., sizeof...(_Indexes)> > + { + }; + + template<int... _Indexes> + struct _Build_index_tuple<0, _Index_tuple<_Indexes...> > + { + typedef _Index_tuple<_Indexes...> __type; + }; + + /** + * Used by _Safe_tuple_element to indicate that there is no tuple + * element at this position. + */ + struct _No_tuple_element; + + /** + * Implementation helper for _Safe_tuple_element. This primary + * template handles the case where it is safe to use @c + * tuple_element. + */ + template<int __i, typename _Tuple, bool _IsSafe> + struct _Safe_tuple_element_impl + : tuple_element<__i, _Tuple> { }; + + /** + * Implementation helper for _Safe_tuple_element. This partial + * specialization handles the case where it is not safe to use @c + * tuple_element. We just return @c _No_tuple_element. + */ + template<int __i, typename _Tuple> + struct _Safe_tuple_element_impl<__i, _Tuple, false> + { + typedef _No_tuple_element type; + }; + + /** + * Like tuple_element, but returns @c _No_tuple_element when + * tuple_element would return an error. + */ + template<int __i, typename _Tuple> + struct _Safe_tuple_element + : _Safe_tuple_element_impl<__i, _Tuple, + (__i >= 0 && __i < tuple_size<_Tuple>::value)> + { + }; + + /** + * Maps an argument to bind() into an actual argument to the bound + * function object [TR1 3.6.3/5]. Only the first parameter should + * be specified: the rest are used to determine among the various + * implementations. Note that, although this class is a function + * object, it isn't entirely normal because it takes only two + * parameters regardless of the number of parameters passed to the + * bind expression. The first parameter is the bound argument and + * the second parameter is a tuple containing references to the + * rest of the arguments. + */ + template<typename _Arg, + bool _IsBindExp = is_bind_expression<_Arg>::value, + bool _IsPlaceholder = (is_placeholder<_Arg>::value > 0)> + class _Mu; + + /** + * If the argument is reference_wrapper<_Tp>, returns the + * underlying reference. [TR1 3.6.3/5 bullet 1] + */ + template<typename _Tp> + class _Mu<reference_wrapper<_Tp>, false, false> + { + public: + typedef _Tp& result_type; + + /* Note: This won't actually work for const volatile + * reference_wrappers, because reference_wrapper::get() is const + * but not volatile-qualified. This might be a defect in the TR. + */ + template<typename _CVRef, typename _Tuple> + result_type + operator()(_CVRef& __arg, const _Tuple&) const volatile + { return __arg.get(); } + }; + + /** + * If the argument is a bind expression, we invoke the underlying + * function object with the same cv-qualifiers as we are given and + * pass along all of our arguments (unwrapped). [TR1 3.6.3/5 bullet 2] + */ + template<typename _Arg> + class _Mu<_Arg, true, false> + { + public: + template<typename _Signature> class result; + + // Determine the result type when we pass the arguments along. This + // involves passing along the cv-qualifiers placed on _Mu and + // unwrapping the argument bundle. + template<typename _CVMu, typename _CVArg, typename... _Args> + class result<_CVMu(_CVArg, tuple<_Args...>)> + : public result_of<_CVArg(_Args...)> { }; + + template<typename _CVArg, typename... _Args> + typename result_of<_CVArg(_Args...)>::type + operator()(_CVArg& __arg, + const tuple<_Args...>& __tuple) const volatile + { + // Construct an index tuple and forward to __call + typedef typename _Build_index_tuple<sizeof...(_Args)>::__type + _Indexes; + return this->__call(__arg, __tuple, _Indexes()); + } + + private: + // Invokes the underlying function object __arg by unpacking all + // of the arguments in the tuple. + template<typename _CVArg, typename... _Args, int... _Indexes> + typename result_of<_CVArg(_Args...)>::type + __call(_CVArg& __arg, const tuple<_Args...>& __tuple, + const _Index_tuple<_Indexes...>&) const volatile + { + return __arg(get<_Indexes>(__tuple)...); + } + }; + + /** + * If the argument is a placeholder for the Nth argument, returns + * a reference to the Nth argument to the bind function object. + * [TR1 3.6.3/5 bullet 3] + */ + template<typename _Arg> + class _Mu<_Arg, false, true> + { + public: + template<typename _Signature> class result; + + template<typename _CVMu, typename _CVArg, typename _Tuple> + class result<_CVMu(_CVArg, _Tuple)> + { + // Add a reference, if it hasn't already been done for us. + // This allows us to be a little bit sloppy in constructing + // the tuple that we pass to result_of<...>. + typedef typename _Safe_tuple_element<(is_placeholder<_Arg>::value + - 1), _Tuple>::type + __base_type; + + public: + typedef typename add_lvalue_reference<__base_type>::type type; + }; + + template<typename _Tuple> + typename result<_Mu(_Arg, _Tuple)>::type + operator()(const volatile _Arg&, const _Tuple& __tuple) const volatile + { + return ::std::get<(is_placeholder<_Arg>::value - 1)>(__tuple); + } + }; + + /** + * If the argument is just a value, returns a reference to that + * value. The cv-qualifiers on the reference are the same as the + * cv-qualifiers on the _Mu object. [TR1 3.6.3/5 bullet 4] + */ + template<typename _Arg> + class _Mu<_Arg, false, false> + { + public: + template<typename _Signature> struct result; + + template<typename _CVMu, typename _CVArg, typename _Tuple> + struct result<_CVMu(_CVArg, _Tuple)> + { + typedef typename add_lvalue_reference<_CVArg>::type type; + }; + + // Pick up the cv-qualifiers of the argument + template<typename _CVArg, typename _Tuple> + _CVArg& + operator()(_CVArg& __arg, const _Tuple&) const volatile + { return __arg; } + }; + + /** + * Maps member pointers into instances of _Mem_fn but leaves all + * other function objects untouched. Used by tr1::bind(). The + * primary template handles the non--member-pointer case. + */ + template<typename _Tp> + struct _Maybe_wrap_member_pointer + { + typedef _Tp type; + + static const _Tp& + __do_wrap(const _Tp& __x) + { return __x; } + }; + + /** + * Maps member pointers into instances of _Mem_fn but leaves all + * other function objects untouched. Used by tr1::bind(). This + * partial specialization handles the member pointer case. + */ + template<typename _Tp, typename _Class> + struct _Maybe_wrap_member_pointer<_Tp _Class::*> + { + typedef _Mem_fn<_Tp _Class::*> type; + + static type + __do_wrap(_Tp _Class::* __pm) + { return type(__pm); } + }; + + /// Type of the function object returned from bind(). + template<typename _Signature> + struct _Bind; + + template<typename _Functor, typename... _Bound_args> + class _Bind<_Functor(_Bound_args...)> + : public _Weak_result_type<_Functor> + { + typedef _Bind __self_type; + typedef typename _Build_index_tuple<sizeof...(_Bound_args)>::__type + _Bound_indexes; + + _Functor _M_f; + tuple<_Bound_args...> _M_bound_args; + + // Call unqualified + template<typename... _Args, int... _Indexes> + typename result_of< + _Functor(typename result_of<_Mu<_Bound_args> + (_Bound_args, tuple<_Args...>)>::type...) + >::type + __call(const tuple<_Args...>& __args, _Index_tuple<_Indexes...>) + { + return _M_f(_Mu<_Bound_args>() + (get<_Indexes>(_M_bound_args), __args)...); + } + + // Call as const + template<typename... _Args, int... _Indexes> + typename result_of< + const _Functor(typename result_of<_Mu<_Bound_args> + (const _Bound_args, tuple<_Args...>) + >::type...)>::type + __call(const tuple<_Args...>& __args, _Index_tuple<_Indexes...>) const + { + return _M_f(_Mu<_Bound_args>() + (get<_Indexes>(_M_bound_args), __args)...); + } + + // Call as volatile + template<typename... _Args, int... _Indexes> + typename result_of< + volatile _Functor(typename result_of<_Mu<_Bound_args> + (volatile _Bound_args, tuple<_Args...>) + >::type...)>::type + __call(const tuple<_Args...>& __args, + _Index_tuple<_Indexes...>) volatile + { + return _M_f(_Mu<_Bound_args>() + (get<_Indexes>(_M_bound_args), __args)...); + } + + // Call as const volatile + template<typename... _Args, int... _Indexes> + typename result_of< + const volatile _Functor(typename result_of<_Mu<_Bound_args> + (const volatile _Bound_args, + tuple<_Args...>) + >::type...)>::type + __call(const tuple<_Args...>& __args, + _Index_tuple<_Indexes...>) const volatile + { + return _M_f(_Mu<_Bound_args>() + (get<_Indexes>(_M_bound_args), __args)...); + } + + public: + explicit _Bind(_Functor __f, _Bound_args... __bound_args) + : _M_f(__f), _M_bound_args(__bound_args...) { } + + // Call unqualified + template<typename... _Args> + typename result_of< + _Functor(typename result_of<_Mu<_Bound_args> + (_Bound_args, tuple<_Args...>)>::type...) + >::type + operator()(_Args&... __args) + { + return this->__call(tie(__args...), _Bound_indexes()); + } + + // Call as const + template<typename... _Args> + typename result_of< + const _Functor(typename result_of<_Mu<_Bound_args> + (const _Bound_args, tuple<_Args...>)>::type...) + >::type + operator()(_Args&... __args) const + { + return this->__call(tie(__args...), _Bound_indexes()); + } + + + // Call as volatile + template<typename... _Args> + typename result_of< + volatile _Functor(typename result_of<_Mu<_Bound_args> + (volatile _Bound_args, tuple<_Args...>)>::type...) + >::type + operator()(_Args&... __args) volatile + { + return this->__call(tie(__args...), _Bound_indexes()); + } + + + // Call as const volatile + template<typename... _Args> + typename result_of< + const volatile _Functor(typename result_of<_Mu<_Bound_args> + (const volatile _Bound_args, + tuple<_Args...>)>::type...) + >::type + operator()(_Args&... __args) const volatile + { + return this->__call(tie(__args...), _Bound_indexes()); + } + }; + + /// Type of the function object returned from bind<R>(). + template<typename _Result, typename _Signature> + struct _Bind_result; + + template<typename _Result, typename _Functor, typename... _Bound_args> + class _Bind_result<_Result, _Functor(_Bound_args...)> + { + typedef _Bind_result __self_type; + typedef typename _Build_index_tuple<sizeof...(_Bound_args)>::__type + _Bound_indexes; + + _Functor _M_f; + tuple<_Bound_args...> _M_bound_args; + + // Call unqualified + template<typename... _Args, int... _Indexes> + _Result + __call(const tuple<_Args...>& __args, _Index_tuple<_Indexes...>) + { + return _M_f(_Mu<_Bound_args>() + (get<_Indexes>(_M_bound_args), __args)...); + } + + // Call as const + template<typename... _Args, int... _Indexes> + _Result + __call(const tuple<_Args...>& __args, _Index_tuple<_Indexes...>) const + { + return _M_f(_Mu<_Bound_args>() + (get<_Indexes>(_M_bound_args), __args)...); + } + + // Call as volatile + template<typename... _Args, int... _Indexes> + _Result + __call(const tuple<_Args...>& __args, + _Index_tuple<_Indexes...>) volatile + { + return _M_f(_Mu<_Bound_args>() + (get<_Indexes>(_M_bound_args), __args)...); + } + + // Call as const volatile + template<typename... _Args, int... _Indexes> + _Result + __call(const tuple<_Args...>& __args, + _Index_tuple<_Indexes...>) const volatile + { + return _M_f(_Mu<_Bound_args>() + (get<_Indexes>(_M_bound_args), __args)...); + } + + public: + typedef _Result result_type; + + explicit + _Bind_result(_Functor __f, _Bound_args... __bound_args) + : _M_f(__f), _M_bound_args(__bound_args...) { } + + // Call unqualified + template<typename... _Args> + result_type + operator()(_Args&... __args) + { + return this->__call(tie(__args...), _Bound_indexes()); + } + + // Call as const + template<typename... _Args> + result_type + operator()(_Args&... __args) const + { + return this->__call(tie(__args...), _Bound_indexes()); + } + + // Call as volatile + template<typename... _Args> + result_type + operator()(_Args&... __args) volatile + { + return this->__call(tie(__args...), _Bound_indexes()); + } + + // Call as const volatile + template<typename... _Args> + result_type + operator()(_Args&... __args) const volatile + { + return this->__call(tie(__args...), _Bound_indexes()); + } + }; + + /// Class template _Bind is always a bind expression. + template<typename _Signature> + struct is_bind_expression<_Bind<_Signature> > + { static const bool value = true; }; + + template<typename _Signature> + const bool is_bind_expression<_Bind<_Signature> >::value; + + /// Class template _Bind_result is always a bind expression. + template<typename _Result, typename _Signature> + struct is_bind_expression<_Bind_result<_Result, _Signature> > + { static const bool value = true; }; + + template<typename _Result, typename _Signature> + const bool is_bind_expression<_Bind_result<_Result, _Signature> >::value; + + /// bind + template<typename _Functor, typename... _ArgTypes> + inline + _Bind<typename _Maybe_wrap_member_pointer<_Functor>::type(_ArgTypes...)> + bind(_Functor __f, _ArgTypes... __args) + { + typedef _Maybe_wrap_member_pointer<_Functor> __maybe_type; + typedef typename __maybe_type::type __functor_type; + typedef _Bind<__functor_type(_ArgTypes...)> __result_type; + return __result_type(__maybe_type::__do_wrap(__f), __args...); + } + + template<typename _Result, typename _Functor, typename... _ArgTypes> + inline + _Bind_result<_Result, + typename _Maybe_wrap_member_pointer<_Functor>::type + (_ArgTypes...)> + bind(_Functor __f, _ArgTypes... __args) + { + typedef _Maybe_wrap_member_pointer<_Functor> __maybe_type; + typedef typename __maybe_type::type __functor_type; + typedef _Bind_result<_Result, __functor_type(_ArgTypes...)> + __result_type; + return __result_type(__maybe_type::__do_wrap(__f), __args...); + } + + /** + * @brief Exception class thrown when class template function's + * operator() is called with an empty target. + * @ingroup exceptions + */ + class bad_function_call : public std::exception { }; + + /** + * The integral constant expression 0 can be converted into a + * pointer to this type. It is used by the function template to + * accept NULL pointers. + */ + struct _M_clear_type; + + /** + * Trait identifying "location-invariant" types, meaning that the + * address of the object (or any of its members) will not escape. + * Also implies a trivial copy constructor and assignment operator. + */ + template<typename _Tp> + struct __is_location_invariant + : integral_constant<bool, + (is_pointer<_Tp>::value + || is_member_pointer<_Tp>::value)> + { + }; + + class _Undefined_class; + + union _Nocopy_types + { + void* _M_object; + const void* _M_const_object; + void (*_M_function_pointer)(); + void (_Undefined_class::*_M_member_pointer)(); + }; + + union _Any_data + { + void* _M_access() { return &_M_pod_data[0]; } + const void* _M_access() const { return &_M_pod_data[0]; } + + template<typename _Tp> + _Tp& + _M_access() + { return *static_cast<_Tp*>(_M_access()); } + + template<typename _Tp> + const _Tp& + _M_access() const + { return *static_cast<const _Tp*>(_M_access()); } + + _Nocopy_types _M_unused; + char _M_pod_data[sizeof(_Nocopy_types)]; + }; + + enum _Manager_operation + { + __get_type_info, + __get_functor_ptr, + __clone_functor, + __destroy_functor + }; + + // Simple type wrapper that helps avoid annoying const problems + // when casting between void pointers and pointers-to-pointers. + template<typename _Tp> + struct _Simple_type_wrapper + { + _Simple_type_wrapper(_Tp __value) : __value(__value) { } + + _Tp __value; + }; + + template<typename _Tp> + struct __is_location_invariant<_Simple_type_wrapper<_Tp> > + : __is_location_invariant<_Tp> + { + }; + + // Converts a reference to a function object into a callable + // function object. + template<typename _Functor> + inline _Functor& + __callable_functor(_Functor& __f) + { return __f; } + + template<typename _Member, typename _Class> + inline _Mem_fn<_Member _Class::*> + __callable_functor(_Member _Class::* &__p) + { return mem_fn(__p); } + + template<typename _Member, typename _Class> + inline _Mem_fn<_Member _Class::*> + __callable_functor(_Member _Class::* const &__p) + { return mem_fn(__p); } + + template<typename _Signature> + class function; + + /// Base class of all polymorphic function object wrappers. + class _Function_base + { + public: + static const std::size_t _M_max_size = sizeof(_Nocopy_types); + static const std::size_t _M_max_align = __alignof__(_Nocopy_types); + + template<typename _Functor> + class _Base_manager + { + protected: + static const bool __stored_locally = + (__is_location_invariant<_Functor>::value + && sizeof(_Functor) <= _M_max_size + && __alignof__(_Functor) <= _M_max_align + && (_M_max_align % __alignof__(_Functor) == 0)); + + typedef integral_constant<bool, __stored_locally> _Local_storage; + + // Retrieve a pointer to the function object + static _Functor* + _M_get_pointer(const _Any_data& __source) + { + const _Functor* __ptr = + __stored_locally? &__source._M_access<_Functor>() + /* have stored a pointer */ : __source._M_access<_Functor*>(); + return const_cast<_Functor*>(__ptr); + } + + // Clone a location-invariant function object that fits within + // an _Any_data structure. + static void + _M_clone(_Any_data& __dest, const _Any_data& __source, true_type) + { + new (__dest._M_access()) _Functor(__source._M_access<_Functor>()); + } + + // Clone a function object that is not location-invariant or + // that cannot fit into an _Any_data structure. + static void + _M_clone(_Any_data& __dest, const _Any_data& __source, false_type) + { + __dest._M_access<_Functor*>() = + new _Functor(*__source._M_access<_Functor*>()); + } + + // Destroying a location-invariant object may still require + // destruction. + static void + _M_destroy(_Any_data& __victim, true_type) + { + __victim._M_access<_Functor>().~_Functor(); + } + + // Destroying an object located on the heap. + static void + _M_destroy(_Any_data& __victim, false_type) + { + delete __victim._M_access<_Functor*>(); + } + + public: + static bool + _M_manager(_Any_data& __dest, const _Any_data& __source, + _Manager_operation __op) + { + switch (__op) + { +#ifdef __GXX_RTTI + case __get_type_info: + __dest._M_access<const type_info*>() = &typeid(_Functor); + break; +#endif + case __get_functor_ptr: + __dest._M_access<_Functor*>() = _M_get_pointer(__source); + break; + + case __clone_functor: + _M_clone(__dest, __source, _Local_storage()); + break; + + case __destroy_functor: + _M_destroy(__dest, _Local_storage()); + break; + } + return false; + } + + static void + _M_init_functor(_Any_data& __functor, const _Functor& __f) + { _M_init_functor(__functor, __f, _Local_storage()); } + + template<typename _Signature> + static bool + _M_not_empty_function(const function<_Signature>& __f) + { return static_cast<bool>(__f); } + + template<typename _Tp> + static bool + _M_not_empty_function(const _Tp*& __fp) + { return __fp; } + + template<typename _Class, typename _Tp> + static bool + _M_not_empty_function(_Tp _Class::* const& __mp) + { return __mp; } + + template<typename _Tp> + static bool + _M_not_empty_function(const _Tp&) + { return true; } + + private: + static void + _M_init_functor(_Any_data& __functor, const _Functor& __f, true_type) + { new (__functor._M_access()) _Functor(__f); } + + static void + _M_init_functor(_Any_data& __functor, const _Functor& __f, false_type) + { __functor._M_access<_Functor*>() = new _Functor(__f); } + }; + + template<typename _Functor> + class _Ref_manager : public _Base_manager<_Functor*> + { + typedef _Function_base::_Base_manager<_Functor*> _Base; + + public: + static bool + _M_manager(_Any_data& __dest, const _Any_data& __source, + _Manager_operation __op) + { + switch (__op) + { +#ifdef __GXX_RTTI + case __get_type_info: + __dest._M_access<const type_info*>() = &typeid(_Functor); + break; #endif + case __get_functor_ptr: + __dest._M_access<_Functor*>() = *_Base::_M_get_pointer(__source); + return is_const<_Functor>::value; + break; + + default: + _Base::_M_manager(__dest, __source, __op); + } + return false; + } + + static void + _M_init_functor(_Any_data& __functor, reference_wrapper<_Functor> __f) + { + // TBD: Use address_of function instead. + _Base::_M_init_functor(__functor, &__f.get()); + } + }; + + _Function_base() : _M_manager(0) { } + + ~_Function_base() + { + if (_M_manager) + _M_manager(_M_functor, _M_functor, __destroy_functor); + } + + + bool _M_empty() const { return !_M_manager; } + + typedef bool (*_Manager_type)(_Any_data&, const _Any_data&, + _Manager_operation); + + _Any_data _M_functor; + _Manager_type _M_manager; + }; + + template<typename _Signature, typename _Functor> + class _Function_handler; + + template<typename _Res, typename _Functor, typename... _ArgTypes> + class _Function_handler<_Res(_ArgTypes...), _Functor> + : public _Function_base::_Base_manager<_Functor> + { + typedef _Function_base::_Base_manager<_Functor> _Base; + + public: + static _Res + _M_invoke(const _Any_data& __functor, _ArgTypes... __args) + { + return (*_Base::_M_get_pointer(__functor))( + std::forward<_ArgTypes>(__args)...); + } + }; + + template<typename _Functor, typename... _ArgTypes> + class _Function_handler<void(_ArgTypes...), _Functor> + : public _Function_base::_Base_manager<_Functor> + { + typedef _Function_base::_Base_manager<_Functor> _Base; + + public: + static void + _M_invoke(const _Any_data& __functor, _ArgTypes... __args) + { + (*_Base::_M_get_pointer(__functor))( + std::forward<_ArgTypes>(__args)...); + } + }; + + template<typename _Res, typename _Functor, typename... _ArgTypes> + class _Function_handler<_Res(_ArgTypes...), reference_wrapper<_Functor> > + : public _Function_base::_Ref_manager<_Functor> + { + typedef _Function_base::_Ref_manager<_Functor> _Base; + + public: + static _Res + _M_invoke(const _Any_data& __functor, _ArgTypes... __args) + { + return __callable_functor(**_Base::_M_get_pointer(__functor))( + std::forward<_ArgTypes>(__args)...); + } + }; + + template<typename _Functor, typename... _ArgTypes> + class _Function_handler<void(_ArgTypes...), reference_wrapper<_Functor> > + : public _Function_base::_Ref_manager<_Functor> + { + typedef _Function_base::_Ref_manager<_Functor> _Base; + + public: + static void + _M_invoke(const _Any_data& __functor, _ArgTypes... __args) + { + __callable_functor(**_Base::_M_get_pointer(__functor))( + std::forward<_ArgTypes>(__args)...); + } + }; + + template<typename _Class, typename _Member, typename _Res, + typename... _ArgTypes> + class _Function_handler<_Res(_ArgTypes...), _Member _Class::*> + : public _Function_handler<void(_ArgTypes...), _Member _Class::*> + { + typedef _Function_handler<void(_ArgTypes...), _Member _Class::*> + _Base; + + public: + static _Res + _M_invoke(const _Any_data& __functor, _ArgTypes... __args) + { + return mem_fn(_Base::_M_get_pointer(__functor)->__value)( + std::forward<_ArgTypes>(__args)...); + } + }; + + template<typename _Class, typename _Member, typename... _ArgTypes> + class _Function_handler<void(_ArgTypes...), _Member _Class::*> + : public _Function_base::_Base_manager< + _Simple_type_wrapper< _Member _Class::* > > + { + typedef _Member _Class::* _Functor; + typedef _Simple_type_wrapper<_Functor> _Wrapper; + typedef _Function_base::_Base_manager<_Wrapper> _Base; + + public: + static bool + _M_manager(_Any_data& __dest, const _Any_data& __source, + _Manager_operation __op) + { + switch (__op) + { +#ifdef __GXX_RTTI + case __get_type_info: + __dest._M_access<const type_info*>() = &typeid(_Functor); + break; +#endif + case __get_functor_ptr: + __dest._M_access<_Functor*>() = + &_Base::_M_get_pointer(__source)->__value; + break; + + default: + _Base::_M_manager(__dest, __source, __op); + } + return false; + } + + static void + _M_invoke(const _Any_data& __functor, _ArgTypes... __args) + { + mem_fn(_Base::_M_get_pointer(__functor)->__value)( + std::forward<_ArgTypes>(__args)...); + } + }; + + /// class function + template<typename _Res, typename... _ArgTypes> + class function<_Res(_ArgTypes...)> + : public _Maybe_unary_or_binary_function<_Res, _ArgTypes...>, + private _Function_base + { + typedef _Res _Signature_type(_ArgTypes...); + + struct _Useless { }; + + public: + typedef _Res result_type; + + // [3.7.2.1] construct/copy/destroy + + /** + * @brief Default construct creates an empty function call wrapper. + * @post @c !(bool)*this + */ + explicit + function() : _Function_base() { } + + /** + * @brief Default construct creates an empty function call wrapper. + * @post @c !(bool)*this + */ + function(_M_clear_type*) : _Function_base() { } + + /** + * @brief %Function copy constructor. + * @param x A %function object with identical call signature. + * @post @c (bool)*this == (bool)x + * + * The newly-created %function contains a copy of the target of @a + * x (if it has one). + */ + function(const function& __x); + + /** + * @brief %Function move constructor. + * @param x A %function object rvalue with identical call signature. + * + * The newly-created %function contains the target of @a x + * (if it has one). + */ + function(function&& __x) : _Function_base() + { + __x.swap(*this); + } + + // TODO: needs allocator_arg_t + + /** + * @brief Builds a %function that targets a copy of the incoming + * function object. + * @param f A %function object that is callable with parameters of + * type @c T1, @c T2, ..., @c TN and returns a value convertible + * to @c Res. + * + * The newly-created %function object will target a copy of @a + * f. If @a f is @c reference_wrapper<F>, then this function + * object will contain a reference to the function object @c + * f.get(). If @a f is a NULL function pointer or NULL + * pointer-to-member, the newly-created object will be empty. + * + * If @a f is a non-NULL function pointer or an object of type @c + * reference_wrapper<F>, this function will not throw. + */ + template<typename _Functor> + function(_Functor __f, + typename __gnu_cxx::__enable_if< + !is_integral<_Functor>::value, _Useless>::__type + = _Useless()); + + /** + * @brief %Function assignment operator. + * @param x A %function with identical call signature. + * @post @c (bool)*this == (bool)x + * @returns @c *this + * + * The target of @a x is copied to @c *this. If @a x has no + * target, then @c *this will be empty. + * + * If @a x targets a function pointer or a reference to a function + * object, then this operation will not throw an %exception. + */ + function& + operator=(const function& __x) + { + function(__x).swap(*this); + return *this; + } + + /** + * @brief %Function move-assignment operator. + * @param x A %function rvalue with identical call signature. + * @returns @c *this + * + * The target of @a x is moved to @c *this. If @a x has no + * target, then @c *this will be empty. + * + * If @a x targets a function pointer or a reference to a function + * object, then this operation will not throw an %exception. + */ + function& + operator=(function&& __x) + { + function(std::move(__x)).swap(*this); + return *this; + } + + /** + * @brief %Function assignment to zero. + * @post @c !(bool)*this + * @returns @c *this + * + * The target of @c *this is deallocated, leaving it empty. + */ + function& + operator=(_M_clear_type*) + { + if (_M_manager) + { + _M_manager(_M_functor, _M_functor, __destroy_functor); + _M_manager = 0; + _M_invoker = 0; + } + return *this; + } + + /** + * @brief %Function assignment to a new target. + * @param f A %function object that is callable with parameters of + * type @c T1, @c T2, ..., @c TN and returns a value convertible + * to @c Res. + * @return @c *this + * + * This %function object wrapper will target a copy of @a + * f. If @a f is @c reference_wrapper<F>, then this function + * object will contain a reference to the function object @c + * f.get(). If @a f is a NULL function pointer or NULL + * pointer-to-member, @c this object will be empty. + * + * If @a f is a non-NULL function pointer or an object of type @c + * reference_wrapper<F>, this function will not throw. + */ + template<typename _Functor> + typename __gnu_cxx::__enable_if<!is_integral<_Functor>::value, + function&>::__type + operator=(_Functor __f) + { + function(__f).swap(*this); + return *this; + } + + /// @overload + template<typename _Functor> + typename __gnu_cxx::__enable_if<!is_integral<_Functor>::value, + function&>::__type + operator=(reference_wrapper<_Functor> __f) + { + function(__f).swap(*this); + return *this; + } + + // [3.7.2.2] function modifiers + + /** + * @brief Swap the targets of two %function objects. + * @param f A %function with identical call signature. + * + * Swap the targets of @c this function object and @a f. This + * function will not throw an %exception. + */ + void swap(function& __x) + { + _Any_data __old_functor = _M_functor; + _M_functor = __x._M_functor; + __x._M_functor = __old_functor; + _Manager_type __old_manager = _M_manager; + _M_manager = __x._M_manager; + __x._M_manager = __old_manager; + _Invoker_type __old_invoker = _M_invoker; + _M_invoker = __x._M_invoker; + __x._M_invoker = __old_invoker; + } + + // TODO: needs allocator_arg_t + /* + template<typename _Functor, typename _Alloc> + void + assign(_Functor __f, const _Alloc& __a) + { + function(__f, __a).swap(*this); + } + */ + + // [3.7.2.3] function capacity + + /** + * @brief Determine if the %function wrapper has a target. + * + * @return @c true when this %function object contains a target, + * or @c false when it is empty. + * + * This function will not throw an %exception. + */ + explicit operator bool() const + { return !_M_empty(); } + + // [3.7.2.4] function invocation + + /** + * @brief Invokes the function targeted by @c *this. + * @returns the result of the target. + * @throws bad_function_call when @c !(bool)*this + * + * The function call operator invokes the target function object + * stored by @c this. + */ + _Res operator()(_ArgTypes... __args) const; + +#ifdef __GXX_RTTI + // [3.7.2.5] function target access + /** + * @brief Determine the type of the target of this function object + * wrapper. + * + * @returns the type identifier of the target function object, or + * @c typeid(void) if @c !(bool)*this. + * + * This function will not throw an %exception. + */ + const type_info& target_type() const; + + /** + * @brief Access the stored target function object. + * + * @return Returns a pointer to the stored target function object, + * if @c typeid(Functor).equals(target_type()); otherwise, a NULL + * pointer. + * + * This function will not throw an %exception. + */ + template<typename _Functor> _Functor* target(); + + /// @overload + template<typename _Functor> const _Functor* target() const; +#endif + + // deleted overloads + template<typename _Res2, typename... _ArgTypes2> + void operator==(const function<_Res2(_ArgTypes2...)>&) const = delete; + template<typename _Res2, typename... _ArgTypes2> + void operator!=(const function<_Res2(_ArgTypes2...)>&) const = delete; + + private: + typedef _Res (*_Invoker_type)(const _Any_data&, _ArgTypes...); + _Invoker_type _M_invoker; + }; + + template<typename _Res, typename... _ArgTypes> + function<_Res(_ArgTypes...)>:: + function(const function& __x) + : _Function_base() + { + if (static_cast<bool>(__x)) + { + _M_invoker = __x._M_invoker; + _M_manager = __x._M_manager; + __x._M_manager(_M_functor, __x._M_functor, __clone_functor); + } + } + + template<typename _Res, typename... _ArgTypes> + template<typename _Functor> + function<_Res(_ArgTypes...)>:: + function(_Functor __f, + typename __gnu_cxx::__enable_if< + !is_integral<_Functor>::value, _Useless>::__type) + : _Function_base() + { + typedef _Function_handler<_Signature_type, _Functor> _My_handler; + + if (_My_handler::_M_not_empty_function(__f)) + { + _M_invoker = &_My_handler::_M_invoke; + _M_manager = &_My_handler::_M_manager; + _My_handler::_M_init_functor(_M_functor, __f); + } + } + + template<typename _Res, typename... _ArgTypes> + _Res + function<_Res(_ArgTypes...)>:: + operator()(_ArgTypes... __args) const + { + if (_M_empty()) + { +#if __EXCEPTIONS + throw bad_function_call(); +#else + __builtin_abort(); +#endif + } + return _M_invoker(_M_functor, std::forward<_ArgTypes>(__args)...); + } + +#ifdef __GXX_RTTI + template<typename _Res, typename... _ArgTypes> + const type_info& + function<_Res(_ArgTypes...)>:: + target_type() const + { + if (_M_manager) + { + _Any_data __typeinfo_result; + _M_manager(__typeinfo_result, _M_functor, __get_type_info); + return *__typeinfo_result._M_access<const type_info*>(); + } + else + return typeid(void); + } + + template<typename _Res, typename... _ArgTypes> + template<typename _Functor> + _Functor* + function<_Res(_ArgTypes...)>:: + target() + { + if (typeid(_Functor) == target_type() && _M_manager) + { + _Any_data __ptr; + if (_M_manager(__ptr, _M_functor, __get_functor_ptr) + && !is_const<_Functor>::value) + return 0; + else + return __ptr._M_access<_Functor*>(); + } + else + return 0; + } + + template<typename _Res, typename... _ArgTypes> + template<typename _Functor> + const _Functor* + function<_Res(_ArgTypes...)>:: + target() const + { + if (typeid(_Functor) == target_type() && _M_manager) + { + _Any_data __ptr; + _M_manager(__ptr, _M_functor, __get_functor_ptr); + return __ptr._M_access<const _Functor*>(); + } + else + return 0; + } +#endif + + // [20.7.15.2.6] null pointer comparisons + + /** + * @brief Compares a polymorphic function object wrapper against 0 + * (the NULL pointer). + * @returns @c true if the wrapper has no target, @c false otherwise + * + * This function will not throw an %exception. + */ + template<typename _Res, typename... _Args> + inline bool + operator==(const function<_Res(_Args...)>& __f, _M_clear_type*) + { return !static_cast<bool>(__f); } + + /// @overload + template<typename _Res, typename... _Args> + inline bool + operator==(_M_clear_type*, const function<_Res(_Args...)>& __f) + { return !static_cast<bool>(__f); } + + /** + * @brief Compares a polymorphic function object wrapper against 0 + * (the NULL pointer). + * @returns @c false if the wrapper has no target, @c true otherwise + * + * This function will not throw an %exception. + */ + template<typename _Res, typename... _Args> + inline bool + operator!=(const function<_Res(_Args...)>& __f, _M_clear_type*) + { return static_cast<bool>(__f); } + + /// @overload + template<typename _Res, typename... _Args> + inline bool + operator!=(_M_clear_type*, const function<_Res(_Args...)>& __f) + { return static_cast<bool>(__f); } + + // [20.7.15.2.7] specialized algorithms + + /** + * @brief Swap the targets of two polymorphic function object wrappers. + * + * This function will not throw an %exception. + */ + template<typename _Res, typename... _Args> + inline void + swap(function<_Res(_Args...)>& __x, function<_Res(_Args...)>& __y) + { __x.swap(__y); } +} + +#endif // __GXX_EXPERIMENTAL_CXX0X__ #endif // _GLIBCXX_FUNCTIONAL diff --git a/libstdc++-v3/include/tr1/functional b/libstdc++-v3/include/tr1/functional index 3deaa5ea56d..4825509aed7 100644 --- a/libstdc++-v3/include/tr1/functional +++ b/libstdc++-v3/include/tr1/functional @@ -31,10 +31,6 @@ #pragma GCC system_header -#if defined(_GLIBCXX_INCLUDE_AS_CXX0X) -# error TR1 header cannot be included from C++0x header -#endif - #include <bits/c++config.h> #include <bits/stl_function.h> @@ -46,18 +42,2102 @@ #include <tr1/functional_hash.h> #include <ext/type_traits.h> -#if defined(_GLIBCXX_INCLUDE_AS_TR1) -# include <tr1_impl/functional> +namespace std +{ +namespace tr1 +{ + template<typename _MemberPointer> + class _Mem_fn; + + /** + * Actual implementation of _Has_result_type, which uses SFINAE to + * determine if the type _Tp has a publicly-accessible member type + * result_type. + */ + template<typename _Tp> + class _Has_result_type_helper : __sfinae_types + { + template<typename _Up> + struct _Wrap_type + { }; + + template<typename _Up> + static __one __test(_Wrap_type<typename _Up::result_type>*); + + template<typename _Up> + static __two __test(...); + + public: + static const bool value = sizeof(__test<_Tp>(0)) == 1; + }; + + template<typename _Tp> + struct _Has_result_type + : integral_constant<bool, + _Has_result_type_helper<typename remove_cv<_Tp>::type>::value> + { }; + + /** + * + */ + /// If we have found a result_type, extract it. + template<bool _Has_result_type, typename _Functor> + struct _Maybe_get_result_type + { }; + + template<typename _Functor> + struct _Maybe_get_result_type<true, _Functor> + { + typedef typename _Functor::result_type result_type; + }; + + /** + * Base class for any function object that has a weak result type, as + * defined in 3.3/3 of TR1. + */ + template<typename _Functor> + struct _Weak_result_type_impl + : _Maybe_get_result_type<_Has_result_type<_Functor>::value, _Functor> + { + }; + + /// Retrieve the result type for a function type. + template<typename _Res, typename... _ArgTypes> + struct _Weak_result_type_impl<_Res(_ArgTypes...)> + { + typedef _Res result_type; + }; + + /// Retrieve the result type for a function reference. + template<typename _Res, typename... _ArgTypes> + struct _Weak_result_type_impl<_Res(&)(_ArgTypes...)> + { + typedef _Res result_type; + }; + + /// Retrieve the result type for a function pointer. + template<typename _Res, typename... _ArgTypes> + struct _Weak_result_type_impl<_Res(*)(_ArgTypes...)> + { + typedef _Res result_type; + }; + + /// Retrieve result type for a member function pointer. + template<typename _Res, typename _Class, typename... _ArgTypes> + struct _Weak_result_type_impl<_Res (_Class::*)(_ArgTypes...)> + { + typedef _Res result_type; + }; + + /// Retrieve result type for a const member function pointer. + template<typename _Res, typename _Class, typename... _ArgTypes> + struct _Weak_result_type_impl<_Res (_Class::*)(_ArgTypes...) const> + { + typedef _Res result_type; + }; + + /// Retrieve result type for a volatile member function pointer. + template<typename _Res, typename _Class, typename... _ArgTypes> + struct _Weak_result_type_impl<_Res (_Class::*)(_ArgTypes...) volatile> + { + typedef _Res result_type; + }; + + /// Retrieve result type for a const volatile member function pointer. + template<typename _Res, typename _Class, typename... _ArgTypes> + struct _Weak_result_type_impl<_Res (_Class::*)(_ArgTypes...)const volatile> + { + typedef _Res result_type; + }; + + /** + * Strip top-level cv-qualifiers from the function object and let + * _Weak_result_type_impl perform the real work. + */ + template<typename _Functor> + struct _Weak_result_type + : _Weak_result_type_impl<typename remove_cv<_Functor>::type> + { + }; + + template<typename _Signature> + class result_of; + + /** + * Actual implementation of result_of. When _Has_result_type is + * true, gets its result from _Weak_result_type. Otherwise, uses + * the function object's member template result to extract the + * result type. + */ + template<bool _Has_result_type, typename _Signature> + struct _Result_of_impl; + + // Handle member data pointers using _Mem_fn's logic + template<typename _Res, typename _Class, typename _T1> + struct _Result_of_impl<false, _Res _Class::*(_T1)> + { + typedef typename _Mem_fn<_Res _Class::*> + ::template _Result_type<_T1>::type type; + }; + + /** + * Determine whether we can determine a result type from @c Functor + * alone. + */ + template<typename _Functor, typename... _ArgTypes> + class result_of<_Functor(_ArgTypes...)> + : public _Result_of_impl< + _Has_result_type<_Weak_result_type<_Functor> >::value, + _Functor(_ArgTypes...)> + { + }; + + /// We already know the result type for @c Functor; use it. + template<typename _Functor, typename... _ArgTypes> + struct _Result_of_impl<true, _Functor(_ArgTypes...)> + { + typedef typename _Weak_result_type<_Functor>::result_type type; + }; + + /** + * We need to compute the result type for this invocation the hard + * way. + */ + template<typename _Functor, typename... _ArgTypes> + struct _Result_of_impl<false, _Functor(_ArgTypes...)> + { + typedef typename _Functor + ::template result<_Functor(_ArgTypes...)>::type type; + }; + + /** + * It is unsafe to access ::result when there are zero arguments, so we + * return @c void instead. + */ + template<typename _Functor> + struct _Result_of_impl<false, _Functor()> + { + typedef void type; + }; + + /// Determines if the type _Tp derives from unary_function. + template<typename _Tp> + struct _Derives_from_unary_function : __sfinae_types + { + private: + template<typename _T1, typename _Res> + static __one __test(const volatile unary_function<_T1, _Res>*); + + // It's tempting to change "..." to const volatile void*, but + // that fails when _Tp is a function type. + static __two __test(...); + + public: + static const bool value = sizeof(__test((_Tp*)0)) == 1; + }; + + /// Determines if the type _Tp derives from binary_function. + template<typename _Tp> + struct _Derives_from_binary_function : __sfinae_types + { + private: + template<typename _T1, typename _T2, typename _Res> + static __one __test(const volatile binary_function<_T1, _T2, _Res>*); + + // It's tempting to change "..." to const volatile void*, but + // that fails when _Tp is a function type. + static __two __test(...); + + public: + static const bool value = sizeof(__test((_Tp*)0)) == 1; + }; + + /// Turns a function type into a function pointer type + template<typename _Tp, bool _IsFunctionType = is_function<_Tp>::value> + struct _Function_to_function_pointer + { + typedef _Tp type; + }; + + template<typename _Tp> + struct _Function_to_function_pointer<_Tp, true> + { + typedef _Tp* type; + }; + + /** + * Invoke a function object, which may be either a member pointer or a + * function object. The first parameter will tell which. + */ + template<typename _Functor, typename... _Args> + inline + typename __gnu_cxx::__enable_if< + (!is_member_pointer<_Functor>::value + && !is_function<_Functor>::value + && !is_function<typename remove_pointer<_Functor>::type>::value), + typename result_of<_Functor(_Args...)>::type + >::__type + __invoke(_Functor& __f, _Args&... __args) + { + return __f(__args...); + } + + template<typename _Functor, typename... _Args> + inline + typename __gnu_cxx::__enable_if< + (is_member_pointer<_Functor>::value + && !is_function<_Functor>::value + && !is_function<typename remove_pointer<_Functor>::type>::value), + typename result_of<_Functor(_Args...)>::type + >::__type + __invoke(_Functor& __f, _Args&... __args) + { + return mem_fn(__f)(__args...); + } + + // To pick up function references (that will become function pointers) + template<typename _Functor, typename... _Args> + inline + typename __gnu_cxx::__enable_if< + (is_pointer<_Functor>::value + && is_function<typename remove_pointer<_Functor>::type>::value), + typename result_of<_Functor(_Args...)>::type + >::__type + __invoke(_Functor __f, _Args&... __args) + { + return __f(__args...); + } + + /** + * Knowing which of unary_function and binary_function _Tp derives + * from, derives from the same and ensures that reference_wrapper + * will have a weak result type. See cases below. + */ + template<bool _Unary, bool _Binary, typename _Tp> + struct _Reference_wrapper_base_impl; + + // Not a unary_function or binary_function, so try a weak result type. + template<typename _Tp> + struct _Reference_wrapper_base_impl<false, false, _Tp> + : _Weak_result_type<_Tp> + { }; + + // unary_function but not binary_function + template<typename _Tp> + struct _Reference_wrapper_base_impl<true, false, _Tp> + : unary_function<typename _Tp::argument_type, + typename _Tp::result_type> + { }; + + // binary_function but not unary_function + template<typename _Tp> + struct _Reference_wrapper_base_impl<false, true, _Tp> + : binary_function<typename _Tp::first_argument_type, + typename _Tp::second_argument_type, + typename _Tp::result_type> + { }; + + // Both unary_function and binary_function. Import result_type to + // avoid conflicts. + template<typename _Tp> + struct _Reference_wrapper_base_impl<true, true, _Tp> + : unary_function<typename _Tp::argument_type, + typename _Tp::result_type>, + binary_function<typename _Tp::first_argument_type, + typename _Tp::second_argument_type, + typename _Tp::result_type> + { + typedef typename _Tp::result_type result_type; + }; + + /** + * Derives from unary_function or binary_function when it + * can. Specializations handle all of the easy cases. The primary + * template determines what to do with a class type, which may + * derive from both unary_function and binary_function. + */ + template<typename _Tp> + struct _Reference_wrapper_base + : _Reference_wrapper_base_impl< + _Derives_from_unary_function<_Tp>::value, + _Derives_from_binary_function<_Tp>::value, + _Tp> + { }; + + // - a function type (unary) + template<typename _Res, typename _T1> + struct _Reference_wrapper_base<_Res(_T1)> + : unary_function<_T1, _Res> + { }; + + // - a function type (binary) + template<typename _Res, typename _T1, typename _T2> + struct _Reference_wrapper_base<_Res(_T1, _T2)> + : binary_function<_T1, _T2, _Res> + { }; + + // - a function pointer type (unary) + template<typename _Res, typename _T1> + struct _Reference_wrapper_base<_Res(*)(_T1)> + : unary_function<_T1, _Res> + { }; + + // - a function pointer type (binary) + template<typename _Res, typename _T1, typename _T2> + struct _Reference_wrapper_base<_Res(*)(_T1, _T2)> + : binary_function<_T1, _T2, _Res> + { }; + + // - a pointer to member function type (unary, no qualifiers) + template<typename _Res, typename _T1> + struct _Reference_wrapper_base<_Res (_T1::*)()> + : unary_function<_T1*, _Res> + { }; + + // - a pointer to member function type (binary, no qualifiers) + template<typename _Res, typename _T1, typename _T2> + struct _Reference_wrapper_base<_Res (_T1::*)(_T2)> + : binary_function<_T1*, _T2, _Res> + { }; + + // - a pointer to member function type (unary, const) + template<typename _Res, typename _T1> + struct _Reference_wrapper_base<_Res (_T1::*)() const> + : unary_function<const _T1*, _Res> + { }; + + // - a pointer to member function type (binary, const) + template<typename _Res, typename _T1, typename _T2> + struct _Reference_wrapper_base<_Res (_T1::*)(_T2) const> + : binary_function<const _T1*, _T2, _Res> + { }; + + // - a pointer to member function type (unary, volatile) + template<typename _Res, typename _T1> + struct _Reference_wrapper_base<_Res (_T1::*)() volatile> + : unary_function<volatile _T1*, _Res> + { }; + + // - a pointer to member function type (binary, volatile) + template<typename _Res, typename _T1, typename _T2> + struct _Reference_wrapper_base<_Res (_T1::*)(_T2) volatile> + : binary_function<volatile _T1*, _T2, _Res> + { }; + + // - a pointer to member function type (unary, const volatile) + template<typename _Res, typename _T1> + struct _Reference_wrapper_base<_Res (_T1::*)() const volatile> + : unary_function<const volatile _T1*, _Res> + { }; + + // - a pointer to member function type (binary, const volatile) + template<typename _Res, typename _T1, typename _T2> + struct _Reference_wrapper_base<_Res (_T1::*)(_T2) const volatile> + : binary_function<const volatile _T1*, _T2, _Res> + { }; + + /// reference_wrapper + template<typename _Tp> + class reference_wrapper + : public _Reference_wrapper_base<typename remove_cv<_Tp>::type> + { + // If _Tp is a function type, we can't form result_of<_Tp(...)>, + // so turn it into a function pointer type. + typedef typename _Function_to_function_pointer<_Tp>::type + _M_func_type; + + _Tp* _M_data; + public: + typedef _Tp type; + + explicit + reference_wrapper(_Tp& __indata): _M_data(&__indata) + { } + + reference_wrapper(const reference_wrapper<_Tp>& __inref): + _M_data(__inref._M_data) + { } + + reference_wrapper& + operator=(const reference_wrapper<_Tp>& __inref) + { + _M_data = __inref._M_data; + return *this; + } + + operator _Tp&() const + { return this->get(); } + + _Tp& + get() const + { return *_M_data; } + + template<typename... _Args> + typename result_of<_M_func_type(_Args...)>::type + operator()(_Args&... __args) const + { + return __invoke(get(), __args...); + } + }; + + + // Denotes a reference should be taken to a variable. + template<typename _Tp> + inline reference_wrapper<_Tp> + ref(_Tp& __t) + { return reference_wrapper<_Tp>(__t); } + + // Denotes a const reference should be taken to a variable. + template<typename _Tp> + inline reference_wrapper<const _Tp> + cref(const _Tp& __t) + { return reference_wrapper<const _Tp>(__t); } + + template<typename _Tp> + inline reference_wrapper<_Tp> + ref(reference_wrapper<_Tp> __t) + { return ref(__t.get()); } + + template<typename _Tp> + inline reference_wrapper<const _Tp> + cref(reference_wrapper<_Tp> __t) + { return cref(__t.get()); } + + template<typename _Tp, bool> + struct _Mem_fn_const_or_non + { + typedef const _Tp& type; + }; + + template<typename _Tp> + struct _Mem_fn_const_or_non<_Tp, false> + { + typedef _Tp& type; + }; + + /** + * Derives from @c unary_function or @c binary_function, or perhaps + * nothing, depending on the number of arguments provided. The + * primary template is the basis case, which derives nothing. + */ + template<typename _Res, typename... _ArgTypes> + struct _Maybe_unary_or_binary_function { }; + + /// Derives from @c unary_function, as appropriate. + template<typename _Res, typename _T1> + struct _Maybe_unary_or_binary_function<_Res, _T1> + : std::unary_function<_T1, _Res> { }; + + /// Derives from @c binary_function, as appropriate. + template<typename _Res, typename _T1, typename _T2> + struct _Maybe_unary_or_binary_function<_Res, _T1, _T2> + : std::binary_function<_T1, _T2, _Res> { }; + + /// Implementation of @c mem_fn for member function pointers. + template<typename _Res, typename _Class, typename... _ArgTypes> + class _Mem_fn<_Res (_Class::*)(_ArgTypes...)> + : public _Maybe_unary_or_binary_function<_Res, _Class*, _ArgTypes...> + { + typedef _Res (_Class::*_Functor)(_ArgTypes...); + + template<typename _Tp> + _Res + _M_call(_Tp& __object, const volatile _Class *, + _ArgTypes... __args) const + { return (__object.*__pmf)(__args...); } + + template<typename _Tp> + _Res + _M_call(_Tp& __ptr, const volatile void *, _ArgTypes... __args) const + { return ((*__ptr).*__pmf)(__args...); } + + public: + typedef _Res result_type; + + explicit _Mem_fn(_Functor __pmf) : __pmf(__pmf) { } + + // Handle objects + _Res + operator()(_Class& __object, _ArgTypes... __args) const + { return (__object.*__pmf)(__args...); } + + // Handle pointers + _Res + operator()(_Class* __object, _ArgTypes... __args) const + { return (__object->*__pmf)(__args...); } + + // Handle smart pointers, references and pointers to derived + template<typename _Tp> + _Res + operator()(_Tp& __object, _ArgTypes... __args) const + { return _M_call(__object, &__object, __args...); } + + private: + _Functor __pmf; + }; + + /// Implementation of @c mem_fn for const member function pointers. + template<typename _Res, typename _Class, typename... _ArgTypes> + class _Mem_fn<_Res (_Class::*)(_ArgTypes...) const> + : public _Maybe_unary_or_binary_function<_Res, const _Class*, + _ArgTypes...> + { + typedef _Res (_Class::*_Functor)(_ArgTypes...) const; + + template<typename _Tp> + _Res + _M_call(_Tp& __object, const volatile _Class *, + _ArgTypes... __args) const + { return (__object.*__pmf)(__args...); } + + template<typename _Tp> + _Res + _M_call(_Tp& __ptr, const volatile void *, _ArgTypes... __args) const + { return ((*__ptr).*__pmf)(__args...); } + + public: + typedef _Res result_type; + + explicit _Mem_fn(_Functor __pmf) : __pmf(__pmf) { } + + // Handle objects + _Res + operator()(const _Class& __object, _ArgTypes... __args) const + { return (__object.*__pmf)(__args...); } + + // Handle pointers + _Res + operator()(const _Class* __object, _ArgTypes... __args) const + { return (__object->*__pmf)(__args...); } + + // Handle smart pointers, references and pointers to derived + template<typename _Tp> + _Res operator()(_Tp& __object, _ArgTypes... __args) const + { return _M_call(__object, &__object, __args...); } + + private: + _Functor __pmf; + }; + + /// Implementation of @c mem_fn for volatile member function pointers. + template<typename _Res, typename _Class, typename... _ArgTypes> + class _Mem_fn<_Res (_Class::*)(_ArgTypes...) volatile> + : public _Maybe_unary_or_binary_function<_Res, volatile _Class*, + _ArgTypes...> + { + typedef _Res (_Class::*_Functor)(_ArgTypes...) volatile; + + template<typename _Tp> + _Res + _M_call(_Tp& __object, const volatile _Class *, + _ArgTypes... __args) const + { return (__object.*__pmf)(__args...); } + + template<typename _Tp> + _Res + _M_call(_Tp& __ptr, const volatile void *, _ArgTypes... __args) const + { return ((*__ptr).*__pmf)(__args...); } + + public: + typedef _Res result_type; + + explicit _Mem_fn(_Functor __pmf) : __pmf(__pmf) { } + + // Handle objects + _Res + operator()(volatile _Class& __object, _ArgTypes... __args) const + { return (__object.*__pmf)(__args...); } + + // Handle pointers + _Res + operator()(volatile _Class* __object, _ArgTypes... __args) const + { return (__object->*__pmf)(__args...); } + + // Handle smart pointers, references and pointers to derived + template<typename _Tp> + _Res + operator()(_Tp& __object, _ArgTypes... __args) const + { return _M_call(__object, &__object, __args...); } + + private: + _Functor __pmf; + }; + + /// Implementation of @c mem_fn for const volatile member function pointers. + template<typename _Res, typename _Class, typename... _ArgTypes> + class _Mem_fn<_Res (_Class::*)(_ArgTypes...) const volatile> + : public _Maybe_unary_or_binary_function<_Res, const volatile _Class*, + _ArgTypes...> + { + typedef _Res (_Class::*_Functor)(_ArgTypes...) const volatile; + + template<typename _Tp> + _Res + _M_call(_Tp& __object, const volatile _Class *, + _ArgTypes... __args) const + { return (__object.*__pmf)(__args...); } + + template<typename _Tp> + _Res + _M_call(_Tp& __ptr, const volatile void *, _ArgTypes... __args) const + { return ((*__ptr).*__pmf)(__args...); } + + public: + typedef _Res result_type; + + explicit _Mem_fn(_Functor __pmf) : __pmf(__pmf) { } + + // Handle objects + _Res + operator()(const volatile _Class& __object, _ArgTypes... __args) const + { return (__object.*__pmf)(__args...); } + + // Handle pointers + _Res + operator()(const volatile _Class* __object, _ArgTypes... __args) const + { return (__object->*__pmf)(__args...); } + + // Handle smart pointers, references and pointers to derived + template<typename _Tp> + _Res operator()(_Tp& __object, _ArgTypes... __args) const + { return _M_call(__object, &__object, __args...); } + + private: + _Functor __pmf; + }; + + + template<typename _Res, typename _Class> + class _Mem_fn<_Res _Class::*> + { + // This bit of genius is due to Peter Dimov, improved slightly by + // Douglas Gregor. + template<typename _Tp> + _Res& + _M_call(_Tp& __object, _Class *) const + { return __object.*__pm; } + + template<typename _Tp, typename _Up> + _Res& + _M_call(_Tp& __object, _Up * const *) const + { return (*__object).*__pm; } + + template<typename _Tp, typename _Up> + const _Res& + _M_call(_Tp& __object, const _Up * const *) const + { return (*__object).*__pm; } + + template<typename _Tp> + const _Res& + _M_call(_Tp& __object, const _Class *) const + { return __object.*__pm; } + + template<typename _Tp> + const _Res& + _M_call(_Tp& __ptr, const volatile void*) const + { return (*__ptr).*__pm; } + + template<typename _Tp> static _Tp& __get_ref(); + + template<typename _Tp> + static __sfinae_types::__one __check_const(_Tp&, _Class*); + template<typename _Tp, typename _Up> + static __sfinae_types::__one __check_const(_Tp&, _Up * const *); + template<typename _Tp, typename _Up> + static __sfinae_types::__two __check_const(_Tp&, const _Up * const *); + template<typename _Tp> + static __sfinae_types::__two __check_const(_Tp&, const _Class*); + template<typename _Tp> + static __sfinae_types::__two __check_const(_Tp&, const volatile void*); + + public: + template<typename _Tp> + struct _Result_type + : _Mem_fn_const_or_non<_Res, + (sizeof(__sfinae_types::__two) + == sizeof(__check_const<_Tp>(__get_ref<_Tp>(), (_Tp*)0)))> + { }; + + template<typename _Signature> + struct result; + + template<typename _CVMem, typename _Tp> + struct result<_CVMem(_Tp)> + : public _Result_type<_Tp> { }; + + template<typename _CVMem, typename _Tp> + struct result<_CVMem(_Tp&)> + : public _Result_type<_Tp> { }; + + explicit + _Mem_fn(_Res _Class::*__pm) : __pm(__pm) { } + + // Handle objects + _Res& + operator()(_Class& __object) const + { return __object.*__pm; } + + const _Res& + operator()(const _Class& __object) const + { return __object.*__pm; } + + // Handle pointers + _Res& + operator()(_Class* __object) const + { return __object->*__pm; } + + const _Res& + operator()(const _Class* __object) const + { return __object->*__pm; } + + // Handle smart pointers and derived + template<typename _Tp> + typename _Result_type<_Tp>::type + operator()(_Tp& __unknown) const + { return _M_call(__unknown, &__unknown); } + + private: + _Res _Class::*__pm; + }; + + /** + * @brief Returns a function object that forwards to the member + * pointer @a pm. + */ + template<typename _Tp, typename _Class> + inline _Mem_fn<_Tp _Class::*> + mem_fn(_Tp _Class::* __pm) + { + return _Mem_fn<_Tp _Class::*>(__pm); + } + + /** + * @brief Determines if the given type _Tp is a function object + * should be treated as a subexpression when evaluating calls to + * function objects returned by bind(). [TR1 3.6.1] + */ + template<typename _Tp> + struct is_bind_expression + { static const bool value = false; }; + + template<typename _Tp> + const bool is_bind_expression<_Tp>::value; + + /** + * @brief Determines if the given type _Tp is a placeholder in a + * bind() expression and, if so, which placeholder it is. [TR1 3.6.2] + */ + template<typename _Tp> + struct is_placeholder + { static const int value = 0; }; + + template<typename _Tp> + const int is_placeholder<_Tp>::value; + + /// The type of placeholder objects defined by libstdc++. + template<int _Num> struct _Placeholder { }; + + /** @namespace std::placeholders + * @brief ISO C++ 0x entities sub namespace for functional. + * + * Define a large number of placeholders. There is no way to + * simplify this with variadic templates, because we're introducing + * unique names for each. + */ + namespace placeholders + { + namespace + { + _Placeholder<1> _1; + _Placeholder<2> _2; + _Placeholder<3> _3; + _Placeholder<4> _4; + _Placeholder<5> _5; + _Placeholder<6> _6; + _Placeholder<7> _7; + _Placeholder<8> _8; + _Placeholder<9> _9; + _Placeholder<10> _10; + _Placeholder<11> _11; + _Placeholder<12> _12; + _Placeholder<13> _13; + _Placeholder<14> _14; + _Placeholder<15> _15; + _Placeholder<16> _16; + _Placeholder<17> _17; + _Placeholder<18> _18; + _Placeholder<19> _19; + _Placeholder<20> _20; + _Placeholder<21> _21; + _Placeholder<22> _22; + _Placeholder<23> _23; + _Placeholder<24> _24; + _Placeholder<25> _25; + _Placeholder<26> _26; + _Placeholder<27> _27; + _Placeholder<28> _28; + _Placeholder<29> _29; + } + } + + /** + * Partial specialization of is_placeholder that provides the placeholder + * number for the placeholder objects defined by libstdc++. + */ + template<int _Num> + struct is_placeholder<_Placeholder<_Num> > + { static const int value = _Num; }; + + template<int _Num> + const int is_placeholder<_Placeholder<_Num> >::value; + + /** + * Stores a tuple of indices. Used by bind() to extract the elements + * in a tuple. + */ + template<int... _Indexes> + struct _Index_tuple { }; + + /// Builds an _Index_tuple<0, 1, 2, ..., _Num-1>. + template<std::size_t _Num, typename _Tuple = _Index_tuple<> > + struct _Build_index_tuple; + + template<std::size_t _Num, int... _Indexes> + struct _Build_index_tuple<_Num, _Index_tuple<_Indexes...> > + : _Build_index_tuple<_Num - 1, + _Index_tuple<_Indexes..., sizeof...(_Indexes)> > + { + }; + + template<int... _Indexes> + struct _Build_index_tuple<0, _Index_tuple<_Indexes...> > + { + typedef _Index_tuple<_Indexes...> __type; + }; + + /** + * Used by _Safe_tuple_element to indicate that there is no tuple + * element at this position. + */ + struct _No_tuple_element; + + /** + * Implementation helper for _Safe_tuple_element. This primary + * template handles the case where it is safe to use @c + * tuple_element. + */ + template<int __i, typename _Tuple, bool _IsSafe> + struct _Safe_tuple_element_impl + : tuple_element<__i, _Tuple> { }; + + /** + * Implementation helper for _Safe_tuple_element. This partial + * specialization handles the case where it is not safe to use @c + * tuple_element. We just return @c _No_tuple_element. + */ + template<int __i, typename _Tuple> + struct _Safe_tuple_element_impl<__i, _Tuple, false> + { + typedef _No_tuple_element type; + }; + + /** + * Like tuple_element, but returns @c _No_tuple_element when + * tuple_element would return an error. + */ + template<int __i, typename _Tuple> + struct _Safe_tuple_element + : _Safe_tuple_element_impl<__i, _Tuple, + (__i >= 0 && __i < tuple_size<_Tuple>::value)> + { + }; + + /** + * Maps an argument to bind() into an actual argument to the bound + * function object [TR1 3.6.3/5]. Only the first parameter should + * be specified: the rest are used to determine among the various + * implementations. Note that, although this class is a function + * object, it isn't entirely normal because it takes only two + * parameters regardless of the number of parameters passed to the + * bind expression. The first parameter is the bound argument and + * the second parameter is a tuple containing references to the + * rest of the arguments. + */ + template<typename _Arg, + bool _IsBindExp = is_bind_expression<_Arg>::value, + bool _IsPlaceholder = (is_placeholder<_Arg>::value > 0)> + class _Mu; + + /** + * If the argument is reference_wrapper<_Tp>, returns the + * underlying reference. [TR1 3.6.3/5 bullet 1] + */ + template<typename _Tp> + class _Mu<reference_wrapper<_Tp>, false, false> + { + public: + typedef _Tp& result_type; + + /* Note: This won't actually work for const volatile + * reference_wrappers, because reference_wrapper::get() is const + * but not volatile-qualified. This might be a defect in the TR. + */ + template<typename _CVRef, typename _Tuple> + result_type + operator()(_CVRef& __arg, const _Tuple&) const volatile + { return __arg.get(); } + }; + + /** + * If the argument is a bind expression, we invoke the underlying + * function object with the same cv-qualifiers as we are given and + * pass along all of our arguments (unwrapped). [TR1 3.6.3/5 bullet 2] + */ + template<typename _Arg> + class _Mu<_Arg, true, false> + { + public: + template<typename _Signature> class result; + + // Determine the result type when we pass the arguments along. This + // involves passing along the cv-qualifiers placed on _Mu and + // unwrapping the argument bundle. + template<typename _CVMu, typename _CVArg, typename... _Args> + class result<_CVMu(_CVArg, tuple<_Args...>)> + : public result_of<_CVArg(_Args...)> { }; + + template<typename _CVArg, typename... _Args> + typename result_of<_CVArg(_Args...)>::type + operator()(_CVArg& __arg, + const tuple<_Args...>& __tuple) const volatile + { + // Construct an index tuple and forward to __call + typedef typename _Build_index_tuple<sizeof...(_Args)>::__type + _Indexes; + return this->__call(__arg, __tuple, _Indexes()); + } + + private: + // Invokes the underlying function object __arg by unpacking all + // of the arguments in the tuple. + template<typename _CVArg, typename... _Args, int... _Indexes> + typename result_of<_CVArg(_Args...)>::type + __call(_CVArg& __arg, const tuple<_Args...>& __tuple, + const _Index_tuple<_Indexes...>&) const volatile + { + return __arg(tr1::get<_Indexes>(__tuple)...); + } + }; + + /** + * If the argument is a placeholder for the Nth argument, returns + * a reference to the Nth argument to the bind function object. + * [TR1 3.6.3/5 bullet 3] + */ + template<typename _Arg> + class _Mu<_Arg, false, true> + { + public: + template<typename _Signature> class result; + + template<typename _CVMu, typename _CVArg, typename _Tuple> + class result<_CVMu(_CVArg, _Tuple)> + { + // Add a reference, if it hasn't already been done for us. + // This allows us to be a little bit sloppy in constructing + // the tuple that we pass to result_of<...>. + typedef typename _Safe_tuple_element<(is_placeholder<_Arg>::value + - 1), _Tuple>::type + __base_type; + + public: + typedef typename add_reference<__base_type>::type type; + }; + + template<typename _Tuple> + typename result<_Mu(_Arg, _Tuple)>::type + operator()(const volatile _Arg&, const _Tuple& __tuple) const volatile + { + return ::std::tr1::get<(is_placeholder<_Arg>::value - 1)>(__tuple); + } + }; + + /** + * If the argument is just a value, returns a reference to that + * value. The cv-qualifiers on the reference are the same as the + * cv-qualifiers on the _Mu object. [TR1 3.6.3/5 bullet 4] + */ + template<typename _Arg> + class _Mu<_Arg, false, false> + { + public: + template<typename _Signature> struct result; + + template<typename _CVMu, typename _CVArg, typename _Tuple> + struct result<_CVMu(_CVArg, _Tuple)> + { + typedef typename add_reference<_CVArg>::type type; + }; + + // Pick up the cv-qualifiers of the argument + template<typename _CVArg, typename _Tuple> + _CVArg& + operator()(_CVArg& __arg, const _Tuple&) const volatile + { return __arg; } + }; + + /** + * Maps member pointers into instances of _Mem_fn but leaves all + * other function objects untouched. Used by tr1::bind(). The + * primary template handles the non--member-pointer case. + */ + template<typename _Tp> + struct _Maybe_wrap_member_pointer + { + typedef _Tp type; + + static const _Tp& + __do_wrap(const _Tp& __x) + { return __x; } + }; + + /** + * Maps member pointers into instances of _Mem_fn but leaves all + * other function objects untouched. Used by tr1::bind(). This + * partial specialization handles the member pointer case. + */ + template<typename _Tp, typename _Class> + struct _Maybe_wrap_member_pointer<_Tp _Class::*> + { + typedef _Mem_fn<_Tp _Class::*> type; + + static type + __do_wrap(_Tp _Class::* __pm) + { return type(__pm); } + }; + + /// Type of the function object returned from bind(). + template<typename _Signature> + struct _Bind; + + template<typename _Functor, typename... _Bound_args> + class _Bind<_Functor(_Bound_args...)> + : public _Weak_result_type<_Functor> + { + typedef _Bind __self_type; + typedef typename _Build_index_tuple<sizeof...(_Bound_args)>::__type + _Bound_indexes; + + _Functor _M_f; + tuple<_Bound_args...> _M_bound_args; + + // Call unqualified + template<typename... _Args, int... _Indexes> + typename result_of< + _Functor(typename result_of<_Mu<_Bound_args> + (_Bound_args, tuple<_Args...>)>::type...) + >::type + __call(const tuple<_Args...>& __args, _Index_tuple<_Indexes...>) + { + return _M_f(_Mu<_Bound_args>() + (tr1::get<_Indexes>(_M_bound_args), __args)...); + } + + // Call as const + template<typename... _Args, int... _Indexes> + typename result_of< + const _Functor(typename result_of<_Mu<_Bound_args> + (const _Bound_args, tuple<_Args...>) + >::type...)>::type + __call(const tuple<_Args...>& __args, _Index_tuple<_Indexes...>) const + { + return _M_f(_Mu<_Bound_args>() + (tr1::get<_Indexes>(_M_bound_args), __args)...); + } + + // Call as volatile + template<typename... _Args, int... _Indexes> + typename result_of< + volatile _Functor(typename result_of<_Mu<_Bound_args> + (volatile _Bound_args, tuple<_Args...>) + >::type...)>::type + __call(const tuple<_Args...>& __args, + _Index_tuple<_Indexes...>) volatile + { + return _M_f(_Mu<_Bound_args>() + (tr1::get<_Indexes>(_M_bound_args), __args)...); + } + + // Call as const volatile + template<typename... _Args, int... _Indexes> + typename result_of< + const volatile _Functor(typename result_of<_Mu<_Bound_args> + (const volatile _Bound_args, + tuple<_Args...>) + >::type...)>::type + __call(const tuple<_Args...>& __args, + _Index_tuple<_Indexes...>) const volatile + { + return _M_f(_Mu<_Bound_args>() + (tr1::get<_Indexes>(_M_bound_args), __args)...); + } + + public: + explicit _Bind(_Functor __f, _Bound_args... __bound_args) + : _M_f(__f), _M_bound_args(__bound_args...) { } + + // Call unqualified + template<typename... _Args> + typename result_of< + _Functor(typename result_of<_Mu<_Bound_args> + (_Bound_args, tuple<_Args...>)>::type...) + >::type + operator()(_Args&... __args) + { + return this->__call(tr1::tie(__args...), _Bound_indexes()); + } + + // Call as const + template<typename... _Args> + typename result_of< + const _Functor(typename result_of<_Mu<_Bound_args> + (const _Bound_args, tuple<_Args...>)>::type...) + >::type + operator()(_Args&... __args) const + { + return this->__call(tr1::tie(__args...), _Bound_indexes()); + } + + + // Call as volatile + template<typename... _Args> + typename result_of< + volatile _Functor(typename result_of<_Mu<_Bound_args> + (volatile _Bound_args, tuple<_Args...>)>::type...) + >::type + operator()(_Args&... __args) volatile + { + return this->__call(tr1::tie(__args...), _Bound_indexes()); + } + + + // Call as const volatile + template<typename... _Args> + typename result_of< + const volatile _Functor(typename result_of<_Mu<_Bound_args> + (const volatile _Bound_args, + tuple<_Args...>)>::type...) + >::type + operator()(_Args&... __args) const volatile + { + return this->__call(tr1::tie(__args...), _Bound_indexes()); + } + }; + + /// Type of the function object returned from bind<R>(). + template<typename _Result, typename _Signature> + struct _Bind_result; + + template<typename _Result, typename _Functor, typename... _Bound_args> + class _Bind_result<_Result, _Functor(_Bound_args...)> + { + typedef _Bind_result __self_type; + typedef typename _Build_index_tuple<sizeof...(_Bound_args)>::__type + _Bound_indexes; + + _Functor _M_f; + tuple<_Bound_args...> _M_bound_args; + + // Call unqualified + template<typename... _Args, int... _Indexes> + _Result + __call(const tuple<_Args...>& __args, _Index_tuple<_Indexes...>) + { + return _M_f(_Mu<_Bound_args>() + (tr1::get<_Indexes>(_M_bound_args), __args)...); + } + + // Call as const + template<typename... _Args, int... _Indexes> + _Result + __call(const tuple<_Args...>& __args, _Index_tuple<_Indexes...>) const + { + return _M_f(_Mu<_Bound_args>() + (tr1::get<_Indexes>(_M_bound_args), __args)...); + } + + // Call as volatile + template<typename... _Args, int... _Indexes> + _Result + __call(const tuple<_Args...>& __args, + _Index_tuple<_Indexes...>) volatile + { + return _M_f(_Mu<_Bound_args>() + (tr1::get<_Indexes>(_M_bound_args), __args)...); + } + + // Call as const volatile + template<typename... _Args, int... _Indexes> + _Result + __call(const tuple<_Args...>& __args, + _Index_tuple<_Indexes...>) const volatile + { + return _M_f(_Mu<_Bound_args>() + (tr1::get<_Indexes>(_M_bound_args), __args)...); + } + + public: + typedef _Result result_type; + + explicit + _Bind_result(_Functor __f, _Bound_args... __bound_args) + : _M_f(__f), _M_bound_args(__bound_args...) { } + + // Call unqualified + template<typename... _Args> + result_type + operator()(_Args&... __args) + { + return this->__call(tr1::tie(__args...), _Bound_indexes()); + } + + // Call as const + template<typename... _Args> + result_type + operator()(_Args&... __args) const + { + return this->__call(tr1::tie(__args...), _Bound_indexes()); + } + + // Call as volatile + template<typename... _Args> + result_type + operator()(_Args&... __args) volatile + { + return this->__call(tr1::tie(__args...), _Bound_indexes()); + } + + // Call as const volatile + template<typename... _Args> + result_type + operator()(_Args&... __args) const volatile + { + return this->__call(tr1::tie(__args...), _Bound_indexes()); + } + }; + + /// Class template _Bind is always a bind expression. + template<typename _Signature> + struct is_bind_expression<_Bind<_Signature> > + { static const bool value = true; }; + + template<typename _Signature> + const bool is_bind_expression<_Bind<_Signature> >::value; + + /// Class template _Bind_result is always a bind expression. + template<typename _Result, typename _Signature> + struct is_bind_expression<_Bind_result<_Result, _Signature> > + { static const bool value = true; }; + + template<typename _Result, typename _Signature> + const bool is_bind_expression<_Bind_result<_Result, _Signature> >::value; + + /// bind + template<typename _Functor, typename... _ArgTypes> + inline + _Bind<typename _Maybe_wrap_member_pointer<_Functor>::type(_ArgTypes...)> + bind(_Functor __f, _ArgTypes... __args) + { + typedef _Maybe_wrap_member_pointer<_Functor> __maybe_type; + typedef typename __maybe_type::type __functor_type; + typedef _Bind<__functor_type(_ArgTypes...)> __result_type; + return __result_type(__maybe_type::__do_wrap(__f), __args...); + } + + template<typename _Result, typename _Functor, typename... _ArgTypes> + inline + _Bind_result<_Result, + typename _Maybe_wrap_member_pointer<_Functor>::type + (_ArgTypes...)> + bind(_Functor __f, _ArgTypes... __args) + { + typedef _Maybe_wrap_member_pointer<_Functor> __maybe_type; + typedef typename __maybe_type::type __functor_type; + typedef _Bind_result<_Result, __functor_type(_ArgTypes...)> + __result_type; + return __result_type(__maybe_type::__do_wrap(__f), __args...); + } + + /** + * @brief Exception class thrown when class template function's + * operator() is called with an empty target. + * @ingroup exceptions + */ + class bad_function_call : public std::exception { }; + + /** + * The integral constant expression 0 can be converted into a + * pointer to this type. It is used by the function template to + * accept NULL pointers. + */ + struct _M_clear_type; + + /** + * Trait identifying "location-invariant" types, meaning that the + * address of the object (or any of its members) will not escape. + * Also implies a trivial copy constructor and assignment operator. + */ + template<typename _Tp> + struct __is_location_invariant + : integral_constant<bool, + (is_pointer<_Tp>::value + || is_member_pointer<_Tp>::value)> + { + }; + + class _Undefined_class; + + union _Nocopy_types + { + void* _M_object; + const void* _M_const_object; + void (*_M_function_pointer)(); + void (_Undefined_class::*_M_member_pointer)(); + }; + + union _Any_data + { + void* _M_access() { return &_M_pod_data[0]; } + const void* _M_access() const { return &_M_pod_data[0]; } + + template<typename _Tp> + _Tp& + _M_access() + { return *static_cast<_Tp*>(_M_access()); } + + template<typename _Tp> + const _Tp& + _M_access() const + { return *static_cast<const _Tp*>(_M_access()); } + + _Nocopy_types _M_unused; + char _M_pod_data[sizeof(_Nocopy_types)]; + }; + + enum _Manager_operation + { + __get_type_info, + __get_functor_ptr, + __clone_functor, + __destroy_functor + }; + + // Simple type wrapper that helps avoid annoying const problems + // when casting between void pointers and pointers-to-pointers. + template<typename _Tp> + struct _Simple_type_wrapper + { + _Simple_type_wrapper(_Tp __value) : __value(__value) { } + + _Tp __value; + }; + + template<typename _Tp> + struct __is_location_invariant<_Simple_type_wrapper<_Tp> > + : __is_location_invariant<_Tp> + { + }; + + // Converts a reference to a function object into a callable + // function object. + template<typename _Functor> + inline _Functor& + __callable_functor(_Functor& __f) + { return __f; } + + template<typename _Member, typename _Class> + inline _Mem_fn<_Member _Class::*> + __callable_functor(_Member _Class::* &__p) + { return mem_fn(__p); } + + template<typename _Member, typename _Class> + inline _Mem_fn<_Member _Class::*> + __callable_functor(_Member _Class::* const &__p) + { return mem_fn(__p); } + + template<typename _Signature> + class function; + + /// Base class of all polymorphic function object wrappers. + class _Function_base + { + public: + static const std::size_t _M_max_size = sizeof(_Nocopy_types); + static const std::size_t _M_max_align = __alignof__(_Nocopy_types); + + template<typename _Functor> + class _Base_manager + { + protected: + static const bool __stored_locally = + (__is_location_invariant<_Functor>::value + && sizeof(_Functor) <= _M_max_size + && __alignof__(_Functor) <= _M_max_align + && (_M_max_align % __alignof__(_Functor) == 0)); + + typedef integral_constant<bool, __stored_locally> _Local_storage; + + // Retrieve a pointer to the function object + static _Functor* + _M_get_pointer(const _Any_data& __source) + { + const _Functor* __ptr = + __stored_locally? &__source._M_access<_Functor>() + /* have stored a pointer */ : __source._M_access<_Functor*>(); + return const_cast<_Functor*>(__ptr); + } + + // Clone a location-invariant function object that fits within + // an _Any_data structure. + static void + _M_clone(_Any_data& __dest, const _Any_data& __source, true_type) + { + new (__dest._M_access()) _Functor(__source._M_access<_Functor>()); + } + + // Clone a function object that is not location-invariant or + // that cannot fit into an _Any_data structure. + static void + _M_clone(_Any_data& __dest, const _Any_data& __source, false_type) + { + __dest._M_access<_Functor*>() = + new _Functor(*__source._M_access<_Functor*>()); + } + + // Destroying a location-invariant object may still require + // destruction. + static void + _M_destroy(_Any_data& __victim, true_type) + { + __victim._M_access<_Functor>().~_Functor(); + } + + // Destroying an object located on the heap. + static void + _M_destroy(_Any_data& __victim, false_type) + { + delete __victim._M_access<_Functor*>(); + } + + public: + static bool + _M_manager(_Any_data& __dest, const _Any_data& __source, + _Manager_operation __op) + { + switch (__op) + { +#ifdef __GXX_RTTI + case __get_type_info: + __dest._M_access<const type_info*>() = &typeid(_Functor); + break; +#endif + case __get_functor_ptr: + __dest._M_access<_Functor*>() = _M_get_pointer(__source); + break; + + case __clone_functor: + _M_clone(__dest, __source, _Local_storage()); + break; + + case __destroy_functor: + _M_destroy(__dest, _Local_storage()); + break; + } + return false; + } + + static void + _M_init_functor(_Any_data& __functor, const _Functor& __f) + { _M_init_functor(__functor, __f, _Local_storage()); } + + template<typename _Signature> + static bool + _M_not_empty_function(const function<_Signature>& __f) + { return static_cast<bool>(__f); } + + template<typename _Tp> + static bool + _M_not_empty_function(const _Tp*& __fp) + { return __fp; } + + template<typename _Class, typename _Tp> + static bool + _M_not_empty_function(_Tp _Class::* const& __mp) + { return __mp; } + + template<typename _Tp> + static bool + _M_not_empty_function(const _Tp&) + { return true; } + + private: + static void + _M_init_functor(_Any_data& __functor, const _Functor& __f, true_type) + { new (__functor._M_access()) _Functor(__f); } + + static void + _M_init_functor(_Any_data& __functor, const _Functor& __f, false_type) + { __functor._M_access<_Functor*>() = new _Functor(__f); } + }; + + template<typename _Functor> + class _Ref_manager : public _Base_manager<_Functor*> + { + typedef _Function_base::_Base_manager<_Functor*> _Base; + + public: + static bool + _M_manager(_Any_data& __dest, const _Any_data& __source, + _Manager_operation __op) + { + switch (__op) + { +#ifdef __GXX_RTTI + case __get_type_info: + __dest._M_access<const type_info*>() = &typeid(_Functor); + break; +#endif + case __get_functor_ptr: + __dest._M_access<_Functor*>() = *_Base::_M_get_pointer(__source); + return is_const<_Functor>::value; + break; + + default: + _Base::_M_manager(__dest, __source, __op); + } + return false; + } + + static void + _M_init_functor(_Any_data& __functor, reference_wrapper<_Functor> __f) + { + // TBD: Use address_of function instead. + _Base::_M_init_functor(__functor, &__f.get()); + } + }; + + _Function_base() : _M_manager(0) { } + + ~_Function_base() + { + if (_M_manager) + _M_manager(_M_functor, _M_functor, __destroy_functor); + } + + + bool _M_empty() const { return !_M_manager; } + + typedef bool (*_Manager_type)(_Any_data&, const _Any_data&, + _Manager_operation); + + _Any_data _M_functor; + _Manager_type _M_manager; + }; + + template<typename _Signature, typename _Functor> + class _Function_handler; + + template<typename _Res, typename _Functor, typename... _ArgTypes> + class _Function_handler<_Res(_ArgTypes...), _Functor> + : public _Function_base::_Base_manager<_Functor> + { + typedef _Function_base::_Base_manager<_Functor> _Base; + + public: + static _Res + _M_invoke(const _Any_data& __functor, _ArgTypes... __args) + { + return (*_Base::_M_get_pointer(__functor))(__args...); + } + }; + + template<typename _Functor, typename... _ArgTypes> + class _Function_handler<void(_ArgTypes...), _Functor> + : public _Function_base::_Base_manager<_Functor> + { + typedef _Function_base::_Base_manager<_Functor> _Base; + + public: + static void + _M_invoke(const _Any_data& __functor, _ArgTypes... __args) + { + (*_Base::_M_get_pointer(__functor))(__args...); + } + }; + + template<typename _Res, typename _Functor, typename... _ArgTypes> + class _Function_handler<_Res(_ArgTypes...), reference_wrapper<_Functor> > + : public _Function_base::_Ref_manager<_Functor> + { + typedef _Function_base::_Ref_manager<_Functor> _Base; + + public: + static _Res + _M_invoke(const _Any_data& __functor, _ArgTypes... __args) + { + return + __callable_functor(**_Base::_M_get_pointer(__functor))(__args...); + } + }; + + template<typename _Functor, typename... _ArgTypes> + class _Function_handler<void(_ArgTypes...), reference_wrapper<_Functor> > + : public _Function_base::_Ref_manager<_Functor> + { + typedef _Function_base::_Ref_manager<_Functor> _Base; + + public: + static void + _M_invoke(const _Any_data& __functor, _ArgTypes... __args) + { + __callable_functor(**_Base::_M_get_pointer(__functor))(__args...); + } + }; + + template<typename _Class, typename _Member, typename _Res, + typename... _ArgTypes> + class _Function_handler<_Res(_ArgTypes...), _Member _Class::*> + : public _Function_handler<void(_ArgTypes...), _Member _Class::*> + { + typedef _Function_handler<void(_ArgTypes...), _Member _Class::*> + _Base; + + public: + static _Res + _M_invoke(const _Any_data& __functor, _ArgTypes... __args) + { + return tr1:: + mem_fn(_Base::_M_get_pointer(__functor)->__value)(__args...); + } + }; + + template<typename _Class, typename _Member, typename... _ArgTypes> + class _Function_handler<void(_ArgTypes...), _Member _Class::*> + : public _Function_base::_Base_manager< + _Simple_type_wrapper< _Member _Class::* > > + { + typedef _Member _Class::* _Functor; + typedef _Simple_type_wrapper<_Functor> _Wrapper; + typedef _Function_base::_Base_manager<_Wrapper> _Base; + + public: + static bool + _M_manager(_Any_data& __dest, const _Any_data& __source, + _Manager_operation __op) + { + switch (__op) + { +#ifdef __GXX_RTTI + case __get_type_info: + __dest._M_access<const type_info*>() = &typeid(_Functor); + break; +#endif + case __get_functor_ptr: + __dest._M_access<_Functor*>() = + &_Base::_M_get_pointer(__source)->__value; + break; + + default: + _Base::_M_manager(__dest, __source, __op); + } + return false; + } + + static void + _M_invoke(const _Any_data& __functor, _ArgTypes... __args) + { + tr1::mem_fn(_Base::_M_get_pointer(__functor)->__value)(__args...); + } + }; + + /// class function + template<typename _Res, typename... _ArgTypes> + class function<_Res(_ArgTypes...)> + : public _Maybe_unary_or_binary_function<_Res, _ArgTypes...>, + private _Function_base + { +#ifndef __GXX_EXPERIMENTAL_CXX0X__ + /// This class is used to implement the safe_bool idiom. + struct _Hidden_type + { + _Hidden_type* _M_bool; + }; + + /// This typedef is used to implement the safe_bool idiom. + typedef _Hidden_type* _Hidden_type::* _Safe_bool; +#endif + + typedef _Res _Signature_type(_ArgTypes...); + + struct _Useless { }; + + public: + typedef _Res result_type; + + // [3.7.2.1] construct/copy/destroy + + /** + * @brief Default construct creates an empty function call wrapper. + * @post @c !(bool)*this + */ + function() : _Function_base() { } + + /** + * @brief Default construct creates an empty function call wrapper. + * @post @c !(bool)*this + */ + function(_M_clear_type*) : _Function_base() { } + + /** + * @brief %Function copy constructor. + * @param x A %function object with identical call signature. + * @post @c (bool)*this == (bool)x + * + * The newly-created %function contains a copy of the target of @a + * x (if it has one). + */ + function(const function& __x); + + /** + * @brief Builds a %function that targets a copy of the incoming + * function object. + * @param f A %function object that is callable with parameters of + * type @c T1, @c T2, ..., @c TN and returns a value convertible + * to @c Res. + * + * The newly-created %function object will target a copy of @a + * f. If @a f is @c reference_wrapper<F>, then this function + * object will contain a reference to the function object @c + * f.get(). If @a f is a NULL function pointer or NULL + * pointer-to-member, the newly-created object will be empty. + * + * If @a f is a non-NULL function pointer or an object of type @c + * reference_wrapper<F>, this function will not throw. + */ + template<typename _Functor> + function(_Functor __f, + typename __gnu_cxx::__enable_if< + !is_integral<_Functor>::value, _Useless>::__type + = _Useless()); + + /** + * @brief %Function assignment operator. + * @param x A %function with identical call signature. + * @post @c (bool)*this == (bool)x + * @returns @c *this + * + * The target of @a x is copied to @c *this. If @a x has no + * target, then @c *this will be empty. + * + * If @a x targets a function pointer or a reference to a function + * object, then this operation will not throw an %exception. + */ + function& + operator=(const function& __x) + { + function(__x).swap(*this); + return *this; + } + + /** + * @brief %Function assignment to zero. + * @post @c !(bool)*this + * @returns @c *this + * + * The target of @c *this is deallocated, leaving it empty. + */ + function& + operator=(_M_clear_type*) + { + if (_M_manager) + { + _M_manager(_M_functor, _M_functor, __destroy_functor); + _M_manager = 0; + _M_invoker = 0; + } + return *this; + } + + /** + * @brief %Function assignment to a new target. + * @param f A %function object that is callable with parameters of + * type @c T1, @c T2, ..., @c TN and returns a value convertible + * to @c Res. + * @return @c *this + * + * This %function object wrapper will target a copy of @a + * f. If @a f is @c reference_wrapper<F>, then this function + * object will contain a reference to the function object @c + * f.get(). If @a f is a NULL function pointer or NULL + * pointer-to-member, @c this object will be empty. + * + * If @a f is a non-NULL function pointer or an object of type @c + * reference_wrapper<F>, this function will not throw. + */ + template<typename _Functor> + typename __gnu_cxx::__enable_if<!is_integral<_Functor>::value, + function&>::__type + operator=(_Functor __f) + { + function(__f).swap(*this); + return *this; + } + + // [3.7.2.2] function modifiers + + /** + * @brief Swap the targets of two %function objects. + * @param f A %function with identical call signature. + * + * Swap the targets of @c this function object and @a f. This + * function will not throw an %exception. + */ + void swap(function& __x) + { + _Any_data __old_functor = _M_functor; + _M_functor = __x._M_functor; + __x._M_functor = __old_functor; + _Manager_type __old_manager = _M_manager; + _M_manager = __x._M_manager; + __x._M_manager = __old_manager; + _Invoker_type __old_invoker = _M_invoker; + _M_invoker = __x._M_invoker; + __x._M_invoker = __old_invoker; + } + + // [3.7.2.3] function capacity + + /** + * @brief Determine if the %function wrapper has a target. + * + * @return @c true when this %function object contains a target, + * or @c false when it is empty. + * + * This function will not throw an %exception. + */ +#ifdef __GXX_EXPERIMENTAL_CXX0X__ + explicit operator bool() const + { return !_M_empty(); } #else -# define _GLIBCXX_INCLUDE_AS_TR1 -# define _GLIBCXX_BEGIN_NAMESPACE_TR1 namespace tr1 { -# define _GLIBCXX_END_NAMESPACE_TR1 } -# define _GLIBCXX_TR1 tr1:: -# include <tr1_impl/functional> -# undef _GLIBCXX_TR1 -# undef _GLIBCXX_END_NAMESPACE_TR1 -# undef _GLIBCXX_BEGIN_NAMESPACE_TR1 -# undef _GLIBCXX_INCLUDE_AS_TR1 + operator _Safe_bool() const + { + if (_M_empty()) + return 0; + else + return &_Hidden_type::_M_bool; + } #endif + // [3.7.2.4] function invocation + + /** + * @brief Invokes the function targeted by @c *this. + * @returns the result of the target. + * @throws bad_function_call when @c !(bool)*this + * + * The function call operator invokes the target function object + * stored by @c this. + */ + _Res operator()(_ArgTypes... __args) const; + +#ifdef __GXX_RTTI + // [3.7.2.5] function target access + /** + * @brief Determine the type of the target of this function object + * wrapper. + * + * @returns the type identifier of the target function object, or + * @c typeid(void) if @c !(bool)*this. + * + * This function will not throw an %exception. + */ + const type_info& target_type() const; + + /** + * @brief Access the stored target function object. + * + * @return Returns a pointer to the stored target function object, + * if @c typeid(Functor).equals(target_type()); otherwise, a NULL + * pointer. + * + * This function will not throw an %exception. + */ + template<typename _Functor> _Functor* target(); + + /// @overload + template<typename _Functor> const _Functor* target() const; +#endif + + private: + // [3.7.2.6] undefined operators + template<typename _Function> + void operator==(const function<_Function>&) const; + template<typename _Function> + void operator!=(const function<_Function>&) const; + + typedef _Res (*_Invoker_type)(const _Any_data&, _ArgTypes...); + _Invoker_type _M_invoker; + }; + + template<typename _Res, typename... _ArgTypes> + function<_Res(_ArgTypes...)>:: + function(const function& __x) + : _Function_base() + { + if (static_cast<bool>(__x)) + { + _M_invoker = __x._M_invoker; + _M_manager = __x._M_manager; + __x._M_manager(_M_functor, __x._M_functor, __clone_functor); + } + } + + template<typename _Res, typename... _ArgTypes> + template<typename _Functor> + function<_Res(_ArgTypes...)>:: + function(_Functor __f, + typename __gnu_cxx::__enable_if< + !is_integral<_Functor>::value, _Useless>::__type) + : _Function_base() + { + typedef _Function_handler<_Signature_type, _Functor> _My_handler; + + if (_My_handler::_M_not_empty_function(__f)) + { + _M_invoker = &_My_handler::_M_invoke; + _M_manager = &_My_handler::_M_manager; + _My_handler::_M_init_functor(_M_functor, __f); + } + } + + template<typename _Res, typename... _ArgTypes> + _Res + function<_Res(_ArgTypes...)>:: + operator()(_ArgTypes... __args) const + { + if (_M_empty()) + { +#if __EXCEPTIONS + throw bad_function_call(); +#else + __builtin_abort(); +#endif + } + return _M_invoker(_M_functor, __args...); + } + +#ifdef __GXX_RTTI + template<typename _Res, typename... _ArgTypes> + const type_info& + function<_Res(_ArgTypes...)>:: + target_type() const + { + if (_M_manager) + { + _Any_data __typeinfo_result; + _M_manager(__typeinfo_result, _M_functor, __get_type_info); + return *__typeinfo_result._M_access<const type_info*>(); + } + else + return typeid(void); + } + + template<typename _Res, typename... _ArgTypes> + template<typename _Functor> + _Functor* + function<_Res(_ArgTypes...)>:: + target() + { + if (typeid(_Functor) == target_type() && _M_manager) + { + _Any_data __ptr; + if (_M_manager(__ptr, _M_functor, __get_functor_ptr) + && !is_const<_Functor>::value) + return 0; + else + return __ptr._M_access<_Functor*>(); + } + else + return 0; + } + + template<typename _Res, typename... _ArgTypes> + template<typename _Functor> + const _Functor* + function<_Res(_ArgTypes...)>:: + target() const + { + if (typeid(_Functor) == target_type() && _M_manager) + { + _Any_data __ptr; + _M_manager(__ptr, _M_functor, __get_functor_ptr); + return __ptr._M_access<const _Functor*>(); + } + else + return 0; + } +#endif + + // [3.7.2.7] null pointer comparisons + + /** + * @brief Compares a polymorphic function object wrapper against 0 + * (the NULL pointer). + * @returns @c true if the wrapper has no target, @c false otherwise + * + * This function will not throw an %exception. + */ + template<typename _Signature> + inline bool + operator==(const function<_Signature>& __f, _M_clear_type*) + { return !static_cast<bool>(__f); } + + /// @overload + template<typename _Signature> + inline bool + operator==(_M_clear_type*, const function<_Signature>& __f) + { return !static_cast<bool>(__f); } + + /** + * @brief Compares a polymorphic function object wrapper against 0 + * (the NULL pointer). + * @returns @c false if the wrapper has no target, @c true otherwise + * + * This function will not throw an %exception. + */ + template<typename _Signature> + inline bool + operator!=(const function<_Signature>& __f, _M_clear_type*) + { return static_cast<bool>(__f); } + + /// @overload + template<typename _Signature> + inline bool + operator!=(_M_clear_type*, const function<_Signature>& __f) + { return static_cast<bool>(__f); } + + // [3.7.2.8] specialized algorithms + + /** + * @brief Swap the targets of two polymorphic function object wrappers. + * + * This function will not throw an %exception. + */ + template<typename _Signature> + inline void + swap(function<_Signature>& __x, function<_Signature>& __y) + { __x.swap(__y); } +} +} + #endif // _GLIBCXX_TR1_FUNCTIONAL diff --git a/libstdc++-v3/include/tr1_impl/functional b/libstdc++-v3/include/tr1_impl/functional deleted file mode 100644 index 9911d46d678..00000000000 --- a/libstdc++-v3/include/tr1_impl/functional +++ /dev/null @@ -1,2137 +0,0 @@ -// TR1 functional header -*- C++ -*- - -// Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. -// -// This file is part of the GNU ISO C++ Library. This library 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. - -// This library is distributed in the hope that it will be useful, -// but WITHOUT ANY WARRANTY; without even the implied warranty of -// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -// GNU General Public License for more details. - -// Under Section 7 of GPL version 3, you are granted additional -// permissions described in the GCC Runtime Library Exception, version -// 3.1, as published by the Free Software Foundation. - -// You should have received a copy of the GNU General Public License and -// a copy of the GCC Runtime Library Exception along with this program; -// see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -// <http://www.gnu.org/licenses/>. - -/** @file tr1_impl/functional - * This is an internal header file, included by other library headers. - * You should not attempt to use it directly. - */ - -namespace std -{ -_GLIBCXX_BEGIN_NAMESPACE_TR1 - - template<typename _MemberPointer> - class _Mem_fn; - - /** - * Actual implementation of _Has_result_type, which uses SFINAE to - * determine if the type _Tp has a publicly-accessible member type - * result_type. - */ - template<typename _Tp> - class _Has_result_type_helper : __sfinae_types - { - template<typename _Up> - struct _Wrap_type - { }; - - template<typename _Up> - static __one __test(_Wrap_type<typename _Up::result_type>*); - - template<typename _Up> - static __two __test(...); - - public: - static const bool value = sizeof(__test<_Tp>(0)) == 1; - }; - - template<typename _Tp> - struct _Has_result_type - : integral_constant<bool, - _Has_result_type_helper<typename remove_cv<_Tp>::type>::value> - { }; - - /** - * - */ - /// If we have found a result_type, extract it. - template<bool _Has_result_type, typename _Functor> - struct _Maybe_get_result_type - { }; - - template<typename _Functor> - struct _Maybe_get_result_type<true, _Functor> - { - typedef typename _Functor::result_type result_type; - }; - - /** - * Base class for any function object that has a weak result type, as - * defined in 3.3/3 of TR1. - */ - template<typename _Functor> - struct _Weak_result_type_impl - : _Maybe_get_result_type<_Has_result_type<_Functor>::value, _Functor> - { - }; - - /// Retrieve the result type for a function type. - template<typename _Res, typename... _ArgTypes> - struct _Weak_result_type_impl<_Res(_ArgTypes...)> - { - typedef _Res result_type; - }; - - /// Retrieve the result type for a function reference. - template<typename _Res, typename... _ArgTypes> - struct _Weak_result_type_impl<_Res(&)(_ArgTypes...)> - { - typedef _Res result_type; - }; - - /// Retrieve the result type for a function pointer. - template<typename _Res, typename... _ArgTypes> - struct _Weak_result_type_impl<_Res(*)(_ArgTypes...)> - { - typedef _Res result_type; - }; - - /// Retrieve result type for a member function pointer. - template<typename _Res, typename _Class, typename... _ArgTypes> - struct _Weak_result_type_impl<_Res (_Class::*)(_ArgTypes...)> - { - typedef _Res result_type; - }; - - /// Retrieve result type for a const member function pointer. - template<typename _Res, typename _Class, typename... _ArgTypes> - struct _Weak_result_type_impl<_Res (_Class::*)(_ArgTypes...) const> - { - typedef _Res result_type; - }; - - /// Retrieve result type for a volatile member function pointer. - template<typename _Res, typename _Class, typename... _ArgTypes> - struct _Weak_result_type_impl<_Res (_Class::*)(_ArgTypes...) volatile> - { - typedef _Res result_type; - }; - - /// Retrieve result type for a const volatile member function pointer. - template<typename _Res, typename _Class, typename... _ArgTypes> - struct _Weak_result_type_impl<_Res (_Class::*)(_ArgTypes...)const volatile> - { - typedef _Res result_type; - }; - - /** - * Strip top-level cv-qualifiers from the function object and let - * _Weak_result_type_impl perform the real work. - */ - template<typename _Functor> - struct _Weak_result_type - : _Weak_result_type_impl<typename remove_cv<_Functor>::type> - { - }; - - template<typename _Signature> - class result_of; - - /** - * Actual implementation of result_of. When _Has_result_type is - * true, gets its result from _Weak_result_type. Otherwise, uses - * the function object's member template result to extract the - * result type. - */ - template<bool _Has_result_type, typename _Signature> - struct _Result_of_impl; - - // Handle member data pointers using _Mem_fn's logic - template<typename _Res, typename _Class, typename _T1> - struct _Result_of_impl<false, _Res _Class::*(_T1)> - { - typedef typename _Mem_fn<_Res _Class::*> - ::template _Result_type<_T1>::type type; - }; - - /** - * Determine whether we can determine a result type from @c Functor - * alone. - */ - template<typename _Functor, typename... _ArgTypes> - class result_of<_Functor(_ArgTypes...)> - : public _Result_of_impl< - _Has_result_type<_Weak_result_type<_Functor> >::value, - _Functor(_ArgTypes...)> - { - }; - - /// We already know the result type for @c Functor; use it. - template<typename _Functor, typename... _ArgTypes> - struct _Result_of_impl<true, _Functor(_ArgTypes...)> - { - typedef typename _Weak_result_type<_Functor>::result_type type; - }; - - /** - * We need to compute the result type for this invocation the hard - * way. - */ - template<typename _Functor, typename... _ArgTypes> - struct _Result_of_impl<false, _Functor(_ArgTypes...)> - { - typedef typename _Functor - ::template result<_Functor(_ArgTypes...)>::type type; - }; - - /** - * It is unsafe to access ::result when there are zero arguments, so we - * return @c void instead. - */ - template<typename _Functor> - struct _Result_of_impl<false, _Functor()> - { - typedef void type; - }; - - /// Determines if the type _Tp derives from unary_function. - template<typename _Tp> - struct _Derives_from_unary_function : __sfinae_types - { - private: - template<typename _T1, typename _Res> - static __one __test(const volatile unary_function<_T1, _Res>*); - - // It's tempting to change "..." to const volatile void*, but - // that fails when _Tp is a function type. - static __two __test(...); - - public: - static const bool value = sizeof(__test((_Tp*)0)) == 1; - }; - - /// Determines if the type _Tp derives from binary_function. - template<typename _Tp> - struct _Derives_from_binary_function : __sfinae_types - { - private: - template<typename _T1, typename _T2, typename _Res> - static __one __test(const volatile binary_function<_T1, _T2, _Res>*); - - // It's tempting to change "..." to const volatile void*, but - // that fails when _Tp is a function type. - static __two __test(...); - - public: - static const bool value = sizeof(__test((_Tp*)0)) == 1; - }; - - /// Turns a function type into a function pointer type - template<typename _Tp, bool _IsFunctionType = is_function<_Tp>::value> - struct _Function_to_function_pointer - { - typedef _Tp type; - }; - - template<typename _Tp> - struct _Function_to_function_pointer<_Tp, true> - { - typedef _Tp* type; - }; - - /** - * Invoke a function object, which may be either a member pointer or a - * function object. The first parameter will tell which. - */ - template<typename _Functor, typename... _Args> - inline - typename __gnu_cxx::__enable_if< - (!is_member_pointer<_Functor>::value - && !is_function<_Functor>::value - && !is_function<typename remove_pointer<_Functor>::type>::value), - typename result_of<_Functor(_Args...)>::type - >::__type - __invoke(_Functor& __f, _Args&... __args) - { - return __f(__args...); - } - - template<typename _Functor, typename... _Args> - inline - typename __gnu_cxx::__enable_if< - (is_member_pointer<_Functor>::value - && !is_function<_Functor>::value - && !is_function<typename remove_pointer<_Functor>::type>::value), - typename result_of<_Functor(_Args...)>::type - >::__type - __invoke(_Functor& __f, _Args&... __args) - { - return mem_fn(__f)(__args...); - } - - // To pick up function references (that will become function pointers) - template<typename _Functor, typename... _Args> - inline - typename __gnu_cxx::__enable_if< - (is_pointer<_Functor>::value - && is_function<typename remove_pointer<_Functor>::type>::value), - typename result_of<_Functor(_Args...)>::type - >::__type - __invoke(_Functor __f, _Args&... __args) - { - return __f(__args...); - } - - /** - * Knowing which of unary_function and binary_function _Tp derives - * from, derives from the same and ensures that reference_wrapper - * will have a weak result type. See cases below. - */ - template<bool _Unary, bool _Binary, typename _Tp> - struct _Reference_wrapper_base_impl; - - // Not a unary_function or binary_function, so try a weak result type. - template<typename _Tp> - struct _Reference_wrapper_base_impl<false, false, _Tp> - : _Weak_result_type<_Tp> - { }; - - // unary_function but not binary_function - template<typename _Tp> - struct _Reference_wrapper_base_impl<true, false, _Tp> - : unary_function<typename _Tp::argument_type, - typename _Tp::result_type> - { }; - - // binary_function but not unary_function - template<typename _Tp> - struct _Reference_wrapper_base_impl<false, true, _Tp> - : binary_function<typename _Tp::first_argument_type, - typename _Tp::second_argument_type, - typename _Tp::result_type> - { }; - - // Both unary_function and binary_function. Import result_type to - // avoid conflicts. - template<typename _Tp> - struct _Reference_wrapper_base_impl<true, true, _Tp> - : unary_function<typename _Tp::argument_type, - typename _Tp::result_type>, - binary_function<typename _Tp::first_argument_type, - typename _Tp::second_argument_type, - typename _Tp::result_type> - { - typedef typename _Tp::result_type result_type; - }; - - /** - * Derives from unary_function or binary_function when it - * can. Specializations handle all of the easy cases. The primary - * template determines what to do with a class type, which may - * derive from both unary_function and binary_function. - */ - template<typename _Tp> - struct _Reference_wrapper_base - : _Reference_wrapper_base_impl< - _Derives_from_unary_function<_Tp>::value, - _Derives_from_binary_function<_Tp>::value, - _Tp> - { }; - - // - a function type (unary) - template<typename _Res, typename _T1> - struct _Reference_wrapper_base<_Res(_T1)> - : unary_function<_T1, _Res> - { }; - - // - a function type (binary) - template<typename _Res, typename _T1, typename _T2> - struct _Reference_wrapper_base<_Res(_T1, _T2)> - : binary_function<_T1, _T2, _Res> - { }; - - // - a function pointer type (unary) - template<typename _Res, typename _T1> - struct _Reference_wrapper_base<_Res(*)(_T1)> - : unary_function<_T1, _Res> - { }; - - // - a function pointer type (binary) - template<typename _Res, typename _T1, typename _T2> - struct _Reference_wrapper_base<_Res(*)(_T1, _T2)> - : binary_function<_T1, _T2, _Res> - { }; - - // - a pointer to member function type (unary, no qualifiers) - template<typename _Res, typename _T1> - struct _Reference_wrapper_base<_Res (_T1::*)()> - : unary_function<_T1*, _Res> - { }; - - // - a pointer to member function type (binary, no qualifiers) - template<typename _Res, typename _T1, typename _T2> - struct _Reference_wrapper_base<_Res (_T1::*)(_T2)> - : binary_function<_T1*, _T2, _Res> - { }; - - // - a pointer to member function type (unary, const) - template<typename _Res, typename _T1> - struct _Reference_wrapper_base<_Res (_T1::*)() const> - : unary_function<const _T1*, _Res> - { }; - - // - a pointer to member function type (binary, const) - template<typename _Res, typename _T1, typename _T2> - struct _Reference_wrapper_base<_Res (_T1::*)(_T2) const> - : binary_function<const _T1*, _T2, _Res> - { }; - - // - a pointer to member function type (unary, volatile) - template<typename _Res, typename _T1> - struct _Reference_wrapper_base<_Res (_T1::*)() volatile> - : unary_function<volatile _T1*, _Res> - { }; - - // - a pointer to member function type (binary, volatile) - template<typename _Res, typename _T1, typename _T2> - struct _Reference_wrapper_base<_Res (_T1::*)(_T2) volatile> - : binary_function<volatile _T1*, _T2, _Res> - { }; - - // - a pointer to member function type (unary, const volatile) - template<typename _Res, typename _T1> - struct _Reference_wrapper_base<_Res (_T1::*)() const volatile> - : unary_function<const volatile _T1*, _Res> - { }; - - // - a pointer to member function type (binary, const volatile) - template<typename _Res, typename _T1, typename _T2> - struct _Reference_wrapper_base<_Res (_T1::*)(_T2) const volatile> - : binary_function<const volatile _T1*, _T2, _Res> - { }; - - /// reference_wrapper - template<typename _Tp> - class reference_wrapper - : public _Reference_wrapper_base<typename remove_cv<_Tp>::type> - { - // If _Tp is a function type, we can't form result_of<_Tp(...)>, - // so turn it into a function pointer type. - typedef typename _Function_to_function_pointer<_Tp>::type - _M_func_type; - - _Tp* _M_data; - public: - typedef _Tp type; - - explicit - reference_wrapper(_Tp& __indata): _M_data(&__indata) - { } - - reference_wrapper(const reference_wrapper<_Tp>& __inref): - _M_data(__inref._M_data) - { } - - reference_wrapper& - operator=(const reference_wrapper<_Tp>& __inref) - { - _M_data = __inref._M_data; - return *this; - } - - operator _Tp&() const - { return this->get(); } - - _Tp& - get() const - { return *_M_data; } - - template<typename... _Args> - typename result_of<_M_func_type(_Args...)>::type - operator()(_Args&... __args) const - { - return __invoke(get(), __args...); - } - }; - - - // Denotes a reference should be taken to a variable. - template<typename _Tp> - inline reference_wrapper<_Tp> - ref(_Tp& __t) - { return reference_wrapper<_Tp>(__t); } - - // Denotes a const reference should be taken to a variable. - template<typename _Tp> - inline reference_wrapper<const _Tp> - cref(const _Tp& __t) - { return reference_wrapper<const _Tp>(__t); } - - template<typename _Tp> - inline reference_wrapper<_Tp> - ref(reference_wrapper<_Tp> __t) - { return ref(__t.get()); } - - template<typename _Tp> - inline reference_wrapper<const _Tp> - cref(reference_wrapper<_Tp> __t) - { return cref(__t.get()); } - - template<typename _Tp, bool> - struct _Mem_fn_const_or_non - { - typedef const _Tp& type; - }; - - template<typename _Tp> - struct _Mem_fn_const_or_non<_Tp, false> - { - typedef _Tp& type; - }; - - /** - * Derives from @c unary_function or @c binary_function, or perhaps - * nothing, depending on the number of arguments provided. The - * primary template is the basis case, which derives nothing. - */ - template<typename _Res, typename... _ArgTypes> - struct _Maybe_unary_or_binary_function { }; - - /// Derives from @c unary_function, as appropriate. - template<typename _Res, typename _T1> - struct _Maybe_unary_or_binary_function<_Res, _T1> - : std::unary_function<_T1, _Res> { }; - - /// Derives from @c binary_function, as appropriate. - template<typename _Res, typename _T1, typename _T2> - struct _Maybe_unary_or_binary_function<_Res, _T1, _T2> - : std::binary_function<_T1, _T2, _Res> { }; - - /// Implementation of @c mem_fn for member function pointers. - template<typename _Res, typename _Class, typename... _ArgTypes> - class _Mem_fn<_Res (_Class::*)(_ArgTypes...)> - : public _Maybe_unary_or_binary_function<_Res, _Class*, _ArgTypes...> - { - typedef _Res (_Class::*_Functor)(_ArgTypes...); - - template<typename _Tp> - _Res - _M_call(_Tp& __object, const volatile _Class *, - _ArgTypes... __args) const - { return (__object.*__pmf)(__args...); } - - template<typename _Tp> - _Res - _M_call(_Tp& __ptr, const volatile void *, _ArgTypes... __args) const - { return ((*__ptr).*__pmf)(__args...); } - - public: - typedef _Res result_type; - - explicit _Mem_fn(_Functor __pmf) : __pmf(__pmf) { } - - // Handle objects - _Res - operator()(_Class& __object, _ArgTypes... __args) const - { return (__object.*__pmf)(__args...); } - - // Handle pointers - _Res - operator()(_Class* __object, _ArgTypes... __args) const - { return (__object->*__pmf)(__args...); } - - // Handle smart pointers, references and pointers to derived - template<typename _Tp> - _Res - operator()(_Tp& __object, _ArgTypes... __args) const - { return _M_call(__object, &__object, __args...); } - - private: - _Functor __pmf; - }; - - /// Implementation of @c mem_fn for const member function pointers. - template<typename _Res, typename _Class, typename... _ArgTypes> - class _Mem_fn<_Res (_Class::*)(_ArgTypes...) const> - : public _Maybe_unary_or_binary_function<_Res, const _Class*, - _ArgTypes...> - { - typedef _Res (_Class::*_Functor)(_ArgTypes...) const; - - template<typename _Tp> - _Res - _M_call(_Tp& __object, const volatile _Class *, - _ArgTypes... __args) const - { return (__object.*__pmf)(__args...); } - - template<typename _Tp> - _Res - _M_call(_Tp& __ptr, const volatile void *, _ArgTypes... __args) const - { return ((*__ptr).*__pmf)(__args...); } - - public: - typedef _Res result_type; - - explicit _Mem_fn(_Functor __pmf) : __pmf(__pmf) { } - - // Handle objects - _Res - operator()(const _Class& __object, _ArgTypes... __args) const - { return (__object.*__pmf)(__args...); } - - // Handle pointers - _Res - operator()(const _Class* __object, _ArgTypes... __args) const - { return (__object->*__pmf)(__args...); } - - // Handle smart pointers, references and pointers to derived - template<typename _Tp> - _Res operator()(_Tp& __object, _ArgTypes... __args) const - { return _M_call(__object, &__object, __args...); } - - private: - _Functor __pmf; - }; - - /// Implementation of @c mem_fn for volatile member function pointers. - template<typename _Res, typename _Class, typename... _ArgTypes> - class _Mem_fn<_Res (_Class::*)(_ArgTypes...) volatile> - : public _Maybe_unary_or_binary_function<_Res, volatile _Class*, - _ArgTypes...> - { - typedef _Res (_Class::*_Functor)(_ArgTypes...) volatile; - - template<typename _Tp> - _Res - _M_call(_Tp& __object, const volatile _Class *, - _ArgTypes... __args) const - { return (__object.*__pmf)(__args...); } - - template<typename _Tp> - _Res - _M_call(_Tp& __ptr, const volatile void *, _ArgTypes... __args) const - { return ((*__ptr).*__pmf)(__args...); } - - public: - typedef _Res result_type; - - explicit _Mem_fn(_Functor __pmf) : __pmf(__pmf) { } - - // Handle objects - _Res - operator()(volatile _Class& __object, _ArgTypes... __args) const - { return (__object.*__pmf)(__args...); } - - // Handle pointers - _Res - operator()(volatile _Class* __object, _ArgTypes... __args) const - { return (__object->*__pmf)(__args...); } - - // Handle smart pointers, references and pointers to derived - template<typename _Tp> - _Res - operator()(_Tp& __object, _ArgTypes... __args) const - { return _M_call(__object, &__object, __args...); } - - private: - _Functor __pmf; - }; - - /// Implementation of @c mem_fn for const volatile member function pointers. - template<typename _Res, typename _Class, typename... _ArgTypes> - class _Mem_fn<_Res (_Class::*)(_ArgTypes...) const volatile> - : public _Maybe_unary_or_binary_function<_Res, const volatile _Class*, - _ArgTypes...> - { - typedef _Res (_Class::*_Functor)(_ArgTypes...) const volatile; - - template<typename _Tp> - _Res - _M_call(_Tp& __object, const volatile _Class *, - _ArgTypes... __args) const - { return (__object.*__pmf)(__args...); } - - template<typename _Tp> - _Res - _M_call(_Tp& __ptr, const volatile void *, _ArgTypes... __args) const - { return ((*__ptr).*__pmf)(__args...); } - - public: - typedef _Res result_type; - - explicit _Mem_fn(_Functor __pmf) : __pmf(__pmf) { } - - // Handle objects - _Res - operator()(const volatile _Class& __object, _ArgTypes... __args) const - { return (__object.*__pmf)(__args...); } - - // Handle pointers - _Res - operator()(const volatile _Class* __object, _ArgTypes... __args) const - { return (__object->*__pmf)(__args...); } - - // Handle smart pointers, references and pointers to derived - template<typename _Tp> - _Res operator()(_Tp& __object, _ArgTypes... __args) const - { return _M_call(__object, &__object, __args...); } - - private: - _Functor __pmf; - }; - - - template<typename _Res, typename _Class> - class _Mem_fn<_Res _Class::*> - { - // This bit of genius is due to Peter Dimov, improved slightly by - // Douglas Gregor. - template<typename _Tp> - _Res& - _M_call(_Tp& __object, _Class *) const - { return __object.*__pm; } - - template<typename _Tp, typename _Up> - _Res& - _M_call(_Tp& __object, _Up * const *) const - { return (*__object).*__pm; } - - template<typename _Tp, typename _Up> - const _Res& - _M_call(_Tp& __object, const _Up * const *) const - { return (*__object).*__pm; } - - template<typename _Tp> - const _Res& - _M_call(_Tp& __object, const _Class *) const - { return __object.*__pm; } - - template<typename _Tp> - const _Res& - _M_call(_Tp& __ptr, const volatile void*) const - { return (*__ptr).*__pm; } - - template<typename _Tp> static _Tp& __get_ref(); - - template<typename _Tp> - static __sfinae_types::__one __check_const(_Tp&, _Class*); - template<typename _Tp, typename _Up> - static __sfinae_types::__one __check_const(_Tp&, _Up * const *); - template<typename _Tp, typename _Up> - static __sfinae_types::__two __check_const(_Tp&, const _Up * const *); - template<typename _Tp> - static __sfinae_types::__two __check_const(_Tp&, const _Class*); - template<typename _Tp> - static __sfinae_types::__two __check_const(_Tp&, const volatile void*); - - public: - template<typename _Tp> - struct _Result_type - : _Mem_fn_const_or_non<_Res, - (sizeof(__sfinae_types::__two) - == sizeof(__check_const<_Tp>(__get_ref<_Tp>(), (_Tp*)0)))> - { }; - - template<typename _Signature> - struct result; - - template<typename _CVMem, typename _Tp> - struct result<_CVMem(_Tp)> - : public _Result_type<_Tp> { }; - - template<typename _CVMem, typename _Tp> - struct result<_CVMem(_Tp&)> - : public _Result_type<_Tp> { }; - - explicit - _Mem_fn(_Res _Class::*__pm) : __pm(__pm) { } - - // Handle objects - _Res& - operator()(_Class& __object) const - { return __object.*__pm; } - - const _Res& - operator()(const _Class& __object) const - { return __object.*__pm; } - - // Handle pointers - _Res& - operator()(_Class* __object) const - { return __object->*__pm; } - - const _Res& - operator()(const _Class* __object) const - { return __object->*__pm; } - - // Handle smart pointers and derived - template<typename _Tp> - typename _Result_type<_Tp>::type - operator()(_Tp& __unknown) const - { return _M_call(__unknown, &__unknown); } - - private: - _Res _Class::*__pm; - }; - - /** - * @brief Returns a function object that forwards to the member - * pointer @a pm. - */ - template<typename _Tp, typename _Class> - inline _Mem_fn<_Tp _Class::*> - mem_fn(_Tp _Class::* __pm) - { - return _Mem_fn<_Tp _Class::*>(__pm); - } - - /** - * @brief Determines if the given type _Tp is a function object - * should be treated as a subexpression when evaluating calls to - * function objects returned by bind(). [TR1 3.6.1] - */ - template<typename _Tp> - struct is_bind_expression - { static const bool value = false; }; - - template<typename _Tp> - const bool is_bind_expression<_Tp>::value; - - /** - * @brief Determines if the given type _Tp is a placeholder in a - * bind() expression and, if so, which placeholder it is. [TR1 3.6.2] - */ - template<typename _Tp> - struct is_placeholder - { static const int value = 0; }; - - template<typename _Tp> - const int is_placeholder<_Tp>::value; - - /// The type of placeholder objects defined by libstdc++. - template<int _Num> struct _Placeholder { }; - - /** @namespace std::placeholders - * @brief ISO C++ 0x entities sub namespace for functional. - * - * Define a large number of placeholders. There is no way to - * simplify this with variadic templates, because we're introducing - * unique names for each. - */ - namespace placeholders - { - namespace - { - _Placeholder<1> _1; - _Placeholder<2> _2; - _Placeholder<3> _3; - _Placeholder<4> _4; - _Placeholder<5> _5; - _Placeholder<6> _6; - _Placeholder<7> _7; - _Placeholder<8> _8; - _Placeholder<9> _9; - _Placeholder<10> _10; - _Placeholder<11> _11; - _Placeholder<12> _12; - _Placeholder<13> _13; - _Placeholder<14> _14; - _Placeholder<15> _15; - _Placeholder<16> _16; - _Placeholder<17> _17; - _Placeholder<18> _18; - _Placeholder<19> _19; - _Placeholder<20> _20; - _Placeholder<21> _21; - _Placeholder<22> _22; - _Placeholder<23> _23; - _Placeholder<24> _24; - _Placeholder<25> _25; - _Placeholder<26> _26; - _Placeholder<27> _27; - _Placeholder<28> _28; - _Placeholder<29> _29; - } - } - - /** - * Partial specialization of is_placeholder that provides the placeholder - * number for the placeholder objects defined by libstdc++. - */ - template<int _Num> - struct is_placeholder<_Placeholder<_Num> > - { static const int value = _Num; }; - - template<int _Num> - const int is_placeholder<_Placeholder<_Num> >::value; - - /** - * Stores a tuple of indices. Used by bind() to extract the elements - * in a tuple. - */ - template<int... _Indexes> - struct _Index_tuple { }; - - /// Builds an _Index_tuple<0, 1, 2, ..., _Num-1>. - template<std::size_t _Num, typename _Tuple = _Index_tuple<> > - struct _Build_index_tuple; - - template<std::size_t _Num, int... _Indexes> - struct _Build_index_tuple<_Num, _Index_tuple<_Indexes...> > - : _Build_index_tuple<_Num - 1, - _Index_tuple<_Indexes..., sizeof...(_Indexes)> > - { - }; - - template<int... _Indexes> - struct _Build_index_tuple<0, _Index_tuple<_Indexes...> > - { - typedef _Index_tuple<_Indexes...> __type; - }; - - /** - * Used by _Safe_tuple_element to indicate that there is no tuple - * element at this position. - */ - struct _No_tuple_element; - - /** - * Implementation helper for _Safe_tuple_element. This primary - * template handles the case where it is safe to use @c - * tuple_element. - */ - template<int __i, typename _Tuple, bool _IsSafe> - struct _Safe_tuple_element_impl - : tuple_element<__i, _Tuple> { }; - - /** - * Implementation helper for _Safe_tuple_element. This partial - * specialization handles the case where it is not safe to use @c - * tuple_element. We just return @c _No_tuple_element. - */ - template<int __i, typename _Tuple> - struct _Safe_tuple_element_impl<__i, _Tuple, false> - { - typedef _No_tuple_element type; - }; - - /** - * Like tuple_element, but returns @c _No_tuple_element when - * tuple_element would return an error. - */ - template<int __i, typename _Tuple> - struct _Safe_tuple_element - : _Safe_tuple_element_impl<__i, _Tuple, - (__i >= 0 && __i < tuple_size<_Tuple>::value)> - { - }; - - /** - * Maps an argument to bind() into an actual argument to the bound - * function object [TR1 3.6.3/5]. Only the first parameter should - * be specified: the rest are used to determine among the various - * implementations. Note that, although this class is a function - * object, it isn't entirely normal because it takes only two - * parameters regardless of the number of parameters passed to the - * bind expression. The first parameter is the bound argument and - * the second parameter is a tuple containing references to the - * rest of the arguments. - */ - template<typename _Arg, - bool _IsBindExp = is_bind_expression<_Arg>::value, - bool _IsPlaceholder = (is_placeholder<_Arg>::value > 0)> - class _Mu; - - /** - * If the argument is reference_wrapper<_Tp>, returns the - * underlying reference. [TR1 3.6.3/5 bullet 1] - */ - template<typename _Tp> - class _Mu<reference_wrapper<_Tp>, false, false> - { - public: - typedef _Tp& result_type; - - /* Note: This won't actually work for const volatile - * reference_wrappers, because reference_wrapper::get() is const - * but not volatile-qualified. This might be a defect in the TR. - */ - template<typename _CVRef, typename _Tuple> - result_type - operator()(_CVRef& __arg, const _Tuple&) const volatile - { return __arg.get(); } - }; - - /** - * If the argument is a bind expression, we invoke the underlying - * function object with the same cv-qualifiers as we are given and - * pass along all of our arguments (unwrapped). [TR1 3.6.3/5 bullet 2] - */ - template<typename _Arg> - class _Mu<_Arg, true, false> - { - public: - template<typename _Signature> class result; - - // Determine the result type when we pass the arguments along. This - // involves passing along the cv-qualifiers placed on _Mu and - // unwrapping the argument bundle. - template<typename _CVMu, typename _CVArg, typename... _Args> - class result<_CVMu(_CVArg, tuple<_Args...>)> - : public result_of<_CVArg(_Args...)> { }; - - template<typename _CVArg, typename... _Args> - typename result_of<_CVArg(_Args...)>::type - operator()(_CVArg& __arg, - const tuple<_Args...>& __tuple) const volatile - { - // Construct an index tuple and forward to __call - typedef typename _Build_index_tuple<sizeof...(_Args)>::__type - _Indexes; - return this->__call(__arg, __tuple, _Indexes()); - } - - private: - // Invokes the underlying function object __arg by unpacking all - // of the arguments in the tuple. - template<typename _CVArg, typename... _Args, int... _Indexes> - typename result_of<_CVArg(_Args...)>::type - __call(_CVArg& __arg, const tuple<_Args...>& __tuple, - const _Index_tuple<_Indexes...>&) const volatile - { - return __arg(_GLIBCXX_TR1 get<_Indexes>(__tuple)...); - } - }; - - /** - * If the argument is a placeholder for the Nth argument, returns - * a reference to the Nth argument to the bind function object. - * [TR1 3.6.3/5 bullet 3] - */ - template<typename _Arg> - class _Mu<_Arg, false, true> - { - public: - template<typename _Signature> class result; - - template<typename _CVMu, typename _CVArg, typename _Tuple> - class result<_CVMu(_CVArg, _Tuple)> - { - // Add a reference, if it hasn't already been done for us. - // This allows us to be a little bit sloppy in constructing - // the tuple that we pass to result_of<...>. - typedef typename _Safe_tuple_element<(is_placeholder<_Arg>::value - - 1), _Tuple>::type - __base_type; - - public: -#ifdef _GLIBCXX_INCLUDE_AS_CXX0X - typedef typename add_lvalue_reference<__base_type>::type type; -#else - typedef typename add_reference<__base_type>::type type; -#endif - }; - - template<typename _Tuple> - typename result<_Mu(_Arg, _Tuple)>::type - operator()(const volatile _Arg&, const _Tuple& __tuple) const volatile - { - return ::std::_GLIBCXX_TR1 get<(is_placeholder<_Arg>::value - - 1)>(__tuple); - } - }; - - /** - * If the argument is just a value, returns a reference to that - * value. The cv-qualifiers on the reference are the same as the - * cv-qualifiers on the _Mu object. [TR1 3.6.3/5 bullet 4] - */ - template<typename _Arg> - class _Mu<_Arg, false, false> - { - public: - template<typename _Signature> struct result; - - template<typename _CVMu, typename _CVArg, typename _Tuple> - struct result<_CVMu(_CVArg, _Tuple)> - { -#ifdef _GLIBCXX_INCLUDE_AS_CXX0X - typedef typename add_lvalue_reference<_CVArg>::type type; -#else - typedef typename add_reference<_CVArg>::type type; -#endif - }; - - // Pick up the cv-qualifiers of the argument - template<typename _CVArg, typename _Tuple> - _CVArg& - operator()(_CVArg& __arg, const _Tuple&) const volatile - { return __arg; } - }; - - /** - * Maps member pointers into instances of _Mem_fn but leaves all - * other function objects untouched. Used by tr1::bind(). The - * primary template handles the non--member-pointer case. - */ - template<typename _Tp> - struct _Maybe_wrap_member_pointer - { - typedef _Tp type; - - static const _Tp& - __do_wrap(const _Tp& __x) - { return __x; } - }; - - /** - * Maps member pointers into instances of _Mem_fn but leaves all - * other function objects untouched. Used by tr1::bind(). This - * partial specialization handles the member pointer case. - */ - template<typename _Tp, typename _Class> - struct _Maybe_wrap_member_pointer<_Tp _Class::*> - { - typedef _Mem_fn<_Tp _Class::*> type; - - static type - __do_wrap(_Tp _Class::* __pm) - { return type(__pm); } - }; - - /// Type of the function object returned from bind(). - template<typename _Signature> - struct _Bind; - - template<typename _Functor, typename... _Bound_args> - class _Bind<_Functor(_Bound_args...)> - : public _Weak_result_type<_Functor> - { - typedef _Bind __self_type; - typedef typename _Build_index_tuple<sizeof...(_Bound_args)>::__type - _Bound_indexes; - - _Functor _M_f; - tuple<_Bound_args...> _M_bound_args; - - // Call unqualified - template<typename... _Args, int... _Indexes> - typename result_of< - _Functor(typename result_of<_Mu<_Bound_args> - (_Bound_args, tuple<_Args...>)>::type...) - >::type - __call(const tuple<_Args...>& __args, _Index_tuple<_Indexes...>) - { - return _M_f(_Mu<_Bound_args>() - (_GLIBCXX_TR1 get<_Indexes>(_M_bound_args), __args)...); - } - - // Call as const - template<typename... _Args, int... _Indexes> - typename result_of< - const _Functor(typename result_of<_Mu<_Bound_args> - (const _Bound_args, tuple<_Args...>) - >::type...)>::type - __call(const tuple<_Args...>& __args, _Index_tuple<_Indexes...>) const - { - return _M_f(_Mu<_Bound_args>() - (_GLIBCXX_TR1 get<_Indexes>(_M_bound_args), __args)...); - } - - // Call as volatile - template<typename... _Args, int... _Indexes> - typename result_of< - volatile _Functor(typename result_of<_Mu<_Bound_args> - (volatile _Bound_args, tuple<_Args...>) - >::type...)>::type - __call(const tuple<_Args...>& __args, - _Index_tuple<_Indexes...>) volatile - { - return _M_f(_Mu<_Bound_args>() - (_GLIBCXX_TR1 get<_Indexes>(_M_bound_args), __args)...); - } - - // Call as const volatile - template<typename... _Args, int... _Indexes> - typename result_of< - const volatile _Functor(typename result_of<_Mu<_Bound_args> - (const volatile _Bound_args, - tuple<_Args...>) - >::type...)>::type - __call(const tuple<_Args...>& __args, - _Index_tuple<_Indexes...>) const volatile - { - return _M_f(_Mu<_Bound_args>() - (_GLIBCXX_TR1 get<_Indexes>(_M_bound_args), __args)...); - } - - public: - explicit _Bind(_Functor __f, _Bound_args... __bound_args) - : _M_f(__f), _M_bound_args(__bound_args...) { } - - // Call unqualified - template<typename... _Args> - typename result_of< - _Functor(typename result_of<_Mu<_Bound_args> - (_Bound_args, tuple<_Args...>)>::type...) - >::type - operator()(_Args&... __args) - { - return this->__call(_GLIBCXX_TR1 tie(__args...), _Bound_indexes()); - } - - // Call as const - template<typename... _Args> - typename result_of< - const _Functor(typename result_of<_Mu<_Bound_args> - (const _Bound_args, tuple<_Args...>)>::type...) - >::type - operator()(_Args&... __args) const - { - return this->__call(_GLIBCXX_TR1 tie(__args...), _Bound_indexes()); - } - - - // Call as volatile - template<typename... _Args> - typename result_of< - volatile _Functor(typename result_of<_Mu<_Bound_args> - (volatile _Bound_args, tuple<_Args...>)>::type...) - >::type - operator()(_Args&... __args) volatile - { - return this->__call(_GLIBCXX_TR1 tie(__args...), _Bound_indexes()); - } - - - // Call as const volatile - template<typename... _Args> - typename result_of< - const volatile _Functor(typename result_of<_Mu<_Bound_args> - (const volatile _Bound_args, - tuple<_Args...>)>::type...) - >::type - operator()(_Args&... __args) const volatile - { - return this->__call(_GLIBCXX_TR1 tie(__args...), _Bound_indexes()); - } - }; - - /// Type of the function object returned from bind<R>(). - template<typename _Result, typename _Signature> - struct _Bind_result; - - template<typename _Result, typename _Functor, typename... _Bound_args> - class _Bind_result<_Result, _Functor(_Bound_args...)> - { - typedef _Bind_result __self_type; - typedef typename _Build_index_tuple<sizeof...(_Bound_args)>::__type - _Bound_indexes; - - _Functor _M_f; - tuple<_Bound_args...> _M_bound_args; - - // Call unqualified - template<typename... _Args, int... _Indexes> - _Result - __call(const tuple<_Args...>& __args, _Index_tuple<_Indexes...>) - { - return _M_f(_Mu<_Bound_args>() - (_GLIBCXX_TR1 get<_Indexes>(_M_bound_args), __args)...); - } - - // Call as const - template<typename... _Args, int... _Indexes> - _Result - __call(const tuple<_Args...>& __args, _Index_tuple<_Indexes...>) const - { - return _M_f(_Mu<_Bound_args>() - (_GLIBCXX_TR1 get<_Indexes>(_M_bound_args), __args)...); - } - - // Call as volatile - template<typename... _Args, int... _Indexes> - _Result - __call(const tuple<_Args...>& __args, - _Index_tuple<_Indexes...>) volatile - { - return _M_f(_Mu<_Bound_args>() - (_GLIBCXX_TR1 get<_Indexes>(_M_bound_args), __args)...); - } - - // Call as const volatile - template<typename... _Args, int... _Indexes> - _Result - __call(const tuple<_Args...>& __args, - _Index_tuple<_Indexes...>) const volatile - { - return _M_f(_Mu<_Bound_args>() - (_GLIBCXX_TR1 get<_Indexes>(_M_bound_args), __args)...); - } - - public: - typedef _Result result_type; - - explicit - _Bind_result(_Functor __f, _Bound_args... __bound_args) - : _M_f(__f), _M_bound_args(__bound_args...) { } - - // Call unqualified - template<typename... _Args> - result_type - operator()(_Args&... __args) - { - return this->__call(_GLIBCXX_TR1 tie(__args...), _Bound_indexes()); - } - - // Call as const - template<typename... _Args> - result_type - operator()(_Args&... __args) const - { - return this->__call(_GLIBCXX_TR1 tie(__args...), _Bound_indexes()); - } - - // Call as volatile - template<typename... _Args> - result_type - operator()(_Args&... __args) volatile - { - return this->__call(_GLIBCXX_TR1 tie(__args...), _Bound_indexes()); - } - - // Call as const volatile - template<typename... _Args> - result_type - operator()(_Args&... __args) const volatile - { - return this->__call(_GLIBCXX_TR1 tie(__args...), _Bound_indexes()); - } - }; - - /// Class template _Bind is always a bind expression. - template<typename _Signature> - struct is_bind_expression<_Bind<_Signature> > - { static const bool value = true; }; - - template<typename _Signature> - const bool is_bind_expression<_Bind<_Signature> >::value; - - /// Class template _Bind_result is always a bind expression. - template<typename _Result, typename _Signature> - struct is_bind_expression<_Bind_result<_Result, _Signature> > - { static const bool value = true; }; - - template<typename _Result, typename _Signature> - const bool is_bind_expression<_Bind_result<_Result, _Signature> >::value; - - /// bind - template<typename _Functor, typename... _ArgTypes> - inline - _Bind<typename _Maybe_wrap_member_pointer<_Functor>::type(_ArgTypes...)> - bind(_Functor __f, _ArgTypes... __args) - { - typedef _Maybe_wrap_member_pointer<_Functor> __maybe_type; - typedef typename __maybe_type::type __functor_type; - typedef _Bind<__functor_type(_ArgTypes...)> __result_type; - return __result_type(__maybe_type::__do_wrap(__f), __args...); - } - - template<typename _Result, typename _Functor, typename... _ArgTypes> - inline - _Bind_result<_Result, - typename _Maybe_wrap_member_pointer<_Functor>::type - (_ArgTypes...)> - bind(_Functor __f, _ArgTypes... __args) - { - typedef _Maybe_wrap_member_pointer<_Functor> __maybe_type; - typedef typename __maybe_type::type __functor_type; - typedef _Bind_result<_Result, __functor_type(_ArgTypes...)> - __result_type; - return __result_type(__maybe_type::__do_wrap(__f), __args...); - } - - /** - * @brief Exception class thrown when class template function's - * operator() is called with an empty target. - * @ingroup exceptions - */ - class bad_function_call : public std::exception { }; - - /** - * The integral constant expression 0 can be converted into a - * pointer to this type. It is used by the function template to - * accept NULL pointers. - */ - struct _M_clear_type; - - /** - * Trait identifying "location-invariant" types, meaning that the - * address of the object (or any of its members) will not escape. - * Also implies a trivial copy constructor and assignment operator. - */ - template<typename _Tp> - struct __is_location_invariant - : integral_constant<bool, - (is_pointer<_Tp>::value - || is_member_pointer<_Tp>::value)> - { - }; - - class _Undefined_class; - - union _Nocopy_types - { - void* _M_object; - const void* _M_const_object; - void (*_M_function_pointer)(); - void (_Undefined_class::*_M_member_pointer)(); - }; - - union _Any_data - { - void* _M_access() { return &_M_pod_data[0]; } - const void* _M_access() const { return &_M_pod_data[0]; } - - template<typename _Tp> - _Tp& - _M_access() - { return *static_cast<_Tp*>(_M_access()); } - - template<typename _Tp> - const _Tp& - _M_access() const - { return *static_cast<const _Tp*>(_M_access()); } - - _Nocopy_types _M_unused; - char _M_pod_data[sizeof(_Nocopy_types)]; - }; - - enum _Manager_operation - { - __get_type_info, - __get_functor_ptr, - __clone_functor, - __destroy_functor - }; - - // Simple type wrapper that helps avoid annoying const problems - // when casting between void pointers and pointers-to-pointers. - template<typename _Tp> - struct _Simple_type_wrapper - { - _Simple_type_wrapper(_Tp __value) : __value(__value) { } - - _Tp __value; - }; - - template<typename _Tp> - struct __is_location_invariant<_Simple_type_wrapper<_Tp> > - : __is_location_invariant<_Tp> - { - }; - - // Converts a reference to a function object into a callable - // function object. - template<typename _Functor> - inline _Functor& - __callable_functor(_Functor& __f) - { return __f; } - - template<typename _Member, typename _Class> - inline _Mem_fn<_Member _Class::*> - __callable_functor(_Member _Class::* &__p) - { return mem_fn(__p); } - - template<typename _Member, typename _Class> - inline _Mem_fn<_Member _Class::*> - __callable_functor(_Member _Class::* const &__p) - { return mem_fn(__p); } - - template<typename _Signature> - class function; - - /// Base class of all polymorphic function object wrappers. - class _Function_base - { - public: - static const std::size_t _M_max_size = sizeof(_Nocopy_types); - static const std::size_t _M_max_align = __alignof__(_Nocopy_types); - - template<typename _Functor> - class _Base_manager - { - protected: - static const bool __stored_locally = - (__is_location_invariant<_Functor>::value - && sizeof(_Functor) <= _M_max_size - && __alignof__(_Functor) <= _M_max_align - && (_M_max_align % __alignof__(_Functor) == 0)); - - typedef integral_constant<bool, __stored_locally> _Local_storage; - - // Retrieve a pointer to the function object - static _Functor* - _M_get_pointer(const _Any_data& __source) - { - const _Functor* __ptr = - __stored_locally? &__source._M_access<_Functor>() - /* have stored a pointer */ : __source._M_access<_Functor*>(); - return const_cast<_Functor*>(__ptr); - } - - // Clone a location-invariant function object that fits within - // an _Any_data structure. - static void - _M_clone(_Any_data& __dest, const _Any_data& __source, true_type) - { - new (__dest._M_access()) _Functor(__source._M_access<_Functor>()); - } - - // Clone a function object that is not location-invariant or - // that cannot fit into an _Any_data structure. - static void - _M_clone(_Any_data& __dest, const _Any_data& __source, false_type) - { - __dest._M_access<_Functor*>() = - new _Functor(*__source._M_access<_Functor*>()); - } - - // Destroying a location-invariant object may still require - // destruction. - static void - _M_destroy(_Any_data& __victim, true_type) - { - __victim._M_access<_Functor>().~_Functor(); - } - - // Destroying an object located on the heap. - static void - _M_destroy(_Any_data& __victim, false_type) - { - delete __victim._M_access<_Functor*>(); - } - - public: - static bool - _M_manager(_Any_data& __dest, const _Any_data& __source, - _Manager_operation __op) - { - switch (__op) - { -#ifdef __GXX_RTTI - case __get_type_info: - __dest._M_access<const type_info*>() = &typeid(_Functor); - break; -#endif - case __get_functor_ptr: - __dest._M_access<_Functor*>() = _M_get_pointer(__source); - break; - - case __clone_functor: - _M_clone(__dest, __source, _Local_storage()); - break; - - case __destroy_functor: - _M_destroy(__dest, _Local_storage()); - break; - } - return false; - } - - static void - _M_init_functor(_Any_data& __functor, const _Functor& __f) - { _M_init_functor(__functor, __f, _Local_storage()); } - - template<typename _Signature> - static bool - _M_not_empty_function(const function<_Signature>& __f) - { return static_cast<bool>(__f); } - - template<typename _Tp> - static bool - _M_not_empty_function(const _Tp*& __fp) - { return __fp; } - - template<typename _Class, typename _Tp> - static bool - _M_not_empty_function(_Tp _Class::* const& __mp) - { return __mp; } - - template<typename _Tp> - static bool - _M_not_empty_function(const _Tp&) - { return true; } - - private: - static void - _M_init_functor(_Any_data& __functor, const _Functor& __f, true_type) - { new (__functor._M_access()) _Functor(__f); } - - static void - _M_init_functor(_Any_data& __functor, const _Functor& __f, false_type) - { __functor._M_access<_Functor*>() = new _Functor(__f); } - }; - - template<typename _Functor> - class _Ref_manager : public _Base_manager<_Functor*> - { - typedef _Function_base::_Base_manager<_Functor*> _Base; - - public: - static bool - _M_manager(_Any_data& __dest, const _Any_data& __source, - _Manager_operation __op) - { - switch (__op) - { -#ifdef __GXX_RTTI - case __get_type_info: - __dest._M_access<const type_info*>() = &typeid(_Functor); - break; -#endif - case __get_functor_ptr: - __dest._M_access<_Functor*>() = *_Base::_M_get_pointer(__source); - return is_const<_Functor>::value; - break; - - default: - _Base::_M_manager(__dest, __source, __op); - } - return false; - } - - static void - _M_init_functor(_Any_data& __functor, reference_wrapper<_Functor> __f) - { - // TBD: Use address_of function instead. - _Base::_M_init_functor(__functor, &__f.get()); - } - }; - - _Function_base() : _M_manager(0) { } - - ~_Function_base() - { - if (_M_manager) - _M_manager(_M_functor, _M_functor, __destroy_functor); - } - - - bool _M_empty() const { return !_M_manager; } - - typedef bool (*_Manager_type)(_Any_data&, const _Any_data&, - _Manager_operation); - - _Any_data _M_functor; - _Manager_type _M_manager; - }; - - template<typename _Signature, typename _Functor> - class _Function_handler; - - template<typename _Res, typename _Functor, typename... _ArgTypes> - class _Function_handler<_Res(_ArgTypes...), _Functor> - : public _Function_base::_Base_manager<_Functor> - { - typedef _Function_base::_Base_manager<_Functor> _Base; - - public: - static _Res - _M_invoke(const _Any_data& __functor, _ArgTypes... __args) - { - return (*_Base::_M_get_pointer(__functor))(__args...); - } - }; - - template<typename _Functor, typename... _ArgTypes> - class _Function_handler<void(_ArgTypes...), _Functor> - : public _Function_base::_Base_manager<_Functor> - { - typedef _Function_base::_Base_manager<_Functor> _Base; - - public: - static void - _M_invoke(const _Any_data& __functor, _ArgTypes... __args) - { - (*_Base::_M_get_pointer(__functor))(__args...); - } - }; - - template<typename _Res, typename _Functor, typename... _ArgTypes> - class _Function_handler<_Res(_ArgTypes...), reference_wrapper<_Functor> > - : public _Function_base::_Ref_manager<_Functor> - { - typedef _Function_base::_Ref_manager<_Functor> _Base; - - public: - static _Res - _M_invoke(const _Any_data& __functor, _ArgTypes... __args) - { - return - __callable_functor(**_Base::_M_get_pointer(__functor))(__args...); - } - }; - - template<typename _Functor, typename... _ArgTypes> - class _Function_handler<void(_ArgTypes...), reference_wrapper<_Functor> > - : public _Function_base::_Ref_manager<_Functor> - { - typedef _Function_base::_Ref_manager<_Functor> _Base; - - public: - static void - _M_invoke(const _Any_data& __functor, _ArgTypes... __args) - { - __callable_functor(**_Base::_M_get_pointer(__functor))(__args...); - } - }; - - template<typename _Class, typename _Member, typename _Res, - typename... _ArgTypes> - class _Function_handler<_Res(_ArgTypes...), _Member _Class::*> - : public _Function_handler<void(_ArgTypes...), _Member _Class::*> - { - typedef _Function_handler<void(_ArgTypes...), _Member _Class::*> - _Base; - - public: - static _Res - _M_invoke(const _Any_data& __functor, _ArgTypes... __args) - { - return _GLIBCXX_TR1 - mem_fn(_Base::_M_get_pointer(__functor)->__value)(__args...); - } - }; - - template<typename _Class, typename _Member, typename... _ArgTypes> - class _Function_handler<void(_ArgTypes...), _Member _Class::*> - : public _Function_base::_Base_manager< - _Simple_type_wrapper< _Member _Class::* > > - { - typedef _Member _Class::* _Functor; - typedef _Simple_type_wrapper<_Functor> _Wrapper; - typedef _Function_base::_Base_manager<_Wrapper> _Base; - - public: - static bool - _M_manager(_Any_data& __dest, const _Any_data& __source, - _Manager_operation __op) - { - switch (__op) - { -#ifdef __GXX_RTTI - case __get_type_info: - __dest._M_access<const type_info*>() = &typeid(_Functor); - break; -#endif - case __get_functor_ptr: - __dest._M_access<_Functor*>() = - &_Base::_M_get_pointer(__source)->__value; - break; - - default: - _Base::_M_manager(__dest, __source, __op); - } - return false; - } - - static void - _M_invoke(const _Any_data& __functor, _ArgTypes... __args) - { - _GLIBCXX_TR1 - mem_fn(_Base::_M_get_pointer(__functor)->__value)(__args...); - } - }; - - /// class function - template<typename _Res, typename... _ArgTypes> - class function<_Res(_ArgTypes...)> - : public _Maybe_unary_or_binary_function<_Res, _ArgTypes...>, - private _Function_base - { -#ifndef __GXX_EXPERIMENTAL_CXX0X__ - /// This class is used to implement the safe_bool idiom. - struct _Hidden_type - { - _Hidden_type* _M_bool; - }; - - /// This typedef is used to implement the safe_bool idiom. - typedef _Hidden_type* _Hidden_type::* _Safe_bool; -#endif - - typedef _Res _Signature_type(_ArgTypes...); - - struct _Useless { }; - - public: - typedef _Res result_type; - - // [3.7.2.1] construct/copy/destroy - - /** - * @brief Default construct creates an empty function call wrapper. - * @post @c !(bool)*this - */ - function() : _Function_base() { } - - /** - * @brief Default construct creates an empty function call wrapper. - * @post @c !(bool)*this - */ - function(_M_clear_type*) : _Function_base() { } - - /** - * @brief %Function copy constructor. - * @param x A %function object with identical call signature. - * @pre @c (bool)*this == (bool)x - * - * The newly-created %function contains a copy of the target of @a - * x (if it has one). - */ - function(const function& __x); - - /** - * @brief Builds a %function that targets a copy of the incoming - * function object. - * @param f A %function object that is callable with parameters of - * type @c T1, @c T2, ..., @c TN and returns a value convertible - * to @c Res. - * - * The newly-created %function object will target a copy of @a - * f. If @a f is @c reference_wrapper<F>, then this function - * object will contain a reference to the function object @c - * f.get(). If @a f is a NULL function pointer or NULL - * pointer-to-member, the newly-created object will be empty. - * - * If @a f is a non-NULL function pointer or an object of type @c - * reference_wrapper<F>, this function will not throw. - */ - template<typename _Functor> - function(_Functor __f, - typename __gnu_cxx::__enable_if< - !is_integral<_Functor>::value, _Useless>::__type - = _Useless()); - - /** - * @brief %Function assignment operator. - * @param x A %function with identical call signature. - * @post @c (bool)*this == (bool)x - * @returns @c *this - * - * The target of @a x is copied to @c *this. If @a x has no - * target, then @c *this will be empty. - * - * If @a x targets a function pointer or a reference to a function - * object, then this operation will not throw an exception. - */ - function& - operator=(const function& __x) - { - function(__x).swap(*this); - return *this; - } - - /** - * @brief %Function assignment to zero. - * @post @c !(bool)*this - * @returns @c *this - * - * The target of @a *this is deallocated, leaving it empty. - */ - function& - operator=(_M_clear_type*) - { - if (_M_manager) - { - _M_manager(_M_functor, _M_functor, __destroy_functor); - _M_manager = 0; - _M_invoker = 0; - } - return *this; - } - - /** - * @brief %Function assignment to a new target. - * @param f A %function object that is callable with parameters of - * type @c T1, @c T2, ..., @c TN and returns a value convertible - * to @c Res. - * @return @c *this - * - * This %function object wrapper will target a copy of @a - * f. If @a f is @c reference_wrapper<F>, then this function - * object will contain a reference to the function object @c - * f.get(). If @a f is a NULL function pointer or NULL - * pointer-to-member, @c this object will be empty. - * - * If @a f is a non-NULL function pointer or an object of type @c - * reference_wrapper<F>, this function will not throw. - */ - template<typename _Functor> - typename __gnu_cxx::__enable_if<!is_integral<_Functor>::value, - function&>::__type - operator=(_Functor __f) - { - function(__f).swap(*this); - return *this; - } - - // [3.7.2.2] function modifiers - - /** - * @brief Swap the targets of two %function objects. - * @param f A %function with identical call signature. - * - * Swap the targets of @c this function object and @a f. This - * function will not throw an exception. - */ - void swap(function& __x) - { - _Any_data __old_functor = _M_functor; - _M_functor = __x._M_functor; - __x._M_functor = __old_functor; - _Manager_type __old_manager = _M_manager; - _M_manager = __x._M_manager; - __x._M_manager = __old_manager; - _Invoker_type __old_invoker = _M_invoker; - _M_invoker = __x._M_invoker; - __x._M_invoker = __old_invoker; - } - - // [3.7.2.3] function capacity - - /** - * @brief Determine if the %function wrapper has a target. - * - * @return @c true when this %function object contains a target, - * or @c false when it is empty. - * - * This function will not throw an exception. - */ -#ifdef __GXX_EXPERIMENTAL_CXX0X__ - explicit operator bool() const - { return !_M_empty(); } -#else - operator _Safe_bool() const - { - if (_M_empty()) - return 0; - else - return &_Hidden_type::_M_bool; - } -#endif - - // [3.7.2.4] function invocation - - /** - * @brief Invokes the function targeted by @c *this. - * @returns the result of the target. - * @throws bad_function_call when @c !(bool)*this - * - * The function call operator invokes the target function object - * stored by @c this. - */ - _Res operator()(_ArgTypes... __args) const; - -#ifdef __GXX_RTTI - // [3.7.2.5] function target access - /** - * @brief Determine the type of the target of this function object - * wrapper. - * - * @returns the type identifier of the target function object, or - * @c typeid(void) if @c !(bool)*this. - * - * This function will not throw an exception. - */ - const type_info& target_type() const; - - /** - * @brief Access the stored target function object. - * - * @return Returns a pointer to the stored target function object, - * if @c typeid(Functor).equals(target_type()); otherwise, a NULL - * pointer. - * - * This function will not throw an exception. - */ - template<typename _Functor> _Functor* target(); - - /// @overload - template<typename _Functor> const _Functor* target() const; -#endif - - private: - // [3.7.2.6] undefined operators - template<typename _Function> - void operator==(const function<_Function>&) const; - template<typename _Function> - void operator!=(const function<_Function>&) const; - - typedef _Res (*_Invoker_type)(const _Any_data&, _ArgTypes...); - _Invoker_type _M_invoker; - }; - - template<typename _Res, typename... _ArgTypes> - function<_Res(_ArgTypes...)>:: - function(const function& __x) - : _Function_base() - { - if (static_cast<bool>(__x)) - { - _M_invoker = __x._M_invoker; - _M_manager = __x._M_manager; - __x._M_manager(_M_functor, __x._M_functor, __clone_functor); - } - } - - template<typename _Res, typename... _ArgTypes> - template<typename _Functor> - function<_Res(_ArgTypes...)>:: - function(_Functor __f, - typename __gnu_cxx::__enable_if< - !is_integral<_Functor>::value, _Useless>::__type) - : _Function_base() - { - typedef _Function_handler<_Signature_type, _Functor> _My_handler; - - if (_My_handler::_M_not_empty_function(__f)) - { - _M_invoker = &_My_handler::_M_invoke; - _M_manager = &_My_handler::_M_manager; - _My_handler::_M_init_functor(_M_functor, __f); - } - } - - template<typename _Res, typename... _ArgTypes> - _Res - function<_Res(_ArgTypes...)>:: - operator()(_ArgTypes... __args) const - { - if (_M_empty()) - { -#if __EXCEPTIONS - throw bad_function_call(); -#else - __builtin_abort(); -#endif - } - return _M_invoker(_M_functor, __args...); - } - -#ifdef __GXX_RTTI - template<typename _Res, typename... _ArgTypes> - const type_info& - function<_Res(_ArgTypes...)>:: - target_type() const - { - if (_M_manager) - { - _Any_data __typeinfo_result; - _M_manager(__typeinfo_result, _M_functor, __get_type_info); - return *__typeinfo_result._M_access<const type_info*>(); - } - else - return typeid(void); - } - - template<typename _Res, typename... _ArgTypes> - template<typename _Functor> - _Functor* - function<_Res(_ArgTypes...)>:: - target() - { - if (typeid(_Functor) == target_type() && _M_manager) - { - _Any_data __ptr; - if (_M_manager(__ptr, _M_functor, __get_functor_ptr) - && !is_const<_Functor>::value) - return 0; - else - return __ptr._M_access<_Functor*>(); - } - else - return 0; - } - - template<typename _Res, typename... _ArgTypes> - template<typename _Functor> - const _Functor* - function<_Res(_ArgTypes...)>:: - target() const - { - if (typeid(_Functor) == target_type() && _M_manager) - { - _Any_data __ptr; - _M_manager(__ptr, _M_functor, __get_functor_ptr); - return __ptr._M_access<const _Functor*>(); - } - else - return 0; - } -#endif - - // [3.7.2.7] null pointer comparisons - - /** - * @brief Compares a polymorphic function object wrapper against 0 - * (the NULL pointer). - * @returns @c true if the wrapper has no target, @c false otherwise - * - * This function will not throw an exception. - */ - template<typename _Signature> - inline bool - operator==(const function<_Signature>& __f, _M_clear_type*) - { return !static_cast<bool>(__f); } - - /// @overload - template<typename _Signature> - inline bool - operator==(_M_clear_type*, const function<_Signature>& __f) - { return !static_cast<bool>(__f); } - - /** - * @brief Compares a polymorphic function object wrapper against 0 - * (the NULL pointer). - * @returns @c false if the wrapper has no target, @c true otherwise - * - * This function will not throw an exception. - */ - template<typename _Signature> - inline bool - operator!=(const function<_Signature>& __f, _M_clear_type*) - { return static_cast<bool>(__f); } - - /// @overload - template<typename _Signature> - inline bool - operator!=(_M_clear_type*, const function<_Signature>& __f) - { return static_cast<bool>(__f); } - - // [3.7.2.8] specialized algorithms - - /** - * @brief Swap the targets of two polymorphic function object wrappers. - * - * This function will not throw an exception. - */ - template<typename _Signature> - inline void - swap(function<_Signature>& __x, function<_Signature>& __y) - { __x.swap(__y); } - -_GLIBCXX_END_NAMESPACE_TR1 -} diff --git a/libstdc++-v3/testsuite/20_util/function/assign/move.cc b/libstdc++-v3/testsuite/20_util/function/assign/move.cc new file mode 100644 index 00000000000..a2ab96245ca --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/function/assign/move.cc @@ -0,0 +1,50 @@ +// { dg-options "-std=gnu++0x" } + +// Copyright (C) 2009 Free Software Foundation, Inc. +// +// This file is part of the GNU ISO C++ Library. This library 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. + +// This library 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 this library; see the file COPYING3. If not see +// <http://www.gnu.org/licenses/>. + +#include <functional> +#include <testsuite_hooks.h> + +int f1() { return 1; } +struct { int operator()() { return 2; } } f2; + +void test01() +{ + bool test __attribute__((unused)) = true; + + typedef std::function<int()> function; + + function fo(f1); + function fo1; + fo1 = (std::move(fo)); + VERIFY( static_cast<bool>(fo1) ); + VERIFY( fo1() == 1 ); + + fo = function(f2); + function fo2; + fo2 = (std::move(fo)); + VERIFY( static_cast<bool>(fo2) ); + VERIFY( fo2() == 2 ); +} + +int main() +{ + test01(); + + return 0; +} diff --git a/libstdc++-v3/testsuite/20_util/function/cmp/cmp_neg.cc b/libstdc++-v3/testsuite/20_util/function/cmp/cmp_neg.cc new file mode 100644 index 00000000000..a196ef64e2e --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/function/cmp/cmp_neg.cc @@ -0,0 +1,37 @@ +// { dg-options "-std=gnu++0x" } +// { dg-do compile } + +// Copyright (C) 2009 Free Software Foundation, Inc. +// +// This file is part of the GNU ISO C++ Library. This library 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. + +// This library 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 this library; see the file COPYING3. If not see +// <http://www.gnu.org/licenses/>. + +#include <functional> + +void test01() +{ + std::function<void()> f1; + std::function<void()> f2; + f1 == f2; // { dg-error "here" } + f1 != f2; // { dg-error "here" } + // { dg-excess-errors "" } +} + +int main() +{ + test01(); + + return 0; +} diff --git a/libstdc++-v3/testsuite/20_util/function/cons/move.cc b/libstdc++-v3/testsuite/20_util/function/cons/move.cc new file mode 100644 index 00000000000..43d71858c9f --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/function/cons/move.cc @@ -0,0 +1,48 @@ +// { dg-options "-std=gnu++0x" } + +// Copyright (C) 2009 Free Software Foundation, Inc. +// +// This file is part of the GNU ISO C++ Library. This library 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. + +// This library 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 this library; see the file COPYING3. If not see +// <http://www.gnu.org/licenses/>. + +#include <functional> +#include <testsuite_hooks.h> + +int f1() { return 1; } +struct { int operator()() { return 2; } } f2; + +void test01() +{ + bool test __attribute__((unused)) = true; + + typedef std::function<int()> function; + + function fo(f1); + function fo1(std::move(fo)); + VERIFY( static_cast<bool>(fo1) ); + VERIFY( fo1() == 1 ); + + fo = function(f2); + function fo2(std::move(fo)); + VERIFY( static_cast<bool>(fo2) ); + VERIFY( fo2() == 2 ); +} + +int main() +{ + test01(); + + return 0; +} diff --git a/libstdc++-v3/testsuite/20_util/function/invoke/move_only.cc b/libstdc++-v3/testsuite/20_util/function/invoke/move_only.cc new file mode 100644 index 00000000000..fbfb0624a00 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/function/invoke/move_only.cc @@ -0,0 +1,61 @@ +// { dg-options "-std=gnu++0x" } + +// Copyright (C) 2009 Free Software Foundation, Inc. +// +// This file is part of the GNU ISO C++ Library. This library 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. + +// This library 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 this library; see the file COPYING3. If not see +// <http://www.gnu.org/licenses/>. + +#include <functional> + +struct moveable +{ + moveable() = default; + ~moveable() = default; + moveable(const moveable& c) = delete; + moveable& operator=(const moveable&) = delete; + moveable(moveable&&) { } +}; + +void f1(moveable) { } +void f2(moveable&&) { } +struct { void operator()(moveable&&) { } } f3; + +void test01() +{ + std::function<void (moveable)> fo1a(f1); + fo1a(moveable()); + + std::function<void (moveable)> fo2a(f2); + fo2a(moveable()); + + std::function<void (moveable)> fo3a(f3); + fo3a(moveable()); + + std::function<void (moveable&&)> fo1b(f1); + fo1b(moveable()); + + std::function<void (moveable&&)> fo2b(f2); + fo2b(moveable()); + + std::function<void (moveable&&)> fo3b(f3); + fo3b(moveable()); +} + +int main() +{ + test01(); + + return 0; +} diff --git a/libstdc++-v3/testsuite/lib/libstdc++.exp b/libstdc++-v3/testsuite/lib/libstdc++.exp index c71991afc90..9ae652f7328 100644 --- a/libstdc++-v3/testsuite/lib/libstdc++.exp +++ b/libstdc++-v3/testsuite/lib/libstdc++.exp @@ -97,6 +97,13 @@ proc libstdc++_init { testfile } { setenv LC_ALL C setenv LANG C + # Many hosts now default to a non-ASCII C locale, however, so + # they can set a charset encoding here if they need. + if { [ishost "*-*-cygwin*"] } { + setenv LC_ALL C.ASCII + setenv LANG C.ASCII + } + set blddir [lookfor_file [get_multilibs] libstdc++-v3] set flags_file "${blddir}/scripts/testsuite_flags" v3track flags_file 2 |