diff options
475 files changed, 15711 insertions, 8686 deletions
diff --git a/ChangeLog b/ChangeLog index a28e29cffb7..e52412498bd 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ + +2008-05-18 Xinliang David Li <davidxl@google.com> + + * ChangeLog: Remove wrong ChangeLog entry. + +2008-05-17 Xinliang David Li <davidxl@google.com> + + * MAINTAINERS (Write After Approval): Add myself. + 2008-05-15 Janus Weil <janus@gcc.gnu.org> * MAINTAINERS (Write After Approval): Add myself. diff --git a/ChangeLog.melt b/ChangeLog.melt index b04f9120b2f..6e01186bd4b 100644 --- a/ChangeLog.melt +++ b/ChangeLog.melt @@ -1,3 +1,6 @@ +2008-05-21 Basile Starynkevitch <basile@starynkevitch.net> + MELT branch merged with trunk r135714 + 2008-05-17 Basile Starynkevitch <basile@starynkevitch.net> MELT branch merged with trunk r135459 diff --git a/MAINTAINERS b/MAINTAINERS index 23f98faab5f..b1163975974 100644 --- a/MAINTAINERS +++ b/MAINTAINERS @@ -372,6 +372,7 @@ Manuel López-Ibáñez manu@gcc.gnu.org Dave Love d.love@dl.ac.uk Martin v. Löwis loewis@informatik.hu-berlin.de H.J. Lu hjl.tools@gmail.com +Xinliang David Li davidxl@google.com William Maddox maddox@google.com Ziga Mahkovec ziga.mahkovec@klika.si Simon Martin simartin@users.sourceforge.net diff --git a/gcc/ChangeLog b/gcc/ChangeLog index 86c6d31605b..9ebf3410540 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,7 +1,312 @@ +2008-05-21 David S. Miller <davem@davemloft.net> + + * config.gcc (sparc-*-linux*): Always include sparc/t-linux in + tmake_file. + +2008-05-21 Eric Botcazou <ebotcazou@adacore.com> + + * cfgexpand.c (tree_expand_cfg): Zap the EH throw statement table + once finished. + +2008-05-20 David Daney <ddaney@avtrex.com> + + * config/mips/mips.md (UNSPEC_SYNC_NEW_OP_12, + UNSPEC_SYNC_OLD_OP_12, + UNSPEC_SYNC_EXCHANGE_12): New define_constants. + (UNSPEC_SYNC_EXCHANGE, UNSPEC_MEMORY_BARRIER, + UNSPEC_SET_GOT_VERSION, + UNSPEC_UPDATE_GOT_VERSION): Renumber. + (optab, insn): Add 'plus' and 'minus' to define_code_attr. + (atomic_hiqi_op): New define_code_iterator. + (sync_compare_and_swap<mode>): Call + mips_expand_atomic_qihi instead of + mips_expand_compare_and_swap_12. + (compare_and_swap_12): Use MIPS_COMPARE_AND_SWAP_12 instead of + MIPS_COMPARE_AND_SWAP_12_0. Pass argument to + MIPS_COMPARE_AND_SWAP_12. + (sync_<optab><mode>, sync_old_<optab><mode>, + sync_new_<optab><mode>, sync_nand<mode>, sync_old_nand<mode>, + sync_new_nand<mode>): New define_expands for HI and QI mode + operands. + (sync_<optab>_12, sync_old_<optab>_12, sync_new_<optab>_12, + sync_nand_12, sync_old_nand_12, sync_new_nand_12): New insns. + (sync_lock_test_and_set<mode>): New define_expand for HI and QI + modes. + (test_and_set_12): New insn. + (sync_old_add<mode>, sync_new_add<mode>, sync_old_<optab><mode>, + sync_new_<optab><mode>, sync_old_nand<mode>, + sync_new_nand<mode>, sync_lock_test_and_set<mode>): Add early + clobber to operand 0 for SI and DI mode insns. + * config/mips/mips-protos.h (mips_gen_fn_6, mips_gen_fn_5, + mips_gen_fn_4): New typedefs. + (mips_gen_fn_ptrs): Define new union type. + (mips_expand_compare_and_swap_12): Remove declaration. + (mips_expand_atomic_qihi): Declare function. + * config/mips/mips.c (mips_expand_compare_and_swap_12): Rename to... + (mips_expand_atomic_qihi): ... this. Use new generator function + parameter. + * config/mips/mips.h (MIPS_COMPARE_AND_SWAP_12): Add OPS parameter. + (MIPS_COMPARE_AND_SWAP_12_0): Delete macro. + (MIPS_COMPARE_AND_SWAP_12_ZERO_OP, + MIPS_COMPARE_AND_SWAP_12_NONZERO_OP, + MIPS_SYNC_OP_12, MIPS_SYNC_OP_12_NOT_NOP, + MIPS_SYNC_OP_12_NOT_NOT, MIPS_SYNC_OLD_OP_12, + MIPS_SYNC_OLD_OP_12_NOT_NOP, MIPS_SYNC_OLD_OP_12_NOT_NOP_REG, + MIPS_SYNC_OLD_OP_12_NOT_NOT, MIPS_SYNC_OLD_OP_12_NOT_NOT_REG, + MIPS_SYNC_NEW_OP_12, MIPS_SYNC_NEW_OP_12_NOT_NOP, + MIPS_SYNC_NEW_OP_12_NOT_NOT, MIPS_SYNC_EXCHANGE_12, + MIPS_SYNC_EXCHANGE_12_ZERO_OP, + MIPS_SYNC_EXCHANGE_12_NONZERO_OP): New macros. + +2008-05-20 H.J. Lu <hongjiu.lu@intel.com> + + * config/i386/i386.c (ix86_expand_vector_init_one_nonzero): Add + the missing break. + +2008-05-20 Anatoly Sokolov <aesok@post.ru> + + * config/avr/avr.h (machine_function): Add 'is_OS_main' field. + * config/avr/avr.c (avr_OS_main_function_p): Add new function. + (avr_attribute_table): Add 'OS_main' function attribute. + (avr_regs_to_save, expand_prologue, expand_epilogue): Handle + functions with 'OS_main' attribute. + +2008-05-20 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/35204 + * tree-ssa-sccvn.c (extract_and_process_scc_for_name): New + helper, split out from ... + (DFS): ... here. Make the DFS walk non-recursive. + +2008-05-20 Sebastian Pop <sebastian.pop@amd.com> + Jan Sjodin <jan.sjodin@amd.com> + + PR tree-optimization/36181 + * tree-parloops.c (loop_has_vector_phi_nodes): New. + (parallelize_loops): Don't parallelize when the loop has vector + phi nodes. + +2008-05-20 Jan Sjodin <jan.sjodin@amd.com> + Sebastian Pop <sebastian.pop@amd.com> + + * tree-loop-linear.c (gather_interchange_stats): Look in the access matrix, + and never look at the tree representation of the memory accesses. + (linear_transform_loops): Computes parameters and access matrices. + * tree-data-ref.c (compute_data_dependences_for_loop): Returns false when fails. + (access_matrix_get_index_for_parameter): New. + * tree-data-ref.h (struct access_matrix): New. + (AM_LOOP_NEST_NUM, AM_NB_INDUCTION_VARS, AM_PARAMETERS, AM_MATRIX, + AM_NB_PARAMETERS, AM_CONST_COLUMN_INDEX, AM_NB_COLUMNS, + AM_GET_SUBSCRIPT_ACCESS_VECTOR, AM_GET_ACCESS_MATRIX_ELEMENT, + am_vector_index_for_loop): New. + (struct data_reference): Add field access_matrix. + (DR_ACCESS_MATRIX): New. + (compute_data_dependences_for_loop): Update declaration. + (lambda_collect_parameters, lambda_compute_access_matrices): Declared. + * lambda.h (lambda_vector_vec_p): Declared. + * lambda-code.c: Depend on pointer-set.h. + (lambda_collect_parameters_from_af, lambda_collect_parameters, + av_for_af_base, av_for_af, build_access_matrix, + lambda_compute_access_matrices): New. + * Makefile.in (lambda-code.o): Depend on pointer-set.h. + +2008-05-20 Joseph Myers <joseph@codesourcery.com> + + * doc/install.texi2html: Generate gcc-vers.texi in $DESTDIR not + $SOURCEDIR/include. + +2008-05-20 Jan Sjodin <jan.sjodin@amd.com> + Sebastian Pop <sebastian.pop@amd.com> + + PR tree-optimization/36206 + * tree-scalar-evolution.c: Remove enum INSERT_SUPERLOOP_CHRECS, + FOLD_CONVERSIONS. + (instantiate_scev_1): Rename flags to fold_conversions. + Do not check for INSERT_SUPERLOOP_CHRECS, keep SSA_NAMEs defined + outeside instantiation_loop. + * tree-chrec.h (evolution_function_is_affine_in_loop): New. + (evolution_function_is_affine_or_constant_p): Removed. + * tree-data-ref.c (dr_analyze_indices): Replace resolve_mixers with + instantiate_scev. + (analyze_siv_subscript): Pass in the loop nest number. + Call evolution_function_is_affine_in_loop instead of + evolution_function_is_affine_p. + (analyze_overlapping_iterations): Pass in the loop nest number. + +2008-05-20 Jan Sjodin <jan.sjodin@amd.com> + Sebastian Pop <sebastian.pop@amd.com> + + PR tree-optimization/36206 + * tree-chrec.h (chrec_fold_op): New. + * tree-data-ref.c (initialize_matrix_A): Traverse NOP_EXPR, PLUS_EXPR, and + other trees. + +2008-05-20 Nathan Sidwell <nathan@codesourcery.com> + + * c-incpath.c (INO_T_EQ): Do not define on non-inode systems. + (DIRS_EQ): New. + (remove_duplicates): Do not set inode on non-inode systems. Use + DIRS_EQ. + +2008-05-20 Sandra Loosemore <sandra@codesourcery.com> + + * config.gcc (tm_file): Update comments about relative pathnames. + +2008-05-20 Richard Guenther <rguenther@suse.de> + + * tree-ssa-reassoc.c (fini_reassoc): Use the statistics + infrastructure. + * tree-ssa-sccvn.c (process_scc): Likewise. + * tree-ssa-sink.c (execute_sink_code): Likewise. + * tree-ssa-threadupdate.c (thread_through_all_blocks): Likewise. + * tree-vrp.c (process_assert_insertions): Likewise. + * tree-ssa-dce.c (eliminate_unnecessary_stmts): Likewise. + (perform_tree_ssa_dce): Likewise. + * tree-ssa-dom.c (tree_ssa_dominator_optimize): Likewise. + (dump_dominator_optimization_stats): Likewise. + * tree-vectorizer.c (vectorize_loops): Likewise. + +2008-05-20 Richard Guenther <rguenther@suse.de> + + * tree-vn.c (vn_lookup_with_vuses): Do not use the alias oracle. + +2008-05-20 Kai Tietz <kai.tietz@onevision.com> + + * config/i386/i386-protos.h (ix86_return_in_memory): Removed. + (ix86_i386elf_return_in_memory): Likewise. + (ix86_i386interix_return_in_memory): Likewise. + * config/i386/i386-interix.h (TARGET_RETURN_IN_MEMORY): Removed. + (SUBTARGET_RETURN_IN_MEMORY): New. + * config/i386/i386elf.h: Likewise. + * config/i386/ptx4-i.h: Likewise. + * config/i386/sol2-10.h: Likewise. + * config/i386/sysv4.h: Likewise. + * config/i386/vx-common.h: Likewise. + * config/i386/i386.h (TARGET_RETURN_IN_MEMORY): Removed. + * config/i386/i386.c (ix86_return_in_memory): Made static and + make use of optional SUBTARGET_RETURN_IN_MEMORY macro. + (ix86_i386elf_return_in_memory): Removed. + (ix86_i386interix_return_in_memory): Removed. + (TARGET_RETURN_IN_MEMORY): Declared within i386.c only. + * target-def.h (TARGET_RETURN_IN_MEMORY): Remove protection #ifdef. + +2008-05-20 Alexandre Oliva <aoliva@redhat.com> + + * cselib.c (cselib_record_sets): Use correct mode for IF_THEN_ELSE. + +2008-05-19 Xinliang David Li <davidxl@google.com> + + * tree-ssa-dce.c: Revert patches of 2008-05-17 and 2008-05-18. + * opts.c: Ditto. + * common.opt: Ditto. + * doc/invoke.texi: Ditto. + +2008-05-19 Eric Botcazou <ebotcazou@adacore.com> + + * tree.c (substitute_in_expr) <tcc_vl_exp>: Fix thinko. + (substitute_placeholder_in_expr) <tcc_vl_exp>: Minor tweak. + +2008-05-19 H.J. Lu <hongjiu.lu@intel.com> + + * config/i386/i386.c (ix86_expand_vector_init_concat): Change + sizes of operand array from 8/4 to 4/2. + (ix86_expand_vector_init_general): Change size of operand array + from 32 to 16. Remove op0, op1 and half_mode. + +2008-05-19 H.J. Lu <hongjiu.lu@intel.com> + + * config/i386/i386.c (ix86_expand_vector_init_concat): New. + (ix86_expand_vector_init_interleave): Likewise. + (ix86_expand_vector_init_general): Use them. Assert word_mode + == SImode when n_words == 4. + +2008-05-19 Uros Bizjak <ubizjak@gmail.com> + + * config/i386/i386.c (ix86_secondary_reload): New static function. + (TARGET_SECONDARY_RELOAD): New define. + * config/i386/i386.h (SECONDARY_OUTPUT_RELOAD_CLASS): Remove. + * config/i386/i386.md (reload_outqi): Remove. + +2008-05-18 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> + + PR middle-end/35509 + * builtins.c (mathfn_built_in_1): Renamed from mathfn_built_in. + Add `implicit' parameter. Handle BUILT_IN_SIGNBIT. + (mathfn_built_in): Rewrite in terms of mathfn_built_in_1. + (fold_builtin_classify): Handle BUILT_IN_ISINF_SIGN. + (fold_builtin_1): Likewise. + * builtins.def (BUILT_IN_ISINF_SIGN): New. + c-common.c (check_builtin_function_arguments): Handle + BUILT_IN_ISINF_SIGN. + * doc/extend.texi: Document __builtin_isinf_sign. + * fold-const.c (operand_equal_p): Handle COND_EXPR. + +2008-05-18 Eric Botcazou <ebotcazou@adacore.com> + + * tree-ssa-dom.c (tree_ssa_dominator_optimize): If some blocks need + EH cleanup at the end of the pass, search for those that have been + turned into forwarder blocks and do the cleanup on their successor. + +2008-05-18 Richard Guenther <rguenther@suse.de> + + * tree-cfg.c (verify_gimple_expr): Allow conversions from + pointers to sizetype and vice versa. + +2008-05-18 Xinliang David Li <davidxl@google.com> + + * gcc/tree-ssa-dce.c: Coding style fix. + (check_pow): Documentation comment. + (check_log): Documenation comment. Coding style fix. + (is_unnecessary_except_errno_call): Ditto. + (gen_conditions_for_pow): Ditto. + (gen_conditions_for_log): Ditto. + (gen_shrink_wrap_conditions): Ditto. + (shrink_wrap_one_built_in_calls): Ditto. + * gcc/doc/invoke.texi: Better documentation string. + * ChangeLog: Fix wrong change log entries from + May 17 checkin on function call DCE. + +2008-05-17 Kaz Kojima <kkojima@gcc.gnu.org> + + * config/sh/sh.c (sh_output_mi_thunk): Update the use of init_flow. + +2008-05-17 Kenneth Zadeck <zadeck@naturalbridge.com> + + * doc/rtl.texi (RTL_CONST_CALL_P, RTL_PURE_CALL_P): Fixed typos. + * df-problems.c (simulation routines): Fixed block comment to + properly say how to add forwards scanning functions. + +2008-05-17 Eric Botcazou <ebotcazou@adacore.com> + + * tree-inline.c (setup_one_parameter): Remove dead code. + +2008-05-17 Eric Botcazou <ebotcazou@adacore.com> + + * fold-const.c (fold_unary) <CASE_CONVERT>: Fold the cast into + a BIT_AND_EXPR only for an INTEGER_TYPE. + +2008-05-17 Xinliang David Li <davidxl@google.com> + + * gcc/tree-ssa-dce.c (cond_dead_built_in_calls): New static variable. + (check_pow, check_log, is_unnecessary_except_errno_call): New + functions to check for eliminating math functions that are pure + except for setting errno. + (gen_conditions_for_pow, gen_conditionas_for_log): New functions to + general condition expressions for shrink-wrapping pow/log calls. + (gen_shrink_wrap_conditions): Ditto. + (shrink_wrap_one_built_in_call): Ditto. + (shrink_wrap_conditional_dead_built_in_calls): Ditto. + (mark_operand_necessary): If debugging, output if OP is necessary. + (eliminate_unnecessary_stmts): Eliminate pow, log calls that are + unnecessary. + * gcc/opts.c (decode_options): set flag_tree_builtin_dce to 1 when + opt level >= 2. + * gcc/common.opt: New user flag -ftree-builtin-dce. + * gcc/doc/invoke.texi (-ftree-builtin-dce): New option. + 2008-05-16 David S. Miller <davem@davemloft.net> - * config/sparc/linux.h (NO_PROFILE_COUNTERS): Undef before - overriding. + * config/sparc/linux.h (NO_PROFILE_COUNTERS): Undef before overriding. * config/sparc/linux64.h (NO_PROFILE_COUNTERS): Likewise. 2008-05-16 Uros Bizjak <ubizjak@gmail.com> @@ -14,7 +319,7 @@ * ifcvt.c (dead_or_predicable): Rename df_simulate_one_insn_backwards to df_simulate_one_insn. * recog.c (peephole2_optimize): Ditto. - * rtl-factoring.c (collect_pattern_seqs, clear_regs_live_in_seq): + * rtl-factoring.c (collect_pattern_seqs, clear_regs_live_in_seq): Ditto. * df.h: Rename df_simulate_one_insn_backwards to df_simulate_one_insn. and delete df_simulate_one_insn_forwards. @@ -23,7 +328,6 @@ (df_simulate_one_insn_backwards): Renamed to df_simulate_one_insn. (df_simulate_one_insn_forwards): Removed. - 2008-05-16 Doug Kwan <dougkwan@google.com> * real.c (real_to_decimal, real_to_hexadecimal): Distinguish @@ -53,8 +357,8 @@ * tree-ssa-sccvn.c (compare_ops, init_scc_vn): Ditto. * function.h (cfun.last_stmt_uid): New field. * tree-flow-inline.h (set_gimple_stmt_uid, gimple_stmt_uid, - gimple_stmt_max_uid, set_gimple_stmt_max_uid, - inc_gimple_stmt_max_uid): New functions. + gimple_stmt_max_uid, set_gimple_stmt_max_uid, inc_gimple_stmt_max_uid): + New functions. * tree-dfa.c (renumber_gimple_stmt_uids): New function. (create_stmt_ann): Initialize the ann->uid field. * tree-ssa-pre.c (compute_avail): Encapsulate the stmt_ann->uid @@ -95,8 +399,7 @@ MULTILIB_MATCHES, MULTILIB_EXCEPTIONS): Likewise. * config/bfin/t-bfin-linux (MULTILIB_OPTIONS, MULTILIB_DIRNAMES, MULTILIB_MATCHES, MULTILIB_EXCEPTIONS): Likewise. - * config/bfin/bfin-protos.h (enum bfin_cpu_type): Add - BFIN_CPU_UNKNOWN. + * config/bfin/bfin-protos.h (enum bfin_cpu_type): Add BFIN_CPU_UNKNOWN. * config/bfin/elf.h (STARTFILE_SPEC): Use specific CRT for BF561. (LIB_SPEC): Use proper linker script for bf561. Error if no mcpu option. @@ -124,8 +427,8 @@ * cgraph.h (compute_inline_parameters): Made public. * tree-pass.h (ipa_opt_pass): Removed function_generate_summary, variable_generate_summary, function_write_summary, - variable_write_summary, variable_read_summary. Added - generate_summary, write_summary, read_summary. + variable_write_summary, variable_read_summary. Added generate_summary, + write_summary, read_summary. * cgraphunit.c (cgraph_process_new_functions): Changed call from pass_ipa_inline.function_generate_summary, to compute_inline_parameters. diff --git a/gcc/ChangeLog.melt b/gcc/ChangeLog.melt index 49440aed549..ca883317fd0 100644 --- a/gcc/ChangeLog.melt +++ b/gcc/ChangeLog.melt @@ -1,4 +1,8 @@ 2008-05-21 Basile Starynkevitch <basile@starynkevitch.net> + merged with trunk rev135714 + * basilys.h: explicit [re-]declaration of fatail_error. + +2008-05-21 Basile Starynkevitch <basile@starynkevitch.net> [handling of OR might be incorrect in cold and improved in warm] * melt/warm-basilys.bysl: (normexp_or) rewritten. [many occurrences of OR replaced by IF because contrib/cold-basilys.lisp might be wrong] @@ -16,7 +20,7 @@ [still buggy warmbasilys2] * melt/warm-basilys.bysl: (normexp_keyword) handling correctly - keyword at toplevel. This affects initializatin of our ctype_value + keyword at toplevel. This affects initialization of our ctype_value etc... 2008-05-20 Basile Starynkevitch <basile@starynkevitch.net> diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index 5e3d3ba01ce..20dd7e0e58c 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20080517 +20080521 diff --git a/gcc/Makefile.in b/gcc/Makefile.in index 076414c3ade..f3797d9642e 100644 --- a/gcc/Makefile.in +++ b/gcc/Makefile.in @@ -2943,7 +2943,7 @@ lambda-code.o: lambda-code.c $(LAMBDA_H) $(GGC_H) $(SYSTEM_H) $(CONFIG_H) \ $(TM_H) $(OPTABS_H) $(TREE_H) $(RTL_H) $(BASIC_BLOCK_H) \ $(DIAGNOSTIC_H) $(TREE_FLOW_H) $(TREE_DUMP_H) $(TIMEVAR_H) $(CFGLOOP_H) \ $(TREE_DATA_REF_H) $(SCEV_H) $(EXPR_H) coretypes.h $(TARGET_H) \ - tree-chrec.h tree-pass.h vec.h vecprim.h $(OBSTACK_H) + tree-chrec.h tree-pass.h vec.h vecprim.h $(OBSTACK_H) pointer-set.h params.o : params.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(PARAMS_H) toplev.h pointer-set.o: pointer-set.c pointer-set.h $(CONFIG_H) $(SYSTEM_H) hooks.o: hooks.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(HOOKS_H) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 83e9177af71..b752aefad40 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,539 @@ +2008-05-21 Thomas Quinot <quinot@adacore.com> + + * g-sothco.ads, g-sothco.adb: New files. + +2008-05-20 Thomas Quinot <quinot@adacore.com> + + * Makefile.rtl (GNAT.Sockets.Thin_Common): New unit. + + * g-sttsne-vxworks.adb: Add missing dependency on Sockets.Constants. + Add missing "with" of Ada.Unchecked_Conversion + + * g-soccon-linux-ppc.ads, g-soccon-linux-64.ads, g-soccon-lynxos.ads, + g-soccon-linux-x86.ads, g-soccon-hpux-ia64.ads, + g-soccon-solaris-64.ads, g-soccon-tru64.ads, g-soccon-aix.ads, + g-soccon-irix.ads, g-soccon-hpux.ads, g-soccon-solaris.ads, + g-soccon-vms.ads, g-soccon-mingw.ads, g-soccon-vxworks.ads, + g-socthi-vxworks.adb, g-soccon-freebsd.ads, g-soccon.ads: + Move common code out of GNAT.Sockets.Thin implementations and into + Thin_Common. + New constant SIZEOF_fd_set + New flag Has_Sockaddr_Len + New constants SIZEOF_sockaddr_in, SIZEOF_sockaddr_in6 + + * g-stsifd-sockets.adb + (Create): Remove call to Set_Length; use Set_Family to set the family + and (on appropriate platforms) length fields in struct sockaddr. + + * g-socthi.adb, g-socthi.ads, g-socthi-vms.ads, g-socthi-vms.adb, + g-socthi-mingw.adb, g-socthi-mingw.ads, g-socthi-vxworks.adb, + g-soccon-darwin.ads, g-soccon-darwin.ads: New constant SIZEOF_fd_set + Move common code out of GNAT.Sockets.Thin implementations and into + Thin_Common. + + * g-socket.ads, g-socket.adb: + Move common code out of GNAT.Sockets.Thin implementations and into + Thin_Common. + (Connect_Socket, Accept_Socket): Provide new versions of these two + routines that operate with a user specified timeout. + (Bind_Socket, Connect_Socket, Send_Socket): Remove calls to Set_Length, + this is now handled automatically by Set_Family on platforms that + require it. + + * gen-soccon.c: + Move common code out of GNAT.Sockets.Thin implementations and into + Thin_Common. + (SIZEOF_sockaddr_in6): On platforms where IPv6 is not supported, define + this constant to 0 (not -1) because we use it to initialize an + unsigned_char value. + Align values for numeric constants only. + Handle the case of systems that do not support AF_INET6. + New constant SIZEOF_fd_set + New flag Has_Sockaddr_Len + New constants SIZEOF_sockaddr_in, SIZEOF_sockaddr_in6 + + * gsocket.h: New flag Has_Sockaddr_Len + New constants SIZEOF_sockaddr_in, SIZEOF_sockaddr_in6 + +2008-05-20 Santiago Uruena <uruena@adacore.com> + + * i-cobol.ads: Interfaces.COBOL should be preelaborate. + +2008-05-20 Arnaud Charlet <charlet@adacore.com> + + * s-linux-hppa.ads (atomic_lock_t): Put back proper alignment now that + the underlying issue with malloc/free has been fixed. Remove associated + comments. + Minor reformatting. + Related to PR ada/24533 + +2008-05-20 Robert Dewar <dewar@adacore.com> + + * ali.adb: Correct casing of ASCII.NUL + + * styleg-c.adb (Check_Identifier): Handle case of names in ASCII + properly. + +2008-05-20 Robert Dewar <dewar@adacore.com> + Gary Dismukes <dismukes@adacore.com> + + * checks.adb (Apply_Arithmetic_Overflow_Check): Avoid intermediate + overflow if result converted to wider integer type. + (Apply_Type_Conversion_Checks): Don't emit checks on conversions to + discriminated types when discriminant checks are suppressed. + +2008-05-20 Vincent Celier <celier@adacore.com> + + * cstand.adb (Print_Standard): Issue the correct Size clause for type + Wide_Wide_Character. + +2008-05-20 Tristan Gingold <gingold@adacore.com> + + * decl.c: Do not emit a variable for a object that has an address + representation clause whose value is known at compile time. + When a variable has an address clause whose value is known at compile + time, refer to this variable by using directly the address instead of + dereferencing a pointer. + +2008-05-20 Robert Dewar <dewar@adacore.com> + + PR ada/30740 + * einfo.ads, einfo.adb (Non_Binary_Modulus): Applies to all types and + subtypes, always False for non-modular types. + Shared_Var_Assign_Proc (node22) and Shared_Var_Read_Proc (node 15) + entry nodes have been replaced by Shared_Var_Procs_Instance (node22) + for Shared_Storage package. + (Is_RACW_Stub_Type): New entity flag. + + * exp_ch4.adb + (Expand_N_Op_Expon): Avoid incorrect optimization of a*(2**b) in the + case where we have a modular type with a non-binary modules. + Comments reformattings. + + * sem_intr.adb: Simplify code not that Non_Binary_Modulus applies to + all types. + +2008-05-20 Javier Miranda <miranda@adacore.com> + + * exp_aggr.adb + (Build_Record_Aggr_Code): Fix wrong tests checking progenitors. Previous + tests did not covered the case in which the type of the aggregate has + no progenitors but some its parents has progenitors. + +2008-05-20 Gary Dismukes <dismukes@adacore.com> + Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch3.adb + (Expand_N_Object_Declaration): Correct the condition which triggers the + generation of a call to Displace when initializing a class-wide object. + (Build_Dcheck_Functions): Build discriminant-checking for null variants + when Frontend_Layout_On_Target is true to ensure that they're available + for calling when a record variant size function is built in Layout. + +2008-05-20 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb (Expand_Assign_Record): Within an initialization + procedure for a derived type retrieve the discriminant values from the + parent using the corresponding discriminant. + (Expand_N_Assignment_Statement): Skip generation of implicit + if-statement associated with controlled types if we are + compiling with restriction No_Finalization. + +2008-05-20 Vincent Celier <celier@adacore.com> + + * prj.adb (Hash (Project_Id)): New function + (Project_Empty): Add new component Interfaces_Defined + + * prj.ads (Source_Data): New component Object_Linked + (Language_Config): New components Object_Generated and Objects_Linked + (Hash (Project_Id)): New function + (Source_Data): New Boolean components In_Interfaces and + Declared_In_Interfaces. + (Project_Data): New Boolean component Interfaces_Defined + + * prj-attr.adb: + New project level attribute Object_Generated and Objects_Linked + Add new project level attribute Interfaces + + * prj-dect.adb: Use functions Present and No throughout + (Parse_Variable_Declaration): If a string type is specified as a simple + name and is not found in the current project, look for it also in the + ancestors of the project. + + * prj-makr.adb: + Replace procedure Make with procedures Initialize, Process and Finalize + to implement H414-023: process different directories with different + patterns. + Use functions Present and No throughout + + * prj-makr.ads: + Replace procedure Make with procedures Initialize, Process and Finalize + + * prj-nmsc.adb + (Add_Source): Set component Object_Exists and Object_Linked accordnig to + the language configuration. + (Process_Project_Level_Array_Attributes): Process new attributes + Object_Generated and Object_Linked. + (Report_No_Sources): New Boolean parameter Continuation, defaulted to + False, to indicate that the erreor/warning is a continuation. + (Check): Call Report_No_Sources with Contnuation = True after the first + call. + (Error_Msg): Process successively contnuation character and warning + character. + (Find_Explicit_Sources): Check that all declared sources have been found + (Check_File): Indicate in hash table Source_Names when a declared source + is found. + (Check_File): Set Other_Part when found + (Find_Explicit_Sources): In multi language mode, check if all exceptions + to the naming scheme have been found. For Ada, report an error if an + exception has not been found. Otherwise, disregard the exception. + (Check_Interfaces): New procedure + (Add_Source): When Other_Part is defined, set mutual pointers in spec + and body. + (Check): In multi-language mode, call Check_Interfaces + (Process_Sources_In_Multi_Language_Mode): Set In_Interfaces to False + for an excluded source. + (Remove_Source): A source replacing a source in the interfaces is also + in the interfaces. + + * prj-pars.adb: Use function Present + + * prj-part.adb: Use functions Present and No throughout + (Parse_Single_Project): Set the parent project for child projects + (Create_Virtual_Extending_Project): Register project with no qualifier + (Parse_Single_Project): Allow an abstract project to be extend several + times. Do not allow an abstract project to extend a non abstract + project. + + * prj-pp.adb: Use functions Present and No throughout + (Print): Take into account the full associative array attribute + declarations. + + * prj-proc.adb: Use functions Present and No throughout + (Expression): Call itself with the same From_Project_Node for the + default value of an external reference. + + * prj-strt.adb: Use functions Present and No throughout + (Parse_Variable_Reference): If a variable is specified as a simple name + and is not found in the current project, look for it also in the + ancestors of the project. + + * prj-tree.ads, prj-tree.adb (Present): New function + (No): New function + Use functions Present and No throughout + (Parent_Project_Of): New function + (Set_Parent_Project_Of): New procedure + + * snames.ads, snames.adb: + Add new standard names Object_Generated and Objects_Linked + +2008-05-20 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch6.adb (Expand_Call): Add guard to ensure that both the parent + and the derived type are of the same kind. + (Expand_Call): Generate type conversions for actuals of + record or array types when the parent and the derived types differ in + size and/or packed status. + +2008-05-20 Javier Miranda <miranda@adacore.com> + Ed Schonberg <schonberg@adacore.com> + + * exp_disp.adb (Make_DT, Make_Secondary_DT, Make_Tags): Avoid + generating dispatch tables of locally defined tagged types statically. + Remove implicit if-statement that is no longer required. + (Expand_Dispatching_Call): If this is a call to an instance of the + generic dispatching constructor, the type of the first argument may be + a subtype of Tag, so always use the base type to recognize this case. + +2008-05-20 Thomas Quinot <quinot@adacore.com> + + * exp_dist.adb + (GARLIC_Support.Add_RACW_Read_Attribute): When a zero value is received, + and the RACW is null-excluding, raise CONSTRAINT_ERROR instead of + assigning NULL into the result, to avoid a spurious warning. + (Add_RACW_Features, case Same_Scope): Add assertion that designated type + is not frozen. + (Add_Stub_Type): Set entity flag Is_RACW_Stub_Type on generated stub + type. + (Build_From_Any_Function, Build_To_Any_Function, + Build_TypeCode_Function): For a type that has user-specified stream + attributes, use an opaque sequence of octets as the representation. + +2008-05-20 Kevin Pouget <pouget@adacore.com> + + * exp_smem.ads, exp_smem.adb: Construction of access and assign + routines has been replaced by an instantiation of + System.Shared_Storage.Shared_Var_Procs generic package, while expanding + shared variable declaration. + Calls to access and assign routines have been replaced by calls to + Read/Write routines of System.Shared_Storage.Shared_Var_Procs + instantiated package. + + * rtsfind.ads: RE_Shared_Var_Procs entry has been added in RE_Unit_Table + It identifies the new generic package added in s-shasto. + + * s-shasto.adb, s-shasto.ads: A new generic package has been added, it + is instantiated for each shared passive variable. It provides + supporting procedures called upon each read or write access by the + expanded code. + + * sem_attr.adb: + For this runtime unit (always compiled in GNAT mode), we allow + stream attributes references for limited types for the case where + shared passive objects are implemented using stream attributes, + which is the default in GNAT's persistent storage implementation. + +2008-05-20 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb + (Freeze_Enumeration_Type): For a subtype that inherits a foreign + convention from its base type, do not set the type to that of integer, + because it may inherit a size clause. + Warn on a size clause with a size different + from that of Integer, if the type has convention C. + +2008-05-20 Vincent Celier <celier@adacore.com> + + * gnatname.adb + (Scan_Args): Rewrite to take into account new switch --and to separate + arguments into sections. + (Gnatname): Call Prj.Makr.Initialize, then Prj.Makr.Process for each + section, then Finalize. + +2008-05-20 Tristan Gingold <gingold@adacore.com> + + * init.c: Enable stack probing on ppc-linux. + + * tracebak.c: Add symbolic traceback for ppc-linux. + + * system-linux-ppc.ads: Enable stack probing on ppc-linux. + +2008-05-20 Arnaud Charlet <charlet@adacore.com> + + * Makefile.in + (common-tools): New rule, to avoid parallel build failure on gnat tools. + Reenable parallel builds on this Makefile. + + * Make-lang.in: Update dependencies. + +2008-05-20 Robert Dewar <dewar@adacore.com> + + * opt.ads (Treat_Restrictions_As_Warnings): New switch + + * sem_prag.adb, par-prag.adb, restrict.ads: Implement flag + Treat_Restrictions_As_Warnings. + + * switch-c.adb: Recognize new switch -gnatr + + * usage.adb: Add line for -gnatr + +2008-05-20 Hristian Kirtchev <kirtchev@adacore.com> + + * par-ch3.adb + (P_Access_Definition): Change the error message when parsing "access + all" in Ada 95 mode. The message no longer forces the user to recompile + in 05 mode only to discover that anonymous access types are not allowed + to have "all". + +2008-05-20 Hristian Kirtchev <kirtchev@adacore.com> + + * par-ch9.adb + (P_Protected): Update the error message on missing "-gnat05" switch when + using interfaces in conjunction with protected types. Remove the + incorrect error message associated with the presence of "private" after + a "with". + +2008-05-20 Ed Schonberg <schonberg@adacore.com> + + * sem_aggr.adb: Update comments. + Improve previous change for PR ada/17985 + +2008-05-20 Thomas Quinot <quinot@adacore.com> + + * sem_cat.adb + (Set_Categorization_From_Scope): Do not set In_Remote_Types unless in + the visible part of the spec of a remote types unit. + (Validate_Remote_Access_Object_Type_Declaration): + New local subprogram Is_Valid_Remote_Object_Type, replaces + Is_Recursively_Limited_Private. + (Validate_RACW_Primitives): Enforce E.2.2(14) rules: the types of all + non-controlling formals (and the return type, even though this is not + explicit in the standard) must support external streaming. + (Validate_RCI_Subprogram_Declaration): Enforce E.2.3(14) rules: same + as above for of RAS types and RCI subprograms. (The return type is not + checked yet). + Update comments related to RACWs designating limited interfaces per + ARG ruling on AI05-060. + + * sem_util.ads, sem_util.adb + (Is_Remote_Access_To_Class_Wide_Type): Only rely on Is_Remote_Types and + Is_Remote_Call_Interface to identify RACW types in a stable and + consistent way. We used to rely in this predicate on the privateness of + the designated type and its ancestors, but depending on the currently + visible private parts, this caused false negatives. We now uniformly + rely on checks made at the point where the RACW type is declared. + (Inspect_Deferred_Constant_Completion): Moved from Sem_Ch7. + +2008-05-20 Javier Miranda <miranda@adacore.com> + Ed Schonberg <schonberg@adacore.com> + Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch3.adb + (Analyze_Object_Declaration): Fix over-conservative condition + restricting use of predefined assignment with tagged types that have + convention CPP. + (Analyze_Object_Declaration): Relax the check regarding deferred + constants declared in scopes other than packages since they can be + completed with pragma Import. + Add missing escaping of all-caps word 'CPP' in error messages. + (Build_Discriminated_Subtype): Do not inherit representation clauses + from parent type if subtype already carries them, because they are + inherited earlier during derivation and already include those that may + come from a partial view. + + * sem_ch9.adb, sem_ch5.adb, sem_ch6.adb (Analyze_Subprogram_Body): + Check the declarations of a subprogram body for proper deferred + constant completion. + + * sem_ch7.ads, sem_ch7.adb + (Inspect_Deferred_Constant_Completion): Moved to sem_util. + +2008-05-20 Ed Schonberg <schonberg@adacore.com> + Thomas Quinot <quinot@adacore.com> + + * sem_ch4.adb + (Try_Indexed_Call): Handle properly a construct of the form F(S) where + F is a parameterless function that returns an array, and S is a subtype + mark. + (Analyze_Call): Insert dereference when the prefix is a parameterless + function that returns an access to subprogram and the call has + parameters. + Reject a non-overloaded call whose name resolves to denote + a primitive operation of the stub type generated to support a remote + access-to-class-wide type. + +2008-05-20 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb + (Note_Redundant_Use): Diagnose a redundant use within a subprogram body + when there is a use clause for the same entity in the context. + (Analyze_Subprogram_Renaming): A renaming_as_body is legal if it is + created for a stream attribute of an abstract type or interface type. + +2008-05-20 Thomas Quinot <quinot@adacore.com> + + * sem_dist.ads, sem_dist.adb (Is_RACW_Stub_Type_Operation): New + subprogram. + + * sem_type.adb + (Add_One_Interp): Ignore any interpretation that is a primitive + operation of an RACW stub type (these primitives are only executed + through dispatching, never through static calls). + (Collect_Interps): When only one interpretation has been found, set N's + Entity and Etype to that interpretation, otherwise Entity and Etype may + still refer to an interpretation that was ignored by Add_One_Interp, + in which case would end up with being marked as not overloaded but with + an Entity attribute not pointing to its (unique) correct interpretation. + +2008-05-20 Ed Schonberg <schonberg@adacore.com> + + * sem_eval.adb + (Eval_Slice): Warn when a slice whose discrete range is a subtype name + denotes the whole array of its prefix. + +2008-05-20 Robert Dewar <dewar@adacore.com> + + * sem_res.adb (Resolve_Op_Not): Warn on double negation + +2008-05-20 Ed Schonberg <schonberg@adacore.com> + + * sprint.adb + (Print_Itype): Do not modify the sloc of the component type of a + (packed) array itype, because it is an unrelated type whose source + location is independent of the point of creation of the itype itself. + +2008-05-20 Thomas Quinot <quinot@adacore.com> + + * uintp.adb, urealp.adb: Replace calls to Increment_Last + Set with + Append. + +2008-05-20 Robert Dewar <dewar@adacore.com> + Vincent Celier <celier@adacore.com> + + * vms_data.ads: Add entry for -gnatr + Put GNAT SYNC section in proper alpha order + Add VMS qualifier /DISPLAY_PROGRESS equivalent to gnatmake switch -d + + * gnat_ugn.texi: Add documentation for new gnatname switch --and + Update the style checks section + Add documentation of -gnatr + Add to the "Adding the Results of Compiler Checks to gnatcheck Output" + subsection the explanation how compiler checks should be disabled for + gnatcheck. + Update the list of Ada 95 reserved words used by in the project language + Add documentation for project qualifiers. + Document that abstract projects may be extended by different projects in + the same project tree. + Add documentation for gnatmake switch -d + + * ug_words: Add -gnatyy VMS equivalence string. + Add entry for -gnatr + +2008-05-20 Bob Duff <duff@adacore.com> + + * a-rttiev.adb + (Set_Handler): Remove code from both of these that implements + RM-D.15(15/2), because it causes a race condition and potential + deadlock. + (Process_Queued_Events): Add comment explaining "exception when others + => null". Add clarifying ".all", even though implicit .all is legal + here. + +2008-05-20 Arnaud Charlet <charlet@adacore.com> + + * s-winext.ads: Replace representation clause by pragma Pack. Gives + equivalent representation, but has the advantage of allowing + compilation of this file under 64 bits platforms. + + * s-os_lib.adb (Normalize_Pathname): Mark Cur_Dir constant. + + * s-osinte-irix.ads: (Alternate_Stack_Size): Add dummy declaration. + + * adaint.c: + Don't define dummy implementation of convert_addresses on ppc-linux. + +2008-05-20 Ed Schonberg <schonberg@adacore.com> + + * exp_ch7.adb + (Expand_Ctrl_Function_Call): Do not attach result to finalization list + if expression is aggregate component. + +2008-05-20 Robert Dewar <dewar@adacore.com> + + * g-byorma.adb, gnatlink.adb, prepcomp.adb, sinfo.ads, + sem_ch12.adb: Update comments. Minor reformatting. + + * exp_ch2.adb: Typo + + * s-unstyp.ads: Fixed some typos in comments. + +2008-05-20 Arnaud Charlet <charlet@adacore.com> + + * s-taspri-vxworks.ads (Task_Address, Task_Address_Size): New + type/constant. + + * g-socthi-vxworks.ads: Update to latest socket changes. + + * a-caldel-vms.adb: Resync with a-caldel spec. + + * exp_ch9.ads, sem_ch8.ads, inline.adb: Minor reformatting. + Update comments. + +2008-05-17 Eric Botcazou <ebotcazou@adacore.com> + + * trans.c (gnat_to_gnu) <N_Validate_Unchecked_Conversion>: Account + for dummy types pointed to by the converted pointer types. + 2008-05-15 Eric Botcazou <ebotcazou@adacore.com> * trans.c (add_decl_expr): At toplevel, mark the TYPE_ADA_SIZE field diff --git a/gcc/ada/Make-lang.in b/gcc/ada/Make-lang.in index 5f631b59ba9..df7682c20b2 100644 --- a/gcc/ada/Make-lang.in +++ b/gcc/ada/Make-lang.in @@ -1387,7 +1387,7 @@ ada/csets.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/csets.ads \ ada/csets.adb ada/debug.ads ada/hostparm.ads ada/opt.ads ada/system.ads \ ada/s-exctab.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/types.ads ada/unchdeal.ads + ada/s-wchcon.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/cstand.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1669,26 +1669,21 @@ ada/exp_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_ch2.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/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_ch2.ads ada/exp_ch2.adb \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_smem.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/exp_vfpt.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/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch8.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/casing.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_ch2.ads ada/exp_ch2.adb ada/exp_smem.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/exp_vfpt.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/rtsfind.ads \ + ada/sem.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_util.ads \ ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/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-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/validsw.ads + ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/exp_ch3.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 \ @@ -2140,19 +2135,18 @@ ada/exp_smem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ ada/exp_smem.ads ada/exp_smem.adb ada/exp_tss.ads ada/exp_util.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/lib.ads \ - ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ - ada/rtsfind.ads ada/sem.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ ada/s-htable.ads ada/s-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-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + ada/s-parame.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/exp_strm.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2175,21 +2169,23 @@ ada/exp_strm.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_tss.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/exp_tss.ads ada/exp_tss.adb ada/exp_util.ads \ - ada/fname.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/exp_tss.ads ada/exp_tss.adb ada/exp_util.ads ada/fname.ads \ + ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/namet.adb \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ - ada/rtsfind.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-secsta.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.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/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.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-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.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/exp_util.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 \ @@ -2370,7 +2366,7 @@ ada/g-u3spch.o : ada/gnat.ads ada/g-spchge.ads ada/g-spchge.adb \ ada/get_targ.o : ada/ada.ads ada/a-unccon.ads ada/get_targ.ads \ ada/get_targ.adb ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \ - ada/s-unstyp.ads ada/types.ads ada/unchdeal.ads + ada/s-unstyp.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/gnat.o : ada/gnat.ads ada/system.ads @@ -2426,12 +2422,13 @@ ada/gnatvsn.o : ada/ada.ads ada/a-unccon.ads ada/gnatvsn.ads \ ada/hlo.o : ada/ada.ads ada/a-unccon.ads ada/hlo.ads ada/hlo.adb \ ada/hostparm.ads ada/output.ads ada/system.ads ada/s-exctab.ads \ ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-unstyp.ads ada/types.ads ada/unchdeal.ads + ada/s-sopco5.ads ada/s-unstyp.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/hostparm.o : ada/ada.ads ada/a-unccon.ads ada/hostparm.ads \ ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-strops.ads \ ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-unstyp.ads \ - ada/types.ads ada/unchdeal.ads + ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/impunit.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 \ @@ -2460,16 +2457,16 @@ ada/inline.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/inline.adb \ ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ - ada/rtsfind.ads ada/sem.ads ada/sem_ch10.ads ada/sem_ch12.ads \ - ada/sem_ch8.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-stalib.ads \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.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/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \ + ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch8.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-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.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/instpar.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 \ @@ -2507,7 +2504,7 @@ ada/krunch.o : ada/ada.ads ada/a-unccon.ads ada/hostparm.ads \ ada/krunch.ads ada/krunch.adb ada/system.ads ada/s-exctab.ads \ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-unstyp.ads \ - ada/types.ads ada/unchdeal.ads + ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/layout.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2703,7 +2700,7 @@ ada/opt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads \ ada/s-unstyp.ads ada/s-wchcon.ads ada/tree_io.ads ada/types.ads \ - ada/unchdeal.ads + ada/unchconv.ads ada/unchdeal.ads ada/osint-b.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ @@ -2747,7 +2744,7 @@ ada/output.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/hostparm.ads ada/output.ads ada/output.adb ada/system.ads \ ada/s-exctab.ads ada/s-os_lib.ads ada/s-stalib.ads ada/s-strops.ads \ ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-unstyp.ads ada/types.ads ada/unchdeal.ads + ada/s-unstyp.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/par.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/csets.ads \ @@ -3416,32 +3413,32 @@ ada/sem_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ ada/errout.ads ada/erroutc.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ - ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch12.ads \ - ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads \ - ada/sem_ch6.adb ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_elim.ads ada/sem_eval.ads ada/sem_mech.ads ada/sem_prag.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/snames.adb \ - ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ - ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/exp_ch9.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch10.ads \ + ada/sem_ch12.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads \ + ada/sem_ch6.ads ada/sem_ch6.adb ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_mech.ads \ + ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/snames.adb ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ + ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ + ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ ada/widechar.ads @@ -3579,17 +3576,18 @@ ada/sem_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_dist.ads \ ada/exp_tss.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_dist.ads \ - ada/sem_dist.adb ada/sem_eval.ads ada/sem_res.ads ada/sem_util.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-carun8.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tbuild.ads \ - ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + ada/opt.ads ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_dist.adb ada/sem_eval.ads ada/sem_res.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/system.ads ada/s-carun8.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tbuild.ads ada/tree_io.ads ada/types.ads \ + ada/types.adb ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/sem_elab.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3820,21 +3818,21 @@ ada/sem_type.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_ch12.ads \ - ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_type.adb ada/sem_util.ads \ - ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/styleg-c.ads ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ + ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_type.adb \ + ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/styleg-c.ads \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_util.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 \ @@ -4080,12 +4078,14 @@ ada/styleg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads -ada/stylesw.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/debug.ads ada/hostparm.ads ada/opt.ads ada/stylesw.ads \ - ada/stylesw.adb ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ - ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/types.ads ada/unchdeal.ads +ada/stylesw.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/debug.ads ada/hostparm.ads ada/opt.ads \ + ada/stylesw.ads ada/stylesw.adb ada/system.ads ada/s-exctab.ads \ + ada/s-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-strops.ads \ + ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/types.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/switch-b.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnatvsn.ads \ @@ -4232,13 +4232,13 @@ ada/ttypef.o : ada/system.ads ada/ttypef.ads ada/ttypes.o : ada/ada.ads ada/a-unccon.ads ada/get_targ.ads \ ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \ - ada/ttypes.ads ada/types.ads ada/unchdeal.ads + ada/ttypes.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/types.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/system.ads \ ada/s-carun8.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \ - ada/types.ads ada/types.adb ada/unchdeal.ads + ada/types.ads ada/types.adb ada/unchconv.ads ada/unchdeal.ads ada/uintp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnat.ads \ @@ -4290,8 +4290,8 @@ ada/validsw.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/debug.ads ada/hostparm.ads ada/opt.ads ada/system.ads \ ada/s-exctab.ads ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads \ ada/s-sopco4.ads ada/s-sopco5.ads ada/s-string.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/types.ads ada/unchdeal.ads ada/validsw.ads \ - ada/validsw.adb + ada/s-wchcon.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/validsw.ads ada/validsw.adb ada/widechar.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/debug.ads ada/hostparm.ads ada/interfac.ads \ @@ -4300,6 +4300,7 @@ ada/widechar.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ ada/s-wchcnv.ads ada/s-wchcnv.adb ada/s-wchcon.ads ada/s-wchjis.ads \ - ada/types.ads ada/unchdeal.ads ada/widechar.ads ada/widechar.adb + ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads \ + ada/widechar.adb # end of regular dependencies diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 4ec544f757f..4d486f2e637 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -56,10 +56,6 @@ # FLEX: Gnu flex works. # Other miscellaneous tools for obscure targets. -# Tell GNU make 3.79 not to run this directory in parallel. -# Not all of the required dependencies are present. -.NOTPARALLEL: - # Suppress smart makes who think they know how to automake Yacc files .y.c: @@ -1780,55 +1776,29 @@ ifeq ($(TOOLSCASE),cross) vpath %.h ../ endif -../../gnatchop$(exeext): - $(GNATMAKE) -c $(ADA_INCLUDES) gnatchop --GCC="$(CC) $(ALL_ADAFLAGS)" - $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatchop - $(GNATLINK) -v gnatchop -o $@ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) - -../../gnat$(exeext): - $(GNATMAKE) -c $(ADA_INCLUDES) gnatcmd --GCC="$(CC) $(ALL_ADAFLAGS)" - $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatcmd - $(GNATLINK) -v gnatcmd -o $@ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) - -../../gnatkr$(exeext): - $(GNATMAKE) -c $(ADA_INCLUDES) gnatkr --GCC="$(CC) $(ALL_ADAFLAGS)" - $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatkr - $(GNATLINK) -v gnatkr -o $@ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) - -../../gnatls$(exeext): - $(GNATMAKE) -c $(ADA_INCLUDES) gnatls --GCC="$(CC) $(ALL_ADAFLAGS)" - $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatls - $(GNATLINK) -v gnatls -o $@ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) - -../../gnatname$(exeext): - $(GNATMAKE) -c $(ADA_INCLUDES) gnatname --GCC="$(CC) $(ALL_ADAFLAGS)" - $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatname - $(GNATLINK) -v gnatname -o $@ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) - -../../gprmake$(exeext): - $(GNATMAKE) -c $(ADA_INCLUDES) gprmake --GCC="$(CC) $(ALL_ADAFLAGS)" - $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gprmake - $(GNATLINK) -v gprmake -o $@ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) - -../../gnatprep$(exeext): - $(GNATMAKE) -c $(ADA_INCLUDES) gnatprep --GCC="$(CC) $(ALL_ADAFLAGS)" - $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatprep - $(GNATLINK) -v gnatprep -o $@ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) - -../../gnatxref$(exeext): - $(GNATMAKE) -c $(ADA_INCLUDES) gnatxref --GCC="$(CC) $(ALL_ADAFLAGS)" - $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatxref - $(GNATLINK) -v gnatxref -o $@ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) - -../../gnatfind$(exeext): - $(GNATMAKE) -c $(ADA_INCLUDES) gnatfind --GCC="$(CC) $(ALL_ADAFLAGS)" - $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatfind - $(GNATLINK) -v gnatfind -o $@ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) - -../../gnatclean$(exeext): - $(GNATMAKE) -c $(ADA_INCLUDES) gnatclean --GCC="$(CC) $(ALL_ADAFLAGS)" - $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatclean - $(GNATLINK) -v gnatclean -o $@ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) +common-tools: + $(GNATMAKE) -c -b $(ADA_INCLUDES) \ + --GNATBIND="$(GNATBIND)" --GCC="$(CC) $(ALL_ADAFLAGS)" \ + gnatchop gnatcmd gnatkr gnatls gnatprep gnatxref gnatfind gnatname \ + gnatclean -bargs $(ADA_INCLUDES) $(GNATBIND_FLAGS) + $(GNATLINK) -v gnatcmd -o ../../gnat$(exext) \ + --GCC="$(GCC_LINK)" $(TOOLS_LIBS) + $(GNATLINK) -v gnatchop -o ../../gnatchop$(exext) \ + --GCC="$(GCC_LINK)" $(TOOLS_LIBS) + $(GNATLINK) -v gnatkr -o ../../gnatkr$(exext) \ + --GCC="$(GCC_LINK)" $(TOOLS_LIBS) + $(GNATLINK) -v gnatls -o ../../gnatls$(exext) \ + --GCC="$(GCC_LINK)" $(TOOLS_LIBS) + $(GNATLINK) -v gnatprep -o ../../gnatprep$(exext) \ + --GCC="$(GCC_LINK)" $(TOOLS_LIBS) + $(GNATLINK) -v gnatxref -o ../../gnatxref$(exext) \ + --GCC="$(GCC_LINK)" $(TOOLS_LIBS) + $(GNATLINK) -v gnatfind -o ../../gnatfind$(exext) \ + --GCC="$(GCC_LINK)" $(TOOLS_LIBS) + $(GNATLINK) -v gnatname -o ../../gnatname$(exext) \ + --GCC="$(GCC_LINK)" $(TOOLS_LIBS) + $(GNATLINK) -v gnatclean -o ../../gnatclean$(exext) \ + --GCC="$(GCC_LINK)" $(TOOLS_LIBS) ../../gnatsym$(exeext): $(GNATMAKE) -c $(ADA_INCLUDES) gnatsym --GCC="$(CC) $(ALL_ADAFLAGS)" @@ -1837,7 +1807,7 @@ endif ../../gnatdll$(exeext): $(GNATMAKE) -c $(ADA_INCLUDES) gnatdll --GCC="$(CC) $(ALL_ADAFLAGS)" - $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) $(GNATBIND_FLAGS) gnatdll + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatdll $(GNATLINK) -v gnatdll -o $@ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) ../../vxaddr2line$(exeext): targext.o diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 755fa31da85..66dfea8ed73 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -368,6 +368,7 @@ GNATRTL_NONTASKING_OBJS= \ g-socket$(objext) \ g-socthi$(objext) \ g-soliop$(objext) \ + g-sothco$(objext) \ g-souinf$(objext) \ g-speche$(objext) \ g-spchge$(objext) \ diff --git a/gcc/ada/a-caldel-vms.adb b/gcc/ada/a-caldel-vms.adb index ed52533d081..b60bc8b5cb1 100644 --- a/gcc/ada/a-caldel-vms.adb +++ b/gcc/ada/a-caldel-vms.adb @@ -44,6 +44,13 @@ package body Ada.Calendar.Delays is use type TSL.Timed_Delay_Call; + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Timed_Delay_NT (Time : Duration; Mode : Integer); + -- Timed delay procedure used when no tasking is active + --------------- -- Delay_For -- --------------- @@ -76,8 +83,6 @@ package body Ada.Calendar.Delays is -- Timed_Delay_NT -- -------------------- - procedure Timed_Delay_NT (Time : Duration; Mode : Integer); - procedure Timed_Delay_NT (Time : Duration; Mode : Integer) is begin OSP.Timed_Delay (Time, Mode); @@ -85,9 +90,8 @@ package body Ada.Calendar.Delays is begin -- Set up the Timed_Delay soft link to the non tasking version if it has - -- not been already set. - -- If tasking is present, Timed_Delay has already set this soft link, or - -- this will be overridden during the elaboration of + -- not been already set. If tasking is present, Timed_Delay has already set + -- this soft link, or this will be overridden during the elaboration of -- System.Tasking.Initialization if TSL.Timed_Delay = null then diff --git a/gcc/ada/a-rttiev.adb b/gcc/ada/a-rttiev.adb index 7031dfbc7c3..72ae4df0be4 100644 --- a/gcc/ada/a-rttiev.adb +++ b/gcc/ada/a-rttiev.adb @@ -66,8 +66,8 @@ package body Ada.Real_Time.Timing_Events is -- Used for mutually exclusive access to All_Events procedure Process_Queued_Events; - -- Examine the queue of pending events for any that have timed-out. For - -- those that have timed-out, remove them from the queue and invoke their + -- Examine the queue of pending events for any that have timed out. For + -- those that have timed out, remove them from the queue and invoke their -- handler (unless the user has cancelled the event by setting the handler -- pointer to null). Mutually exclusive access is held via Event_Queue_Lock -- during part of the processing. @@ -142,7 +142,7 @@ package body Ada.Real_Time.Timing_Events is if Next_Event.Timeout > Clock then - -- We found one that has not yet timed-out. The queue is in + -- We found one that has not yet timed out. The queue is in -- ascending order by Timeout so there is no need to continue -- processing (and indeed we must not continue since we always -- delete the first element). @@ -182,8 +182,12 @@ package body Ada.Real_Time.Timing_Events is Next_Event.Handler := null; if Handler /= null then - Handler (Timing_Event (Next_Event.all)); + Handler.all (Timing_Event (Next_Event.all)); end if; + + -- Ignore exceptions propagated by Handler.all, as required by + -- RM-D.15(21/2) + exception when others => null; @@ -261,12 +265,15 @@ package body Ada.Real_Time.Timing_Events is begin Remove_From_Queue (Event'Unchecked_Access); Event.Handler := null; - if At_Time <= Clock then - if Handler /= null then - Handler (Event); - end if; - return; - end if; + + -- RM-D.15(15/2) requires that at this point, we check whether the time + -- has already passed, and if so, call Handler.all directly from here + -- instead of doing the enqueuing below. However, this causes a nasty + -- race condition and potential deadlock. If the current task has + -- already locked the protected object of Handler.all, and the time has + -- passed, deadlock would occur. Therefore, we ignore the requirement. + -- The same comment applies to the other Set_Handler below. + if Handler /= null then Event.Timeout := At_Time; Event.Handler := Handler; @@ -286,12 +293,9 @@ package body Ada.Real_Time.Timing_Events is begin Remove_From_Queue (Event'Unchecked_Access); Event.Handler := null; - if In_Time <= Time_Span_Zero then - if Handler /= null then - Handler (Event); - end if; - return; - end if; + + -- See comment in the other Set_Handler above. + if Handler /= null then Event.Timeout := Clock + In_Time; Event.Handler := Handler; diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 62e540c9448..391a424a094 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -2882,6 +2882,7 @@ _flush_cache() && defined (__SVR4)) \ && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \ && ! (defined (linux) && defined (__ia64__)) \ + && ! (defined (linux) && defined (powerpc)) \ && ! defined (__FreeBSD__) \ && ! defined (__hpux__) \ && ! defined (__APPLE__) \ diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 31695a386ac..e00bc4646c3 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -1838,7 +1838,7 @@ package body ALI is end if; end loop; - Add_Char_To_Name_Buffer (nul); + Add_Char_To_Name_Buffer (NUL); Skip_Eol; end if; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 38512547e7f..aea61397dc9 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -765,148 +765,256 @@ package body Checks is -- Apply_Arithmetic_Overflow_Check -- ------------------------------------- - -- This routine is called only if the type is an integer type, and - -- a software arithmetic overflow check must be performed for op - -- (add, subtract, multiply). The check is performed only if - -- Software_Overflow_Checking is enabled and Do_Overflow_Check - -- is set. In this case we expand the operation into a more complex - -- sequence of tests that ensures that overflow is properly caught. + -- This routine is called only if the type is an integer type, and a + -- software arithmetic overflow check may be needed for op (add, subtract, + -- or multiply). This check is performed only if Software_Overflow_Checking + -- is enabled and Do_Overflow_Check is set. In this case we expand the + -- operation into a more complex sequence of tests that ensures that + -- overflow is properly caught. procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Typ : constant Entity_Id := Etype (N); - Rtyp : constant Entity_Id := Root_Type (Typ); - Siz : constant Int := UI_To_Int (Esize (Rtyp)); - Dsiz : constant Int := Siz * 2; - Opnod : Node_Id; - Ctyp : Entity_Id; - Opnd : Node_Id; - Cent : RE_Id; + Typ : Entity_Id := Etype (N); + Rtyp : Entity_Id := Root_Type (Typ); begin - -- Skip this if overflow checks are done in back end, or the overflow - -- flag is not set anyway, or we are not doing code expansion. - -- Special case CLI target, where arithmetic overflow checks can be - -- performed for integer and long_integer - - if Backend_Overflow_Checks_On_Target - or else (VM_Target = CLI_Target and then Siz >= Standard_Integer_Size) - or else not Do_Overflow_Check (N) - or else not Expander_Active + -- An interesting special case. If the arithmetic operation appears as + -- the operand of a type conversion: + + -- type1 (x op y) + + -- and all the following conditions apply: + + -- arithmetic operation is for a signed integer type + -- target type type1 is a static integer subtype + -- range of x and y are both included in the range of type1 + -- range of x op y is included in the range of type1 + -- size of type1 is at least twice the result size of op + + -- then we don't do an overflow check in any case, instead we transform + -- the operation so that we end up with: + + -- type1 (type1 (x) op type1 (y)) + + -- This avoids intermediate overflow before the conversion. It is + -- explicitly permitted by RM 3.5.4(24): + + -- For the execution of a predefined operation of a signed integer + -- type, the implementation need not raise Constraint_Error if the + -- result is outside the base range of the type, so long as the + -- correct result is produced. + + -- It's hard to imagine that any programmer counts on the exception + -- being raised in this case, and in any case it's wrong coding to + -- have this expectation, given the RM permission. Furthermore, other + -- Ada compilers do allow such out of range results. + + -- Note that we do this transformation even if overflow checking is + -- off, since this is precisely about giving the "right" result and + -- avoiding the need for an overflow check. + + if Is_Signed_Integer_Type (Typ) + and then Nkind (Parent (N)) = N_Type_Conversion then - return; + declare + Target_Type : constant Entity_Id := + Base_Type (Entity (Subtype_Mark (Parent (N)))); + + Llo, Lhi : Uint; + Rlo, Rhi : Uint; + LOK, ROK : Boolean; + + Vlo : Uint; + Vhi : Uint; + VOK : Boolean; + + Tlo : Uint; + Thi : Uint; + + begin + if Is_Integer_Type (Target_Type) + and then RM_Size (Root_Type (Target_Type)) >= 2 * RM_Size (Rtyp) + then + Tlo := Expr_Value (Type_Low_Bound (Target_Type)); + Thi := Expr_Value (Type_High_Bound (Target_Type)); + + Determine_Range (Left_Opnd (N), LOK, Llo, Lhi); + Determine_Range (Right_Opnd (N), ROK, Rlo, Rhi); + + if (LOK and ROK) + and then Tlo <= Llo and then Lhi <= Thi + and then Tlo <= Rlo and then Rhi <= Thi + then + Determine_Range (N, VOK, Vlo, Vhi); + + if VOK and then Tlo <= Vlo and then Vhi <= Thi then + Rewrite (Left_Opnd (N), + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), + Expression => Relocate_Node (Left_Opnd (N)))); + + Rewrite (Right_Opnd (N), + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), + Expression => Relocate_Node (Right_Opnd (N)))); + + Set_Etype (N, Target_Type); + Typ := Target_Type; + Rtyp := Root_Type (Typ); + Analyze_And_Resolve (Left_Opnd (N), Target_Type); + Analyze_And_Resolve (Right_Opnd (N), Target_Type); + + -- Given that the target type is twice the size of the + -- source type, overflow is now impossible, so we can + -- safely kill the overflow check and return. + + Set_Do_Overflow_Check (N, False); + return; + end if; + end if; + end if; + end; end if; - -- Otherwise, we generate the full general code for front end overflow - -- detection, which works by doing arithmetic in a larger type: + -- Now see if an overflow check is required + + declare + Siz : constant Int := UI_To_Int (Esize (Rtyp)); + Dsiz : constant Int := Siz * 2; + Opnod : Node_Id; + Ctyp : Entity_Id; + Opnd : Node_Id; + Cent : RE_Id; + + begin + -- Skip check if back end does overflow checks, or the overflow flag + -- is not set anyway, or we are not doing code expansion. + + -- Special case CLI target, where arithmetic overflow checks can be + -- performed for integer and long_integer - -- x op y + if Backend_Overflow_Checks_On_Target + or else not Do_Overflow_Check (N) + or else not Expander_Active + or else + (VM_Target = CLI_Target and then Siz >= Standard_Integer_Size) + then + return; + end if; - -- is expanded into + -- Otherwise, generate the full general code for front end overflow + -- detection, which works by doing arithmetic in a larger type: - -- Typ (Checktyp (x) op Checktyp (y)); + -- x op y - -- where Typ is the type of the original expression, and Checktyp is - -- an integer type of sufficient length to hold the largest possible - -- result. + -- is expanded into - -- In the case where check type exceeds the size of Long_Long_Integer, - -- we use a different approach, expanding to: + -- Typ (Checktyp (x) op Checktyp (y)); - -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y))) + -- where Typ is the type of the original expression, and Checktyp is + -- an integer type of sufficient length to hold the largest possible + -- result. - -- where xxx is Add, Multiply or Subtract as appropriate + -- If the size of check type exceeds the size of Long_Long_Integer, + -- we use a different approach, expanding to: - -- Find check type if one exists + -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y))) - if Dsiz <= Standard_Integer_Size then - Ctyp := Standard_Integer; + -- where xxx is Add, Multiply or Subtract as appropriate - elsif Dsiz <= Standard_Long_Long_Integer_Size then - Ctyp := Standard_Long_Long_Integer; + -- Find check type if one exists - -- No check type exists, use runtime call + if Dsiz <= Standard_Integer_Size then + Ctyp := Standard_Integer; - else - if Nkind (N) = N_Op_Add then - Cent := RE_Add_With_Ovflo_Check; + elsif Dsiz <= Standard_Long_Long_Integer_Size then + Ctyp := Standard_Long_Long_Integer; - elsif Nkind (N) = N_Op_Multiply then - Cent := RE_Multiply_With_Ovflo_Check; + -- No check type exists, use runtime call else - pragma Assert (Nkind (N) = N_Op_Subtract); - Cent := RE_Subtract_With_Ovflo_Check; - end if; + if Nkind (N) = N_Op_Add then + Cent := RE_Add_With_Ovflo_Check; - Rewrite (N, - OK_Convert_To (Typ, - Make_Function_Call (Loc, - Name => New_Reference_To (RTE (Cent), Loc), - Parameter_Associations => New_List ( - OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)), - OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N)))))); + elsif Nkind (N) = N_Op_Multiply then + Cent := RE_Multiply_With_Ovflo_Check; - Analyze_And_Resolve (N, Typ); - return; - end if; + else + pragma Assert (Nkind (N) = N_Op_Subtract); + Cent := RE_Subtract_With_Ovflo_Check; + end if; + + Rewrite (N, + OK_Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (Cent), Loc), + Parameter_Associations => New_List ( + OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)), + OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N)))))); - -- If we fall through, we have the case where we do the arithmetic in - -- the next higher type and get the check by conversion. In these cases - -- Ctyp is set to the type to be used as the check type. + Analyze_And_Resolve (N, Typ); + return; + end if; - Opnod := Relocate_Node (N); + -- If we fall through, we have the case where we do the arithmetic + -- in the next higher type and get the check by conversion. In these + -- cases Ctyp is set to the type to be used as the check type. - Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod)); + Opnod := Relocate_Node (N); - Analyze (Opnd); - Set_Etype (Opnd, Ctyp); - Set_Analyzed (Opnd, True); - Set_Left_Opnd (Opnod, Opnd); + Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod)); - Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod)); + Analyze (Opnd); + Set_Etype (Opnd, Ctyp); + Set_Analyzed (Opnd, True); + Set_Left_Opnd (Opnod, Opnd); - Analyze (Opnd); - Set_Etype (Opnd, Ctyp); - Set_Analyzed (Opnd, True); - Set_Right_Opnd (Opnod, Opnd); + Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod)); - -- The type of the operation changes to the base type of the check type, - -- and we reset the overflow check indication, since clearly no overflow - -- is possible now that we are using a double length type. We also set - -- the Analyzed flag to avoid a recursive attempt to expand the node. + Analyze (Opnd); + Set_Etype (Opnd, Ctyp); + Set_Analyzed (Opnd, True); + Set_Right_Opnd (Opnod, Opnd); - Set_Etype (Opnod, Base_Type (Ctyp)); - Set_Do_Overflow_Check (Opnod, False); - Set_Analyzed (Opnod, True); + -- The type of the operation changes to the base type of the check + -- type, and we reset the overflow check indication, since clearly no + -- overflow is possible now that we are using a double length type. + -- We also set the Analyzed flag to avoid a recursive attempt to + -- expand the node. - -- Now build the outer conversion + Set_Etype (Opnod, Base_Type (Ctyp)); + Set_Do_Overflow_Check (Opnod, False); + Set_Analyzed (Opnod, True); - Opnd := OK_Convert_To (Typ, Opnod); - Analyze (Opnd); - Set_Etype (Opnd, Typ); + -- Now build the outer conversion - -- In the discrete type case, we directly generate the range check for - -- the outer operand. This range check will implement the required - -- overflow check. + Opnd := OK_Convert_To (Typ, Opnod); + Analyze (Opnd); + Set_Etype (Opnd, Typ); - if Is_Discrete_Type (Typ) then - Rewrite (N, Opnd); - Generate_Range_Check (Expression (N), Typ, CE_Overflow_Check_Failed); + -- In the discrete type case, we directly generate the range check + -- for the outer operand. This range check will implement the + -- required overflow check. - -- For other types, we enable overflow checking on the conversion, - -- after setting the node as analyzed to prevent recursive attempts - -- to expand the conversion node. + if Is_Discrete_Type (Typ) then + Rewrite (N, Opnd); + Generate_Range_Check + (Expression (N), Typ, CE_Overflow_Check_Failed); - else - Set_Analyzed (Opnd, True); - Enable_Overflow_Check (Opnd); - Rewrite (N, Opnd); - end if; + -- For other types, we enable overflow checking on the conversion, + -- after setting the node as analyzed to prevent recursive attempts + -- to expand the conversion node. - exception - when RE_Not_Available => - return; + else + Set_Analyzed (Opnd, True); + Enable_Overflow_Check (Opnd); + Rewrite (N, Opnd); + end if; + + exception + when RE_Not_Available => + return; + end; end Apply_Arithmetic_Overflow_Check; ---------------------------- @@ -2231,6 +2339,7 @@ package body Checks is end; elsif Comes_From_Source (N) + and then not Discriminant_Checks_Suppressed (Target_Type) and then Is_Record_Type (Target_Type) and then Is_Derived_Type (Target_Type) and then not Is_Tagged_Type (Target_Type) diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 1404d35ac41..56f87916c45 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -1829,7 +1829,7 @@ package body CStand is Write_Eol; P (" type Wide_Wide_Character is (...)"); - Write_Str (" for Wide_Character'Size use "); + Write_Str (" for Wide_Wide_Character'Size use "); Write_Int (Standard_Wide_Wide_Character_Size); P (";"); P (" -- See RM A.1(36) for details of this type"); diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c index 8565305c2d5..8f29ca77dfc 100644 --- a/gcc/ada/decl.c +++ b/gcc/ada/decl.c @@ -122,6 +122,17 @@ static void check_ok_for_atomic (tree, Entity_Id, bool); static int compatible_signatures_p (tree ftype1, tree ftype2); static void rest_of_type_decl_compilation_no_defer (tree); +/* Return true if GNAT_ADDRESS is a compile time known value. + In particular catch System'To_Address. */ + +static bool +compile_time_known_address_p (Node_Id gnat_address) +{ + return ((Nkind (gnat_address) == N_Unchecked_Type_Conversion + && Compile_Time_Known_Value (Expression (gnat_address))) + || Compile_Time_Known_Value (gnat_address)); +} + /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a GCC type corresponding to that entity. GNAT_ENTITY is assumed to refer to an Ada type. */ @@ -1026,7 +1037,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) = build_reference_type_for_mode (gnu_type, ptr_mode, true); gnu_address = convert (gnu_type, gnu_address); used_by_ref = true; - const_flag = !Is_Public (gnat_entity); + const_flag = !Is_Public (gnat_entity) + || compile_time_known_address_p (Expression (Address_Clause + (gnat_entity))); /* If we don't have an initializing expression for the underlying variable, the initializing expression for the pointer is the @@ -1058,9 +1071,24 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) = build_reference_type_for_mode (gnu_type, ptr_mode, true); gnu_size = NULL_TREE; - gnu_expr = NULL_TREE; /* No point in taking the address of an initializing expression that isn't going to be used. */ + gnu_expr = NULL_TREE; + + /* If it has an address clause whose value is known at compile + time, make the object a CONST_DECL. This will avoid a + useless dereference. */ + if (Present (Address_Clause (gnat_entity))) + { + Node_Id gnat_address + = Expression (Address_Clause (gnat_entity)); + + if (compile_time_known_address_p (gnat_address)) + { + gnu_expr = gnat_to_gnu (gnat_address); + const_flag = true; + } + } used_by_ref = true; } @@ -1258,7 +1286,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) for these. */ if (TREE_CODE (gnu_decl) == CONST_DECL && (definition || Sloc (gnat_entity) > Standard_Location) - && (Is_Public (gnat_entity) + && ((Is_Public (gnat_entity) + && !Present (Address_Clause (gnat_entity))) || optimize == 0 || Address_Taken (gnat_entity) || Is_Aliased (gnat_entity) @@ -1271,6 +1300,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnat_entity); SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var); + + /* As debugging information will be generated for the variable, + do not generate information for the constant. */ + DECL_IGNORED_P (gnu_decl) = true; } /* If this is declared in a block that contains a block with an diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 7374a7e41ae..7d3fbdf57d7 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -126,7 +126,6 @@ package body Einfo is -- Scale_Value Uint15 -- Storage_Size_Variable Node15 -- String_Literal_Low_Bound Node15 - -- Shared_Var_Read_Proc Node15 -- Access_Disp_Table Elist16 -- Cloned_Subtype Node16 @@ -193,7 +192,7 @@ package body Einfo is -- Private_View Node22 -- Protected_Formal Node22 -- Scope_Depth_Value Uint22 - -- Shared_Var_Assign_Proc Node22 + -- Shared_Var_Procs_Instance Node22 -- Associated_Final_Chain Node23 -- CR_Discriminant Node23 @@ -505,8 +504,8 @@ package body Einfo is -- Optimize_Alignment_Space Flag241 -- Optimize_Alignment_Time Flag242 -- Overlays_Constant Flag243 + -- Is_RACW_Stub_Type Flag244 - -- (unused) Flag244 -- (unused) Flag245 -- (unused) Flag246 -- (unused) Flag247 @@ -1975,6 +1974,12 @@ package body Einfo is return Flag189 (Id); end Is_Pure_Unit_Access_Type; + function Is_RACW_Stub_Type (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag244 (Id); + end Is_RACW_Stub_Type; + function Is_Raised (Id : E) return B is begin pragma Assert (Ekind (Id) = E_Exception); @@ -2239,7 +2244,7 @@ package body Einfo is function Non_Binary_Modulus (Id : E) return B is begin - pragma Assert (Is_Modular_Integer_Type (Id)); + pragma Assert (Is_Type (Id)); return Flag58 (Base_Type (Id)); end Non_Binary_Modulus; @@ -2537,17 +2542,11 @@ package body Einfo is return List14 (Id); end Shadow_Entities; - function Shared_Var_Assign_Proc (Id : E) return E is + function Shared_Var_Procs_Instance (Id : E) return E is begin pragma Assert (Ekind (Id) = E_Variable); return Node22 (Id); - end Shared_Var_Assign_Proc; - - function Shared_Var_Read_Proc (Id : E) return E is - begin - pragma Assert (Ekind (Id) = E_Variable); - return Node15 (Id); - end Shared_Var_Read_Proc; + end Shared_Var_Procs_Instance; function Size_Check_Code (Id : E) return N is begin @@ -4424,6 +4423,12 @@ package body Einfo is Set_Flag189 (Id, V); end Set_Is_Pure_Unit_Access_Type; + procedure Set_Is_RACW_Stub_Type (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag244 (Id, V); + end Set_Is_RACW_Stub_Type; + procedure Set_Is_Raised (Id : E; V : B := True) is begin pragma Assert (Ekind (Id) = E_Exception); @@ -4697,7 +4702,7 @@ package body Einfo is procedure Set_Non_Binary_Modulus (Id : E; V : B := True) is begin - pragma Assert (Ekind (Id) = E_Modular_Integer_Type); + pragma Assert (Is_Type (Id) and then Id = Base_Type (Id)); Set_Flag58 (Id, V); end Set_Non_Binary_Modulus; @@ -5000,17 +5005,11 @@ package body Einfo is Set_List14 (Id, V); end Set_Shadow_Entities; - procedure Set_Shared_Var_Assign_Proc (Id : E; V : E) is + procedure Set_Shared_Var_Procs_Instance (Id : E; V : E) is begin pragma Assert (Ekind (Id) = E_Variable); Set_Node22 (Id, V); - end Set_Shared_Var_Assign_Proc; - - procedure Set_Shared_Var_Read_Proc (Id : E; V : E) is - begin - pragma Assert (Ekind (Id) = E_Variable); - Set_Node15 (Id, V); - end Set_Shared_Var_Read_Proc; + end Set_Shared_Var_Procs_Instance; procedure Set_Size_Check_Code (Id : E; V : N) is begin @@ -7621,6 +7620,7 @@ package body Einfo is W ("Is_Public", Flag10 (Id)); W ("Is_Pure", Flag44 (Id)); W ("Is_Pure_Unit_Access_Type", Flag189 (Id)); + W ("Is_RACW_Stub_Type", Flag244 (Id)); W ("Is_Raised", Flag224 (Id)); W ("Is_Remote_Call_Interface", Flag62 (Id)); W ("Is_Remote_Types", Flag61 (Id)); @@ -8131,9 +8131,6 @@ package body Einfo is when E_String_Literal_Subtype => Write_Str ("String_Literal_Low_Bound"); - when E_Variable => - Write_Str ("Shared_Var_Read_Proc"); - when others => Write_Str ("Field15??"); end case; @@ -8506,7 +8503,7 @@ package body Einfo is Write_Str ("Private_View"); when E_Variable => - Write_Str ("Shared_Var_Assign_Proc"); + Write_Str ("Shared_Var_Procs_Instance"); when others => Write_Str ("Field22??"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 852d9966ddf..e1623042b52 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2581,6 +2581,10 @@ package Einfo is -- subtype appears in a pure unit. Used to give an error message at -- freeze time if the access type has a storage pool. +-- Is_RACW_Stub_Type (Flag244) +-- Present in all types, true for the stub types generated for remote +-- access-to-class-wide types. + -- Is_Raised (Flag224) -- Present in exception entities. Set if the entity is referenced by a -- a raise statement. @@ -2595,12 +2599,12 @@ package Einfo is -- Is_Remote_Call_Interface (Flag62) -- Present in all entities. Set in E_Package and E_Generic_Package -- entities to which a pragma Remote_Call_Interace is applied, and --- also in all entities within such packages. +-- also on entities declared in the visible part of such a package. -- Is_Remote_Types (Flag61) -- Present in all entities. Set in E_Package and E_Generic_Package --- entities to which a pragma Remote_Types is applied, and also in --- all entities within such packages. +-- entities to which a pragma Remote_Types is applied, and also on +-- entities declared in the visible part of the spec of such a package. -- Is_Renaming_Of_Object (Flag112) -- Present in all entities, set only for a variable or constant for @@ -3044,8 +3048,8 @@ package Einfo is -- of a record, returns the next _Tag field in this record. -- Non_Binary_Modulus (Flag58) [base type only] --- Present in modular integer types. Set if the modulus for the type --- is other than a power of 2. +-- Present in all subtype and type entities. Set for modular integer +-- types if the modulus value is other than a power of 2. -- Non_Limited_View (Node17) -- Present in incomplete types that are the shadow entities created @@ -3479,15 +3483,10 @@ package Einfo is -- standard format list (i.e. First (Shadow_Entities) is the first -- entry and subsequent entries are obtained using Next. --- Shared_Var_Assign_Proc (Node22) --- Present in variables. Set non-Empty only if Is_Shared_Passive is --- set, in which case this is the entity for the shared memory assign --- routine. See Exp_Smem for full details. - --- Shared_Var_Read_Proc (Node15) +-- Shared_Var_Procs_Instance (Node22) -- Present in variables. Set non-Empty only if Is_Shared_Passive is --- set, in which case this is the entity for the shared memory read --- routine. See Exp_Smem for full details. +-- set, in which case this is the entity for the associated instance of +-- System.Shared_Storage.Shared_Var_Procs. See Exp_Smem for full details. -- Size_Check_Code (Node19) -- Present in constants and variables. Normally Empty. Set if code is @@ -4698,6 +4697,7 @@ package Einfo is -- Is_Generic_Actual_Type (Flag94) -- Is_Generic_Type (Flag13) -- Is_Protected_Interface (Flag198) + -- Is_RACW_Stub_Type (Flag244) -- Is_Synchronized_Interface (Flag199) -- Is_Task_Interface (Flag200) -- Is_Non_Static_Subtype (Flag109) @@ -5490,14 +5490,13 @@ package Einfo is -- Esize (Uint12) -- Extra_Accessibility (Node13) -- Alignment (Uint14) - -- Shared_Var_Read_Proc (Node15) -- Unset_Reference (Node16) -- Actual_Subtype (Node17) -- Renamed_Object (Node18) -- Size_Check_Code (Node19) -- Prival_Link (Node20) -- Interface_Name (Node21) - -- Shared_Var_Assign_Proc (Node22) + -- Shared_Var_Procs_Instance (Node22) -- Extra_Constrained (Node23) -- Debug_Renaming_Link (Node25) -- Last_Assignment (Node26) @@ -5990,6 +5989,7 @@ package Einfo is function Is_Public (Id : E) return B; function Is_Pure (Id : E) return B; function Is_Pure_Unit_Access_Type (Id : E) return B; + function Is_RACW_Stub_Type (Id : E) return B; function Is_Raised (Id : E) return B; function Is_Remote_Call_Interface (Id : E) return B; function Is_Remote_Types (Id : E) return B; @@ -6085,8 +6085,7 @@ package Einfo is function Scope_Depth_Value (Id : E) return U; function Sec_Stack_Needed_For_Return (Id : E) return B; function Shadow_Entities (Id : E) return S; - function Shared_Var_Assign_Proc (Id : E) return E; - function Shared_Var_Read_Proc (Id : E) return E; + function Shared_Var_Procs_Instance (Id : E) return E; function Size_Check_Code (Id : E) return N; function Size_Known_At_Compile_Time (Id : E) return B; function Size_Depends_On_Discriminant (Id : E) return B; @@ -6555,6 +6554,7 @@ package Einfo is procedure Set_Is_Public (Id : E; V : B := True); procedure Set_Is_Pure (Id : E; V : B := True); procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True); + procedure Set_Is_RACW_Stub_Type (Id : E; V : B := True); procedure Set_Is_Raised (Id : E; V : B := True); procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True); procedure Set_Is_Remote_Types (Id : E; V : B := True); @@ -6650,8 +6650,7 @@ package Einfo is procedure Set_Scope_Depth_Value (Id : E; V : U); procedure Set_Sec_Stack_Needed_For_Return (Id : E; V : B := True); procedure Set_Shadow_Entities (Id : E; V : S); - procedure Set_Shared_Var_Assign_Proc (Id : E; V : E); - procedure Set_Shared_Var_Read_Proc (Id : E; V : E); + procedure Set_Shared_Var_Procs_Instance (Id : E; V : E); procedure Set_Size_Check_Code (Id : E; V : N); procedure Set_Size_Depends_On_Discriminant (Id : E; V : B := True); procedure Set_Size_Known_At_Compile_Time (Id : E; V : B := True); @@ -7236,6 +7235,7 @@ package Einfo is pragma Inline (Is_Public); pragma Inline (Is_Pure); pragma Inline (Is_Pure_Unit_Access_Type); + pragma Inline (Is_RACW_Stub_Type); pragma Inline (Is_Raised); pragma Inline (Is_Real_Type); pragma Inline (Is_Record_Type); @@ -7340,8 +7340,7 @@ package Einfo is pragma Inline (Scope_Depth_Value); pragma Inline (Sec_Stack_Needed_For_Return); pragma Inline (Shadow_Entities); - pragma Inline (Shared_Var_Assign_Proc); - pragma Inline (Shared_Var_Read_Proc); + pragma Inline (Shared_Var_Procs_Instance); pragma Inline (Size_Check_Code); pragma Inline (Size_Depends_On_Discriminant); pragma Inline (Size_Known_At_Compile_Time); @@ -7628,6 +7627,7 @@ package Einfo is pragma Inline (Set_Is_Public); pragma Inline (Set_Is_Pure); pragma Inline (Set_Is_Pure_Unit_Access_Type); + pragma Inline (Set_Is_RACW_Stub_Type); pragma Inline (Set_Is_Raised); pragma Inline (Set_Is_Remote_Call_Interface); pragma Inline (Set_Is_Remote_Types); @@ -7722,8 +7722,7 @@ package Einfo is pragma Inline (Set_Scope_Depth_Value); pragma Inline (Set_Sec_Stack_Needed_For_Return); pragma Inline (Set_Shadow_Entities); - pragma Inline (Set_Shared_Var_Assign_Proc); - pragma Inline (Set_Shared_Var_Read_Proc); + pragma Inline (Set_Shared_Var_Procs_Instance); pragma Inline (Set_Size_Check_Code); pragma Inline (Set_Size_Depends_On_Discriminant); pragma Inline (Set_Size_Known_At_Compile_Time); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index c815369e821..af531ab6ed0 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -2573,11 +2573,7 @@ package body Exp_Aggr is -- Ada 2005 (AI-251): If tagged type has progenitors we must -- also initialize tags of the secondary dispatch tables. - if Present (Abstract_Interfaces (Base_Type (Typ))) - and then not - Is_Empty_Elmt_List - (Abstract_Interfaces (Base_Type (Typ))) - then + if Has_Abstract_Interfaces (Base_Type (Typ)) then Init_Secondary_Tags (Typ => Base_Type (Typ), Target => Target, @@ -3084,10 +3080,7 @@ package body Exp_Aggr is -- abstract interfaces we must also initialize the tags of the -- secondary dispatch tables. - if Present (Abstract_Interfaces (Base_Type (Typ))) - and then not - Is_Empty_Elmt_List (Abstract_Interfaces (Base_Type (Typ))) - then + if Has_Abstract_Interfaces (Base_Type (Typ)) then Init_Secondary_Tags (Typ => Base_Type (Typ), Target => Target, @@ -3317,8 +3310,10 @@ package body Exp_Aggr is and then Ekind (Current_Scope) /= E_Return_Statement and then not Is_Limited_Type (Typ) then - Establish_Transient_Scope (Aggr, Sec_Stack => - Is_Controlled (Typ) or else Has_Controlled_Component (Typ)); + Establish_Transient_Scope + (Aggr, + Sec_Stack => + Is_Controlled (Typ) or else Has_Controlled_Component (Typ)); end if; Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ, Obj => Obj)); diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index c3716c387fa..6093f2a7333 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -469,7 +469,7 @@ package body Exp_Ch2 is -- we also generate an extra parameter to hold the Constrained -- attribute of the actual. No renaming is generated for this flag. - -- Calling Node_Possible_Modifications in the expander is dubious, + -- Calling Note_Possible_Modification in the expander is dubious, -- because this generates a cross-reference entry, and should be -- done during semantic processing so it is called in -gnatc mode??? diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 3ec27893af0..1ed0703f251 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1027,10 +1027,14 @@ package body Exp_Ch3 is Saved_Enclosing_Func_Id : Entity_Id; begin - -- Build the discriminant checking function for each variant, label - -- all components of that variant with the function's name. - -- We only Generate a discriminant-checking function only if the + -- Build the discriminant-checking function for each variant, and + -- label all components of that variant with the function's name. + -- We only Generate a discriminant-checking function when the -- variant is not empty, to prevent the creation of dead code. + -- The exception to that is when Frontend_Layout_On_Target is set, + -- because the variant record size function generated in package + -- Layout needs to generate calls to all discriminant-checking + -- functions, including those for empty variants. Discr_Name := Entity (Name (Variant_Part_Node)); Variant := First_Non_Pragma (Variants (Variant_Part_Node)); @@ -1038,7 +1042,9 @@ package body Exp_Ch3 is while Present (Variant) loop Component_List_Node := Component_List (Variant); - if not Null_Present (Component_List_Node) then + if not Null_Present (Component_List_Node) + or else Frontend_Layout_On_Target + then Func_Id := Build_Dcheck_Function (Discr_Name, Variant); Decl := First_Non_Pragma (Component_Items (Component_List_Node)); @@ -4377,17 +4383,23 @@ package body Exp_Ch3 is -- Ada 2005 (AI-251): Rewrite the expression that initializes a -- class-wide object to ensure that we copy the full object, - -- unless we're targetting a VM where interfaces are handled by - -- VM itself. + -- unless we are targetting a VM where interfaces are handled by + -- VM itself. Note that if the root type of Typ is an ancestor + -- of Expr's type, both types share the same dispatch table and + -- there is no need to displace the pointer. -- Replace - -- CW : I'Class := Obj; + -- CW : I'Class := Obj; -- by - -- CW__1 : I'Class := I'Class (Base_Address (Obj'Address)); - -- CW : I'Class renames Displace (CW__1, I'Tag); + -- Temp : I'Class := I'Class (Base_Address (Obj'Address)); + -- CW : I'Class renames Displace (Temp, I'Tag); if Is_Interface (Typ) - and then Is_Class_Wide_Type (Etype (Expr)) + and then Is_Class_Wide_Type (Typ) + and then + (Is_Class_Wide_Type (Etype (Expr)) + or else + not Is_Parent (Root_Type (Typ), Etype (Expr))) and then Comes_From_Source (Def_Id) and then VM_Target = No_VM then @@ -5344,7 +5356,7 @@ package body Exp_Ch3 is and then Chars (Comp) = Chars (Old_Comp) then Set_Discriminant_Checking_Func (Comp, - Discriminant_Checking_Func (Old_Comp)); + Discriminant_Checking_Func (Old_Comp)); end if; Next_Component (Old_Comp); @@ -5658,8 +5670,8 @@ package body Exp_Ch3 is null; -- Do not add the body of the predefined primitives if we are - -- compiling under restriction No_Dispatching_Calls of if we - -- are compiling a CPP tagged type. + -- compiling under restriction No_Dispatching_Calls or if we are + -- compiling a CPP tagged type. elsif not Restriction_Active (No_Dispatching_Calls) then Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); @@ -6739,20 +6751,19 @@ package body Exp_Ch3 is else -- Don't need to set any value if this interface shares - -- the primary dispatch table + -- the primary dispatch table. if not Is_Parent (Iface, Typ) then Append_To (Stmts_List, Build_Set_Static_Offset_To_Top (Loc, - Iface_Tag => - New_Reference_To (Iface_Tag, Loc), + Iface_Tag => New_Reference_To (Iface_Tag, Loc), Offset_Value => Unchecked_Convert_To (RTE (RE_Storage_Offset), Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Reference_To (Tag_Comp, Loc)), Attribute_Name => Name_Position)))); end if; @@ -6772,14 +6783,12 @@ package body Exp_Ch3 is (RTE (RE_Register_Interface_Offset), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, - Prefix => New_Copy_Tree (Target), + Prefix => New_Copy_Tree (Target), Attribute_Name => Name_Address), Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To - (Node (First_Elmt - (Access_Disp_Table (Iface))), - Loc)), + (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)), New_Occurrence_Of (Standard_True, Loc), @@ -6788,7 +6797,7 @@ package body Exp_Ch3 is Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), + Prefix => New_Copy_Tree (Target), Selector_Name => New_Reference_To (Tag_Comp, Loc)), Attribute_Name => Name_Position)), @@ -6841,7 +6850,7 @@ package body Exp_Ch3 is Tag_Comp => Tag_Comp, Iface_Tag => Node (Iface_Tag_Elmt)); - -- Otherwise we generate code to initialize the tag + -- Otherwise generate code to initialize the tag else -- Check if the parent of the record type has variable size @@ -7125,7 +7134,7 @@ package body Exp_Ch3 is -- Make_Eq_Case -- ------------------ - -- <Make_Eq_if shared components> + -- <Make_Eq_If shared components> -- case X.D1 is -- when V1 => <Make_Eq_Case> on subcomponents -- ... @@ -7203,7 +7212,7 @@ package body Exp_Ch3 is -- return False; -- end if; - -- or a null statement if the list L is empty + -- or a null statement if the list L is empty. function Make_Eq_If (E : Entity_Id; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index ee440f14424..0246516fcbf 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -110,20 +110,19 @@ package body Exp_Ch4 is Bodies : List_Id; Typ : Entity_Id) return Node_Id; -- Expand an array equality into a call to a function implementing this - -- equality, and a call to it. Loc is the location for the generated - -- nodes. Lhs and Rhs are the array expressions to be compared. - -- Bodies is a list on which to attach bodies of local functions that - -- are created in the process. It is the responsibility of the - -- caller to insert those bodies at the right place. Nod provides - -- the Sloc value for the generated code. Normally the types used - -- for the generated equality routine are taken from Lhs and Rhs. - -- However, in some situations of generated code, the Etype fields - -- of Lhs and Rhs are not set yet. In such cases, Typ supplies the - -- type to be used for the formal parameters. + -- equality, and a call to it. Loc is the location for the generated nodes. + -- Lhs and Rhs are the array expressions to be compared. Bodies is a list + -- on which to attach bodies of local functions that are created in the + -- process. It is the responsibility of the caller to insert those bodies + -- at the right place. Nod provides the Sloc value for the generated code. + -- Normally the types used for the generated equality routine are taken + -- from Lhs and Rhs. However, in some situations of generated code, the + -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies + -- the type to be used for the formal parameters. procedure Expand_Boolean_Operator (N : Node_Id); - -- Common expansion processing for Boolean operators (And, Or, Xor) - -- for the case of array type arguments. + -- Common expansion processing for Boolean operators (And, Or, Xor) for the + -- case of array type arguments. function Expand_Composite_Equality (Nod : Node_Id; @@ -131,19 +130,19 @@ package body Exp_Ch4 is Lhs : Node_Id; Rhs : Node_Id; Bodies : List_Id) return Node_Id; - -- Local recursive function used to expand equality for nested - -- composite types. Used by Expand_Record/Array_Equality, Bodies - -- is a list on which to attach bodies of local functions that are - -- created in the process. This is the responsibility of the caller - -- to insert those bodies at the right place. Nod provides the Sloc - -- value for generated code. Lhs and Rhs are the left and right sides - -- for the comparison, and Typ is the type of the arrays to compare. + -- Local recursive function used to expand equality for nested composite + -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which + -- to attach bodies of local functions that are created in the process. + -- This is the responsibility of the caller to insert those bodies at the + -- right place. Nod provides the Sloc value for generated code. Lhs and Rhs + -- are the left and right sides for the comparison, and Typ is the type of + -- the arrays to compare. procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id); - -- This routine handles expansion of concatenation operations, where - -- N is the N_Op_Concat node being expanded and Operands is the list - -- of operands (at least two are present). The caller has dealt with - -- converting any singleton operands into singleton aggregates. + -- This routine handles expansion of concatenation operations, where N is + -- the N_Op_Concat node being expanded and Operands is the list of operands + -- (at least two are present). The caller has dealt with converting any + -- singleton operands into singleton aggregates. procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id); -- Routine to expand concatenation of 2-5 operands (in the list Operands) @@ -153,18 +152,18 @@ package body Exp_Ch4 is -- already converted character operands to strings in this case). procedure Fixup_Universal_Fixed_Operation (N : Node_Id); - -- N is either an N_Op_Divide or N_Op_Multiply node whose result is - -- universal fixed. We do not have such a type at runtime, so the - -- purpose of this routine is to find the real type by looking up - -- the tree. We also determine if the operation must be rounded. + -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal + -- fixed. We do not have such a type at runtime, so the purpose of this + -- routine is to find the real type by looking up the tree. We also + -- determine if the operation must be rounded. function Get_Allocator_Final_List (N : Node_Id; T : Entity_Id; PtrT : Entity_Id) return Entity_Id; - -- If the designated type is controlled, build final_list expression - -- for created object. If context is an access parameter, create a - -- local access type to have a usable finalization list. + -- If the designated type is controlled, build final_list expression for + -- created object. If context is an access parameter, create a local access + -- type to have a usable finalization list. function Has_Inferable_Discriminants (N : Node_Id) return Boolean; -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable @@ -185,22 +184,22 @@ package body Exp_Ch4 is function Make_Array_Comparison_Op (Typ : Entity_Id; Nod : Node_Id) return Node_Id; - -- Comparisons between arrays are expanded in line. This function - -- produces the body of the implementation of (a > b), where a and b - -- are one-dimensional arrays of some discrete type. The original - -- node is then expanded into the appropriate call to this function. - -- Nod provides the Sloc value for the generated code. + -- Comparisons between arrays are expanded in line. This function produces + -- the body of the implementation of (a > b), where a and b are one- + -- dimensional arrays of some discrete type. The original node is then + -- expanded into the appropriate call to this function. Nod provides the + -- Sloc value for the generated code. function Make_Boolean_Array_Op (Typ : Entity_Id; N : Node_Id) return Node_Id; - -- Boolean operations on boolean arrays are expanded in line. This - -- function produce the body for the node N, which is (a and b), - -- (a or b), or (a xor b). It is used only the normal case and not - -- the packed case. The type involved, Typ, is the Boolean array type, - -- and the logical operations in the body are simple boolean operations. - -- Note that Typ is always a constrained type (the caller has ensured - -- this by using Convert_To_Actual_Subtype if necessary). + -- Boolean operations on boolean arrays are expanded in line. This function + -- produce the body for the node N, which is (a and b), (a or b), or (a xor + -- b). It is used only the normal case and not the packed case. The type + -- involved, Typ, is the Boolean array type, and the logical operations in + -- the body are simple boolean operations. Note that Typ is always a + -- constrained type (the caller has ensured this by using + -- Convert_To_Actual_Subtype if necessary). procedure Rewrite_Comparison (N : Node_Id); -- If N is the node for a comparison whose outcome can be determined at @@ -218,9 +217,8 @@ package body Exp_Ch4 is (Lhs : Node_Id; Op1 : Node_Id; Op2 : Node_Id) return Boolean; - -- In the context of an assignment, where the right-hand side is a - -- boolean operation on arrays, check whether operation can be performed - -- in place. + -- In the context of an assignment, where the right-hand side is a boolean + -- operation on arrays, check whether operation can be performed in place. procedure Unary_Op_Validity_Checks (N : Node_Id); pragma Inline (Unary_Op_Validity_Checks); @@ -478,28 +476,30 @@ package body Exp_Ch4 is (Ref : Node_Id; Built_In_Place : Boolean := False); -- Ada 2005 (AI-344): For an allocator with a class-wide designated - -- type, generate an accessibility check to verify that the level of - -- the type of the created object is not deeper than the level of the - -- access type. If the type of the qualified expression is class- - -- wide, then always generate the check (except in the case where it - -- is known to be unnecessary, see comment below). Otherwise, only - -- generate the check if the level of the qualified expression type - -- is statically deeper than the access type. Although the static - -- accessibility will generally have been performed as a legality - -- check, it won't have been done in cases where the allocator - -- appears in generic body, so a run-time check is needed in general. - -- One special case is when the access type is declared in the same - -- scope as the class-wide allocator, in which case the check can - -- never fail, so it need not be generated. As an open issue, there - -- seem to be cases where the static level associated with the - -- class-wide object's underlying type is not sufficient to perform - -- the proper accessibility check, such as for allocators in nested - -- subprograms or accept statements initialized by class-wide formals - -- when the actual originates outside at a deeper static level. The - -- nested subprogram case might require passing accessibility levels - -- along with class-wide parameters, and the task case seems to be - -- an actual gap in the language rules that needs to be fixed by the - -- ARG. ??? + -- type, generate an accessibility check to verify that the level of the + -- type of the created object is not deeper than the level of the access + -- type. If the type of the qualified expression is class- wide, then + -- always generate the check (except in the case where it is known to be + -- unnecessary, see comment below). Otherwise, only generate the check + -- if the level of the qualified expression type is statically deeper + -- than the access type. + -- + -- Although the static accessibility will generally have been performed + -- as a legality check, it won't have been done in cases where the + -- allocator appears in generic body, so a run-time check is needed in + -- general. One special case is when the access type is declared in the + -- same scope as the class-wide allocator, in which case the check can + -- never fail, so it need not be generated. + -- + -- As an open issue, there seem to be cases where the static level + -- associated with the class-wide object's underlying type is not + -- sufficient to perform the proper accessibility check, such as for + -- allocators in nested subprograms or accept statements initialized by + -- class-wide formals when the actual originates outside at a deeper + -- static level. The nested subprogram case might require passing + -- accessibility levels along with class-wide parameters, and the task + -- case seems to be an actual gap in the language rules that needs to + -- be fixed by the ARG. ??? ------------------------------- -- Apply_Accessibility_Check -- @@ -577,12 +577,12 @@ package body Exp_Ch4 is begin if Is_Tagged_Type (T) or else Controlled_Type (T) then - -- Ada 2005 (AI-318-02): If the initialization expression is a - -- call to a build-in-place function, then access to the allocated - -- object must be passed to the function. Currently we limit such - -- functions to those with constrained limited result subtypes, - -- but eventually we plan to expand the allowed forms of functions - -- that are treated as build-in-place. + -- Ada 2005 (AI-318-02): If the initialization expression is a call + -- to a build-in-place function, then access to the allocated object + -- must be passed to the function. Currently we limit such functions + -- to those with constrained limited result subtypes, but eventually + -- we plan to expand the allowed forms of functions that are treated + -- as build-in-place. if Ada_Version >= Ada_05 and then Is_Build_In_Place_Function_Call (Exp) @@ -762,11 +762,10 @@ package body Exp_Ch4 is -- Generate an additional object containing the address of the -- returned object. The type of this second object declaration - -- is the correct type required for the common processing - -- that is still performed by this subprogram. The displacement - -- of this pointer to reference the component associated with - -- the interface type will be done at the end of the common - -- processing. + -- is the correct type required for the common processing that + -- is still performed by this subprogram. The displacement of + -- this pointer to reference the component associated with the + -- interface type will be done at the end of common processing. New_Decl := Make_Object_Declaration (Loc, @@ -845,10 +844,10 @@ package body Exp_Ch4 is Associated_Storage_Pool (PtrT); begin - -- If it is an allocation on the secondary stack - -- (i.e. a value returned from a function), the object - -- is attached on the caller side as soon as the call - -- is completed (see Expand_Ctrl_Function_Call) + -- If it is an allocation on the secondary stack (i.e. a value + -- returned from a function), the object is attached on the + -- caller side as soon as the call is completed (see + -- Expand_Ctrl_Function_Call) if Is_RTE (Apool, RE_SS_Pool) then declare @@ -899,10 +898,9 @@ package body Exp_Ch4 is Make_Adjust_Call ( Ref => - -- An unchecked conversion is needed in the - -- classwide case because the designated type - -- can be an ancestor of the subtype mark of - -- the allocator. + -- An unchecked conversion is needed in the classwide + -- case because the designated type can be an ancestor of + -- the subtype mark of the allocator. Unchecked_Convert_To (T, Make_Explicit_Dereference (Loc, @@ -919,9 +917,9 @@ package body Exp_Ch4 is Rewrite (N, New_Reference_To (Temp, Loc)); Analyze_And_Resolve (N, PtrT); - -- Ada 2005 (AI-251): Displace the pointer to reference the - -- record component containing the secondary dispatch table - -- of the interface type. + -- Ada 2005 (AI-251): Displace the pointer to reference the record + -- component containing the secondary dispatch table of the interface + -- type. if Is_Interface (Directly_Designated_Type (PtrT)) then Displace_Allocator_Pointer (N); @@ -965,20 +963,18 @@ package body Exp_Ch4 is else -- First check against the type of the qualified expression -- - -- NOTE: The commented call should be correct, but for - -- some reason causes the compiler to bomb (sigsegv) on - -- ACVC test c34007g, so for now we just perform the old - -- (incorrect) test against the designated subtype with - -- no sliding in the else part of the if statement below. - -- ??? + -- NOTE: The commented call should be correct, but for some reason + -- causes the compiler to bomb (sigsegv) on ACVC test c34007g, so for + -- now we just perform the old (incorrect) test against the + -- designated subtype with no sliding in the else part of the if + -- statement below. ??? -- -- Apply_Constraint_Check (Exp, T, No_Sliding => True); - -- A check is also needed in cases where the designated - -- subtype is constrained and differs from the subtype - -- given in the qualified expression. Note that the check - -- on the qualified expression does not allow sliding, - -- but this check does (a relaxation from Ada 83). + -- A check is also needed in cases where the designated subtype is + -- constrained and differs from the subtype given in the qualified + -- expression. Note that the check on the qualified expression does + -- not allow sliding, but this check does (a relaxation from Ada 83). if Is_Constrained (DesigT) and then not Subtypes_Statically_Match @@ -987,19 +983,18 @@ package body Exp_Ch4 is Apply_Constraint_Check (Exp, DesigT, No_Sliding => False); - -- The nonsliding check should really be performed - -- (unconditionally) against the subtype of the - -- qualified expression, but that causes a problem - -- with c34007g (see above), so for now we retain this. + -- The nonsliding check should really be performed (unconditionally) + -- against the subtype of the qualified expression, but that causes a + -- problem with c34007g (see above), so for now we retain this. else Apply_Constraint_Check (Exp, DesigT, No_Sliding => True); end if; - -- For an access to unconstrained packed array, GIGI needs - -- to see an expression with a constrained subtype in order - -- to compute the proper size for the allocator. + -- For an access to unconstrained packed array, GIGI needs to see an + -- expression with a constrained subtype in order to compute the + -- proper size for the allocator. if Is_Array_Type (T) and then not Is_Constrained (T) @@ -1021,12 +1016,12 @@ package body Exp_Ch4 is end; end if; - -- Ada 2005 (AI-318-02): If the initialization expression is a - -- call to a build-in-place function, then access to the allocated - -- object must be passed to the function. Currently we limit such - -- functions to those with constrained limited result subtypes, - -- but eventually we plan to expand the allowed forms of functions - -- that are treated as build-in-place. + -- Ada 2005 (AI-318-02): If the initialization expression is a call + -- to a build-in-place function, then access to the allocated object + -- must be passed to the function. Currently we limit such functions + -- to those with constrained limited result subtypes, but eventually + -- we plan to expand the allowed forms of functions that are treated + -- as build-in-place. if Ada_Version >= Ada_05 and then Is_Build_In_Place_Function_Call (Exp) @@ -1044,10 +1039,10 @@ package body Exp_Ch4 is -- Expand_Array_Comparison -- ----------------------------- - -- Expansion is only required in the case of array types. For the - -- unpacked case, an appropriate runtime routine is called. For - -- packed cases, and also in some other cases where a runtime - -- routine cannot be called, the form of the expansion is: + -- Expansion is only required in the case of array types. For the unpacked + -- case, an appropriate runtime routine is called. For packed cases, and + -- also in some other cases where a runtime routine cannot be called, the + -- form of the expansion is: -- [body for greater_nn; boolean_expression] @@ -1071,9 +1066,9 @@ package body Exp_Ch4 is -- True for byte addressable target function Length_Less_Than_4 (Opnd : Node_Id) return Boolean; - -- Returns True if the length of the given operand is known to be - -- less than 4. Returns False if this length is known to be four - -- or greater or is not known at compile time. + -- Returns True if the length of the given operand is known to be less + -- than 4. Returns False if this length is known to be four or greater + -- or is not known at compile time. ------------------------ -- Length_Less_Than_4 -- @@ -1272,8 +1267,8 @@ package body Exp_Ch4 is -- Expand_Array_Equality -- --------------------------- - -- Expand an equality function for multi-dimensional arrays. Here is - -- an example of such a function for Nb_Dimension = 2 + -- Expand an equality function for multi-dimensional arrays. Here is an + -- example of such a function for Nb_Dimension = 2 -- function Enn (A : atyp; B : btyp) return boolean is -- begin @@ -1320,15 +1315,15 @@ package body Exp_Ch4 is -- return true; -- end Enn; - -- Note on the formal types used (atyp and btyp). If either of the - -- arrays is of a private type, we use the underlying type, and - -- do an unchecked conversion of the actual. If either of the arrays - -- has a bound depending on a discriminant, then we use the base type - -- since otherwise we have an escaped discriminant in the function. + -- Note on the formal types used (atyp and btyp). If either of the arrays + -- is of a private type, we use the underlying type, and do an unchecked + -- conversion of the actual. If either of the arrays has a bound depending + -- on a discriminant, then we use the base type since otherwise we have an + -- escaped discriminant in the function. - -- If both arrays are constrained and have the same bounds, we can - -- generate a loop with an explicit iteration scheme using a 'Range - -- attribute over the first array. + -- If both arrays are constrained and have the same bounds, we can generate + -- a loop with an explicit iteration scheme using a 'Range attribute over + -- the first array. function Expand_Array_Equality (Nod : Node_Id; @@ -1361,12 +1356,12 @@ package body Exp_Ch4 is -- This builds the attribute reference Arr'Nam (Expr) function Component_Equality (Typ : Entity_Id) return Node_Id; - -- Create one statement to compare corresponding components, - -- designated by a full set of indices. + -- Create one statement to compare corresponding components, designated + -- by a full set of indices. function Get_Arg_Type (N : Node_Id) return Entity_Id; - -- Given one of the arguments, computes the appropriate type to - -- be used for that argument in the corresponding function formal + -- Given one of the arguments, computes the appropriate type to be used + -- for that argument in the corresponding function formal function Handle_One_Dimension (N : Int; @@ -1392,13 +1387,13 @@ package body Exp_Ch4 is -- end loop -- -- N is the dimension for which we are generating a loop. Index is the - -- N'th index node, whose Etype is Index_Type_n in the above code. - -- The xxx statement is either the loop or declare for the next - -- dimension or if this is the last dimension the comparison - -- of corresponding components of the arrays. + -- N'th index node, whose Etype is Index_Type_n in the above code. The + -- xxx statement is either the loop or declare for the next dimension + -- or if this is the last dimension the comparison of corresponding + -- components of the arrays. -- - -- The actual way the code works is to return the comparison - -- of corresponding components for the N+1 call. That's neater! + -- The actual way the code works is to return the comparison of + -- corresponding components for the N+1 call. That's neater! function Test_Empty_Arrays return Node_Id; -- This function constructs the test for both arrays being empty @@ -1407,8 +1402,8 @@ package body Exp_Ch4 is -- (B'length (1) = 0 or else B'length (2) = 0 or else ...) function Test_Lengths_Correspond return Node_Id; - -- This function constructs the test for arrays having different - -- lengths in at least one index position, in which case resull + -- This function constructs the test for arrays having different lengths + -- in at least one index position, in which case the resulting code is: -- A'length (1) /= B'length (1) -- or else @@ -1463,8 +1458,8 @@ package body Exp_Ch4 is if Nkind (Test) = N_Raise_Program_Error then -- This node is going to be inserted at a location where a - -- statement is expected: clear its Etype so analysis will - -- set it to the expected Standard_Void_Type. + -- statement is expected: clear its Etype so analysis will set + -- it to the expected Standard_Void_Type. Set_Etype (Test, Empty); return Test; @@ -1525,8 +1520,8 @@ package body Exp_Ch4 is Ltyp /= Rtyp or else not Is_Constrained (Ltyp); -- If the index types are identical, and we are working with - -- constrained types, then we can use the same index for both of - -- the arrays. + -- constrained types, then we can use the same index for both + -- of the arrays. An : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('A')); @@ -1714,9 +1709,9 @@ package body Exp_Ch4 is Ltyp := Get_Arg_Type (Lhs); Rtyp := Get_Arg_Type (Rhs); - -- For now, if the argument types are not the same, go to the - -- base type, since the code assumes that the formals have the - -- same type. This is fixable in future ??? + -- For now, if the argument types are not the same, go to the base type, + -- since the code assumes that the formals have the same type. This is + -- fixable in future ??? if Ltyp /= Rtyp then Ltyp := Base_Type (Ltyp); @@ -1775,9 +1770,9 @@ package body Exp_Ch4 is Set_Has_Completion (Func_Name, True); Set_Is_Inlined (Func_Name); - -- If the array type is distinct from the type of the arguments, - -- it is the full view of a private type. Apply an unchecked - -- conversion to insure that analysis of the call succeeds. + -- If the array type is distinct from the type of the arguments, it + -- is the full view of a private type. Apply an unchecked conversion + -- to insure that analysis of the call succeeds. declare L, R : Node_Id; @@ -1813,16 +1808,16 @@ package body Exp_Ch4 is -- Expand_Boolean_Operator -- ----------------------------- - -- Note that we first get the actual subtypes of the operands, - -- since we always want to deal with types that have bounds. + -- Note that we first get the actual subtypes of the operands, since we + -- always want to deal with types that have bounds. procedure Expand_Boolean_Operator (N : Node_Id) is Typ : constant Entity_Id := Etype (N); begin - -- Special case of bit packed array where both operands are known - -- to be properly aligned. In this case we use an efficient run time - -- routine to carry out the operation (see System.Bit_Ops). + -- Special case of bit packed array where both operands are known to be + -- properly aligned. In this case we use an efficient run time routine + -- to carry out the operation (see System.Bit_Ops). if Is_Bit_Packed_Array (Typ) and then not Is_Possibly_Unaligned_Object (Left_Opnd (N)) @@ -1916,8 +1911,8 @@ package body Exp_Ch4 is Full_Type := Typ; end if; - -- Defense against malformed private types with no completion - -- the error will be diagnosed later by check_completion + -- Defense against malformed private types with no completion the error + -- will be diagnosed later by check_completion if No (Full_Type) then return New_Reference_To (Standard_False, Loc); @@ -1937,11 +1932,11 @@ package body Exp_Ch4 is then return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); - -- For composite component types, and floating-point types, use - -- the expansion. This deals with tagged component types (where - -- we use the applicable equality routine) and floating-point, - -- (where we need to worry about negative zeroes), and also the - -- case of any composite type recursively containing such fields. + -- For composite component types, and floating-point types, use the + -- expansion. This deals with tagged component types (where we use + -- the applicable equality routine) and floating-point, (where we + -- need to worry about negative zeroes), and also the case of any + -- composite type recursively containing such fields. else return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type); @@ -1955,11 +1950,10 @@ package body Exp_Ch4 is Full_Type := Root_Type (Full_Type); end if; - -- If this is derived from an untagged private type completed - -- with a tagged type, it does not have a full view, so we - -- use the primitive operations of the private type. - -- This check should no longer be necessary when these - -- types receive their full views ??? + -- If this is derived from an untagged private type completed with a + -- tagged type, it does not have a full view, so we use the primitive + -- operations of the private type. This check should no longer be + -- necessary when these types receive their full views ??? if Is_Private_Type (Typ) and then not Is_Tagged_Type (Typ) @@ -1998,8 +1992,8 @@ package body Exp_Ch4 is if Present (Eq_Op) then if Etype (First_Formal (Eq_Op)) /= Full_Type then - -- Inherited equality from parent type. Convert the actuals - -- to match signature of operation. + -- Inherited equality from parent type. Convert the actuals to + -- match signature of operation. declare T : constant Entity_Id := Etype (First_Formal (Eq_Op)); @@ -2040,7 +2034,7 @@ package body Exp_Ch4 is if Is_Constrained (Lhs_Type) then - -- Since the enclosing record can never be an + -- Since the enclosing record type can never be an -- Unchecked_Union (this code is executed for records -- that do not have variants), we may reference its -- discriminant(s). @@ -2121,8 +2115,8 @@ package body Exp_Ch4 is end; end if; - -- Shouldn't this be an else, we can't fall through - -- the above IF, right??? + -- Shouldn't this be an else, we can't fall through the above + -- IF, right??? return Make_Function_Call (Loc, @@ -2145,10 +2139,10 @@ package body Exp_Ch4 is -- Expand_Concatenate_Other -- ------------------------------ - -- Let n be the number of array operands to be concatenated, Base_Typ - -- their base type, Ind_Typ their index type, and Arr_Typ the original - -- array type to which the concatenation operator applies, then the - -- following subprogram is constructed: + -- Let n be the number of array operands to be concatenated, Base_Typ their + -- base type, Ind_Typ their index type, and Arr_Typ the original array type + -- to which the concatenation operator applies, then the following + -- subprogram is constructed: -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is -- L : Ind_Typ; @@ -2425,9 +2419,9 @@ package body Exp_Ch4 is Target_Type : Entity_Id; begin - -- If the index type is an enumeration type, the computation - -- can be done in standard integer. Otherwise, choose a large - -- enough integer type. + -- If the index type is an enumeration type, the computation can be + -- done in standard integer. Otherwise, choose a large enough integer + -- type to accomodate the index type computation. if Is_Enumeration_Type (Ind_Typ) or else Root_Type (Ind_Typ) = Standard_Integer @@ -2937,12 +2931,12 @@ package body Exp_Ch4 is -- typ! (coext.all) if Nkind (Coext) = N_Identifier then - Ref := Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => - New_Reference_To (Etype (Coext), Loc), - Expression => - Make_Explicit_Dereference (Loc, - New_Copy_Tree (Coext))); + Ref := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (Etype (Coext), Loc), + Expression => + Make_Explicit_Dereference (Loc, + Prefix => New_Copy_Tree (Coext))); else Ref := New_Copy_Tree (Coext); end if; @@ -3056,9 +3050,9 @@ package body Exp_Ch4 is end if; end if; - -- Under certain circumstances we can replace an allocator by an - -- access to statically allocated storage. The conditions, as noted - -- in AARM 3.10 (10c) are as follows: + -- Under certain circumstances we can replace an allocator by an access + -- to statically allocated storage. The conditions, as noted in AARM + -- 3.10 (10c) are as follows: -- Size and initial value is known at compile time -- Access type is access-to-constant @@ -3083,8 +3077,8 @@ package body Exp_Ch4 is -- Tnn : aliased x := y; - -- and replace the allocator by Tnn'Unrestricted_Access. - -- Tnn is marked as requiring static allocation. + -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is + -- marked as requiring static allocation. Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); @@ -3114,8 +3108,8 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, PtrT); - -- We set the variable as statically allocated, since we don't - -- want it going on the stack of the current procedure! + -- We set the variable as statically allocated, since we don't want + -- it going on the stack of the current procedure! Set_Is_Statically_Allocated (Temp); return; @@ -3147,9 +3141,8 @@ package body Exp_Ch4 is -- If the allocator is for a type which requires initialization, and -- there is no initial value (i.e. operand is a subtype indication - -- rather than a qualified expression), then we must generate a call - -- to the initialization routine. This is done using an expression - -- actions node: + -- rather than a qualified expression), then we must generate a call to + -- the initialization routine using an expressions action node: -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn] @@ -3364,10 +3357,10 @@ package body Exp_Ch4 is if Dis then -- If the allocated object will be constrained by the - -- default values for discriminants, then build a - -- subtype with those defaults, and change the allocated - -- subtype to that. Note that this happens in fewer - -- cases in Ada 2005 (AI-363). + -- default values for discriminants, then build a subtype + -- with those defaults, and change the allocated subtype + -- to that. Note that this happens in fewer cases in Ada + -- 2005 (AI-363). if not Is_Constrained (Typ) and then Present (Discriminant_Default_Value @@ -3600,15 +3593,15 @@ package body Exp_Ch4 is if Nkind (Right) = N_Identifier then - -- Change (Left and then True) to Left. Note that we know there - -- are no actions associated with the True operand, since we - -- just checked for this case above. + -- Change (Left and then True) to Left. Note that we know there are + -- no actions associated with the True operand, since we just checked + -- for this case above. if Entity (Right) = Standard_True then Rewrite (N, Left); - -- Change (Left and then False) to False, making sure to preserve - -- any side effects associated with the Left operand. + -- Change (Left and then False) to False, making sure to preserve any + -- side effects associated with the Left operand. elsif Entity (Right) = Standard_False then Remove_Side_Effects (Left); @@ -3851,8 +3844,8 @@ package body Exp_Ch4 is return; - -- If both checks are known to succeed, replace result - -- by True, since we know we are in range. + -- If both checks are known to succeed, replace result by True, + -- since we know we are in range. elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then if Warn1 then @@ -3989,9 +3982,9 @@ package body Exp_Ch4 is New_Reference_To (Standard_True, Loc)); Analyze_And_Resolve (N, Rtyp); - -- For the constrained array case, we have to check the - -- subscripts for an exact match if the lengths are - -- non-zero (the lengths must match in any case). + -- For the constrained array case, we have to check the subscripts + -- for an exact match if the lengths are non-zero (the lengths + -- must match in any case). elsif Is_Array_Type (Typ) then @@ -4059,13 +4052,13 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, Rtyp); end Check_Subscripts; - -- These are the cases where constraint checks may be - -- required, e.g. records with possible discriminants + -- These are the cases where constraint checks may be required, + -- e.g. records with possible discriminants else -- Expand the test into a series of discriminant comparisons. - -- The expression that is built is the negation of the one - -- that is used for checking discriminant constraints. + -- The expression that is built is the negation of the one that + -- is used for checking discriminant constraints. Obj := Relocate_Node (Left_Opnd (N)); @@ -4104,18 +4097,18 @@ package body Exp_Ch4 is T : constant Entity_Id := Etype (P); begin - -- A special optimization, if we have an indexed component that - -- is selecting from a slice, then we can eliminate the slice, - -- since, for example, x (i .. j)(k) is identical to x(k). The - -- only difference is the range check required by the slice. The - -- range check for the slice itself has already been generated. - -- The range check for the subscripting operation is ensured - -- by converting the subject to the subtype of the slice. - - -- This optimization not only generates better code, avoiding - -- slice messing especially in the packed case, but more importantly - -- bypasses some problems in handling this peculiar case, for - -- example, the issue of dealing specially with object renamings. + -- A special optimization, if we have an indexed component that is + -- selecting from a slice, then we can eliminate the slice, since, for + -- example, x (i .. j)(k) is identical to x(k). The only difference is + -- the range check required by the slice. The range check for the slice + -- itself has already been generated. The range check for the + -- subscripting operation is ensured by converting the subject to + -- the subtype of the slice. + + -- This optimization not only generates better code, avoiding slice + -- messing especially in the packed case, but more importantly bypasses + -- some problems in handling this peculiar case, for example, the issue + -- of dealing specially with object renamings. if Nkind (P) = N_Slice then Rewrite (N, @@ -4138,11 +4131,11 @@ package body Exp_Ch4 is Make_Build_In_Place_Call_In_Anonymous_Context (P); end if; - -- If the prefix is an access type, then we unconditionally rewrite - -- if as an explicit deference. This simplifies processing for several - -- cases, including packed array cases and certain cases in which - -- checks must be generated. We used to try to do this only when it - -- was necessary, but it cleans up the code to do it all the time. + -- If the prefix is an access type, then we unconditionally rewrite if + -- as an explicit deference. This simplifies processing for several + -- cases, including packed array cases and certain cases in which checks + -- must be generated. We used to try to do this only when it was + -- necessary, but it cleans up the code to do it all the time. if Is_Access_Type (T) then Insert_Explicit_Dereference (P); @@ -4176,8 +4169,8 @@ package body Exp_Ch4 is -- convert it to a reference to the corresponding Packed_Array_Type. -- We only want to do this for simple references, and not for: - -- Left side of assignment, or prefix of left side of assignment, - -- or prefix of the prefix, to handle packed arrays of packed arrays, + -- Left side of assignment, or prefix of left side of assignment, or + -- prefix of the prefix, to handle packed arrays of packed arrays, -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement -- Renaming objects in renaming associations @@ -4222,8 +4215,8 @@ package body Exp_Ch4 is then return; - -- If the expression is an index of an indexed component, - -- it must be expanded regardless of context. + -- If the expression is an index of an indexed component, it must + -- be expanded regardless of context. elsif Nkind (Parnt) = N_Indexed_Component and then Child /= Prefix (Parnt) @@ -4252,8 +4245,8 @@ package body Exp_Ch4 is return; end if; - -- Keep looking up tree for unchecked expression, or if we are - -- the prefix of a possible assignment left side. + -- Keep looking up tree for unchecked expression, or if we are the + -- prefix of a possible assignment left side. Child := Parnt; Parnt := Parent (Child); @@ -4296,11 +4289,11 @@ package body Exp_Ch4 is -- Expand_N_Null -- ------------------- - -- The only replacement required is for the case of a null of type - -- that is an access to protected subprogram. We represent such - -- access values as a record, and so we must replace the occurrence - -- of null by the equivalent record (with a null address and a null - -- pointer in it), so that the backend creates the proper value. + -- The only replacement required is for the case of a null of type that is + -- an access to protected subprogram. We represent such access values as a + -- record, and so we must replace the occurrence of null by the equivalent + -- record (with a null address and a null pointer in it), so that the + -- backend creates the proper value. procedure Expand_N_Null (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -4318,9 +4311,9 @@ package body Exp_Ch4 is Rewrite (N, Agg); Analyze_And_Resolve (N, Equivalent_Type (Typ)); - -- For subsequent semantic analysis, the node must retain its - -- type. Gigi in any case replaces this type by the corresponding - -- record type before processing the node. + -- For subsequent semantic analysis, the node must retain its type. + -- Gigi in any case replaces this type by the corresponding record + -- type before processing the node. Set_Etype (N, Typ); end if; @@ -4347,9 +4340,8 @@ package body Exp_Ch4 is and then Is_Signed_Integer_Type (Etype (N)) and then Do_Overflow_Check (N) then - -- The only case to worry about is when the argument is - -- equal to the largest negative number, so what we do is - -- to insert the check: + -- The only case to worry about is when the argument is equal to the + -- largest negative number, so what we do is to insert the check: -- [constraint_error when Expr = typ'Base'First] @@ -4465,8 +4457,8 @@ package body Exp_Ch4 is -- Single operand for concatenation Cnode : Node_Id; - -- Node which is to be replaced by the result of concatenating - -- the nodes in the list Opnds. + -- Node which is to be replaced by the result of concatenating the nodes + -- in the list Opnds. Atyp : Entity_Id; -- Array type of concatenation result type @@ -4510,9 +4502,9 @@ package body Exp_Ch4 is Binary_Op_Validity_Checks (N); - -- If we are the left operand of a concatenation higher up the - -- tree, then do nothing for now, since we want to deal with a - -- series of concatenations as a unit. + -- If we are the left operand of a concatenation higher up the tree, + -- then do nothing for now, since we want to deal with a series of + -- concatenations as a unit. if Nkind (Parent (N)) = N_Op_Concat and then N = Left_Opnd (Parent (N)) @@ -4564,10 +4556,10 @@ package body Exp_Ch4 is Append (Right_Opnd (Cnode), Opnds); end loop Inner; - -- Here we process the collected operands. First we convert - -- singleton operands to singleton aggregates. This is skipped - -- however for the case of two operands of type String, since - -- we have special routines for these cases. + -- Here we process the collected operands. First we convert singleton + -- operands to singleton aggregates. This is skipped however for the + -- case of two operands of type String since we have special routines + -- for these cases. Atyp := Base_Type (Etype (Cnode)); Ctyp := Base_Type (Component_Type (Etype (Cnode))); @@ -4668,9 +4660,9 @@ package body Exp_Ch4 is if Is_Fixed_Point_Type (Typ) then - -- No special processing if Treat_Fixed_As_Integer is set, - -- since from a semantic point of view such operations are - -- simply integer operations and will be treated that way. + -- No special processing if Treat_Fixed_As_Integer is set, since + -- from a semantic point of view such operations are simply integer + -- operations and will be treated that way. if not Treat_Fixed_As_Integer (N) then if Is_Integer_Type (Rtyp) then @@ -4680,8 +4672,8 @@ package body Exp_Ch4 is end if; end if; - -- Other cases of division of fixed-point operands. Again we - -- exclude the case where Treat_Fixed_As_Integer is set. + -- Other cases of division of fixed-point operands. Again we exclude the + -- case where Treat_Fixed_As_Integer is set. elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp)) @@ -4694,9 +4686,8 @@ package body Exp_Ch4 is Expand_Divide_Fixed_By_Fixed_Giving_Float (N); end if; - -- Mixed-mode operations can appear in a non-static universal - -- context, in which case the integer argument must be converted - -- explicitly. + -- Mixed-mode operations can appear in a non-static universal context, + -- in which case the integer argument must be converted explicitly. elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) @@ -5178,9 +5169,9 @@ package body Exp_Ch4 is then null; - -- For composite and floating-point cases, expand equality loop - -- to make sure of using proper comparisons for tagged types, - -- and correctly handling the floating-point case. + -- For composite and floating-point cases, expand equality loop to + -- make sure of using proper comparisons for tagged types, and + -- correctly handling the floating-point case. else Rewrite (N, @@ -5210,20 +5201,19 @@ package body Exp_Ch4 is return; end if; - -- If this is derived from an untagged private type completed - -- with a tagged type, it does not have a full view, so we - -- use the primitive operations of the private type. - -- This check should no longer be necessary when these - -- types receive their full views ??? + -- If this is derived from an untagged private type completed with + -- a tagged type, it does not have a full view, so we use the + -- primitive operations of the private type. This check should no + -- longer be necessary when these types get their full views??? if Is_Private_Type (A_Typ) and then not Is_Tagged_Type (A_Typ) and then Is_Derived_Type (A_Typ) and then No (Full_View (A_Typ)) then - -- Search for equality operation, checking that the - -- operands have the same type. Note that we must find - -- a matching entry, or something is very wrong! + -- Search for equality operation, checking that the operands + -- have the same type. Note that we must find a matching entry, + -- or something is very wrong! Prim := First_Elmt (Collect_Primitive_Operations (A_Typ)); @@ -5241,11 +5231,11 @@ package body Exp_Ch4 is Op_Name := Node (Prim); -- Find the type's predefined equality or an overriding - -- user-defined equality. The reason for not simply calling + -- user- defined equality. The reason for not simply calling -- Find_Prim_Op here is that there may be a user-defined - -- overloaded equality op that precedes the equality that - -- we want, so we have to explicitly search (e.g., there - -- could be an equality with two different parameter types). + -- overloaded equality op that precedes the equality that we want, + -- so we have to explicitly search (e.g., there could be an + -- equality with two different parameter types). else if Is_Class_Wide_Type (Typl) then @@ -5370,12 +5360,12 @@ package body Exp_Ch4 is begin Binary_Op_Validity_Checks (N); - -- If either operand is of a private type, then we have the use of - -- an intrinsic operator, and we get rid of the privateness, by using - -- root types of underlying types for the actual operation. Otherwise - -- the private types will cause trouble if we expand multiplications - -- or shifts etc. We also do this transformation if the result type - -- is different from the base type. + -- If either operand is of a private type, then we have the use of an + -- intrinsic operator, and we get rid of the privateness, by using root + -- types of underlying types for the actual operation. Otherwise the + -- private types will cause trouble if we expand multiplications or + -- shifts etc. We also do this transformation if the result type is + -- different from the base type. if Is_Private_Type (Etype (Base)) or else @@ -5483,6 +5473,10 @@ package body Exp_Ch4 is -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion -- of the higher level node converts it into a shift. + -- Note: this transformation is not applicable for a modular type with + -- a non-binary modulus in the multiplication case, since we get a wrong + -- result if the shift causes an overflow before the modular reduction. + if Nkind (Base) = N_Integer_Literal and then Intval (Base) = 2 and then Is_Integer_Type (Root_Type (Exptyp)) @@ -5498,6 +5492,7 @@ package body Exp_Ch4 is begin if (Nkind (P) = N_Op_Multiply + and then not Non_Binary_Modulus (Typ) and then ((Is_Integer_Type (Etype (L)) and then R = N) or else @@ -5538,9 +5533,9 @@ package body Exp_Ch4 is Make_Integer_Literal (Loc, Modulus (Rtyp)), Exp)))); - -- Binary case, in this case, we call one of two routines, either - -- the unsigned integer case, or the unsigned long long integer - -- case, with a final "and" operation to do the required mod. + -- Binary case, in this case, we call one of two routines, either the + -- unsigned integer case, or the unsigned long long integer case, + -- with a final "and" operation to do the required mod. else if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then @@ -5859,9 +5854,9 @@ package body Exp_Ch4 is Left_Opnd => Left_Opnd (N), Right_Opnd => Right_Opnd (N))); - -- Instead of reanalyzing the node we do the analysis manually. - -- This avoids anomalies when the replacement is done in an - -- instance and is epsilon more efficient. + -- Instead of reanalyzing the node we do the analysis manually. This + -- avoids anomalies when the replacement is done in an instance and + -- is epsilon more efficient. Set_Entity (N, Standard_Entity (S_Op_Rem)); Set_Etype (N, Typ); @@ -5894,13 +5889,13 @@ package body Exp_Ch4 is -- minus one. Gigi does not handle this case correctly, because -- it generates a divide instruction which may trap in this case. - -- In fact the check is quite easy, if the right operand is -1, - -- then the mod value is always 0, and we can just ignore the - -- left operand completely in this case. + -- In fact the check is quite easy, if the right operand is -1, then + -- the mod value is always 0, and we can just ignore the left operand + -- completely in this case. - -- The operand type may be private (e.g. in the expansion of an - -- an intrinsic operation) so we must use the underlying type to - -- get the bounds, and convert the literals explicitly. + -- The operand type may be private (e.g. in the expansion of an an + -- intrinsic operation) so we must use the underlying type to get the + -- bounds, and convert the literals explicitly. LLB := Expr_Value @@ -6042,9 +6037,9 @@ package body Exp_Ch4 is if Is_Fixed_Point_Type (Typ) then - -- No special processing if Treat_Fixed_As_Integer is set, - -- since from a semantic point of view such operations are - -- simply integer operations and will be treated that way. + -- No special processing if Treat_Fixed_As_Integer is set, since from + -- a semantic point of view such operations are simply integer + -- operations and will be treated that way. if not Treat_Fixed_As_Integer (N) then @@ -6065,8 +6060,8 @@ package body Exp_Ch4 is end if; end if; - -- Other cases of multiplication of fixed-point operands. Again - -- we exclude the cases where Treat_Fixed_As_Integer flag is set. + -- Other cases of multiplication of fixed-point operands. Again we + -- exclude the cases where Treat_Fixed_As_Integer flag is set. elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp)) and then not Treat_Fixed_As_Integer (N) @@ -6078,9 +6073,8 @@ package body Exp_Ch4 is Expand_Multiply_Fixed_By_Fixed_Giving_Float (N); end if; - -- Mixed-mode operations can appear in a non-static universal - -- context, in which case the integer argument must be converted - -- explicitly. + -- Mixed-mode operations can appear in a non-static universal context, + -- in which case the integer argument must be converted explicitly. elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) @@ -6187,18 +6181,18 @@ package body Exp_Ch4 is -- Expand_N_Op_Not -- --------------------- - -- If the argument is other than a Boolean array type, there is no - -- special expansion required. + -- If the argument is other than a Boolean array type, there is no special + -- expansion required. -- For the packed case, we call the special routine in Exp_Pakd, except -- that if the component size is greater than one, we use the standard -- routine generating a gruesome loop (it is so peculiar to have packed - -- arrays with non-standard Boolean representations anyway, so it does - -- not matter that we do not handle this case efficiently). + -- arrays with non-standard Boolean representations anyway, so it does not + -- matter that we do not handle this case efficiently). - -- For the unpacked case (and for the special packed case where we have - -- non standard Booleans, as discussed above), we generate and insert - -- into the tree the following function definition: + -- For the unpacked case (and for the special packed case where we have non + -- standard Booleans, as discussed above), we generate and insert into the + -- tree the following function definition: -- function Nnnn (A : arr) is -- B : arr; @@ -6435,9 +6429,9 @@ package body Exp_Ch4 is Apply_Divide_Check (N); end if; - -- Apply optimization x rem 1 = 0. We don't really need that with - -- gcc, but it is useful with other back ends (e.g. AAMP), and is - -- certainly harmless. + -- Apply optimization x rem 1 = 0. We don't really need that with gcc, + -- but it is useful with other back ends (e.g. AAMP), and is certainly + -- harmless. if Is_Integer_Type (Etype (N)) and then Compile_Time_Known_Value (Right) @@ -6448,20 +6442,20 @@ package body Exp_Ch4 is return; end if; - -- Deal with annoying case of largest negative number remainder - -- minus one. Gigi does not handle this case correctly, because - -- it generates a divide instruction which may trap in this case. + -- Deal with annoying case of largest negative number remainder minus + -- one. Gigi does not handle this case correctly, because it generates + -- a divide instruction which may trap in this case. - -- In fact the check is quite easy, if the right operand is -1, - -- then the remainder is always 0, and we can just ignore the - -- left operand completely in this case. + -- In fact the check is quite easy, if the right operand is -1, then + -- the remainder is always 0, and we can just ignore the left operand + -- completely in this case. Determine_Range (Right, ROK, Rlo, Rhi); Determine_Range (Left, LOK, Llo, Lhi); - -- The operand type may be private (e.g. in the expansion of an - -- an intrinsic operation) so we must use the underlying type to - -- get the bounds, and convert the literals explicitly. + -- The operand type may be private (e.g. in the expansion of an an + -- intrinsic operation) so we must use the underlying type to get the + -- bounds, and convert the literals explicitly. LLB := Expr_Value @@ -6632,9 +6626,9 @@ package body Exp_Ch4 is Adjust_Result_Type (N, Typ); return; - -- If left argument is True, change (True and then Right) to - -- True. In this case we can forget the actions associated with - -- Right, since they will never be executed. + -- If left argument is True, change (True and then Right) to True. In + -- this case we can forget the actions associated with Right, since + -- they will never be executed. elsif Entity (Left) = Standard_True then Kill_Dead_Code (Right); @@ -6676,15 +6670,15 @@ package body Exp_Ch4 is if Nkind (Right) = N_Identifier then - -- Change (Left or else False) to Left. Note that we know there - -- are no actions associated with the True operand, since we - -- just checked for this case above. + -- Change (Left or else False) to Left. Note that we know there are + -- no actions associated with the True operand, since we just checked + -- for this case above. if Entity (Right) = Standard_False then Rewrite (N, Left); - -- Change (Left or else True) to True, making sure to preserve - -- any side effects associated with the Left operand. + -- Change (Left or else True) to True, making sure to preserve any + -- side effects associated with the Left operand. elsif Entity (Right) = Standard_True then Remove_Side_Effects (Left); @@ -6774,8 +6768,8 @@ package body Exp_Ch4 is if Do_Discriminant_Check (N) then - -- Present the discriminant checking function to the backend, - -- so that it can inline the call to the function. + -- Present the discriminant checking function to the backend, so that + -- it can inline the call to the function. Add_Inlined_Body (Discriminant_Checking_Func @@ -6837,9 +6831,9 @@ package body Exp_Ch4 is then null; - -- Don't do this optimization for the prefix of an attribute - -- or the operand of an object renaming declaration since these - -- are contexts where we do not want the value anyway. + -- Don't do this optimization for the prefix of an attribute or + -- the operand of an object renaming declaration since these are + -- contexts where we do not want the value anyway. elsif (Nkind (Par) = N_Attribute_Reference and then Prefix (Par) = N) @@ -6855,12 +6849,12 @@ package body Exp_Ch4 is null; -- Green light to see if we can do the optimization. There is - -- still one condition that inhibits the optimization below - -- but now is the time to check the particular discriminant. + -- still one condition that inhibits the optimization below but + -- now is the time to check the particular discriminant. else - -- Loop through discriminants to find the matching - -- discriminant constraint to see if we can copy it. + -- Loop through discriminants to find the matching discriminant + -- constraint to see if we can copy it. Disc := First_Discriminant (Ptyp); Dcon := First_Elmt (Discriminant_Constraint (Ptyp)); @@ -6881,10 +6875,10 @@ package body Exp_Ch4 is then exit Discr_Loop; - -- In the context of a case statement, the expression - -- may have the base type of the discriminant, and we - -- need to preserve the constraint to avoid spurious - -- errors on missing cases. + -- In the context of a case statement, the expression may + -- have the base type of the discriminant, and we need to + -- preserve the constraint to avoid spurious errors on + -- missing cases. elsif Nkind (Parent (N)) = N_Case_Statement and then Etype (Node (Dcon)) /= Etype (Disc) @@ -6924,8 +6918,8 @@ package body Exp_Ch4 is -- Note: the above loop should always find a matching -- discriminant, but if it does not, we just missed an - -- optimization due to some glitch (perhaps a previous - -- error), so ignore. + -- optimization due to some glitch (perhaps a previous error), + -- so ignore. end if; end if; @@ -6971,21 +6965,21 @@ package body Exp_Ch4 is Ptp : Entity_Id := Etype (Pfx); function Is_Procedure_Actual (N : Node_Id) return Boolean; - -- Check whether the argument is an actual for a procedure call, - -- in which case the expansion of a bit-packed slice is deferred - -- until the call itself is expanded. The reason this is required - -- is that we might have an IN OUT or OUT parameter, and the copy out - -- is essential, and that copy out would be missed if we created a - -- temporary here in Expand_N_Slice. Note that we don't bother - -- to test specifically for an IN OUT or OUT mode parameter, since it - -- is a bit tricky to do, and it is harmless to defer expansion - -- in the IN case, since the call processing will still generate the - -- appropriate copy in operation, which will take care of the slice. + -- Check whether the argument is an actual for a procedure call, in + -- which case the expansion of a bit-packed slice is deferred until the + -- call itself is expanded. The reason this is required is that we might + -- have an IN OUT or OUT parameter, and the copy out is essential, and + -- that copy out would be missed if we created a temporary here in + -- Expand_N_Slice. Note that we don't bother to test specifically for an + -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it + -- is harmless to defer expansion in the IN case, since the call + -- processing will still generate the appropriate copy in operation, + -- which will take care of the slice. procedure Make_Temporary; - -- Create a named variable for the value of the slice, in - -- cases where the back-end cannot handle it properly, e.g. - -- when packed types or unaligned slices are involved. + -- Create a named variable for the value of the slice, in cases where + -- the back-end cannot handle it properly, e.g. when packed types or + -- unaligned slices are involved. ------------------------- -- Is_Procedure_Actual -- @@ -7001,11 +6995,11 @@ package body Exp_Ch4 is if Nkind (Par) = N_Procedure_Call_Statement then return True; - -- If our parent is a type conversion, keep climbing the - -- tree, since a type conversion can be a procedure actual. - -- Also keep climbing if parameter association or a qualified - -- expression, since these are additional cases that do can - -- appear on procedure actuals. + -- If our parent is a type conversion, keep climbing the tree, + -- since a type conversion can be a procedure actual. Also keep + -- climbing if parameter association or a qualified expression, + -- since these are additional cases that do can appear on + -- procedure actuals. elsif Nkind_In (Par, N_Type_Conversion, N_Parameter_Association, @@ -7072,9 +7066,9 @@ package body Exp_Ch4 is Make_Build_In_Place_Call_In_Anonymous_Context (Pfx); end if; - -- Range checks are potentially also needed for cases involving - -- a slice indexed by a subtype indication, but Do_Range_Check - -- can currently only be set for expressions ??? + -- Range checks are potentially also needed for cases involving a slice + -- indexed by a subtype indication, but Do_Range_Check can currently + -- only be set for expressions ??? if not Index_Checks_Suppressed (Ptp) and then (not Is_Entity_Name (Pfx) @@ -7104,24 +7098,24 @@ package body Exp_Ch4 is -- 1. Right or left side of an assignment (we can handle this -- situation correctly in the assignment statement expansion). - -- 2. Prefix of indexed component (the slide is optimized away - -- in this case, see the start of Expand_N_Slice.) + -- 2. Prefix of indexed component (the slide is optimized away in this + -- case, see the start of Expand_N_Slice.) - -- 3. Object renaming declaration, since we want the name of - -- the slice, not the value. + -- 3. Object renaming declaration, since we want the name of the + -- slice, not the value. - -- 4. Argument to procedure call, since copy-in/copy-out handling - -- may be required, and this is handled in the expansion of - -- call itself. + -- 4. Argument to procedure call, since copy-in/copy-out handling may + -- be required, and this is handled in the expansion of call + -- itself. - -- 5. Prefix of an address attribute (this is an error which - -- is caught elsewhere, and the expansion would interfere - -- with generating the error message). + -- 5. Prefix of an address attribute (this is an error which is caught + -- elsewhere, and the expansion would interfere with generating the + -- error message). if not Is_Packed (Typ) then - -- Apply transformation for actuals of a function call, - -- where Expand_Actuals is not used. + -- Apply transformation for actuals of a function call, where + -- Expand_Actuals is not used. if Nkind (Parent (N)) = N_Function_Call and then Is_Possibly_Unaligned_Slice (N) @@ -7162,12 +7156,12 @@ package body Exp_Ch4 is Operand_Type : Entity_Id := Etype (Operand); procedure Handle_Changed_Representation; - -- This is called in the case of record and array type conversions - -- to see if there is a change of representation to be handled. - -- Change of representation is actually handled at the assignment - -- statement level, and what this procedure does is rewrite node N - -- conversion as an assignment to temporary. If there is no change - -- of representation, then the conversion node is unchanged. + -- This is called in the case of record and array type conversions to + -- see if there is a change of representation to be handled. Change of + -- representation is actually handled at the assignment statement level, + -- and what this procedure does is rewrite node N conversion as an + -- assignment to temporary. If there is no change of representation, + -- then the conversion node is unchanged. procedure Real_Range_Check; -- Handles generation of range check for real target value @@ -7205,8 +7199,8 @@ package body Exp_Ch4 is else Cons := No_List; - -- If type is unconstrained we have to add a constraint, - -- copied from the actual value of the left hand side. + -- If type is unconstrained we have to add a constraint, copied + -- from the actual value of the left hand side. if not Is_Constrained (Target_Type) then if Has_Discriminants (Operand_Type) then @@ -7302,9 +7296,8 @@ package body Exp_Ch4 is -- Real_Range_Check -- ---------------------- - -- Case of conversions to floating-point or fixed-point. If range - -- checks are enabled and the target type has a range constraint, - -- we convert: + -- Case of conversions to floating-point or fixed-point. If range checks + -- are enabled and the target type has a range constraint, we convert: -- typ (x) @@ -7314,10 +7307,10 @@ package body Exp_Ch4 is -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last] -- Tnn - -- This is necessary when there is a conversion of integer to float - -- or to fixed-point to ensure that the correct checks are made. It - -- is not necessary for float to float where it is enough to simply - -- set the Do_Range_Check flag. + -- This is necessary when there is a conversion of integer to float or + -- to fixed-point to ensure that the correct checks are made. It is not + -- necessary for float to float where it is enough to simply set the + -- Do_Range_Check flag. procedure Real_Range_Check is Btyp : constant Entity_Id := Base_Type (Target_Type); @@ -7334,8 +7327,8 @@ package body Exp_Ch4 is return; end if; - -- Nothing to do if range checks suppressed, or target has the - -- same range as the base type (or is the base type). + -- Nothing to do if range checks suppressed, or target has the same + -- range as the base type (or is the base type). if Range_Checks_Suppressed (Target_Type) or else (Lo = Type_Low_Bound (Btyp) @@ -7345,8 +7338,8 @@ package body Exp_Ch4 is return; end if; - -- Nothing to do if expression is an entity on which checks - -- have been suppressed. + -- Nothing to do if expression is an entity on which checks have been + -- suppressed. if Is_Entity_Name (Operand) and then Range_Checks_Suppressed (Entity (Operand)) @@ -7354,10 +7347,10 @@ package body Exp_Ch4 is return; end if; - -- Nothing to do if bounds are all static and we can tell that - -- the expression is within the bounds of the target. Note that - -- if the operand is of an unconstrained floating-point type, - -- then we do not trust it to be in range (might be infinite) + -- Nothing to do if bounds are all static and we can tell that the + -- expression is within the bounds of the target. Note that if the + -- operand is of an unconstrained floating-point type, then we do + -- not trust it to be in range (might be infinite) declare S_Lo : constant Node_Id := Type_Low_Bound (Xtyp); @@ -7460,17 +7453,17 @@ package body Exp_Ch4 is -- Start of processing for Expand_N_Type_Conversion begin - -- Nothing at all to do if conversion is to the identical type - -- so remove the conversion completely, it is useless. + -- Nothing at all to do if conversion is to the identical type so remove + -- the conversion completely, it is useless. if Operand_Type = Target_Type then Rewrite (N, Relocate_Node (Operand)); return; end if; - -- Nothing to do if this is the second argument of read. This - -- is a "backwards" conversion that will be handled by the - -- specialized code in attribute processing. + -- Nothing to do if this is the second argument of read. This is a + -- "backwards" conversion that will be handled by the specialized code + -- in attribute processing. if Nkind (Parent (N)) = N_Attribute_Reference and then Attribute_Name (Parent (N)) = Name_Read @@ -7523,13 +7516,12 @@ package body Exp_Ch4 is then Apply_Accessibility_Check (Operand, Target_Type); - -- If the level of the operand type is statically deeper - -- then the level of the target type, then force Program_Error. - -- Note that this can only occur for cases where the attribute - -- is within the body of an instantiation (otherwise the - -- conversion will already have been rejected as illegal). - -- Note: warnings are issued by the analyzer for the instance - -- cases. + -- If the level of the operand type is statically deeper then the + -- level of the target type, then force Program_Error. Note that this + -- can only occur for cases where the attribute is within the body of + -- an instantiation (otherwise the conversion will already have been + -- rejected as illegal). Note: warnings are issued by the analyzer + -- for the instance cases. elsif In_Instance_Body and then Type_Access_Level (Operand_Type) > @@ -7540,12 +7532,11 @@ package body Exp_Ch4 is Reason => PE_Accessibility_Check_Failed)); Set_Etype (N, Target_Type); - -- When the operand is a selected access discriminant - -- the check needs to be made against the level of the - -- object denoted by the prefix of the selected name. - -- Force Program_Error for this case as well (this - -- accessibility violation can only happen if within - -- the body of an instantiation). + -- When the operand is a selected access discriminant the check needs + -- to be made against the level of the object denoted by the prefix + -- of the selected name. Force Program_Error for this case as well + -- (this accessibility violation can only happen if within the body + -- of an instantiation). elsif In_Instance_Body and then Ekind (Operand_Type) = E_Anonymous_Access_Type @@ -7562,9 +7553,9 @@ package body Exp_Ch4 is -- Case of conversions of tagged types and access to tagged types - -- When needed, that is to say when the expression is class-wide, - -- Add runtime a tag check for (strict) downward conversion by using - -- the membership test, generating: + -- When needed, that is to say when the expression is class-wide, Add + -- runtime a tag check for (strict) downward conversion by using the + -- membership test, generating: -- [constraint_error when Operand not in Target_Type'Class] @@ -7579,10 +7570,9 @@ package body Exp_Ch4 is and then Is_Tagged_Type (Designated_Type (Target_Type))) or else Is_Tagged_Type (Target_Type) then - -- Do not do any expansion in the access type case if the - -- parent is a renaming, since this is an error situation - -- which will be caught by Sem_Ch8, and the expansion can - -- interfere with this error check. + -- Do not do any expansion in the access type case if the parent is a + -- renaming, since this is an error situation which will be caught by + -- Sem_Ch8, and the expansion can interfere with this error check. if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) @@ -7622,8 +7612,7 @@ package body Exp_Ch4 is Actual_Target_Type) and then not Tag_Checks_Suppressed (Actual_Target_Type) then - -- The conversion is valid for any descendant of the - -- target type + -- Conversion is valid for any descendant of the target type Actual_Target_Type := Class_Wide_Type (Actual_Target_Type); @@ -7677,9 +7666,9 @@ package body Exp_Ch4 is -- Case of conversions from a fixed-point type - -- These conversions require special expansion and processing, found - -- in the Exp_Fixd package. We ignore cases where Conversion_OK is - -- set, since from a semantic point of view, these are simple integer + -- These conversions require special expansion and processing, found in + -- the Exp_Fixd package. We ignore cases where Conversion_OK is set, + -- since from a semantic point of view, these are simple integer -- conversions, which do not need further processing. elsif Is_Fixed_Point_Type (Operand_Type) @@ -7691,11 +7680,10 @@ package body Exp_Ch4 is pragma Assert (Operand_Type /= Universal_Fixed); - -- Check for special case of the conversion to universal real - -- that occurs as a result of the use of a round attribute. - -- In this case, the real type for the conversion is taken - -- from the target type of the Round attribute and the - -- result must be marked as rounded. + -- Check for special case of the conversion to universal real that + -- occurs as a result of the use of a round attribute. In this case, + -- the real type for the conversion is taken from the target type of + -- the Round attribute and the result must be marked as rounded. if Target_Type = Universal_Real and then Nkind (Parent (N)) = N_Attribute_Reference @@ -7727,10 +7715,10 @@ package body Exp_Ch4 is -- Case of conversions to a fixed-point type - -- These conversions require special expansion and processing, found - -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK - -- is set, since from a semantic point of view, these are simple - -- integer conversions, which do not need further processing. + -- These conversions require special expansion and processing, found in + -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set, + -- since from a semantic point of view, these are simple integer + -- conversions, which do not need further processing. elsif Is_Fixed_Point_Type (Target_Type) and then not Conversion_OK (N) @@ -7782,9 +7770,9 @@ package body Exp_Ch4 is -- Case of array conversions - -- Expansion of array conversions, add required length/range checks - -- but only do this if there is no change of representation. For - -- handling of this case, see Handle_Changed_Representation. + -- Expansion of array conversions, add required length/range checks but + -- only do this if there is no change of representation. For handling of + -- this case, see Handle_Changed_Representation. elsif Is_Array_Type (Target_Type) then @@ -7798,8 +7786,8 @@ package body Exp_Ch4 is -- Case of conversions of discriminated types - -- Add required discriminant checks if target is constrained. Again - -- this change is skipped if we have a change of representation. + -- Add required discriminant checks if target is constrained. Again this + -- change is skipped if we have a change of representation. elsif Has_Discriminants (Target_Type) and then Is_Constrained (Target_Type) @@ -7814,8 +7802,8 @@ package body Exp_Ch4 is elsif Is_Record_Type (Target_Type) then -- Ada 2005 (AI-216): Program_Error is raised when converting from - -- a derived Unchecked_Union type to an unconstrained non-Unchecked_ - -- Union type if the operand lacks inferable discriminants. + -- a derived Unchecked_Union type to an unconstrained type that is + -- not Unchecked_Union if the operand lacks inferable discriminants. if Is_Derived_Type (Operand_Type) and then Is_Unchecked_Union (Base_Type (Operand_Type)) @@ -7823,7 +7811,7 @@ package body Exp_Ch4 is and then not Is_Unchecked_Union (Base_Type (Target_Type)) and then not Has_Inferable_Discriminants (Operand) then - -- To prevent Gigi from generating illegal code, we make a + -- To prevent Gigi from generating illegal code, we generate a -- Program_Error node, but we give it the target type of the -- conversion. @@ -7870,25 +7858,24 @@ package body Exp_Ch4 is Real_Range_Check; end if; - -- At this stage, either the conversion node has been transformed - -- into some other equivalent expression, or left as a conversion - -- that can be handled by Gigi. The conversions that Gigi can handle - -- are the following: + -- At this stage, either the conversion node has been transformed into + -- some other equivalent expression, or left as a conversion that can + -- be handled by Gigi. The conversions that Gigi can handle are the + -- following: -- Conversions with no change of representation or type - -- Numeric conversions involving integer values, floating-point - -- values, and fixed-point values. Fixed-point values are allowed - -- only if Conversion_OK is set, i.e. if the fixed-point values - -- are to be treated as integers. + -- Numeric conversions involving integer, floating- and fixed-point + -- values. Fixed-point values are allowed only if Conversion_OK is + -- set, i.e. if the fixed-point values are to be treated as integers. -- No other conversions should be passed to Gigi -- Check: are these rules stated in sinfo??? if so, why restate here??? - -- The only remaining step is to generate a range check if we still - -- have a type conversion at this stage and Do_Range_Check is set. - -- For now we do this only for conversions of discrete types. + -- The only remaining step is to generate a range check if we still have + -- a type conversion at this stage and Do_Range_Check is set. For now we + -- do this only for conversions of discrete types. if Nkind (N) = N_Type_Conversion and then Is_Discrete_Type (Etype (N)) @@ -7904,9 +7891,9 @@ package body Exp_Ch4 is then Set_Do_Range_Check (Expr, False); - -- Before we do a range check, we have to deal with treating - -- a fixed-point operand as an integer. The way we do this - -- is simply to do an unchecked conversion to an appropriate + -- Before we do a range check, we have to deal with treating a + -- fixed-point operand as an integer. The way we do this is + -- simply to do an unchecked conversion to an appropriate -- integer type large enough to hold the result. -- This code is not active yet, because we are only dealing @@ -7927,8 +7914,8 @@ package body Exp_Ch4 is end if; -- Reset overflow flag, since the range check will include - -- dealing with possible overflow, and generate the check - -- If Address is either source or target type, suppress + -- dealing with possible overflow, and generate the check If + -- Address is either a source type or target type, suppress -- range check to avoid typing anomalies when it is a visible -- integer type. @@ -7975,8 +7962,8 @@ package body Exp_Ch4 is -- Expand_N_Unchecked_Type_Conversion -- ---------------------------------------- - -- If this cannot be handled by Gigi and we haven't already made - -- a temporary for it, do it now. + -- If this cannot be handled by Gigi and we haven't already made a + -- temporary for it, do it now. procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is Target_Type : constant Entity_Id := Etype (N); @@ -8019,9 +8006,9 @@ package body Exp_Ch4 is then Rewrite (N, Make_Integer_Literal (Sloc (N), Val)); - -- If Address is the target type, just set the type - -- to avoid a spurious type error on the literal when - -- Address is a visible integer type. + -- If Address is the target type, just set the type to avoid a + -- spurious type error on the literal when Address is a visible + -- integer type. if Is_Descendent_Of_Address (Target_Type) then Set_Etype (N, Target_Type); @@ -8425,11 +8412,11 @@ package body Exp_Ch4 is New_Reference_To (Pool, Loc), - -- Storage_Address. We use the attribute Pool_Address, - -- which uses the pointer itself to find the address of - -- the object, and which handles unconstrained arrays - -- properly by computing the address of the template. - -- i.e. the correct address of the corresponding allocation. + -- Storage_Address. We use the attribute Pool_Address, which uses + -- the pointer itself to find the address of the object, and which + -- handles unconstrained arrays properly by computing the address + -- of the template. i.e. the correct address of the corresponding + -- allocation. Make_Attribute_Reference (Loc, Prefix => Duplicate_Subexpr_Move_Checks (N), @@ -8722,8 +8709,8 @@ package body Exp_Ch4 is -- Make_Boolean_Array_Op -- --------------------------- - -- For logical operations on boolean arrays, expand in line the - -- following, replacing 'and' with 'or' or 'xor' where needed: + -- For logical operations on boolean arrays, expand in line the following, + -- replacing 'and' with 'or' or 'xor' where needed: -- function Annn (A : typ; B: typ) return typ is -- C : typ; @@ -9002,9 +8989,8 @@ package body Exp_Ch4 is -- Start of processing for Is_Safe_In_Place_Array_Op begin - -- We skip this processing if the component size is not the - -- same as a system storage unit (since at least for NOT - -- this would cause problems). + -- Skip this processing if the component size is different from system + -- storage unit (since at least for NOT this would cause problems). if Component_Size (Etype (Lhs)) /= System_Storage_Unit then return False; @@ -9034,15 +9020,15 @@ package body Exp_Ch4 is -- Tagged_Membership -- ----------------------- - -- There are two different cases to consider depending on whether - -- the right operand is a class-wide type or not. If not we just - -- compare the actual tag of the left expr to the target type tag: + -- There are two different cases to consider depending on whether the right + -- operand is a class-wide type or not. If not we just compare the actual + -- tag of the left expr to the target type tag: -- -- Left_Expr.Tag = Right_Type'Tag; -- - -- If it is a class-wide type we use the RT function CW_Membership which - -- is usually implemented by looking in the ancestor tables contained in - -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag + -- If it is a class-wide type we use the RT function CW_Membership which is + -- usually implemented by looking in the ancestor tables contained in the + -- dispatch table pointed by Left_Expr.Tag for Typ'Tag -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT -- function IW_Membership which is usually implemented by looking in the diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 0018a673522..00ab0d6fa9d 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1886,8 +1886,11 @@ package body Exp_Ch5 is -- <code for controlled and/or tagged assignment> -- end if; + -- Skip this if Restriction (No_Finalization) is active + if not Statically_Different (Lhs, Rhs) and then Expand_Ctrl_Actions + and then not Restriction_Active (No_Finalization) then L := New_List ( Make_Implicit_If_Statement (N, diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index a8470b6f2c5..8791fcf6958 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2641,77 +2641,110 @@ package body Exp_Ch6 is ("cannot call abstract subprogram &!", Name (N), Parent_Subp); end if; - -- Add an explicit conversion for parameter of the derived type. - -- This is only done for scalar and access in-parameters. Others - -- have been expanded in expand_actuals. + -- Inspect all formals of derived subprogram Subp. Compare parameter + -- types with the parent subprogram and check whether an actual may + -- need a type conversion to the corresponding formal of the parent + -- subprogram. - Formal := First_Formal (Subp); - Parent_Formal := First_Formal (Parent_Subp); - Actual := First_Actual (N); - - -- It is not clear that conversion is needed for intrinsic - -- subprograms, but it certainly is for those that are user- - -- defined, and that can be inherited on derivation, namely - -- unchecked conversion and deallocation. - -- General case needs study ??? + -- Not clear whether intrinsic subprograms need such conversions. ??? if not Is_Intrinsic_Subprogram (Parent_Subp) or else Is_Generic_Instance (Parent_Subp) then - while Present (Formal) loop - if Etype (Formal) /= Etype (Parent_Formal) - and then Is_Scalar_Type (Etype (Formal)) - and then Ekind (Formal) = E_In_Parameter - and then - not Subtypes_Statically_Match - (Etype (Parent_Formal), Etype (Actual)) - and then not Raises_Constraint_Error (Actual) - then - Rewrite (Actual, - OK_Convert_To (Etype (Parent_Formal), - Relocate_Node (Actual))); + declare + procedure Convert (Act : Node_Id; Typ : Entity_Id); + -- Rewrite node Act as a type conversion of Act to Typ. Analyze + -- and resolve the newly generated construct. - Analyze (Actual); - Resolve (Actual, Etype (Parent_Formal)); - Enable_Range_Check (Actual); + ------------- + -- Convert -- + ------------- - elsif Is_Access_Type (Etype (Formal)) - and then Base_Type (Etype (Parent_Formal)) /= - Base_Type (Etype (Actual)) - then - if Ekind (Formal) /= E_In_Parameter then - Rewrite (Actual, - Convert_To (Etype (Parent_Formal), - Relocate_Node (Actual))); - - Analyze (Actual); - Resolve (Actual, Etype (Parent_Formal)); - - elsif - Ekind (Etype (Parent_Formal)) = E_Anonymous_Access_Type - and then Designated_Type (Etype (Parent_Formal)) - /= - Designated_Type (Etype (Actual)) - and then not Is_Controlling_Formal (Formal) + procedure Convert (Act : Node_Id; Typ : Entity_Id) is + begin + Rewrite (Act, OK_Convert_To (Typ, Relocate_Node (Act))); + Analyze (Act); + Resolve (Act, Typ); + end Convert; + + -- Local variables + + Actual_Typ : Entity_Id; + Formal_Typ : Entity_Id; + Parent_Typ : Entity_Id; + + begin + Actual := First_Actual (N); + Formal := First_Formal (Subp); + Parent_Formal := First_Formal (Parent_Subp); + while Present (Formal) loop + Actual_Typ := Etype (Actual); + Formal_Typ := Etype (Formal); + Parent_Typ := Etype (Parent_Formal); + + -- For an IN parameter of a scalar type, the parent formal + -- type and derived formal type differ or the parent formal + -- type and actual type do not match statically. + + if Is_Scalar_Type (Formal_Typ) + and then Ekind (Formal) = E_In_Parameter + and then Formal_Typ /= Parent_Typ + and then + not Subtypes_Statically_Match (Parent_Typ, Actual_Typ) + and then not Raises_Constraint_Error (Actual) then - -- This unchecked conversion is not necessary unless - -- inlining is enabled, because in that case the type - -- mismatch may become visible in the body about to be - -- inlined. + Convert (Actual, Parent_Typ); + Enable_Range_Check (Actual); - Rewrite (Actual, - Unchecked_Convert_To (Etype (Parent_Formal), - Relocate_Node (Actual))); + -- For access types, the parent formal type and actual type + -- differ. - Analyze (Actual); - Resolve (Actual, Etype (Parent_Formal)); + elsif Is_Access_Type (Formal_Typ) + and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ) + then + if Ekind (Formal) /= E_In_Parameter then + Convert (Actual, Parent_Typ); + + elsif Ekind (Parent_Typ) = E_Anonymous_Access_Type + and then Designated_Type (Parent_Typ) /= + Designated_Type (Actual_Typ) + and then not Is_Controlling_Formal (Formal) + then + -- This unchecked conversion is not necessary unless + -- inlining is enabled, because in that case the type + -- mismatch may become visible in the body about to be + -- inlined. + + Rewrite (Actual, + Unchecked_Convert_To (Parent_Typ, + Relocate_Node (Actual))); + + Analyze (Actual); + Resolve (Actual, Parent_Typ); + end if; + + -- For array and record types, the parent formal type and + -- derived formal type have different sizes or pragma Pack + -- status. + + elsif ((Is_Array_Type (Formal_Typ) + and then Is_Array_Type (Parent_Typ)) + or else + (Is_Record_Type (Formal_Typ) + and then Is_Record_Type (Parent_Typ))) + and then + (Esize (Formal_Typ) /= Esize (Parent_Typ) + or else Has_Pragma_Pack (Formal_Typ) /= + Has_Pragma_Pack (Parent_Typ)) + then + Convert (Actual, Parent_Typ); end if; - end if; - Next_Formal (Formal); - Next_Formal (Parent_Formal); - Next_Actual (Actual); - end loop; + Next_Actual (Actual); + Next_Formal (Formal); + Next_Formal (Parent_Formal); + end loop; + end; end if; Orig_Subp := Subp; @@ -2744,7 +2777,7 @@ package body Exp_Ch6 is -- Handle case of access to protected subprogram type if Is_Access_Protected_Subprogram_Type - (Base_Type (Etype (Prefix (Name (N))))) + (Base_Type (Etype (Prefix (Name (N))))) then -- If this is a call through an access to protected operation, -- the prefix has the form (object'address, operation'access). diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 916f7af0a10..0140c7677f7 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -1471,6 +1471,17 @@ package body Exp_Ch7 is -- Attach_To_Final_List (_Lx, Resx (Resx'last)._controller, 3); + -- If the context is an aggregate, the call will be expanded into an + -- assignment, and the attachment will be done when the aggregate + -- expansion is complete. See body of Exp_Aggr for the treatment of + -- other controlled components. + + if Nkind (Parent (N)) = N_Aggregate then + return; + end if; + + -- Case where type has controlled components + if Has_Controlled_Component (Rtype) then declare T1 : Entity_Id := Rtype; @@ -1536,15 +1547,14 @@ package body Exp_Ch7 is With_Attach => Make_Integer_Literal (Loc, Attach_Level)); end if; - else - -- Here, we have a controlled type that does not seem to have - -- controlled components but it could be a class wide type whose - -- further derivations have controlled components. So we don't know - -- if the object itself needs to be attached or if it - -- has a record controller. We need to call a runtime function - -- (Deep_Tag_Attach) which knows what to do thanks to the - -- RC_Offset in the dispatch table. + -- Here, we have a controlled type that does not seem to have + -- controlled components but it could be a class wide type whose + -- further derivations have controlled components. So we don't know + -- if the object itself needs to be attached or if it has a record + -- controller. We need to call a runtime function (Deep_Tag_Attach) + -- which knows what to do thanks to the RC_Offset in the dispatch table. + else Action := Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Deep_Tag_Attach), Loc), diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 2628e150ca1..0e9715dde0d 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -158,17 +158,15 @@ package Exp_Ch9 is function Convert_Concurrent (N : Node_Id; - Typ : Entity_Id) - return Node_Id; - -- N is an expression of type Typ. If the type is not a concurrent - -- type then it is returned unchanged. If it is a task or protected - -- reference, Convert_Concurrent creates an unchecked conversion node - -- from this expression to the corresponding concurrent record type - -- value. We need this in any situation where the concurrent type is - -- used, because the actual concurrent object is an object of the - -- corresponding concurrent type, and manipulations on the concurrent - -- object actually manipulate the corresponding object of the record - -- type. + Typ : Entity_Id) return Node_Id; + -- N is an expression of type Typ. If the type is not a concurrent type + -- then it is returned unchanged. If it is a task or protected reference, + -- Convert_Concurrent creates an unchecked conversion node from this + -- expression to the corresponding concurrent record type value. We need + -- this in any situation where the concurrent type is used, because the + -- actual concurrent object is an object of the corresponding concurrent + -- type, and manipulations on the concurrent object actually manipulate the + -- corresponding object of the record type. function Entry_Index_Expression (Sloc : Source_Ptr; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index b4efbf87cc7..58bd28b2d72 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -335,8 +335,9 @@ package body Exp_Disp is Loc : constant Source_Ptr := Sloc (Call_Node); Call_Typ : constant Entity_Id := Etype (Call_Node); - Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); - Param_List : constant List_Id := Parameter_Associations (Call_Node); + Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); + Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg)); + Param_List : constant List_Id := Parameter_Associations (Call_Node); Subp : Entity_Id; CW_Typ : Entity_Id; @@ -416,9 +417,9 @@ package body Exp_Disp is -- This capability of dispatching directly by tag is also needed by the -- implementation of AI-260 (for the generic dispatching constructors). - if Etype (Ctrl_Arg) = RTE (RE_Tag) + if Ctrl_Typ = RTE (RE_Tag) or else (RTE_Available (RE_Interface_Tag) - and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)) + and then Ctrl_Typ = RTE (RE_Interface_Tag)) then CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp)); @@ -427,11 +428,11 @@ package body Exp_Disp is -- there are cases where the controlling type is resolved to a specific -- type (such as for designated types of arguments such as CW'Access). - elsif Is_Access_Type (Etype (Ctrl_Arg)) then - CW_Typ := Class_Wide_Type (Designated_Type (Etype (Ctrl_Arg))); + elsif Is_Access_Type (Ctrl_Typ) then + CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ)); else - CW_Typ := Class_Wide_Type (Etype (Ctrl_Arg)); + CW_Typ := Class_Wide_Type (Ctrl_Typ); end if; Typ := Root_Type (CW_Typ); @@ -619,9 +620,9 @@ package body Exp_Disp is -- interface class-wide type then use it directly. Otherwise, the tag -- must be extracted from the controlling object. - if Etype (Ctrl_Arg) = RTE (RE_Tag) + if Ctrl_Typ = RTE (RE_Tag) or else (RTE_Available (RE_Interface_Tag) - and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)) + and then Ctrl_Typ = RTE (RE_Interface_Tag)) then Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); @@ -643,8 +644,8 @@ package body Exp_Disp is -- Ada 2005 (AI-251): Abstract interface class-wide type - elsif Is_Interface (Etype (Ctrl_Arg)) - and then Is_Class_Wide_Type (Etype (Ctrl_Arg)) + elsif Is_Interface (Ctrl_Typ) + and then Is_Class_Wide_Type (Ctrl_Typ) then Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); @@ -3175,10 +3176,7 @@ package body Exp_Disp is if not Building_Static_DT (Typ) then Set_Ekind (Predef_Prims, E_Variable); - Set_Is_Statically_Allocated (Predef_Prims); - Set_Ekind (Iface_DT, E_Variable); - Set_Is_Statically_Allocated (Iface_DT); -- Statically allocated dispatch tables and related entities are -- constants. @@ -3676,9 +3674,9 @@ package body Exp_Disp is -- Local variables - Elab_Code : constant List_Id := New_List; - Result : constant List_Id := New_List; - Tname : constant Name_Id := Chars (Typ); + Elab_Code : constant List_Id := New_List; + Result : constant List_Id := New_List; + Tname : constant Name_Id := Chars (Typ); AI : Elmt_Id; AI_Tag_Elmt : Elmt_Id; AI_Tag_Comp : Elmt_Id; @@ -3689,11 +3687,9 @@ package body Exp_Disp is I_Depth : Nat := 0; Iface_Table_Node : Node_Id; Name_ITable : Name_Id; - Name_No_Reg : Name_Id; Nb_Predef_Prims : Nat := 0; Nb_Prim : Nat := 0; New_Node : Node_Id; - No_Reg : Node_Id; Num_Ifaces : Nat := 0; Parent_Typ : Entity_Id; Prim : Entity_Id; @@ -3903,26 +3899,11 @@ package body Exp_Disp is DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); - Set_Is_Statically_Allocated (DT); - Set_Is_Statically_Allocated (SSD); - Set_Is_Statically_Allocated (TSD); - Set_Is_Statically_Allocated (Predef_Prims); - - -- Generate code to define the boolean that controls registration, in - -- order to avoid multiple registrations for tagged types defined in - -- multiple-called scopes. - - Name_No_Reg := New_External_Name (Tname, 'F', Suffix_Index => -1); - No_Reg := Make_Defining_Identifier (Loc, Name_No_Reg); - - Set_Ekind (No_Reg, E_Variable); - Set_Is_Statically_Allocated (No_Reg); - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => No_Reg, - Object_Definition => New_Reference_To (Standard_Boolean, Loc), - Expression => New_Reference_To (Standard_True, Loc))); + Set_Is_Statically_Allocated (DT, Is_Library_Level_Tagged_Type (Typ)); + Set_Is_Statically_Allocated (SSD, Is_Library_Level_Tagged_Type (Typ)); + Set_Is_Statically_Allocated (TSD, Is_Library_Level_Tagged_Type (Typ)); + Set_Is_Statically_Allocated (Predef_Prims, + Is_Library_Level_Tagged_Type (Typ)); -- In case of locally defined tagged type we declare the object -- containing the dispatch table by means of a variable. Its @@ -4544,7 +4525,8 @@ package body Exp_Disp is Name_ITable := New_External_Name (Tname, 'I'); ITable := Make_Defining_Identifier (Loc, Name_ITable); - Set_Is_Statically_Allocated (ITable); + Set_Is_Statically_Allocated (ITable, + Is_Library_Level_Tagged_Type (Typ)); -- The table of interfaces is not constant; its slots are -- filled at run-time by the IP routine using attribute @@ -5385,19 +5367,10 @@ package body Exp_Disp is -- Skip this action in the following cases: -- 1) if Register_Tag is not available. -- 2) in No_Run_Time mode. - -- 3) if Typ is an abstract interface type (the secondary tags will - -- be registered later in types implementing this interface type). - -- 4) if Typ is not defined at the library level (this is required + -- 3) if Typ is not defined at the library level (this is required -- to avoid adding concurrency control to the hash table used -- by the run-time to register the tags). - -- Generate: - -- if No_Reg then - -- [ Elab_Code ] - -- [ Register_Tag (Dt_Ptr); ] - -- No_Reg := False; - -- end if; - if not No_Run_Time_Mode and then Is_Library_Level_Entity (Typ) and then RTE_Available (RE_Register_Tag) @@ -5409,15 +5382,9 @@ package body Exp_Disp is New_List (New_Reference_To (DT_Ptr, Loc)))); end if; - Append_To (Elab_Code, - Make_Assignment_Statement (Loc, - Name => New_Reference_To (No_Reg, Loc), - Expression => New_Reference_To (Standard_False, Loc))); - - Append_To (Result, - Make_Implicit_If_Statement (Typ, - Condition => New_Reference_To (No_Reg, Loc), - Then_Statements => Elab_Code)); + if not Is_Empty_List (Elab_Code) then + Append_List_To (Result, Elab_Code); + end if; -- Populate the two auxiliary tables used for dispatching -- asynchronous, conditional and timed selects for synchronized @@ -5838,7 +5805,8 @@ package body Exp_Disp is Set_Ekind (Iface_DT_Ptr, E_Constant); Set_Is_Tag (Iface_DT_Ptr); Set_Has_Thunks (Iface_DT_Ptr); - Set_Is_Statically_Allocated (Iface_DT_Ptr); + Set_Is_Statically_Allocated (Iface_DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); Set_Is_True_Constant (Iface_DT_Ptr); Set_Related_Type (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); @@ -5854,7 +5822,8 @@ package body Exp_Disp is Set_Ekind (Iface_DT_Ptr, E_Constant); Set_Is_Tag (Iface_DT_Ptr); Set_Has_Thunks (Iface_DT_Ptr); - Set_Is_Statically_Allocated (Iface_DT_Ptr); + Set_Is_Statically_Allocated (Iface_DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); Set_Is_True_Constant (Iface_DT_Ptr); Set_Related_Type (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); @@ -5869,7 +5838,8 @@ package body Exp_Disp is Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); Set_Ekind (Iface_DT_Ptr, E_Constant); Set_Is_Tag (Iface_DT_Ptr); - Set_Is_Statically_Allocated (Iface_DT_Ptr); + Set_Is_Statically_Allocated (Iface_DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); Set_Is_True_Constant (Iface_DT_Ptr); Set_Related_Type (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); @@ -5883,7 +5853,8 @@ package body Exp_Disp is Set_Etype (Iface_DT_Ptr, RTE (RE_Address)); Set_Ekind (Iface_DT_Ptr, E_Constant); Set_Is_Tag (Iface_DT_Ptr); - Set_Is_Statically_Allocated (Iface_DT_Ptr); + Set_Is_Statically_Allocated (Iface_DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); Set_Is_True_Constant (Iface_DT_Ptr); Set_Related_Type (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 435afc5c51c..a409fe44191 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -1085,8 +1085,8 @@ package body Exp_Dist is Existing : Boolean; -- True when appropriate stubs have already been generated (this is the -- case when another RACW with the same designated type has already been - -- encountered, in which case we reuse the previous stubs rather than - -- generating new ones). + -- encountered), in which case we reuse the previous stubs rather than + -- generating new ones. begin if not Expander_Active then @@ -1164,12 +1164,13 @@ package body Exp_Dist is RPC_Receiver_Decl => RPC_Receiver_Decl, Body_Decls => Body_Decls); - if not Same_Scope and then not Existing then + -- If we already have stubs for this designated type, nothing to do - -- The RACW has been declared in another scope than the designated - -- type and has not been handled by another RACW in the same package - -- as the first one, so add primitives for the stub type here. + if Existing then + return; + end if; + if Is_Frozen (Desig) then Validate_RACW_Primitives (RACW_Type); Add_RACW_Primitive_Declarations_And_Bodies (Designated_Type => Desig, @@ -1177,10 +1178,9 @@ package body Exp_Dist is Body_Decls => Body_Decls); else - -- Validate_RACW_Primitives will be called when the designated type - -- is frozen, see Exp_Ch3.Freeze_Type. - - -- ??? Shouldn't we have a pragma Assert (not Is_Frozen (Desig))? + -- Validate_RACW_Primitives requires the list of all primitives of + -- the designated type, so defer processing until Desig is frozen. + -- See Exp_Ch3.Freeze_Type. Add_Access_Type_To_Process (E => Desig, A => RACW_Type); end if; @@ -1870,6 +1870,8 @@ package body Exp_Dist is Stub_Type := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S')); + Set_Ekind (Stub_Type, E_Record_Type); + Set_Is_RACW_Stub_Type (Stub_Type); Stub_Type_Access := Make_Defining_Identifier (Loc, Chars => New_External_Name @@ -3085,19 +3087,34 @@ package body Exp_Dist is Set_Etype (Stubbed_Result, Stub_Type_Access); - -- If the Address is Null_Address, then return a null object + -- If the Address is Null_Address, then return a null object, unless + -- RACW_Type is null-excluding, in which case inconditionally raise + -- CONSTRAINT_ERROR instead. - Append_To (Statements, - Make_Implicit_If_Statement (RACW_Type, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => New_Occurrence_Of (Source_Address, Loc), - Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), - Then_Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => Result, - Expression => Make_Null (Loc)), - Make_Simple_Return_Statement (Loc)))); + declare + Zero_Statements : List_Id; + -- Statements executed when a zero value is received + begin + if Can_Never_Be_Null (RACW_Type) then + Zero_Statements := New_List ( + Make_Raise_Constraint_Error (Loc, + Reason => CE_Null_Not_Allowed)); + else + Zero_Statements := New_List ( + Make_Assignment_Statement (Loc, + Name => Result, + Expression => Make_Null (Loc)), + Make_Simple_Return_Statement (Loc)); + end if; + + Append_To (Statements, + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Source_Address, Loc), + Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), + Then_Statements => Zero_Statements)); + end; -- If the RACW denotes an object created on the current partition, -- Local_Statements will be executed. The real object will be used. @@ -8470,7 +8487,7 @@ package body Exp_Dist is function Find_Numeric_Representation (Typ : Entity_Id) return Entity_Id; - -- Given a numeric type Typ, return the smallest integer or floarting + -- Given a numeric type Typ, return the smallest integer or floating -- point type from Standard, or the smallest unsigned (modular) type -- from System.Unsigned_Types, whose range encompasses that of Typ. @@ -8729,11 +8746,16 @@ package body Exp_Dist is Decl : out Node_Id; Fnam : out Entity_Id) is - Spec : Node_Id; + Spec : Node_Id; Decls : constant List_Id := New_List; - Stms : constant List_Id := New_List; - Any_Parameter : constant Entity_Id - := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Stms : constant List_Id := New_List; + + Any_Parameter : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('A')); + + Use_Opaque_Representation : Boolean; + begin if Is_Itype (Typ) then Build_From_Any_Function @@ -8763,9 +8785,21 @@ package body Exp_Dist is pragma Assert (not (Is_Remote_Access_To_Class_Wide_Type (Typ))); - if Is_Derived_Type (Typ) - and then not Is_Tagged_Type (Typ) + Use_Opaque_Representation := False; + + if Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Output, At_Any_Place => True) + or else + Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Write, At_Any_Place => True) then + -- If user-defined stream attributes are specified for this + -- type, use them and transmit data as an opaque sequence of + -- stream elements. + + Use_Opaque_Representation := True; + + elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => @@ -9292,6 +9326,11 @@ package body Exp_Dist is Decls)))); else + Use_Opaque_Representation := True; + end if; + + if Use_Opaque_Representation then + -- Default: type is represented as an opaque sequence of bytes declare @@ -9588,6 +9627,10 @@ package body Exp_Dist is Any_Decl : Node_Id; Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls); + Use_Opaque_Representation : Boolean; + -- When True, use stream attributes and represent type as an + -- opaque sequence of bytes. + begin if Is_Itype (Typ) then Build_To_Any_Function @@ -9598,8 +9641,8 @@ package body Exp_Dist is return; end if; - Fnam := Make_Stream_Procedure_Function_Name (Loc, - Typ, Name_uTo_Any); + Fnam := + Make_Stream_Procedure_Function_Name (Loc, Typ, Name_uTo_Any); Spec := Make_Function_Specification (Loc, @@ -9620,39 +9663,58 @@ package body Exp_Dist is Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); - if Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then + Use_Opaque_Representation := False; + + if Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Output, At_Any_Place => True) + or else + Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Write, At_Any_Place => True) + then + -- If user-defined stream attributes are specified for this + -- type, use them and transmit data as an opaque sequence of + -- stream elements. + + Use_Opaque_Representation := True; + + elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then + + -- Non-tagged derived type: convert to root type + declare - Rt_Type : constant Entity_Id - := Root_Type (Typ); - Expr : constant Node_Id - := OK_Convert_To ( - Rt_Type, - New_Occurrence_Of (Expr_Parameter, Loc)); + Rt_Type : constant Entity_Id := Root_Type (Typ); + Expr : constant Node_Id := + OK_Convert_To + (Rt_Type, + New_Occurrence_Of (Expr_Parameter, Loc)); begin Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls)); end; elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then + + -- Non-tagged record type + if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then declare - Rt_Type : constant Entity_Id - := Etype (Typ); - Expr : constant Node_Id - := OK_Convert_To ( - Rt_Type, - New_Occurrence_Of (Expr_Parameter, Loc)); + Rt_Type : constant Entity_Id := Etype (Typ); + Expr : constant Node_Id := + OK_Convert_To (Rt_Type, + New_Occurrence_Of (Expr_Parameter, Loc)); begin Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls)); end; + -- Comment needed here (and label on declare block ???) + else declare - Disc : Entity_Id := Empty; - Rdef : constant Node_Id := - Type_Definition (Declaration_Node (Typ)); - Counter : Int := 0; + Disc : Entity_Id := Empty; + Rdef : constant Node_Id := + Type_Definition (Declaration_Node (Typ)); + Counter : Int := 0; Elements : constant List_Id := New_List; procedure TA_Rec_Add_Process_Element @@ -9661,6 +9723,7 @@ package body Exp_Dist is Counter : in out Int; Rec : Entity_Id; Field : Node_Id); + -- Processing routine for traversal below procedure TA_Append_Record_Traversal is new Append_Record_Traversal @@ -9702,15 +9765,15 @@ package body Exp_Dist is else -- A variant part - declare - Variant : Node_Id; + Variant_Part : declare + Variant : Node_Id; Struct_Counter : Int := 0; Block_Decls : constant List_Id := New_List; Block_Stmts : constant List_Id := New_List; VP_Stmts : List_Id; - Alt_List : constant List_Id := New_List; + Alt_List : constant List_Id := New_List; Choice_List : List_Id; Union_Any : constant Entity_Id := @@ -9723,8 +9786,8 @@ package body Exp_Dist is function Make_Discriminant_Reference return Node_Id; - -- Build a selected component for the - -- discriminant of this variant part. + -- Build reference to the discriminant for this + -- variant part. --------------------------------- -- Make_Discriminant_Reference -- @@ -9743,6 +9806,8 @@ package body Exp_Dist is return Nod; end Make_Discriminant_Reference; + -- Start processing for Variant_Part + begin Append_To (Stmts, Make_Block_Statement (Loc, @@ -9752,11 +9817,10 @@ package body Exp_Dist is Make_Handled_Sequence_Of_Statements (Loc, Statements => Block_Stmts))); - -- Declare the Variant Part aggregate - -- (Union_Any). - -- Knowing the position of this VP in - -- the variant record, we can fetch the - -- VP typecode from Container. + -- Declare variant part aggregate (Union_Any). + -- Knowing the position of this VP in the + -- variant record, we can fetch the VP typecode + -- from Container. Append_To (Block_Decls, Make_Object_Declaration (Loc, @@ -9777,9 +9841,8 @@ package body Exp_Dist is Make_Integer_Literal (Loc, Counter))))))); - -- Declare the inner struct aggregate - -- (that will contain the components - -- of this VP) + -- Declare inner struct aggregate (which + -- contains the components of this VP). Append_To (Block_Decls, Make_Object_Declaration (Loc, @@ -9800,9 +9863,7 @@ package body Exp_Dist is Make_Integer_Literal (Loc, Uint_1))))))); - -- Construct a case statement that will choose - -- the appropriate code at runtime depending on - -- the discriminant. + -- Build case statement Append_To (Block_Stmts, Make_Case_Statement (Loc, @@ -9818,8 +9879,7 @@ package body Exp_Dist is VP_Stmts := New_List; - -- Append discriminant value to union - -- aggregate. + -- Append discriminant val to union aggregate Append_To (VP_Stmts, Make_Procedure_Call_Statement (Loc, @@ -9878,8 +9938,9 @@ package body Exp_Dist is Next_Non_Pragma (Variant); end loop; - end; + end Variant_Part; end if; + Counter := Counter + 1; end TA_Rec_Add_Process_Element; @@ -9989,6 +10050,9 @@ package body Exp_Dist is end if; elsif Is_Array_Type (Typ) then + + -- Constrained and unconstrained array types + declare Constrained : constant Boolean := Is_Constrained (Typ); @@ -10074,6 +10138,9 @@ package body Exp_Dist is end; elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then + + -- Integer types + Set_Expression (Any_Decl, Build_To_Any_Call ( OK_Convert_To ( @@ -10082,14 +10149,22 @@ package body Exp_Dist is Decls)); else - -- Default: type is represented as an opaque sequence of bytes + -- Default case, including tagged types: opaque representation + + Use_Opaque_Representation := True; + end if; + if Use_Opaque_Representation then declare - Strm : constant Entity_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('S')); + Strm : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); + -- Stream used to store data representation produced by + -- stream attribute. begin - -- Strm : aliased Buffer_Stream_Type; + -- Generate: + -- Strm : aliased Buffer_Stream_Type; Append_To (Decls, Make_Object_Declaration (Loc, @@ -10100,7 +10175,8 @@ package body Exp_Dist is Object_Definition => New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); - -- Allocate_Buffer (Strm); + -- Generate: + -- Allocate_Buffer (Strm); Append_To (Stms, Make_Procedure_Call_Statement (Loc, @@ -10109,19 +10185,21 @@ package body Exp_Dist is Parameter_Associations => New_List ( New_Occurrence_Of (Strm, Loc)))); - -- T'Output (Strm'Access, E); + -- Generate: + -- T'Output (Strm'Access, E); Append_To (Stms, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Output, - Expressions => New_List ( + Expressions => New_List ( Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Strm, Loc), + Prefix => New_Occurrence_Of (Strm, Loc), Attribute_Name => Name_Access), New_Occurrence_Of (Expr_Parameter, Loc)))); - -- BS_To_Any (Strm, A); + -- Generate: + -- BS_To_Any (Strm, A); Append_To (Stms, Make_Procedure_Call_Statement (Loc, @@ -10131,7 +10209,8 @@ package body Exp_Dist is New_Occurrence_Of (Strm, Loc), New_Occurrence_Of (Any, Loc)))); - -- Release_Buffer (Strm); + -- Generate: + -- Release_Buffer (Strm); Append_To (Stms, Make_Procedure_Call_Statement (Loc, @@ -10175,14 +10254,13 @@ package body Exp_Dist is Typ : Entity_Id; Decls : List_Id) return Node_Id is - U_Type : Entity_Id := Underlying_Type (Typ); + U_Type : Entity_Id := Underlying_Type (Typ); -- The full view, if Typ is private; the completion, -- if Typ is incomplete. - Fnam : Entity_Id := Empty; - Lib_RE : RE_Id := RE_Null; - - Expr : Node_Id; + Fnam : Entity_Id := Empty; + Lib_RE : RE_Id := RE_Null; + Expr : Node_Id; begin -- Special case System.PolyORB.Interface.Any: its primitives have @@ -10729,22 +10807,29 @@ package body Exp_Dist is Initialize_Parameter_List (Type_Name_Str, Type_Repo_Id_Str, Parameters); - if Is_Derived_Type (Typ) - and then not Is_Tagged_Type (Typ) + if Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Output, At_Any_Place => True) + or else + Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Write, At_Any_Place => True) then + -- If user-defined stream attributes are specified for this + -- type, use them and transmit data as an opaque sequence of + -- stream elements. + + Return_Alias_TypeCode + (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc)); + + elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then Return_Alias_TypeCode ( Build_TypeCode_Call (Loc, Etype (Typ), Decls)); - elsif Is_Integer_Type (Typ) - or else Is_Unsigned_Type (Typ) - then + elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then Return_Alias_TypeCode ( Build_TypeCode_Call (Loc, Find_Numeric_Representation (Typ), Decls)); - elsif Is_Record_Type (Typ) - and then not Is_Tagged_Type (Typ) - then + elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then -- Record typecodes are encoded as follows: -- -- TC_STRUCT @@ -11280,11 +11365,33 @@ package body Exp_Dist is Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Full_View); begin + -- For an RACW encountered before the freeze point of its designated + -- type, the stub type is generated at the point of the RACW declaration + -- but the primitives are generated only once the designated type is + -- frozen. That freeze can occur in another scope, for example when the + -- RACW is declared in a nested package. In that case we need to + -- reestablish the stub type's scope prior to generating its primitive + -- operations. + if Stub_Elements /= Empty_Stub_Structure then - Add_RACW_Primitive_Declarations_And_Bodies - (Full_View, - Stub_Elements.RPC_Receiver_Decl, - Stub_Elements.Body_Decls); + declare + Saved_Scope : constant Entity_Id := Current_Scope; + Stubs_Scope : constant Entity_Id := + Scope (Stub_Elements.Stub_Type); + begin + if Current_Scope /= Stubs_Scope then + Push_Scope (Stubs_Scope); + end if; + + Add_RACW_Primitive_Declarations_And_Bodies + (Full_View, + Stub_Elements.RPC_Receiver_Decl, + Stub_Elements.Body_Decls); + + if Current_Scope /= Saved_Scope then + Pop_Scope; + end if; + end; end if; end Remote_Types_Tagged_Full_View_Encountered; diff --git a/gcc/ada/exp_smem.adb b/gcc/ada/exp_smem.adb index ae1ea9b68d0..0e3fc2379a4 100644 --- a/gcc/ada/exp_smem.adb +++ b/gcc/ada/exp_smem.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -71,6 +71,29 @@ package body Exp_Smem is -- OUT or IN OUT parameter to a procedure call. If the result is -- True, then Insert_Node is set to point to the call. + function Build_Shared_Var_Proc_Call + (Loc : Source_Ptr; + E : Node_Id; + N : Name_Id) return Node_Id; + -- Build a call to support procedure N for shared object E (provided by + -- the instance of System.Shared_Storage.Shared_Var_Procs associated to E). + + -------------------------------- + -- Build_Shared_Var_Proc_Call -- + -------------------------------- + + function Build_Shared_Var_Proc_Call + (Loc : Source_Ptr; + E : Entity_Id; + N : Name_Id) return Node_Id is + begin + return Make_Procedure_Call_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Shared_Var_Procs_Instance (E), Loc), + Selector_Name => Make_Identifier (Loc, Chars => N))); + end Build_Shared_Var_Proc_Call; + --------------------- -- Add_Read_Before -- --------------------- @@ -78,14 +101,9 @@ package body Exp_Smem is procedure Add_Read_Before (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Ent : constant Node_Id := Entity (N); - begin - if Present (Shared_Var_Read_Proc (Ent)) then - Insert_Action (N, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Shared_Var_Read_Proc (Ent), Loc), - Parameter_Associations => Empty_List)); + if Present (Shared_Var_Procs_Instance (Ent)) then + Insert_Action (N, Build_Shared_Var_Proc_Call (Loc, Ent, Name_Read)); end if; end Add_Read_Before; @@ -134,8 +152,7 @@ package body Exp_Smem is -- Now, right after the Lock, insert a call to read the object Insert_Before_And_Analyze (Inode, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Shared_Var_Read_Proc (Obj), Loc))); + Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read)); -- Now insert the Unlock call after @@ -150,8 +167,7 @@ package body Exp_Smem is if Nkind (N) = N_Procedure_Call_Statement then Insert_After_And_Analyze (Inode, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Shared_Var_Assign_Proc (Obj), Loc))); + Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write)); end if; end Add_Shared_Var_Lock_Procs; @@ -165,12 +181,9 @@ package body Exp_Smem is Ent : constant Node_Id := Entity (N); begin - if Present (Shared_Var_Assign_Proc (Ent)) then + if Present (Shared_Var_Procs_Instance (Ent)) then Insert_After_And_Analyze (Insert_Node, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Shared_Var_Assign_Proc (Ent), Loc), - Parameter_Associations => Empty_List)); + Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write)); end if; end Add_Write_After; @@ -276,21 +289,18 @@ package body Exp_Smem is Ent : constant Entity_Id := Defining_Identifier (N); Typ : constant Entity_Id := Etype (Ent); Vnm : String_Id; - Atr : Node_Id; After : constant Node_Id := Next (N); -- Node located right after N originally (after insertion of the SV -- procs this node is right after the last inserted node). - Assign_Proc : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Ent), 'A')); - - Read_Proc : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Ent), 'R')); + SVP_Instance : constant Entity_Id := Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Ent), 'G')); + -- Instance of System.Shared_Storage.Shared_Var_Procs associated + -- with Ent. - S : Entity_Id; + Instantiation : Node_Id; + -- Package instanciation node for SVP_Instance -- Start of processing for Make_Shared_Var_Procs @@ -298,149 +308,33 @@ package body Exp_Smem is Build_Full_Name (Ent, Vnm); -- We turn off Shared_Passive during construction and analysis of - -- the assign and read routines, to avoid improper attempts to - -- process the variable references within these procedures. + -- the generic package instantition, to avoid improper attempts to + -- process the variable references within these instantiation. Set_Is_Shared_Passive (Ent, False); - -- Construct assignment routine - - -- procedure VarA is - -- S : Ada.Streams.Stream_IO.Stream_Access; - -- begin - -- S := Shared_Var_WOpen ("pkg.var"); - -- typ'Write (S, var); - -- Shared_Var_Close (S); - -- end VarA; - - S := Make_Defining_Identifier (Loc, Name_uS); - - Atr := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), - Attribute_Name => Name_Write, - Expressions => New_List ( - New_Reference_To (S, Loc), - New_Occurrence_Of (Ent, Loc))); - - Insert_After_And_Analyze (N, - Make_Subprogram_Body (Loc, - Specification => - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Assign_Proc), - - -- S : Ada.Streams.Stream_IO.Stream_Access; - - Declarations => New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => S, - Object_Definition => - New_Occurrence_Of (RTE (RE_Stream_Access), Loc))), - - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - - -- S := Shared_Var_WOpen ("pkg.var"); - - Make_Assignment_Statement (Loc, - Name => New_Reference_To (S, Loc), - Expression => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of - (RTE (RE_Shared_Var_WOpen), Loc), - Parameter_Associations => New_List ( - Make_String_Literal (Loc, Vnm)))), - - Atr, - - -- Shared_Var_Close (S); - - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Shared_Var_Close), Loc), - Parameter_Associations => - New_List (New_Reference_To (S, Loc))))))); - - -- Construct read routine - - -- procedure varR is - -- S : Ada.Streams.Stream_IO.Stream_Access; - -- begin - -- S := Shared_Var_ROpen ("pkg.var"); - -- if S /= null then - -- typ'Read (S, Var); - -- Shared_Var_Close (S); - -- end if; - -- end varR; - - S := Make_Defining_Identifier (Loc, Name_uS); - - Atr := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), - Attribute_Name => Name_Read, - Expressions => New_List ( - New_Reference_To (S, Loc), - New_Occurrence_Of (Ent, Loc))); - - Insert_After_And_Analyze (N, - Make_Subprogram_Body (Loc, - Specification => - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Read_Proc), - - -- S : Ada.Streams.Stream_IO.Stream_Access; - - Declarations => New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => S, - Object_Definition => - New_Occurrence_Of (RTE (RE_Stream_Access), Loc))), - - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - - -- S := Shared_Var_ROpen ("pkg.var"); - - Make_Assignment_Statement (Loc, - Name => New_Reference_To (S, Loc), - Expression => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of - (RTE (RE_Shared_Var_ROpen), Loc), - Parameter_Associations => New_List ( - Make_String_Literal (Loc, Vnm)))), - - -- if S /= null then - - Make_Implicit_If_Statement (N, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => New_Reference_To (S, Loc), - Right_Opnd => Make_Null (Loc)), - - Then_Statements => New_List ( - - -- typ'Read (S, Var); - - Atr, - - -- Shared_Var_Close (S); - - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (RTE (RE_Shared_Var_Close), Loc), - Parameter_Associations => - New_List (New_Reference_To (S, Loc))))))))); - - Set_Is_Shared_Passive (Ent, True); - Set_Shared_Var_Assign_Proc (Ent, Assign_Proc); - Set_Shared_Var_Read_Proc (Ent, Read_Proc); + -- Construct generic package instantiation + + -- package varG is new Shared_Var_Procs (Typ, var, "pkg.var"); + + Instantiation := + Make_Package_Instantiation (Loc, + Defining_Unit_Name => SVP_Instance, + Name => + New_Occurrence_Of (RTE (RE_Shared_Var_Procs), Loc), + Generic_Associations => New_List ( + Make_Generic_Association (Loc, Explicit_Generic_Actual_Parameter => + New_Occurrence_Of (Typ, Loc)), + Make_Generic_Association (Loc, Explicit_Generic_Actual_Parameter => + New_Occurrence_Of (Ent, Loc)), + Make_Generic_Association (Loc, Explicit_Generic_Actual_Parameter => + Make_String_Literal (Loc, Vnm)))); + + Insert_After_And_Analyze (N, Instantiation); + + Set_Is_Shared_Passive (Ent, True); + Set_Shared_Var_Procs_Instance + (Ent, Defining_Entity (Instance_Spec (Instantiation))); -- Return last node before After diff --git a/gcc/ada/exp_smem.ads b/gcc/ada/exp_smem.ads index 69b4ee90eba..d1738255187 100644 --- a/gcc/ada/exp_smem.ads +++ b/gcc/ada/exp_smem.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2008, 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- -- @@ -49,10 +49,11 @@ package Exp_Smem is -- read/write calls for the protected object within the lock region. function Make_Shared_Var_Procs (N : Node_Id) return Node_Id; - -- N is the node for the declaration of a shared passive variable. This - -- procedure constructs and inserts the read and assignment procedures - -- for the shared memory variable. See System.Shared_Storage for a full - -- description of these procedures and how they are used. The last inserted - -- node is returned. + -- N is the node for the declaration of a shared passive variable. + -- This procedure constructs an instantiation of + -- System.Shared_Storage.Shared_Var_Procs that contains the read and + -- assignment procedures for the shared memory variable. + -- See System.Shared_Storage for a full description of these procedures + -- and how they are used. The last inserted node is returned. end Exp_Smem; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index f2bd7b13b67..21b1ad5884c 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3828,12 +3828,36 @@ package body Freeze is procedure Freeze_Enumeration_Type (Typ : Entity_Id) is begin + -- By default, if no size clause is present, an enumeration type with + -- Convention C is assumed to interface to a C enum, and has integer + -- size. This applies to types. For subtypes, verify that its base + -- type has no size clause either. + if Has_Foreign_Convention (Typ) and then not Has_Size_Clause (Typ) + and then not Has_Size_Clause (Base_Type (Typ)) and then Esize (Typ) < Standard_Integer_Size then Init_Esize (Typ, Standard_Integer_Size); + else + -- If the enumeration type interfaces to C, and it has a size clause + -- that specifies less than int size, it warrants a warning. The + -- user may intend the C type to be an enum or a char, so this is + -- not by itself an error that the Ada compiler can detect, but it + -- it is a worth a heads-up. For Boolean and Character types we + -- assume that the programmer has the proper C type in mind. + + if Convention (Typ) = Convention_C + and then Has_Size_Clause (Typ) + and then Esize (Typ) /= Esize (Standard_Integer) + and then not Is_Boolean_Type (Typ) + and then not Is_Character_Type (Typ) + then + Error_Msg_N + ("C enum types have the size of a C int?", Size_Clause (Typ)); + end if; + Adjust_Esize_For_Alignment (Typ); end if; end Freeze_Enumeration_Type; diff --git a/gcc/ada/g-byorma.adb b/gcc/ada/g-byorma.adb index 6bbaedf8b71..7e355b041b5 100755 --- a/gcc/ada/g-byorma.adb +++ b/gcc/ada/g-byorma.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2006-2007, AdaCore -- +-- Copyright (C) 2006-2008, 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- -- @@ -87,6 +87,7 @@ package body GNAT.Byte_Order_Mark is then Len := 2; BOM := UTF16_LE; + -- UTF-8 (endian-independent) elsif Str'Length >= 3 @@ -178,7 +179,7 @@ package body GNAT.Byte_Order_Mark is and then Str (Str'First + 2) = Character'Val (16#78#) and then Str (Str'First + 3) = Character'Val (16#6D#) then - -- Utf8, ASCII, some part of ISO8859, Shift-JIS, EUC,... + -- UTF-8, ASCII, some part of ISO8859, Shift-JIS, EUC,... Len := 0; BOM := Unknown; diff --git a/gcc/ada/g-soccon-aix.ads b/gcc/ada/g-soccon-aix.ads index 5b36015b1b3..c0a1503f363 100644 --- a/gcc/ada/g-soccon-aix.ads +++ b/gcc/ada/g-soccon-aix.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,137 +39,138 @@ -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. +with Interfaces.C; package GNAT.Sockets.Constants is -------------- -- Families -- -------------- - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 24; -- IPv6 address family + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 24; -- IPv6 address family ----------- -- Modes -- ----------- - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket ------------------- -- Socket errors -- ------------------- - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 67; -- Address already in use - EADDRNOTAVAIL : constant := 68; -- Cannot assign address - EAFNOSUPPORT : constant := 66; -- Addr family not supported - EALREADY : constant := 56; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 72; -- Connection aborted - ECONNREFUSED : constant := 79; -- Connection refused - ECONNRESET : constant := 73; -- Connection reset by peer - EDESTADDRREQ : constant := 58; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 80; -- Host is down - EHOSTUNREACH : constant := 81; -- No route to host - EINPROGRESS : constant := 55; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 75; -- Socket already connected - ELOOP : constant := 85; -- Too many symbolic links - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 59; -- Message too long - ENAMETOOLONG : constant := 86; -- Name too long - ENETDOWN : constant := 69; -- Network is down - ENETRESET : constant := 71; -- Disconn. on network reset - ENETUNREACH : constant := 70; -- Network is unreachable - ENOBUFS : constant := 74; -- No buffer space available - ENOPROTOOPT : constant := 61; -- Protocol not available - ENOTCONN : constant := 76; -- Socket not connected - ENOTSOCK : constant := 57; -- Operation on non socket - EOPNOTSUPP : constant := 64; -- Operation not supported - EPFNOSUPPORT : constant := 65; -- Unknown protocol family - EPROTONOSUPPORT : constant := 62; -- Unknown protocol - EPROTOTYPE : constant := 60; -- Unknown protocol type - ESHUTDOWN : constant := 77; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 63; -- Socket type not supported - ETIMEDOUT : constant := 78; -- Connection timed out - ETOOMANYREFS : constant := 115; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 67; -- Address already in use + EADDRNOTAVAIL : constant := 68; -- Cannot assign address + EAFNOSUPPORT : constant := 66; -- Addr family not supported + EALREADY : constant := 56; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 72; -- Connection aborted + ECONNREFUSED : constant := 79; -- Connection refused + ECONNRESET : constant := 73; -- Connection reset by peer + EDESTADDRREQ : constant := 58; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 80; -- Host is down + EHOSTUNREACH : constant := 81; -- No route to host + EINPROGRESS : constant := 55; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 75; -- Socket already connected + ELOOP : constant := 85; -- Too many symbolic links + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 59; -- Message too long + ENAMETOOLONG : constant := 86; -- Name too long + ENETDOWN : constant := 69; -- Network is down + ENETRESET : constant := 71; -- Disconn. on network reset + ENETUNREACH : constant := 70; -- Network is unreachable + ENOBUFS : constant := 74; -- No buffer space available + ENOPROTOOPT : constant := 61; -- Protocol not available + ENOTCONN : constant := 76; -- Socket not connected + ENOTSOCK : constant := 57; -- Operation on non socket + EOPNOTSUPP : constant := 64; -- Operation not supported + EPFNOSUPPORT : constant := 65; -- Unknown protocol family + EPROTONOSUPPORT : constant := 62; -- Unknown protocol + EPROTOTYPE : constant := 60; -- Unknown protocol type + ESHUTDOWN : constant := 77; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 63; -- Socket type not supported + ETIMEDOUT : constant := 78; -- Connection timed out + ETOOMANYREFS : constant := 115; -- Too many references + EWOULDBLOCK : constant := 11; -- Operation would block ----------------- -- Host errors -- ----------------- - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors ------------------- -- Control flags -- ------------------- - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read -------------------- -- Shutdown modes -- -------------------- - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send --------------------- -- Protocol levels -- --------------------- - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP ------------------- -- Request flags -- ------------------- - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send + MSG_Forced_Flags : constant := 0; -- Flags set on all send(2) calls -------------------- -- Socket options -- -------------------- - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_REUSEPORT : constant := 512; -- Bind reuse port number - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - IP_PKTINFO : constant := -1; -- Get datagram info + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_REUSEPORT : constant := 512; -- Bind reuse port number + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 4101; -- Emission timeout + SO_RCVTIMEO : constant := 4102; -- Reception timeout + SO_ERROR : constant := 4103; -- Get/clear error status + IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + IP_PKTINFO : constant := -1; -- Get datagram info ------------------- -- System limits -- ------------------- - IOV_MAX : constant := 16; -- Maximum writev iovcnt + IOV_MAX : constant := 16; -- Maximum writev iovcnt ---------------------- -- Type definitions -- @@ -177,18 +178,29 @@ package GNAT.Sockets.Constants is -- Sizes (in bytes) of the components of struct timeval - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec + SIZEOF_tv_sec : constant := 4; -- tv_sec + SIZEOF_tv_usec : constant := 4; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 28; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 8192; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.int; + subtype H_Length_T is Interfaces.C.int; ---------------------------------------- -- Properties of supported interfaces -- ---------------------------------------- - Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- + Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 0; -- Sockaddr has sa_len field Thread_Blocking_IO : constant Boolean := True; -- Set False for contexts where socket i/o are process blocking diff --git a/gcc/ada/g-soccon-darwin.ads b/gcc/ada/g-soccon-darwin.ads index 8b4ac6154a6..7e7922405eb 100644 --- a/gcc/ada/g-soccon-darwin.ads +++ b/gcc/ada/g-soccon-darwin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,141 +35,142 @@ -- by the GNAT.Sockets package (g-socket.ads). This package should not be -- directly with'ed by an applications program. --- This is the version for powerpc-apple-darwin8.9.0 +-- This is the version for i386-apple-darwin8.8.4 -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. +with Interfaces.C; package GNAT.Sockets.Constants is -------------- -- Families -- -------------- - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 30; -- IPv6 address family + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 30; -- IPv6 address family ----------- -- Modes -- ----------- - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket ------------------- -- Socket errors -- ------------------- - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 48; -- Address already in use - EADDRNOTAVAIL : constant := 49; -- Cannot assign address - EAFNOSUPPORT : constant := 47; -- Addr family not supported - EALREADY : constant := 37; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 53; -- Connection aborted - ECONNREFUSED : constant := 61; -- Connection refused - ECONNRESET : constant := 54; -- Connection reset by peer - EDESTADDRREQ : constant := 39; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 64; -- Host is down - EHOSTUNREACH : constant := 65; -- No route to host - EINPROGRESS : constant := 36; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 56; -- Socket already connected - ELOOP : constant := 62; -- Too many symbolic links - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 40; -- Message too long - ENAMETOOLONG : constant := 63; -- Name too long - ENETDOWN : constant := 50; -- Network is down - ENETRESET : constant := 52; -- Disconn. on network reset - ENETUNREACH : constant := 51; -- Network is unreachable - ENOBUFS : constant := 55; -- No buffer space available - ENOPROTOOPT : constant := 42; -- Protocol not available - ENOTCONN : constant := 57; -- Socket not connected - ENOTSOCK : constant := 38; -- Operation on non socket - EOPNOTSUPP : constant := 45; -- Operation not supported - EPFNOSUPPORT : constant := 46; -- Unknown protocol family - EPROTONOSUPPORT : constant := 43; -- Unknown protocol - EPROTOTYPE : constant := 41; -- Unknown protocol type - ESHUTDOWN : constant := 58; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported - ETIMEDOUT : constant := 60; -- Connection timed out - ETOOMANYREFS : constant := 59; -- Too many references - EWOULDBLOCK : constant := 35; -- Operation would block + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 48; -- Address already in use + EADDRNOTAVAIL : constant := 49; -- Cannot assign address + EAFNOSUPPORT : constant := 47; -- Addr family not supported + EALREADY : constant := 37; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 53; -- Connection aborted + ECONNREFUSED : constant := 61; -- Connection refused + ECONNRESET : constant := 54; -- Connection reset by peer + EDESTADDRREQ : constant := 39; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 64; -- Host is down + EHOSTUNREACH : constant := 65; -- No route to host + EINPROGRESS : constant := 36; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 56; -- Socket already connected + ELOOP : constant := 62; -- Too many symbolic links + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 40; -- Message too long + ENAMETOOLONG : constant := 63; -- Name too long + ENETDOWN : constant := 50; -- Network is down + ENETRESET : constant := 52; -- Disconn. on network reset + ENETUNREACH : constant := 51; -- Network is unreachable + ENOBUFS : constant := 55; -- No buffer space available + ENOPROTOOPT : constant := 42; -- Protocol not available + ENOTCONN : constant := 57; -- Socket not connected + ENOTSOCK : constant := 38; -- Operation on non socket + EOPNOTSUPP : constant := 45; -- Operation not supported + EPFNOSUPPORT : constant := 46; -- Unknown protocol family + EPROTONOSUPPORT : constant := 43; -- Unknown protocol + EPROTOTYPE : constant := 41; -- Unknown protocol type + ESHUTDOWN : constant := 58; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported + ETIMEDOUT : constant := 60; -- Connection timed out + ETOOMANYREFS : constant := 59; -- Too many references + EWOULDBLOCK : constant := 35; -- Operation would block ----------------- -- Host errors -- ----------------- - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors ------------------- -- Control flags -- ------------------- - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read -------------------- -- Shutdown modes -- -------------------- - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send --------------------- -- Protocol levels -- --------------------- - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP ------------------- -- Request flags -- ------------------- - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send + MSG_Forced_Flags : constant := 0; -- Flags set on all send(2) calls -------------------- -- Socket options -- -------------------- - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_REUSEPORT : constant := 512; -- Bind reuse port number - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - IP_PKTINFO : constant := -1; -- Get datagram info + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_REUSEPORT : constant := 512; -- Bind reuse port number + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 4101; -- Emission timeout + SO_RCVTIMEO : constant := 4102; -- Reception timeout + SO_ERROR : constant := 4103; -- Get/clear error status + IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + IP_PKTINFO : constant := -1; -- Get datagram info ------------------- -- System limits -- ------------------- - IOV_MAX : constant := 1024; -- Maximum writev iovcnt + IOV_MAX : constant := 1024; -- Maximum writev iovcnt ---------------------- -- Type definitions -- @@ -177,18 +178,29 @@ package GNAT.Sockets.Constants is -- Sizes (in bytes) of the components of struct timeval - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec + SIZEOF_tv_sec : constant := 4; -- tv_sec + SIZEOF_tv_usec : constant := 4; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 28; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 128; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.int; + subtype H_Length_T is Interfaces.C.int; ---------------------------------------- -- Properties of supported interfaces -- ---------------------------------------- - Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- + Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 0; -- Sockaddr has sa_len field Thread_Blocking_IO : constant Boolean := True; -- Set False for contexts where socket i/o are process blocking diff --git a/gcc/ada/g-soccon-freebsd.ads b/gcc/ada/g-soccon-freebsd.ads index 14fbf9d5299..8af0908ef97 100644 --- a/gcc/ada/g-soccon-freebsd.ads +++ b/gcc/ada/g-soccon-freebsd.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,137 +39,138 @@ -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. +with Interfaces.C; package GNAT.Sockets.Constants is -------------- -- Families -- -------------- - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 28; -- IPv6 address family + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 28; -- IPv6 address family ----------- -- Modes -- ----------- - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket ------------------- -- Socket errors -- ------------------- - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 48; -- Address already in use - EADDRNOTAVAIL : constant := 49; -- Cannot assign address - EAFNOSUPPORT : constant := 47; -- Addr family not supported - EALREADY : constant := 37; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 53; -- Connection aborted - ECONNREFUSED : constant := 61; -- Connection refused - ECONNRESET : constant := 54; -- Connection reset by peer - EDESTADDRREQ : constant := 39; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 64; -- Host is down - EHOSTUNREACH : constant := 65; -- No route to host - EINPROGRESS : constant := 36; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 56; -- Socket already connected - ELOOP : constant := 62; -- Too many symbolic links - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 40; -- Message too long - ENAMETOOLONG : constant := 63; -- Name too long - ENETDOWN : constant := 50; -- Network is down - ENETRESET : constant := 52; -- Disconn. on network reset - ENETUNREACH : constant := 51; -- Network is unreachable - ENOBUFS : constant := 55; -- No buffer space available - ENOPROTOOPT : constant := 42; -- Protocol not available - ENOTCONN : constant := 57; -- Socket not connected - ENOTSOCK : constant := 38; -- Operation on non socket - EOPNOTSUPP : constant := 45; -- Operation not supported - EPFNOSUPPORT : constant := 46; -- Unknown protocol family - EPROTONOSUPPORT : constant := 43; -- Unknown protocol - EPROTOTYPE : constant := 41; -- Unknown protocol type - ESHUTDOWN : constant := 58; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported - ETIMEDOUT : constant := 60; -- Connection timed out - ETOOMANYREFS : constant := 59; -- Too many references - EWOULDBLOCK : constant := 35; -- Operation would block + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 48; -- Address already in use + EADDRNOTAVAIL : constant := 49; -- Cannot assign address + EAFNOSUPPORT : constant := 47; -- Addr family not supported + EALREADY : constant := 37; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 53; -- Connection aborted + ECONNREFUSED : constant := 61; -- Connection refused + ECONNRESET : constant := 54; -- Connection reset by peer + EDESTADDRREQ : constant := 39; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 64; -- Host is down + EHOSTUNREACH : constant := 65; -- No route to host + EINPROGRESS : constant := 36; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 56; -- Socket already connected + ELOOP : constant := 62; -- Too many symbolic links + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 40; -- Message too long + ENAMETOOLONG : constant := 63; -- Name too long + ENETDOWN : constant := 50; -- Network is down + ENETRESET : constant := 52; -- Disconn. on network reset + ENETUNREACH : constant := 51; -- Network is unreachable + ENOBUFS : constant := 55; -- No buffer space available + ENOPROTOOPT : constant := 42; -- Protocol not available + ENOTCONN : constant := 57; -- Socket not connected + ENOTSOCK : constant := 38; -- Operation on non socket + EOPNOTSUPP : constant := 45; -- Operation not supported + EPFNOSUPPORT : constant := 46; -- Unknown protocol family + EPROTONOSUPPORT : constant := 43; -- Unknown protocol + EPROTOTYPE : constant := 41; -- Unknown protocol type + ESHUTDOWN : constant := 58; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported + ETIMEDOUT : constant := 60; -- Connection timed out + ETOOMANYREFS : constant := 59; -- Too many references + EWOULDBLOCK : constant := 35; -- Operation would block ----------------- -- Host errors -- ----------------- - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors ------------------- -- Control flags -- ------------------- - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read -------------------- -- Shutdown modes -- -------------------- - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send --------------------- -- Protocol levels -- --------------------- - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP ------------------- -- Request flags -- ------------------- - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := 131072; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + MSG_NOSIGNAL : constant := 131072; -- No SIGPIPE on send + MSG_Forced_Flags : constant := 0; -- Flags set on all send(2) calls -------------------- -- Socket options -- -------------------- - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_REUSEPORT : constant := 512; -- Bind reuse port number - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - IP_PKTINFO : constant := -1; -- Get datagram info + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_REUSEPORT : constant := 512; -- Bind reuse port number + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 4101; -- Emission timeout + SO_RCVTIMEO : constant := 4102; -- Reception timeout + SO_ERROR : constant := 4103; -- Get/clear error status + IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + IP_PKTINFO : constant := -1; -- Get datagram info ------------------- -- System limits -- ------------------- - IOV_MAX : constant := 1024; -- Maximum writev iovcnt + IOV_MAX : constant := 1024; -- Maximum writev iovcnt ---------------------- -- Type definitions -- @@ -177,18 +178,29 @@ package GNAT.Sockets.Constants is -- Sizes (in bytes) of the components of struct timeval - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec + SIZEOF_tv_sec : constant := 4; -- tv_sec + SIZEOF_tv_usec : constant := 4; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 28; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 128; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.int; + subtype H_Length_T is Interfaces.C.int; ---------------------------------------- -- Properties of supported interfaces -- ---------------------------------------- - Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- + Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 1; -- Sockaddr has sa_len field Thread_Blocking_IO : constant Boolean := True; -- Set False for contexts where socket i/o are process blocking diff --git a/gcc/ada/g-soccon-hpux-ia64.ads b/gcc/ada/g-soccon-hpux-ia64.ads index 38e287ef58a..4c364bd9532 100644 --- a/gcc/ada/g-soccon-hpux-ia64.ads +++ b/gcc/ada/g-soccon-hpux-ia64.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,137 +39,138 @@ -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. +with Interfaces.C; package GNAT.Sockets.Constants is -------------- -- Families -- -------------- - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 22; -- IPv6 address family + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 22; -- IPv6 address family ----------- -- Modes -- ----------- - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket ------------------- -- Socket errors -- ------------------- - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 226; -- Address already in use - EADDRNOTAVAIL : constant := 227; -- Cannot assign address - EAFNOSUPPORT : constant := 225; -- Addr family not supported - EALREADY : constant := 244; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 231; -- Connection aborted - ECONNREFUSED : constant := 239; -- Connection refused - ECONNRESET : constant := 232; -- Connection reset by peer - EDESTADDRREQ : constant := 217; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 241; -- Host is down - EHOSTUNREACH : constant := 242; -- No route to host - EINPROGRESS : constant := 245; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 234; -- Socket already connected - ELOOP : constant := 249; -- Too many symbolic links - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 218; -- Message too long - ENAMETOOLONG : constant := 248; -- Name too long - ENETDOWN : constant := 228; -- Network is down - ENETRESET : constant := 230; -- Disconn. on network reset - ENETUNREACH : constant := 229; -- Network is unreachable - ENOBUFS : constant := 233; -- No buffer space available - ENOPROTOOPT : constant := 220; -- Protocol not available - ENOTCONN : constant := 235; -- Socket not connected - ENOTSOCK : constant := 216; -- Operation on non socket - EOPNOTSUPP : constant := 223; -- Operation not supported - EPFNOSUPPORT : constant := 224; -- Unknown protocol family - EPROTONOSUPPORT : constant := 221; -- Unknown protocol - EPROTOTYPE : constant := 219; -- Unknown protocol type - ESHUTDOWN : constant := 236; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 222; -- Socket type not supported - ETIMEDOUT : constant := 238; -- Connection timed out - ETOOMANYREFS : constant := 237; -- Too many references - EWOULDBLOCK : constant := 246; -- Operation would block + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 226; -- Address already in use + EADDRNOTAVAIL : constant := 227; -- Cannot assign address + EAFNOSUPPORT : constant := 225; -- Addr family not supported + EALREADY : constant := 244; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 231; -- Connection aborted + ECONNREFUSED : constant := 239; -- Connection refused + ECONNRESET : constant := 232; -- Connection reset by peer + EDESTADDRREQ : constant := 217; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 241; -- Host is down + EHOSTUNREACH : constant := 242; -- No route to host + EINPROGRESS : constant := 245; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 234; -- Socket already connected + ELOOP : constant := 249; -- Too many symbolic links + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 218; -- Message too long + ENAMETOOLONG : constant := 248; -- Name too long + ENETDOWN : constant := 228; -- Network is down + ENETRESET : constant := 230; -- Disconn. on network reset + ENETUNREACH : constant := 229; -- Network is unreachable + ENOBUFS : constant := 233; -- No buffer space available + ENOPROTOOPT : constant := 220; -- Protocol not available + ENOTCONN : constant := 235; -- Socket not connected + ENOTSOCK : constant := 216; -- Operation on non socket + EOPNOTSUPP : constant := 223; -- Operation not supported + EPFNOSUPPORT : constant := 224; -- Unknown protocol family + EPROTONOSUPPORT : constant := 221; -- Unknown protocol + EPROTOTYPE : constant := 219; -- Unknown protocol type + ESHUTDOWN : constant := 236; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 222; -- Socket type not supported + ETIMEDOUT : constant := 238; -- Connection timed out + ETOOMANYREFS : constant := 237; -- Too many references + EWOULDBLOCK : constant := 246; -- Operation would block ----------------- -- Host errors -- ----------------- - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors ------------------- -- Control flags -- ------------------- - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read -------------------- -- Shutdown modes -- -------------------- - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send --------------------- -- Protocol levels -- --------------------- - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP ------------------- -- Request flags -- ------------------- - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send + MSG_Forced_Flags : constant := 0; -- Flags set on all send(2) calls -------------------- -- Socket options -- -------------------- - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_REUSEPORT : constant := 512; -- Bind reuse port number - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 2; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group - IP_PKTINFO : constant := -1; -- Get datagram info + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_REUSEPORT : constant := 512; -- Bind reuse port number + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 4101; -- Emission timeout + SO_RCVTIMEO : constant := 4102; -- Reception timeout + SO_ERROR : constant := 4103; -- Get/clear error status + IP_MULTICAST_IF : constant := 2; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group + IP_PKTINFO : constant := -1; -- Get datagram info ------------------- -- System limits -- ------------------- - IOV_MAX : constant := 16; -- Maximum writev iovcnt + IOV_MAX : constant := 16; -- Maximum writev iovcnt ---------------------- -- Type definitions -- @@ -177,18 +178,29 @@ package GNAT.Sockets.Constants is -- Sizes (in bytes) of the components of struct timeval - SIZEOF_tv_sec : constant := 8; -- tv_sec - SIZEOF_tv_usec : constant := 8; -- tv_usec + SIZEOF_tv_sec : constant := 8; -- tv_sec + SIZEOF_tv_usec : constant := 8; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 28; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 256; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.int; + subtype H_Length_T is Interfaces.C.int; ---------------------------------------- -- Properties of supported interfaces -- ---------------------------------------- - Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- + Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 0; -- Sockaddr has sa_len field Thread_Blocking_IO : constant Boolean := True; -- Set False for contexts where socket i/o are process blocking diff --git a/gcc/ada/g-soccon-hpux.ads b/gcc/ada/g-soccon-hpux.ads index c1851faee11..c49075def5a 100644 --- a/gcc/ada/g-soccon-hpux.ads +++ b/gcc/ada/g-soccon-hpux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,137 +39,138 @@ -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. +with Interfaces.C; package GNAT.Sockets.Constants is -------------- -- Families -- -------------- - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := -1; -- IPv6 address family + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := -1; -- IPv6 address family ----------- -- Modes -- ----------- - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket ------------------- -- Socket errors -- ------------------- - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 226; -- Address already in use - EADDRNOTAVAIL : constant := 227; -- Cannot assign address - EAFNOSUPPORT : constant := 225; -- Addr family not supported - EALREADY : constant := 244; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 231; -- Connection aborted - ECONNREFUSED : constant := 239; -- Connection refused - ECONNRESET : constant := 232; -- Connection reset by peer - EDESTADDRREQ : constant := 217; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 241; -- Host is down - EHOSTUNREACH : constant := 242; -- No route to host - EINPROGRESS : constant := 245; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 234; -- Socket already connected - ELOOP : constant := 249; -- Too many symbolic links - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 218; -- Message too long - ENAMETOOLONG : constant := 248; -- Name too long - ENETDOWN : constant := 228; -- Network is down - ENETRESET : constant := 230; -- Disconn. on network reset - ENETUNREACH : constant := 229; -- Network is unreachable - ENOBUFS : constant := 233; -- No buffer space available - ENOPROTOOPT : constant := 220; -- Protocol not available - ENOTCONN : constant := 235; -- Socket not connected - ENOTSOCK : constant := 216; -- Operation on non socket - EOPNOTSUPP : constant := 223; -- Operation not supported - EPFNOSUPPORT : constant := 224; -- Unknown protocol family - EPROTONOSUPPORT : constant := 221; -- Unknown protocol - EPROTOTYPE : constant := 219; -- Unknown protocol type - ESHUTDOWN : constant := 236; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 222; -- Socket type not supported - ETIMEDOUT : constant := 238; -- Connection timed out - ETOOMANYREFS : constant := 237; -- Too many references - EWOULDBLOCK : constant := 246; -- Operation would block + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 226; -- Address already in use + EADDRNOTAVAIL : constant := 227; -- Cannot assign address + EAFNOSUPPORT : constant := 225; -- Addr family not supported + EALREADY : constant := 244; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 231; -- Connection aborted + ECONNREFUSED : constant := 239; -- Connection refused + ECONNRESET : constant := 232; -- Connection reset by peer + EDESTADDRREQ : constant := 217; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 241; -- Host is down + EHOSTUNREACH : constant := 242; -- No route to host + EINPROGRESS : constant := 245; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 234; -- Socket already connected + ELOOP : constant := 249; -- Too many symbolic links + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 218; -- Message too long + ENAMETOOLONG : constant := 248; -- Name too long + ENETDOWN : constant := 228; -- Network is down + ENETRESET : constant := 230; -- Disconn. on network reset + ENETUNREACH : constant := 229; -- Network is unreachable + ENOBUFS : constant := 233; -- No buffer space available + ENOPROTOOPT : constant := 220; -- Protocol not available + ENOTCONN : constant := 235; -- Socket not connected + ENOTSOCK : constant := 216; -- Operation on non socket + EOPNOTSUPP : constant := 223; -- Operation not supported + EPFNOSUPPORT : constant := 224; -- Unknown protocol family + EPROTONOSUPPORT : constant := 221; -- Unknown protocol + EPROTOTYPE : constant := 219; -- Unknown protocol type + ESHUTDOWN : constant := 236; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 222; -- Socket type not supported + ETIMEDOUT : constant := 238; -- Connection timed out + ETOOMANYREFS : constant := 237; -- Too many references + EWOULDBLOCK : constant := 246; -- Operation would block ----------------- -- Host errors -- ----------------- - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors ------------------- -- Control flags -- ------------------- - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read -------------------- -- Shutdown modes -- -------------------- - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send --------------------- -- Protocol levels -- --------------------- - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP ------------------- -- Request flags -- ------------------- - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send + MSG_Forced_Flags : constant := 0; -- Flags set on all send(2) calls -------------------- -- Socket options -- -------------------- - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_REUSEPORT : constant := 512; -- Bind reuse port number - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 2; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group - IP_PKTINFO : constant := -1; -- Get datagram info + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_REUSEPORT : constant := 512; -- Bind reuse port number + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 4101; -- Emission timeout + SO_RCVTIMEO : constant := 4102; -- Reception timeout + SO_ERROR : constant := 4103; -- Get/clear error status + IP_MULTICAST_IF : constant := 2; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group + IP_PKTINFO : constant := -1; -- Get datagram info ------------------- -- System limits -- ------------------- - IOV_MAX : constant := 16; -- Maximum writev iovcnt + IOV_MAX : constant := 16; -- Maximum writev iovcnt ---------------------- -- Type definitions -- @@ -177,18 +178,29 @@ package GNAT.Sockets.Constants is -- Sizes (in bytes) of the components of struct timeval - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec + SIZEOF_tv_sec : constant := 4; -- tv_sec + SIZEOF_tv_usec : constant := 4; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 0; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 256; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.int; + subtype H_Length_T is Interfaces.C.int; ---------------------------------------- -- Properties of supported interfaces -- ---------------------------------------- - Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- + Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 0; -- Sockaddr has sa_len field Thread_Blocking_IO : constant Boolean := True; -- Set False for contexts where socket i/o are process blocking diff --git a/gcc/ada/g-soccon-irix.ads b/gcc/ada/g-soccon-irix.ads index a00ff051b54..3952a599efe 100644 --- a/gcc/ada/g-soccon-irix.ads +++ b/gcc/ada/g-soccon-irix.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,137 +39,138 @@ -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. +with Interfaces.C; package GNAT.Sockets.Constants is -------------- -- Families -- -------------- - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 24; -- IPv6 address family + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 24; -- IPv6 address family ----------- -- Modes -- ----------- - SOCK_STREAM : constant := 2; -- Stream socket - SOCK_DGRAM : constant := 1; -- Datagram socket + SOCK_STREAM : constant := 2; -- Stream socket + SOCK_DGRAM : constant := 1; -- Datagram socket ------------------- -- Socket errors -- ------------------- - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 125; -- Address already in use - EADDRNOTAVAIL : constant := 126; -- Cannot assign address - EAFNOSUPPORT : constant := 124; -- Addr family not supported - EALREADY : constant := 149; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 130; -- Connection aborted - ECONNREFUSED : constant := 146; -- Connection refused - ECONNRESET : constant := 131; -- Connection reset by peer - EDESTADDRREQ : constant := 96; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 147; -- Host is down - EHOSTUNREACH : constant := 148; -- No route to host - EINPROGRESS : constant := 150; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 133; -- Socket already connected - ELOOP : constant := 90; -- Too many symbolic links - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 97; -- Message too long - ENAMETOOLONG : constant := 78; -- Name too long - ENETDOWN : constant := 127; -- Network is down - ENETRESET : constant := 129; -- Disconn. on network reset - ENETUNREACH : constant := 128; -- Network is unreachable - ENOBUFS : constant := 132; -- No buffer space available - ENOPROTOOPT : constant := 99; -- Protocol not available - ENOTCONN : constant := 134; -- Socket not connected - ENOTSOCK : constant := 95; -- Operation on non socket - EOPNOTSUPP : constant := 122; -- Operation not supported - EPFNOSUPPORT : constant := 123; -- Unknown protocol family - EPROTONOSUPPORT : constant := 120; -- Unknown protocol - EPROTOTYPE : constant := 98; -- Unknown protocol type - ESHUTDOWN : constant := 143; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported - ETIMEDOUT : constant := 145; -- Connection timed out - ETOOMANYREFS : constant := 144; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 125; -- Address already in use + EADDRNOTAVAIL : constant := 126; -- Cannot assign address + EAFNOSUPPORT : constant := 124; -- Addr family not supported + EALREADY : constant := 149; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 130; -- Connection aborted + ECONNREFUSED : constant := 146; -- Connection refused + ECONNRESET : constant := 131; -- Connection reset by peer + EDESTADDRREQ : constant := 96; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 147; -- Host is down + EHOSTUNREACH : constant := 148; -- No route to host + EINPROGRESS : constant := 150; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 133; -- Socket already connected + ELOOP : constant := 90; -- Too many symbolic links + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 97; -- Message too long + ENAMETOOLONG : constant := 78; -- Name too long + ENETDOWN : constant := 127; -- Network is down + ENETRESET : constant := 129; -- Disconn. on network reset + ENETUNREACH : constant := 128; -- Network is unreachable + ENOBUFS : constant := 132; -- No buffer space available + ENOPROTOOPT : constant := 99; -- Protocol not available + ENOTCONN : constant := 134; -- Socket not connected + ENOTSOCK : constant := 95; -- Operation on non socket + EOPNOTSUPP : constant := 122; -- Operation not supported + EPFNOSUPPORT : constant := 123; -- Unknown protocol family + EPROTONOSUPPORT : constant := 120; -- Unknown protocol + EPROTOTYPE : constant := 98; -- Unknown protocol type + ESHUTDOWN : constant := 143; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported + ETIMEDOUT : constant := 145; -- Connection timed out + ETOOMANYREFS : constant := 144; -- Too many references + EWOULDBLOCK : constant := 11; -- Operation would block ----------------- -- Host errors -- ----------------- - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors ------------------- -- Control flags -- ------------------- - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read -------------------- -- Shutdown modes -- -------------------- - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send --------------------- -- Protocol levels -- --------------------- - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP ------------------- -- Request flags -- ------------------- - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send + MSG_Forced_Flags : constant := 0; -- Flags set on all send(2) calls -------------------- -- Socket options -- -------------------- - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_REUSEPORT : constant := 512; -- Bind reuse port number - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 20; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 21; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 22; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 23; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 24; -- Leave a multicast group - IP_PKTINFO : constant := -1; -- Get datagram info + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_REUSEPORT : constant := 512; -- Bind reuse port number + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 4101; -- Emission timeout + SO_RCVTIMEO : constant := 4102; -- Reception timeout + SO_ERROR : constant := 4103; -- Get/clear error status + IP_MULTICAST_IF : constant := 20; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 21; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 22; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 23; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 24; -- Leave a multicast group + IP_PKTINFO : constant := -1; -- Get datagram info ------------------- -- System limits -- ------------------- - IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt + IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt ---------------------- -- Type definitions -- @@ -177,18 +178,29 @@ package GNAT.Sockets.Constants is -- Sizes (in bytes) of the components of struct timeval - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec + SIZEOF_tv_sec : constant := 4; -- tv_sec + SIZEOF_tv_usec : constant := 4; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 32; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 128; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.int; + subtype H_Length_T is Interfaces.C.int; ---------------------------------------- -- Properties of supported interfaces -- ---------------------------------------- - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- + Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 0; -- Sockaddr has sa_len field Thread_Blocking_IO : constant Boolean := True; -- Set False for contexts where socket i/o are process blocking diff --git a/gcc/ada/g-soccon-linux-64.ads b/gcc/ada/g-soccon-linux-64.ads index cd4332df743..3d82b326ecf 100644 --- a/gcc/ada/g-soccon-linux-64.ads +++ b/gcc/ada/g-soccon-linux-64.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,137 +39,138 @@ -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. +with Interfaces.C; package GNAT.Sockets.Constants is -------------- -- Families -- -------------- - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 10; -- IPv6 address family + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 10; -- IPv6 address family ----------- -- Modes -- ----------- - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket ------------------- -- Socket errors -- ------------------- - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 98; -- Address already in use - EADDRNOTAVAIL : constant := 99; -- Cannot assign address - EAFNOSUPPORT : constant := 97; -- Addr family not supported - EALREADY : constant := 114; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 103; -- Connection aborted - ECONNREFUSED : constant := 111; -- Connection refused - ECONNRESET : constant := 104; -- Connection reset by peer - EDESTADDRREQ : constant := 89; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 112; -- Host is down - EHOSTUNREACH : constant := 113; -- No route to host - EINPROGRESS : constant := 115; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 106; -- Socket already connected - ELOOP : constant := 40; -- Too many symbolic links - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 90; -- Message too long - ENAMETOOLONG : constant := 36; -- Name too long - ENETDOWN : constant := 100; -- Network is down - ENETRESET : constant := 102; -- Disconn. on network reset - ENETUNREACH : constant := 101; -- Network is unreachable - ENOBUFS : constant := 105; -- No buffer space available - ENOPROTOOPT : constant := 92; -- Protocol not available - ENOTCONN : constant := 107; -- Socket not connected - ENOTSOCK : constant := 88; -- Operation on non socket - EOPNOTSUPP : constant := 95; -- Operation not supported - EPFNOSUPPORT : constant := 96; -- Unknown protocol family - EPROTONOSUPPORT : constant := 93; -- Unknown protocol - EPROTOTYPE : constant := 91; -- Unknown protocol type - ESHUTDOWN : constant := 108; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 94; -- Socket type not supported - ETIMEDOUT : constant := 110; -- Connection timed out - ETOOMANYREFS : constant := 109; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 98; -- Address already in use + EADDRNOTAVAIL : constant := 99; -- Cannot assign address + EAFNOSUPPORT : constant := 97; -- Addr family not supported + EALREADY : constant := 114; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 103; -- Connection aborted + ECONNREFUSED : constant := 111; -- Connection refused + ECONNRESET : constant := 104; -- Connection reset by peer + EDESTADDRREQ : constant := 89; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 112; -- Host is down + EHOSTUNREACH : constant := 113; -- No route to host + EINPROGRESS : constant := 115; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 106; -- Socket already connected + ELOOP : constant := 40; -- Too many symbolic links + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 90; -- Message too long + ENAMETOOLONG : constant := 36; -- Name too long + ENETDOWN : constant := 100; -- Network is down + ENETRESET : constant := 102; -- Disconn. on network reset + ENETUNREACH : constant := 101; -- Network is unreachable + ENOBUFS : constant := 105; -- No buffer space available + ENOPROTOOPT : constant := 92; -- Protocol not available + ENOTCONN : constant := 107; -- Socket not connected + ENOTSOCK : constant := 88; -- Operation on non socket + EOPNOTSUPP : constant := 95; -- Operation not supported + EPFNOSUPPORT : constant := 96; -- Unknown protocol family + EPROTONOSUPPORT : constant := 93; -- Unknown protocol + EPROTOTYPE : constant := 91; -- Unknown protocol type + ESHUTDOWN : constant := 108; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 94; -- Socket type not supported + ETIMEDOUT : constant := 110; -- Connection timed out + ETOOMANYREFS : constant := 109; -- Too many references + EWOULDBLOCK : constant := 11; -- Operation would block ----------------- -- Host errors -- ----------------- - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors ------------------- -- Control flags -- ------------------- - FIONBIO : constant := 21537; -- Set/clear non-blocking io - FIONREAD : constant := 21531; -- How many bytes to read + FIONBIO : constant := 21537; -- Set/clear non-blocking io + FIONREAD : constant := 21531; -- How many bytes to read -------------------- -- Shutdown modes -- -------------------- - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send --------------------- -- Protocol levels -- --------------------- - SOL_SOCKET : constant := 1; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP + SOL_SOCKET : constant := 1; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP ------------------- -- Request flags -- ------------------- - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 128; -- Send end of record - MSG_WAITALL : constant := 256; -- Wait for full reception - MSG_NOSIGNAL : constant := 16384; -- No SIGPIPE on send - MSG_Forced_Flags : constant := MSG_NOSIGNAL; + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 128; -- Send end of record + MSG_WAITALL : constant := 256; -- Wait for full reception + MSG_NOSIGNAL : constant := 16384; -- No SIGPIPE on send + MSG_Forced_Flags : constant := MSG_NOSIGNAL; -- Flags set on all send(2) calls -------------------- -- Socket options -- -------------------- - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 2; -- Bind reuse local address - SO_REUSEPORT : constant := -1; -- Bind reuse port number - SO_KEEPALIVE : constant := 9; -- Enable keep-alive msgs - SO_LINGER : constant := 13; -- Defer close to flush data - SO_BROADCAST : constant := 6; -- Can send broadcast msgs - SO_SNDBUF : constant := 7; -- Set/get send buffer size - SO_RCVBUF : constant := 8; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 21; -- Emission timeout - SO_RCVTIMEO : constant := 20; -- Reception timeout - SO_ERROR : constant := 4; -- Get/clear error status - IP_MULTICAST_IF : constant := 32; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 33; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 34; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 35; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 36; -- Leave a multicast group - IP_PKTINFO : constant := 8; -- Get datagram info + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 2; -- Bind reuse local address + SO_REUSEPORT : constant := -1; -- Bind reuse port number + SO_KEEPALIVE : constant := 9; -- Enable keep-alive msgs + SO_LINGER : constant := 13; -- Defer close to flush data + SO_BROADCAST : constant := 6; -- Can send broadcast msgs + SO_SNDBUF : constant := 7; -- Set/get send buffer size + SO_RCVBUF : constant := 8; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 21; -- Emission timeout + SO_RCVTIMEO : constant := 20; -- Reception timeout + SO_ERROR : constant := 4; -- Get/clear error status + IP_MULTICAST_IF : constant := 32; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 33; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 34; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 35; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 36; -- Leave a multicast group + IP_PKTINFO : constant := 8; -- Get datagram info ------------------- -- System limits -- ------------------- - IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt + IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt ---------------------- -- Type definitions -- @@ -177,18 +178,29 @@ package GNAT.Sockets.Constants is -- Sizes (in bytes) of the components of struct timeval - SIZEOF_tv_sec : constant := 8; -- tv_sec - SIZEOF_tv_usec : constant := 8; -- tv_usec + SIZEOF_tv_sec : constant := 8; -- tv_sec + SIZEOF_tv_usec : constant := 8; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 28; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 128; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.int; + subtype H_Length_T is Interfaces.C.int; ---------------------------------------- -- Properties of supported interfaces -- ---------------------------------------- - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- + Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 0; -- Sockaddr has sa_len field Thread_Blocking_IO : constant Boolean := True; -- Set False for contexts where socket i/o are process blocking diff --git a/gcc/ada/g-soccon-linux-ppc.ads b/gcc/ada/g-soccon-linux-ppc.ads index 4ae8556f48e..7a8c2e260b3 100644 --- a/gcc/ada/g-soccon-linux-ppc.ads +++ b/gcc/ada/g-soccon-linux-ppc.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,141 +35,142 @@ -- by the GNAT.Sockets package (g-socket.ads). This package should not be -- directly with'ed by an applications program. --- This is the version for powerpc-linux +-- This is the version for ppc-unknown-linux-gnu -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. +with Interfaces.C; package GNAT.Sockets.Constants is -------------- -- Families -- -------------- - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 10; -- IPv6 address family + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 10; -- IPv6 address family ----------- -- Modes -- ----------- - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket ------------------- -- Socket errors -- ------------------- - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 98; -- Address already in use - EADDRNOTAVAIL : constant := 99; -- Cannot assign address - EAFNOSUPPORT : constant := 97; -- Addr family not supported - EALREADY : constant := 114; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 103; -- Connection aborted - ECONNREFUSED : constant := 111; -- Connection refused - ECONNRESET : constant := 104; -- Connection reset by peer - EDESTADDRREQ : constant := 89; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 112; -- Host is down - EHOSTUNREACH : constant := 113; -- No route to host - EINPROGRESS : constant := 115; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 106; -- Socket already connected - ELOOP : constant := 40; -- Too many symbolic links - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 90; -- Message too long - ENAMETOOLONG : constant := 36; -- Name too long - ENETDOWN : constant := 100; -- Network is down - ENETRESET : constant := 102; -- Disconn. on network reset - ENETUNREACH : constant := 101; -- Network is unreachable - ENOBUFS : constant := 105; -- No buffer space available - ENOPROTOOPT : constant := 92; -- Protocol not available - ENOTCONN : constant := 107; -- Socket not connected - ENOTSOCK : constant := 88; -- Operation on non socket - EOPNOTSUPP : constant := 95; -- Operation not supported - EPFNOSUPPORT : constant := 96; -- Unknown protocol family - EPROTONOSUPPORT : constant := 93; -- Unknown protocol - EPROTOTYPE : constant := 91; -- Unknown protocol type - ESHUTDOWN : constant := 108; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 94; -- Socket type not supported - ETIMEDOUT : constant := 110; -- Connection timed out - ETOOMANYREFS : constant := 109; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 98; -- Address already in use + EADDRNOTAVAIL : constant := 99; -- Cannot assign address + EAFNOSUPPORT : constant := 97; -- Addr family not supported + EALREADY : constant := 114; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 103; -- Connection aborted + ECONNREFUSED : constant := 111; -- Connection refused + ECONNRESET : constant := 104; -- Connection reset by peer + EDESTADDRREQ : constant := 89; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 112; -- Host is down + EHOSTUNREACH : constant := 113; -- No route to host + EINPROGRESS : constant := 115; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 106; -- Socket already connected + ELOOP : constant := 40; -- Too many symbolic links + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 90; -- Message too long + ENAMETOOLONG : constant := 36; -- Name too long + ENETDOWN : constant := 100; -- Network is down + ENETRESET : constant := 102; -- Disconn. on network reset + ENETUNREACH : constant := 101; -- Network is unreachable + ENOBUFS : constant := 105; -- No buffer space available + ENOPROTOOPT : constant := 92; -- Protocol not available + ENOTCONN : constant := 107; -- Socket not connected + ENOTSOCK : constant := 88; -- Operation on non socket + EOPNOTSUPP : constant := 95; -- Operation not supported + EPFNOSUPPORT : constant := 96; -- Unknown protocol family + EPROTONOSUPPORT : constant := 93; -- Unknown protocol + EPROTOTYPE : constant := 91; -- Unknown protocol type + ESHUTDOWN : constant := 108; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 94; -- Socket type not supported + ETIMEDOUT : constant := 110; -- Connection timed out + ETOOMANYREFS : constant := 109; -- Too many references + EWOULDBLOCK : constant := 11; -- Operation would block ----------------- -- Host errors -- ----------------- - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors ------------------- -- Control flags -- ------------------- - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read -------------------- -- Shutdown modes -- -------------------- - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send --------------------- -- Protocol levels -- --------------------- - SOL_SOCKET : constant := 1; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP + SOL_SOCKET : constant := 1; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP ------------------- -- Request flags -- ------------------- - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 128; -- Send end of record - MSG_WAITALL : constant := 256; -- Wait for full reception - MSG_NOSIGNAL : constant := 16384; -- No SIGPIPE on send - MSG_Forced_Flags : constant := MSG_NOSIGNAL; + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 128; -- Send end of record + MSG_WAITALL : constant := 256; -- Wait for full reception + MSG_NOSIGNAL : constant := 16384; -- No SIGPIPE on send + MSG_Forced_Flags : constant := MSG_NOSIGNAL; -- Flags set on all send(2) calls -------------------- -- Socket options -- -------------------- - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 2; -- Bind reuse local address - SO_REUSEPORT : constant := -1; -- Bind reuse port number - SO_KEEPALIVE : constant := 9; -- Enable keep-alive msgs - SO_LINGER : constant := 13; -- Defer close to flush data - SO_BROADCAST : constant := 6; -- Can send broadcast msgs - SO_SNDBUF : constant := 7; -- Set/get send buffer size - SO_RCVBUF : constant := 8; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 19; -- Emission timeout - SO_RCVTIMEO : constant := 18; -- Reception timeout - SO_ERROR : constant := 4; -- Get/clear error status - IP_MULTICAST_IF : constant := 32; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 33; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 34; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 35; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 36; -- Leave a multicast group - IP_PKTINFO : constant := 8; -- Get datagram info + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 2; -- Bind reuse local address + SO_REUSEPORT : constant := -1; -- Bind reuse port number + SO_KEEPALIVE : constant := 9; -- Enable keep-alive msgs + SO_LINGER : constant := 13; -- Defer close to flush data + SO_BROADCAST : constant := 6; -- Can send broadcast msgs + SO_SNDBUF : constant := 7; -- Set/get send buffer size + SO_RCVBUF : constant := 8; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 19; -- Emission timeout + SO_RCVTIMEO : constant := 18; -- Reception timeout + SO_ERROR : constant := 4; -- Get/clear error status + IP_MULTICAST_IF : constant := 32; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 33; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 34; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 35; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 36; -- Leave a multicast group + IP_PKTINFO : constant := 8; -- Get datagram info ------------------- -- System limits -- ------------------- - IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt + IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt ---------------------- -- Type definitions -- @@ -177,18 +178,29 @@ package GNAT.Sockets.Constants is -- Sizes (in bytes) of the components of struct timeval - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec + SIZEOF_tv_sec : constant := 4; -- tv_sec + SIZEOF_tv_usec : constant := 4; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 28; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 128; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.int; + subtype H_Length_T is Interfaces.C.int; ---------------------------------------- -- Properties of supported interfaces -- ---------------------------------------- - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- + Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 0; -- Sockaddr has sa_len field Thread_Blocking_IO : constant Boolean := True; -- Set False for contexts where socket i/o are process blocking diff --git a/gcc/ada/g-soccon-linux-x86.ads b/gcc/ada/g-soccon-linux-x86.ads index b1c9188c7bc..ed2b8d9624d 100644 --- a/gcc/ada/g-soccon-linux-x86.ads +++ b/gcc/ada/g-soccon-linux-x86.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,137 +39,138 @@ -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. +with Interfaces.C; package GNAT.Sockets.Constants is -------------- -- Families -- -------------- - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 10; -- IPv6 address family + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 10; -- IPv6 address family ----------- -- Modes -- ----------- - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket ------------------- -- Socket errors -- ------------------- - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 98; -- Address already in use - EADDRNOTAVAIL : constant := 99; -- Cannot assign address - EAFNOSUPPORT : constant := 97; -- Addr family not supported - EALREADY : constant := 114; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 103; -- Connection aborted - ECONNREFUSED : constant := 111; -- Connection refused - ECONNRESET : constant := 104; -- Connection reset by peer - EDESTADDRREQ : constant := 89; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 112; -- Host is down - EHOSTUNREACH : constant := 113; -- No route to host - EINPROGRESS : constant := 115; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 106; -- Socket already connected - ELOOP : constant := 40; -- Too many symbolic links - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 90; -- Message too long - ENAMETOOLONG : constant := 36; -- Name too long - ENETDOWN : constant := 100; -- Network is down - ENETRESET : constant := 102; -- Disconn. on network reset - ENETUNREACH : constant := 101; -- Network is unreachable - ENOBUFS : constant := 105; -- No buffer space available - ENOPROTOOPT : constant := 92; -- Protocol not available - ENOTCONN : constant := 107; -- Socket not connected - ENOTSOCK : constant := 88; -- Operation on non socket - EOPNOTSUPP : constant := 95; -- Operation not supported - EPFNOSUPPORT : constant := 96; -- Unknown protocol family - EPROTONOSUPPORT : constant := 93; -- Unknown protocol - EPROTOTYPE : constant := 91; -- Unknown protocol type - ESHUTDOWN : constant := 108; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 94; -- Socket type not supported - ETIMEDOUT : constant := 110; -- Connection timed out - ETOOMANYREFS : constant := 109; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 98; -- Address already in use + EADDRNOTAVAIL : constant := 99; -- Cannot assign address + EAFNOSUPPORT : constant := 97; -- Addr family not supported + EALREADY : constant := 114; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 103; -- Connection aborted + ECONNREFUSED : constant := 111; -- Connection refused + ECONNRESET : constant := 104; -- Connection reset by peer + EDESTADDRREQ : constant := 89; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 112; -- Host is down + EHOSTUNREACH : constant := 113; -- No route to host + EINPROGRESS : constant := 115; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 106; -- Socket already connected + ELOOP : constant := 40; -- Too many symbolic links + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 90; -- Message too long + ENAMETOOLONG : constant := 36; -- Name too long + ENETDOWN : constant := 100; -- Network is down + ENETRESET : constant := 102; -- Disconn. on network reset + ENETUNREACH : constant := 101; -- Network is unreachable + ENOBUFS : constant := 105; -- No buffer space available + ENOPROTOOPT : constant := 92; -- Protocol not available + ENOTCONN : constant := 107; -- Socket not connected + ENOTSOCK : constant := 88; -- Operation on non socket + EOPNOTSUPP : constant := 95; -- Operation not supported + EPFNOSUPPORT : constant := 96; -- Unknown protocol family + EPROTONOSUPPORT : constant := 93; -- Unknown protocol + EPROTOTYPE : constant := 91; -- Unknown protocol type + ESHUTDOWN : constant := 108; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 94; -- Socket type not supported + ETIMEDOUT : constant := 110; -- Connection timed out + ETOOMANYREFS : constant := 109; -- Too many references + EWOULDBLOCK : constant := 11; -- Operation would block ----------------- -- Host errors -- ----------------- - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors ------------------- -- Control flags -- ------------------- - FIONBIO : constant := 21537; -- Set/clear non-blocking io - FIONREAD : constant := 21531; -- How many bytes to read + FIONBIO : constant := 21537; -- Set/clear non-blocking io + FIONREAD : constant := 21531; -- How many bytes to read -------------------- -- Shutdown modes -- -------------------- - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send --------------------- -- Protocol levels -- --------------------- - SOL_SOCKET : constant := 1; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP + SOL_SOCKET : constant := 1; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP ------------------- -- Request flags -- ------------------- - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 128; -- Send end of record - MSG_WAITALL : constant := 256; -- Wait for full reception - MSG_NOSIGNAL : constant := 16384; -- No SIGPIPE on send - MSG_Forced_Flags : constant := MSG_NOSIGNAL; + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 128; -- Send end of record + MSG_WAITALL : constant := 256; -- Wait for full reception + MSG_NOSIGNAL : constant := 16384; -- No SIGPIPE on send + MSG_Forced_Flags : constant := MSG_NOSIGNAL; -- Flags set on all send(2) calls -------------------- -- Socket options -- -------------------- - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 2; -- Bind reuse local address - SO_REUSEPORT : constant := -1; -- Bind reuse port number - SO_KEEPALIVE : constant := 9; -- Enable keep-alive msgs - SO_LINGER : constant := 13; -- Defer close to flush data - SO_BROADCAST : constant := 6; -- Can send broadcast msgs - SO_SNDBUF : constant := 7; -- Set/get send buffer size - SO_RCVBUF : constant := 8; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 21; -- Emission timeout - SO_RCVTIMEO : constant := 20; -- Reception timeout - SO_ERROR : constant := 4; -- Get/clear error status - IP_MULTICAST_IF : constant := 32; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 33; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 34; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 35; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 36; -- Leave a multicast group - IP_PKTINFO : constant := 8; -- Get datagram info + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 2; -- Bind reuse local address + SO_REUSEPORT : constant := -1; -- Bind reuse port number + SO_KEEPALIVE : constant := 9; -- Enable keep-alive msgs + SO_LINGER : constant := 13; -- Defer close to flush data + SO_BROADCAST : constant := 6; -- Can send broadcast msgs + SO_SNDBUF : constant := 7; -- Set/get send buffer size + SO_RCVBUF : constant := 8; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 21; -- Emission timeout + SO_RCVTIMEO : constant := 20; -- Reception timeout + SO_ERROR : constant := 4; -- Get/clear error status + IP_MULTICAST_IF : constant := 32; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 33; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 34; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 35; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 36; -- Leave a multicast group + IP_PKTINFO : constant := 8; -- Get datagram info ------------------- -- System limits -- ------------------- - IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt + IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt ---------------------- -- Type definitions -- @@ -177,18 +178,29 @@ package GNAT.Sockets.Constants is -- Sizes (in bytes) of the components of struct timeval - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec + SIZEOF_tv_sec : constant := 4; -- tv_sec + SIZEOF_tv_usec : constant := 4; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 28; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 128; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.int; + subtype H_Length_T is Interfaces.C.int; ---------------------------------------- -- Properties of supported interfaces -- ---------------------------------------- - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- + Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 0; -- Sockaddr has sa_len field Thread_Blocking_IO : constant Boolean := True; -- Set False for contexts where socket i/o are process blocking diff --git a/gcc/ada/g-soccon-lynxos.ads b/gcc/ada/g-soccon-lynxos.ads index ee0fa91596e..04c75bf63e4 100644 --- a/gcc/ada/g-soccon-lynxos.ads +++ b/gcc/ada/g-soccon-lynxos.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,137 +39,138 @@ -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. +with Interfaces.C; package GNAT.Sockets.Constants is -------------- -- Families -- -------------- - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 28; -- IPv6 address family + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 28; -- IPv6 address family ----------- -- Modes -- ----------- - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket ------------------- -- Socket errors -- ------------------- - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 98; -- Address already in use - EADDRNOTAVAIL : constant := 99; -- Cannot assign address - EAFNOSUPPORT : constant := 97; -- Addr family not supported - EALREADY : constant := 114; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 103; -- Connection aborted - ECONNREFUSED : constant := 111; -- Connection refused - ECONNRESET : constant := 104; -- Connection reset by peer - EDESTADDRREQ : constant := 89; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 112; -- Host is down - EHOSTUNREACH : constant := 113; -- No route to host - EINPROGRESS : constant := 115; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 106; -- Socket already connected - ELOOP : constant := 40; -- Too many symbolic links - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 90; -- Message too long - ENAMETOOLONG : constant := 36; -- Name too long - ENETDOWN : constant := 100; -- Network is down - ENETRESET : constant := 102; -- Disconn. on network reset - ENETUNREACH : constant := 101; -- Network is unreachable - ENOBUFS : constant := 105; -- No buffer space available - ENOPROTOOPT : constant := 92; -- Protocol not available - ENOTCONN : constant := 107; -- Socket not connected - ENOTSOCK : constant := 88; -- Operation on non socket - EOPNOTSUPP : constant := 95; -- Operation not supported - EPFNOSUPPORT : constant := 96; -- Unknown protocol family - EPROTONOSUPPORT : constant := 93; -- Unknown protocol - EPROTOTYPE : constant := 91; -- Unknown protocol type - ESHUTDOWN : constant := 108; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 94; -- Socket type not supported - ETIMEDOUT : constant := 110; -- Connection timed out - ETOOMANYREFS : constant := 109; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 98; -- Address already in use + EADDRNOTAVAIL : constant := 99; -- Cannot assign address + EAFNOSUPPORT : constant := 97; -- Addr family not supported + EALREADY : constant := 114; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 103; -- Connection aborted + ECONNREFUSED : constant := 111; -- Connection refused + ECONNRESET : constant := 104; -- Connection reset by peer + EDESTADDRREQ : constant := 89; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 112; -- Host is down + EHOSTUNREACH : constant := 113; -- No route to host + EINPROGRESS : constant := 115; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 106; -- Socket already connected + ELOOP : constant := 40; -- Too many symbolic links + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 90; -- Message too long + ENAMETOOLONG : constant := 36; -- Name too long + ENETDOWN : constant := 100; -- Network is down + ENETRESET : constant := 102; -- Disconn. on network reset + ENETUNREACH : constant := 101; -- Network is unreachable + ENOBUFS : constant := 105; -- No buffer space available + ENOPROTOOPT : constant := 92; -- Protocol not available + ENOTCONN : constant := 107; -- Socket not connected + ENOTSOCK : constant := 88; -- Operation on non socket + EOPNOTSUPP : constant := 95; -- Operation not supported + EPFNOSUPPORT : constant := 96; -- Unknown protocol family + EPROTONOSUPPORT : constant := 93; -- Unknown protocol + EPROTOTYPE : constant := 91; -- Unknown protocol type + ESHUTDOWN : constant := 108; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 94; -- Socket type not supported + ETIMEDOUT : constant := 110; -- Connection timed out + ETOOMANYREFS : constant := 109; -- Too many references + EWOULDBLOCK : constant := 11; -- Operation would block ----------------- -- Host errors -- ----------------- - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors ------------------- -- Control flags -- ------------------- - FIONBIO : constant := 21537; -- Set/clear non-blocking io - FIONREAD : constant := 21531; -- How many bytes to read + FIONBIO : constant := 21537; -- Set/clear non-blocking io + FIONREAD : constant := 21531; -- How many bytes to read -------------------- -- Shutdown modes -- -------------------- - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send --------------------- -- Protocol levels -- --------------------- - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP ------------------- -- Request flags -- ------------------- - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 128; -- Send end of record - MSG_WAITALL : constant := 256; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 128; -- Send end of record + MSG_WAITALL : constant := 256; -- Wait for full reception + MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send + MSG_Forced_Flags : constant := 0; -- Flags set on all send(2) calls -------------------- -- Socket options -- -------------------- - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_REUSEPORT : constant := 512; -- Bind reuse port number - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - IP_PKTINFO : constant := -1; -- Get datagram info + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_REUSEPORT : constant := 512; -- Bind reuse port number + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 4101; -- Emission timeout + SO_RCVTIMEO : constant := 4102; -- Reception timeout + SO_ERROR : constant := 4103; -- Get/clear error status + IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + IP_PKTINFO : constant := -1; -- Get datagram info ------------------- -- System limits -- ------------------- - IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt + IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt ---------------------- -- Type definitions -- @@ -177,18 +178,29 @@ package GNAT.Sockets.Constants is -- Sizes (in bytes) of the components of struct timeval - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec + SIZEOF_tv_sec : constant := 4; -- tv_sec + SIZEOF_tv_usec : constant := 4; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 28; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 512; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.int; + subtype H_Length_T is Interfaces.C.int; ---------------------------------------- -- Properties of supported interfaces -- ---------------------------------------- - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- + Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 0; -- Sockaddr has sa_len field Thread_Blocking_IO : constant Boolean := True; -- Set False for contexts where socket i/o are process blocking diff --git a/gcc/ada/g-soccon-mingw.ads b/gcc/ada/g-soccon-mingw.ads index 1266a4bfdc9..3bb83e4bebe 100644 --- a/gcc/ada/g-soccon-mingw.ads +++ b/gcc/ada/g-soccon-mingw.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,137 +39,138 @@ -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. +with Interfaces.C; package GNAT.Sockets.Constants is -------------- -- Families -- -------------- - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 23; -- IPv6 address family + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 23; -- IPv6 address family ----------- -- Modes -- ----------- - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket ------------------- -- Socket errors -- ------------------- - EACCES : constant := 10013; -- Permission denied - EADDRINUSE : constant := 10048; -- Address already in use - EADDRNOTAVAIL : constant := 10049; -- Cannot assign address - EAFNOSUPPORT : constant := 10047; -- Addr family not supported - EALREADY : constant := 10037; -- Operation in progress - EBADF : constant := 10009; -- Bad file descriptor - ECONNABORTED : constant := 10053; -- Connection aborted - ECONNREFUSED : constant := 10061; -- Connection refused - ECONNRESET : constant := 10054; -- Connection reset by peer - EDESTADDRREQ : constant := 10039; -- Destination addr required - EFAULT : constant := 10014; -- Bad address - EHOSTDOWN : constant := 10064; -- Host is down - EHOSTUNREACH : constant := 10065; -- No route to host - EINPROGRESS : constant := 10036; -- Operation now in progress - EINTR : constant := 10004; -- Interrupted system call - EINVAL : constant := 10022; -- Invalid argument - EIO : constant := 10101; -- Input output error - EISCONN : constant := 10056; -- Socket already connected - ELOOP : constant := 10062; -- Too many symbolic links - EMFILE : constant := 10024; -- Too many open files - EMSGSIZE : constant := 10040; -- Message too long - ENAMETOOLONG : constant := 10063; -- Name too long - ENETDOWN : constant := 10050; -- Network is down - ENETRESET : constant := 10052; -- Disconn. on network reset - ENETUNREACH : constant := 10051; -- Network is unreachable - ENOBUFS : constant := 10055; -- No buffer space available - ENOPROTOOPT : constant := 10042; -- Protocol not available - ENOTCONN : constant := 10057; -- Socket not connected - ENOTSOCK : constant := 10038; -- Operation on non socket - EOPNOTSUPP : constant := 10045; -- Operation not supported - EPFNOSUPPORT : constant := 10046; -- Unknown protocol family - EPROTONOSUPPORT : constant := 10043; -- Unknown protocol - EPROTOTYPE : constant := 10041; -- Unknown protocol type - ESHUTDOWN : constant := 10058; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 10044; -- Socket type not supported - ETIMEDOUT : constant := 10060; -- Connection timed out - ETOOMANYREFS : constant := 10059; -- Too many references - EWOULDBLOCK : constant := 10035; -- Operation would block + EACCES : constant := 10013; -- Permission denied + EADDRINUSE : constant := 10048; -- Address already in use + EADDRNOTAVAIL : constant := 10049; -- Cannot assign address + EAFNOSUPPORT : constant := 10047; -- Addr family not supported + EALREADY : constant := 10037; -- Operation in progress + EBADF : constant := 10009; -- Bad file descriptor + ECONNABORTED : constant := 10053; -- Connection aborted + ECONNREFUSED : constant := 10061; -- Connection refused + ECONNRESET : constant := 10054; -- Connection reset by peer + EDESTADDRREQ : constant := 10039; -- Destination addr required + EFAULT : constant := 10014; -- Bad address + EHOSTDOWN : constant := 10064; -- Host is down + EHOSTUNREACH : constant := 10065; -- No route to host + EINPROGRESS : constant := 10036; -- Operation now in progress + EINTR : constant := 10004; -- Interrupted system call + EINVAL : constant := 10022; -- Invalid argument + EIO : constant := 10101; -- Input output error + EISCONN : constant := 10056; -- Socket already connected + ELOOP : constant := 10062; -- Too many symbolic links + EMFILE : constant := 10024; -- Too many open files + EMSGSIZE : constant := 10040; -- Message too long + ENAMETOOLONG : constant := 10063; -- Name too long + ENETDOWN : constant := 10050; -- Network is down + ENETRESET : constant := 10052; -- Disconn. on network reset + ENETUNREACH : constant := 10051; -- Network is unreachable + ENOBUFS : constant := 10055; -- No buffer space available + ENOPROTOOPT : constant := 10042; -- Protocol not available + ENOTCONN : constant := 10057; -- Socket not connected + ENOTSOCK : constant := 10038; -- Operation on non socket + EOPNOTSUPP : constant := 10045; -- Operation not supported + EPFNOSUPPORT : constant := 10046; -- Unknown protocol family + EPROTONOSUPPORT : constant := 10043; -- Unknown protocol + EPROTOTYPE : constant := 10041; -- Unknown protocol type + ESHUTDOWN : constant := 10058; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 10044; -- Socket type not supported + ETIMEDOUT : constant := 10060; -- Connection timed out + ETOOMANYREFS : constant := 10059; -- Too many references + EWOULDBLOCK : constant := 10035; -- Operation would block ----------------- -- Host errors -- ----------------- - HOST_NOT_FOUND : constant := 11001; -- Unknown host - TRY_AGAIN : constant := 11002; -- Host name lookup failure - NO_DATA : constant := 11004; -- No data record for name - NO_RECOVERY : constant := 11003; -- Non recoverable errors + HOST_NOT_FOUND : constant := 11001; -- Unknown host + TRY_AGAIN : constant := 11002; -- Host name lookup failure + NO_DATA : constant := 11004; -- No data record for name + NO_RECOVERY : constant := 11003; -- Non recoverable errors ------------------- -- Control flags -- ------------------- - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read -------------------- -- Shutdown modes -- -------------------- - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send --------------------- -- Protocol levels -- --------------------- - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP ------------------- -- Request flags -- ------------------- - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := -1; -- Send end of record - MSG_WAITALL : constant := -1; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := -1; -- Send end of record + MSG_WAITALL : constant := -1; -- Wait for full reception + MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send + MSG_Forced_Flags : constant := 0; -- Flags set on all send(2) calls -------------------- -- Socket options -- -------------------- - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_REUSEPORT : constant := -1; -- Bind reuse port number - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - IP_PKTINFO : constant := 19; -- Get datagram info + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_REUSEPORT : constant := -1; -- Bind reuse port number + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 4101; -- Emission timeout + SO_RCVTIMEO : constant := 4102; -- Reception timeout + SO_ERROR : constant := 4103; -- Get/clear error status + IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + IP_PKTINFO : constant := 19; -- Get datagram info ------------------- -- System limits -- ------------------- - IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt + IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt ---------------------- -- Type definitions -- @@ -177,14 +178,32 @@ package GNAT.Sockets.Constants is -- Sizes (in bytes) of the components of struct timeval - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec + SIZEOF_tv_sec : constant := 4; -- tv_sec + SIZEOF_tv_usec : constant := 4; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 28; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 4100; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.short; + subtype H_Length_T is Interfaces.C.short; ---------------------------------------- -- Properties of supported interfaces -- ---------------------------------------- - Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops + Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 0; -- Sockaddr has sa_len field + + Thread_Blocking_IO : constant Boolean := True; + -- Set False for contexts where socket i/o are process blocking ------------------------------ -- MinGW-specific constants -- @@ -193,16 +212,9 @@ package GNAT.Sockets.Constants is -- These constants may be used only within the MinGW version of -- GNAT.Sockets.Thin. - WSASYSNOTREADY : constant := 10091; -- System not ready - WSAVERNOTSUPPORTED : constant := 10092; -- Version not supported - WSANOTINITIALISED : constant := 10093; -- Winsock not initialized - WSAEDISCON : constant := 10101; -- Disconnected - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking + WSASYSNOTREADY : constant := 10091; -- System not ready + WSAVERNOTSUPPORTED : constant := 10092; -- Version not supported + WSANOTINITIALISED : constant := 10093; -- Winsock not initialized + WSAEDISCON : constant := 10101; -- Disconnected end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-solaris-64.ads b/gcc/ada/g-soccon-solaris-64.ads index 7cd8c8b2c25..2d5f2d98aff 100644 --- a/gcc/ada/g-soccon-solaris-64.ads +++ b/gcc/ada/g-soccon-solaris-64.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,141 +35,142 @@ -- by the GNAT.Sockets package (g-socket.ads). This package should not be -- directly with'ed by an applications program. --- This is the version for sparc64-sun-solaris2.8 +-- This is the version for sparc-sun-solaris2.8 -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. +with Interfaces.C; package GNAT.Sockets.Constants is -------------- -- Families -- -------------- - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 26; -- IPv6 address family + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 26; -- IPv6 address family ----------- -- Modes -- ----------- - SOCK_STREAM : constant := 2; -- Stream socket - SOCK_DGRAM : constant := 1; -- Datagram socket + SOCK_STREAM : constant := 2; -- Stream socket + SOCK_DGRAM : constant := 1; -- Datagram socket ------------------- -- Socket errors -- ------------------- - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 125; -- Address already in use - EADDRNOTAVAIL : constant := 126; -- Cannot assign address - EAFNOSUPPORT : constant := 124; -- Addr family not supported - EALREADY : constant := 149; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 130; -- Connection aborted - ECONNREFUSED : constant := 146; -- Connection refused - ECONNRESET : constant := 131; -- Connection reset by peer - EDESTADDRREQ : constant := 96; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 147; -- Host is down - EHOSTUNREACH : constant := 148; -- No route to host - EINPROGRESS : constant := 150; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 133; -- Socket already connected - ELOOP : constant := 90; -- Too many symbolic links - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 97; -- Message too long - ENAMETOOLONG : constant := 78; -- Name too long - ENETDOWN : constant := 127; -- Network is down - ENETRESET : constant := 129; -- Disconn. on network reset - ENETUNREACH : constant := 128; -- Network is unreachable - ENOBUFS : constant := 132; -- No buffer space available - ENOPROTOOPT : constant := 99; -- Protocol not available - ENOTCONN : constant := 134; -- Socket not connected - ENOTSOCK : constant := 95; -- Operation on non socket - EOPNOTSUPP : constant := 122; -- Operation not supported - EPFNOSUPPORT : constant := 123; -- Unknown protocol family - EPROTONOSUPPORT : constant := 120; -- Unknown protocol - EPROTOTYPE : constant := 98; -- Unknown protocol type - ESHUTDOWN : constant := 143; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported - ETIMEDOUT : constant := 145; -- Connection timed out - ETOOMANYREFS : constant := 144; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 125; -- Address already in use + EADDRNOTAVAIL : constant := 126; -- Cannot assign address + EAFNOSUPPORT : constant := 124; -- Addr family not supported + EALREADY : constant := 149; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 130; -- Connection aborted + ECONNREFUSED : constant := 146; -- Connection refused + ECONNRESET : constant := 131; -- Connection reset by peer + EDESTADDRREQ : constant := 96; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 147; -- Host is down + EHOSTUNREACH : constant := 148; -- No route to host + EINPROGRESS : constant := 150; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 133; -- Socket already connected + ELOOP : constant := 90; -- Too many symbolic links + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 97; -- Message too long + ENAMETOOLONG : constant := 78; -- Name too long + ENETDOWN : constant := 127; -- Network is down + ENETRESET : constant := 129; -- Disconn. on network reset + ENETUNREACH : constant := 128; -- Network is unreachable + ENOBUFS : constant := 132; -- No buffer space available + ENOPROTOOPT : constant := 99; -- Protocol not available + ENOTCONN : constant := 134; -- Socket not connected + ENOTSOCK : constant := 95; -- Operation on non socket + EOPNOTSUPP : constant := 122; -- Operation not supported + EPFNOSUPPORT : constant := 123; -- Unknown protocol family + EPROTONOSUPPORT : constant := 120; -- Unknown protocol + EPROTOTYPE : constant := 98; -- Unknown protocol type + ESHUTDOWN : constant := 143; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported + ETIMEDOUT : constant := 145; -- Connection timed out + ETOOMANYREFS : constant := 144; -- Too many references + EWOULDBLOCK : constant := 11; -- Operation would block ----------------- -- Host errors -- ----------------- - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors ------------------- -- Control flags -- ------------------- - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read -------------------- -- Shutdown modes -- -------------------- - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send --------------------- -- Protocol levels -- --------------------- - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP ------------------- -- Request flags -- ------------------- - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send + MSG_Forced_Flags : constant := 0; -- Flags set on all send(2) calls -------------------- -- Socket options -- -------------------- - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_REUSEPORT : constant := -1; -- Bind reuse port number - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 16; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 17; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 18; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 19; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 20; -- Leave a multicast group - IP_PKTINFO : constant := -1; -- Get datagram info + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_REUSEPORT : constant := -1; -- Bind reuse port number + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 4101; -- Emission timeout + SO_RCVTIMEO : constant := 4102; -- Reception timeout + SO_ERROR : constant := 4103; -- Get/clear error status + IP_MULTICAST_IF : constant := 16; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 17; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 18; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 19; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 20; -- Leave a multicast group + IP_PKTINFO : constant := -1; -- Get datagram info ------------------- -- System limits -- ------------------- - IOV_MAX : constant := 16; -- Maximum writev iovcnt + IOV_MAX : constant := 16; -- Maximum writev iovcnt ---------------------- -- Type definitions -- @@ -177,18 +178,29 @@ package GNAT.Sockets.Constants is -- Sizes (in bytes) of the components of struct timeval - SIZEOF_tv_sec : constant := 8; -- tv_sec - SIZEOF_tv_usec : constant := 8; -- tv_usec + SIZEOF_tv_sec : constant := 4; -- tv_sec + SIZEOF_tv_usec : constant := 4; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 32; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 128; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.int; + subtype H_Length_T is Interfaces.C.int; ---------------------------------------- -- Properties of supported interfaces -- ---------------------------------------- - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- + Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 0; -- Sockaddr has sa_len field Thread_Blocking_IO : constant Boolean := True; -- Set False for contexts where socket i/o are process blocking diff --git a/gcc/ada/g-soccon-solaris.ads b/gcc/ada/g-soccon-solaris.ads index cd0aebd5125..2d5f2d98aff 100644 --- a/gcc/ada/g-soccon-solaris.ads +++ b/gcc/ada/g-soccon-solaris.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,137 +39,138 @@ -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. +with Interfaces.C; package GNAT.Sockets.Constants is -------------- -- Families -- -------------- - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 26; -- IPv6 address family + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 26; -- IPv6 address family ----------- -- Modes -- ----------- - SOCK_STREAM : constant := 2; -- Stream socket - SOCK_DGRAM : constant := 1; -- Datagram socket + SOCK_STREAM : constant := 2; -- Stream socket + SOCK_DGRAM : constant := 1; -- Datagram socket ------------------- -- Socket errors -- ------------------- - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 125; -- Address already in use - EADDRNOTAVAIL : constant := 126; -- Cannot assign address - EAFNOSUPPORT : constant := 124; -- Addr family not supported - EALREADY : constant := 149; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 130; -- Connection aborted - ECONNREFUSED : constant := 146; -- Connection refused - ECONNRESET : constant := 131; -- Connection reset by peer - EDESTADDRREQ : constant := 96; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 147; -- Host is down - EHOSTUNREACH : constant := 148; -- No route to host - EINPROGRESS : constant := 150; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 133; -- Socket already connected - ELOOP : constant := 90; -- Too many symbolic links - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 97; -- Message too long - ENAMETOOLONG : constant := 78; -- Name too long - ENETDOWN : constant := 127; -- Network is down - ENETRESET : constant := 129; -- Disconn. on network reset - ENETUNREACH : constant := 128; -- Network is unreachable - ENOBUFS : constant := 132; -- No buffer space available - ENOPROTOOPT : constant := 99; -- Protocol not available - ENOTCONN : constant := 134; -- Socket not connected - ENOTSOCK : constant := 95; -- Operation on non socket - EOPNOTSUPP : constant := 122; -- Operation not supported - EPFNOSUPPORT : constant := 123; -- Unknown protocol family - EPROTONOSUPPORT : constant := 120; -- Unknown protocol - EPROTOTYPE : constant := 98; -- Unknown protocol type - ESHUTDOWN : constant := 143; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported - ETIMEDOUT : constant := 145; -- Connection timed out - ETOOMANYREFS : constant := 144; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 125; -- Address already in use + EADDRNOTAVAIL : constant := 126; -- Cannot assign address + EAFNOSUPPORT : constant := 124; -- Addr family not supported + EALREADY : constant := 149; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 130; -- Connection aborted + ECONNREFUSED : constant := 146; -- Connection refused + ECONNRESET : constant := 131; -- Connection reset by peer + EDESTADDRREQ : constant := 96; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 147; -- Host is down + EHOSTUNREACH : constant := 148; -- No route to host + EINPROGRESS : constant := 150; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 133; -- Socket already connected + ELOOP : constant := 90; -- Too many symbolic links + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 97; -- Message too long + ENAMETOOLONG : constant := 78; -- Name too long + ENETDOWN : constant := 127; -- Network is down + ENETRESET : constant := 129; -- Disconn. on network reset + ENETUNREACH : constant := 128; -- Network is unreachable + ENOBUFS : constant := 132; -- No buffer space available + ENOPROTOOPT : constant := 99; -- Protocol not available + ENOTCONN : constant := 134; -- Socket not connected + ENOTSOCK : constant := 95; -- Operation on non socket + EOPNOTSUPP : constant := 122; -- Operation not supported + EPFNOSUPPORT : constant := 123; -- Unknown protocol family + EPROTONOSUPPORT : constant := 120; -- Unknown protocol + EPROTOTYPE : constant := 98; -- Unknown protocol type + ESHUTDOWN : constant := 143; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported + ETIMEDOUT : constant := 145; -- Connection timed out + ETOOMANYREFS : constant := 144; -- Too many references + EWOULDBLOCK : constant := 11; -- Operation would block ----------------- -- Host errors -- ----------------- - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors ------------------- -- Control flags -- ------------------- - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read -------------------- -- Shutdown modes -- -------------------- - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send --------------------- -- Protocol levels -- --------------------- - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP ------------------- -- Request flags -- ------------------- - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send + MSG_Forced_Flags : constant := 0; -- Flags set on all send(2) calls -------------------- -- Socket options -- -------------------- - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_REUSEPORT : constant := -1; -- Bind reuse port number - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 16; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 17; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 18; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 19; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 20; -- Leave a multicast group - IP_PKTINFO : constant := -1; -- Get datagram info + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_REUSEPORT : constant := -1; -- Bind reuse port number + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 4101; -- Emission timeout + SO_RCVTIMEO : constant := 4102; -- Reception timeout + SO_ERROR : constant := 4103; -- Get/clear error status + IP_MULTICAST_IF : constant := 16; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 17; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 18; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 19; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 20; -- Leave a multicast group + IP_PKTINFO : constant := -1; -- Get datagram info ------------------- -- System limits -- ------------------- - IOV_MAX : constant := 16; -- Maximum writev iovcnt + IOV_MAX : constant := 16; -- Maximum writev iovcnt ---------------------- -- Type definitions -- @@ -177,18 +178,29 @@ package GNAT.Sockets.Constants is -- Sizes (in bytes) of the components of struct timeval - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec + SIZEOF_tv_sec : constant := 4; -- tv_sec + SIZEOF_tv_usec : constant := 4; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 32; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 128; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.int; + subtype H_Length_T is Interfaces.C.int; ---------------------------------------- -- Properties of supported interfaces -- ---------------------------------------- - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- + Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 0; -- Sockaddr has sa_len field Thread_Blocking_IO : constant Boolean := True; -- Set False for contexts where socket i/o are process blocking diff --git a/gcc/ada/g-soccon-tru64.ads b/gcc/ada/g-soccon-tru64.ads index 959625ef9c5..a14e6106d4a 100644 --- a/gcc/ada/g-soccon-tru64.ads +++ b/gcc/ada/g-soccon-tru64.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,137 +39,138 @@ -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. +with Interfaces.C; package GNAT.Sockets.Constants is -------------- -- Families -- -------------- - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 26; -- IPv6 address family + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 26; -- IPv6 address family ----------- -- Modes -- ----------- - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket ------------------- -- Socket errors -- ------------------- - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 48; -- Address already in use - EADDRNOTAVAIL : constant := 49; -- Cannot assign address - EAFNOSUPPORT : constant := 47; -- Addr family not supported - EALREADY : constant := 37; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 53; -- Connection aborted - ECONNREFUSED : constant := 61; -- Connection refused - ECONNRESET : constant := 54; -- Connection reset by peer - EDESTADDRREQ : constant := 39; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 64; -- Host is down - EHOSTUNREACH : constant := 65; -- No route to host - EINPROGRESS : constant := 36; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 56; -- Socket already connected - ELOOP : constant := 62; -- Too many symbolic links - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 40; -- Message too long - ENAMETOOLONG : constant := 63; -- Name too long - ENETDOWN : constant := 50; -- Network is down - ENETRESET : constant := 52; -- Disconn. on network reset - ENETUNREACH : constant := 51; -- Network is unreachable - ENOBUFS : constant := 55; -- No buffer space available - ENOPROTOOPT : constant := 42; -- Protocol not available - ENOTCONN : constant := 57; -- Socket not connected - ENOTSOCK : constant := 38; -- Operation on non socket - EOPNOTSUPP : constant := 45; -- Operation not supported - EPFNOSUPPORT : constant := 46; -- Unknown protocol family - EPROTONOSUPPORT : constant := 43; -- Unknown protocol - EPROTOTYPE : constant := 41; -- Unknown protocol type - ESHUTDOWN : constant := 58; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported - ETIMEDOUT : constant := 60; -- Connection timed out - ETOOMANYREFS : constant := 59; -- Too many references - EWOULDBLOCK : constant := 35; -- Operation would block + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 48; -- Address already in use + EADDRNOTAVAIL : constant := 49; -- Cannot assign address + EAFNOSUPPORT : constant := 47; -- Addr family not supported + EALREADY : constant := 37; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 53; -- Connection aborted + ECONNREFUSED : constant := 61; -- Connection refused + ECONNRESET : constant := 54; -- Connection reset by peer + EDESTADDRREQ : constant := 39; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 64; -- Host is down + EHOSTUNREACH : constant := 65; -- No route to host + EINPROGRESS : constant := 36; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 56; -- Socket already connected + ELOOP : constant := 62; -- Too many symbolic links + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 40; -- Message too long + ENAMETOOLONG : constant := 63; -- Name too long + ENETDOWN : constant := 50; -- Network is down + ENETRESET : constant := 52; -- Disconn. on network reset + ENETUNREACH : constant := 51; -- Network is unreachable + ENOBUFS : constant := 55; -- No buffer space available + ENOPROTOOPT : constant := 42; -- Protocol not available + ENOTCONN : constant := 57; -- Socket not connected + ENOTSOCK : constant := 38; -- Operation on non socket + EOPNOTSUPP : constant := 45; -- Operation not supported + EPFNOSUPPORT : constant := 46; -- Unknown protocol family + EPROTONOSUPPORT : constant := 43; -- Unknown protocol + EPROTOTYPE : constant := 41; -- Unknown protocol type + ESHUTDOWN : constant := 58; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported + ETIMEDOUT : constant := 60; -- Connection timed out + ETOOMANYREFS : constant := 59; -- Too many references + EWOULDBLOCK : constant := 35; -- Operation would block ----------------- -- Host errors -- ----------------- - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors ------------------- -- Control flags -- ------------------- - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read -------------------- -- Shutdown modes -- -------------------- - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send --------------------- -- Protocol levels -- --------------------- - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP ------------------- -- Request flags -- ------------------- - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send + MSG_Forced_Flags : constant := 0; -- Flags set on all send(2) calls -------------------- -- Socket options -- -------------------- - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_REUSEPORT : constant := 512; -- Bind reuse port number - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - IP_PKTINFO : constant := -1; -- Get datagram info + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_REUSEPORT : constant := 512; -- Bind reuse port number + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 4101; -- Emission timeout + SO_RCVTIMEO : constant := 4102; -- Reception timeout + SO_ERROR : constant := 4103; -- Get/clear error status + IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + IP_PKTINFO : constant := -1; -- Get datagram info ------------------- -- System limits -- ------------------- - IOV_MAX : constant := 1024; -- Maximum writev iovcnt + IOV_MAX : constant := 1024; -- Maximum writev iovcnt ---------------------- -- Type definitions -- @@ -177,18 +178,29 @@ package GNAT.Sockets.Constants is -- Sizes (in bytes) of the components of struct timeval - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec + SIZEOF_tv_sec : constant := 4; -- tv_sec + SIZEOF_tv_usec : constant := 4; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 32; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 512; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.int; + subtype H_Length_T is Interfaces.C.int; ---------------------------------------- -- Properties of supported interfaces -- ---------------------------------------- - Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- + Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 0; -- Sockaddr has sa_len field Thread_Blocking_IO : constant Boolean := True; -- Set False for contexts where socket i/o are process blocking diff --git a/gcc/ada/g-soccon-vms.ads b/gcc/ada/g-soccon-vms.ads index 8634a0a00f4..072ee499c3c 100644 --- a/gcc/ada/g-soccon-vms.ads +++ b/gcc/ada/g-soccon-vms.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,137 +39,138 @@ -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. +with Interfaces.C; package GNAT.Sockets.Constants is -------------- -- Families -- -------------- - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 26; -- IPv6 address family + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 26; -- IPv6 address family ----------- -- Modes -- ----------- - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket ------------------- -- Socket errors -- ------------------- - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 48; -- Address already in use - EADDRNOTAVAIL : constant := 49; -- Cannot assign address - EAFNOSUPPORT : constant := 47; -- Addr family not supported - EALREADY : constant := 37; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 53; -- Connection aborted - ECONNREFUSED : constant := 61; -- Connection refused - ECONNRESET : constant := 54; -- Connection reset by peer - EDESTADDRREQ : constant := 39; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 64; -- Host is down - EHOSTUNREACH : constant := 65; -- No route to host - EINPROGRESS : constant := 36; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 56; -- Socket already connected - ELOOP : constant := 62; -- Too many symbolic links - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 40; -- Message too long - ENAMETOOLONG : constant := 63; -- Name too long - ENETDOWN : constant := 50; -- Network is down - ENETRESET : constant := 52; -- Disconn. on network reset - ENETUNREACH : constant := 51; -- Network is unreachable - ENOBUFS : constant := 55; -- No buffer space available - ENOPROTOOPT : constant := 42; -- Protocol not available - ENOTCONN : constant := 57; -- Socket not connected - ENOTSOCK : constant := 38; -- Operation on non socket - EOPNOTSUPP : constant := 45; -- Operation not supported - EPFNOSUPPORT : constant := 46; -- Unknown protocol family - EPROTONOSUPPORT : constant := 43; -- Unknown protocol - EPROTOTYPE : constant := 41; -- Unknown protocol type - ESHUTDOWN : constant := 58; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported - ETIMEDOUT : constant := 60; -- Connection timed out - ETOOMANYREFS : constant := 59; -- Too many references - EWOULDBLOCK : constant := 35; -- Operation would block + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 48; -- Address already in use + EADDRNOTAVAIL : constant := 49; -- Cannot assign address + EAFNOSUPPORT : constant := 47; -- Addr family not supported + EALREADY : constant := 37; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 53; -- Connection aborted + ECONNREFUSED : constant := 61; -- Connection refused + ECONNRESET : constant := 54; -- Connection reset by peer + EDESTADDRREQ : constant := 39; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 64; -- Host is down + EHOSTUNREACH : constant := 65; -- No route to host + EINPROGRESS : constant := 36; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 56; -- Socket already connected + ELOOP : constant := 62; -- Too many symbolic links + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 40; -- Message too long + ENAMETOOLONG : constant := 63; -- Name too long + ENETDOWN : constant := 50; -- Network is down + ENETRESET : constant := 52; -- Disconn. on network reset + ENETUNREACH : constant := 51; -- Network is unreachable + ENOBUFS : constant := 55; -- No buffer space available + ENOPROTOOPT : constant := 42; -- Protocol not available + ENOTCONN : constant := 57; -- Socket not connected + ENOTSOCK : constant := 38; -- Operation on non socket + EOPNOTSUPP : constant := 45; -- Operation not supported + EPFNOSUPPORT : constant := 46; -- Unknown protocol family + EPROTONOSUPPORT : constant := 43; -- Unknown protocol + EPROTOTYPE : constant := 41; -- Unknown protocol type + ESHUTDOWN : constant := 58; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported + ETIMEDOUT : constant := 60; -- Connection timed out + ETOOMANYREFS : constant := 59; -- Too many references + EWOULDBLOCK : constant := 35; -- Operation would block ----------------- -- Host errors -- ----------------- - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors ------------------- -- Control flags -- ------------------- - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read -------------------- -- Shutdown modes -- -------------------- - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send --------------------- -- Protocol levels -- --------------------- - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP ------------------- -- Request flags -- ------------------- - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 128; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 128; -- Wait for full reception + MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send + MSG_Forced_Flags : constant := 0; -- Flags set on all send(2) calls -------------------- -- Socket options -- -------------------- - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_REUSEPORT : constant := 512; -- Bind reuse port number - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - IP_PKTINFO : constant := -1; -- Get datagram info + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_REUSEPORT : constant := 512; -- Bind reuse port number + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 4101; -- Emission timeout + SO_RCVTIMEO : constant := 4102; -- Reception timeout + SO_ERROR : constant := 4103; -- Get/clear error status + IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + IP_PKTINFO : constant := -1; -- Get datagram info ------------------- -- System limits -- ------------------- - IOV_MAX : constant := 1024; -- Maximum writev iovcnt + IOV_MAX : constant := 1024; -- Maximum writev iovcnt ---------------------- -- Type definitions -- @@ -177,18 +178,29 @@ package GNAT.Sockets.Constants is -- Sizes (in bytes) of the components of struct timeval - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec + SIZEOF_tv_sec : constant := 4; -- tv_sec + SIZEOF_tv_usec : constant := 4; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 28; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 512; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.int; + subtype H_Length_T is Interfaces.C.int; ---------------------------------------- -- Properties of supported interfaces -- ---------------------------------------- - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- + Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 0; -- Sockaddr has sa_len field Thread_Blocking_IO : constant Boolean := True; -- Set False for contexts where socket i/o are process blocking diff --git a/gcc/ada/g-soccon-vxworks.ads b/gcc/ada/g-soccon-vxworks.ads index 16cf1feb48e..8af174351dc 100644 --- a/gcc/ada/g-soccon-vxworks.ads +++ b/gcc/ada/g-soccon-vxworks.ads @@ -35,141 +35,142 @@ -- by the GNAT.Sockets package (g-socket.ads). This package should not be -- directly with'ed by an applications program. --- This is the version for powerpc-wrs-vxworks +-- This is the version for VxWorks -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. +with Interfaces.C; package GNAT.Sockets.Constants is -------------- -- Families -- -------------- - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := -1; -- IPv6 address family + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 28; -- IPv6 address family ----------- -- Modes -- ----------- - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket ------------------- -- Socket errors -- ------------------- - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 48; -- Address already in use - EADDRNOTAVAIL : constant := 49; -- Cannot assign address - EAFNOSUPPORT : constant := 47; -- Addr family not supported - EALREADY : constant := 69; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 53; -- Connection aborted - ECONNREFUSED : constant := 61; -- Connection refused - ECONNRESET : constant := 54; -- Connection reset by peer - EDESTADDRREQ : constant := 40; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 67; -- Host is down - EHOSTUNREACH : constant := 65; -- No route to host - EINPROGRESS : constant := 68; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 56; -- Socket already connected - ELOOP : constant := 64; -- Too many symbolic links - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 36; -- Message too long - ENAMETOOLONG : constant := 26; -- Name too long - ENETDOWN : constant := 62; -- Network is down - ENETRESET : constant := 52; -- Disconn. on network reset - ENETUNREACH : constant := 51; -- Network is unreachable - ENOBUFS : constant := 55; -- No buffer space available - ENOPROTOOPT : constant := 42; -- Protocol not available - ENOTCONN : constant := 57; -- Socket not connected - ENOTSOCK : constant := 50; -- Operation on non socket - EOPNOTSUPP : constant := 45; -- Operation not supported - EPFNOSUPPORT : constant := 46; -- Unknown protocol family - EPROTONOSUPPORT : constant := 43; -- Unknown protocol - EPROTOTYPE : constant := 41; -- Unknown protocol type - ESHUTDOWN : constant := 58; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported - ETIMEDOUT : constant := 60; -- Connection timed out - ETOOMANYREFS : constant := 59; -- Too many references - EWOULDBLOCK : constant := 70; -- Operation would block + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 48; -- Address already in use + EADDRNOTAVAIL : constant := 49; -- Cannot assign address + EAFNOSUPPORT : constant := 47; -- Addr family not supported + EALREADY : constant := 69; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 53; -- Connection aborted + ECONNREFUSED : constant := 61; -- Connection refused + ECONNRESET : constant := 54; -- Connection reset by peer + EDESTADDRREQ : constant := 40; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 67; -- Host is down + EHOSTUNREACH : constant := 65; -- No route to host + EINPROGRESS : constant := 68; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 56; -- Socket already connected + ELOOP : constant := 64; -- Too many symbolic links + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 36; -- Message too long + ENAMETOOLONG : constant := 26; -- Name too long + ENETDOWN : constant := 62; -- Network is down + ENETRESET : constant := 52; -- Disconn. on network reset + ENETUNREACH : constant := 51; -- Network is unreachable + ENOBUFS : constant := 55; -- No buffer space available + ENOPROTOOPT : constant := 42; -- Protocol not available + ENOTCONN : constant := 57; -- Socket not connected + ENOTSOCK : constant := 50; -- Operation on non socket + EOPNOTSUPP : constant := 45; -- Operation not supported + EPFNOSUPPORT : constant := 46; -- Unknown protocol family + EPROTONOSUPPORT : constant := 43; -- Unknown protocol + EPROTOTYPE : constant := 41; -- Unknown protocol type + ESHUTDOWN : constant := 58; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported + ETIMEDOUT : constant := 60; -- Connection timed out + ETOOMANYREFS : constant := 59; -- Too many references + EWOULDBLOCK : constant := 70; -- Operation would block ----------------- -- Host errors -- ----------------- - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors ------------------- -- Control flags -- ------------------- - FIONBIO : constant := 16; -- Set/clear non-blocking io - FIONREAD : constant := 1; -- How many bytes to read + FIONBIO : constant := 16; -- Set/clear non-blocking io + FIONREAD : constant := 1; -- How many bytes to read -------------------- -- Shutdown modes -- -------------------- - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send --------------------- -- Protocol levels -- --------------------- - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP ------------------- -- Request flags -- ------------------- - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send - MSG_Forced_Flags : constant := 0; + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send + MSG_Forced_Flags : constant := 0; -- Flags set on all send(2) calls -------------------- -- Socket options -- -------------------- - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_REUSEPORT : constant := 512; -- Bind reuse port number - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 4101; -- Emission timeout - SO_RCVTIMEO : constant := 4102; -- Reception timeout - SO_ERROR : constant := 4103; -- Get/clear error status - IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - IP_PKTINFO : constant := -1; -- Get datagram info + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_REUSEPORT : constant := 512; -- Bind reuse port number + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 4101; -- Emission timeout + SO_RCVTIMEO : constant := 4102; -- Reception timeout + SO_ERROR : constant := 4103; -- Get/clear error status + IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + IP_PKTINFO : constant := -1; -- Get datagram info ------------------- -- System limits -- ------------------- - IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt + IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt ---------------------- -- Type definitions -- @@ -177,14 +178,32 @@ package GNAT.Sockets.Constants is -- Sizes (in bytes) of the components of struct timeval - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec + SIZEOF_tv_sec : constant := 4; -- tv_sec + SIZEOF_tv_usec : constant := 4; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 28; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 256; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.int; + subtype H_Length_T is Interfaces.C.int; ---------------------------------------- -- Properties of supported interfaces -- ---------------------------------------- - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops + Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 1; -- Sockaddr has sa_len field + + Thread_Blocking_IO : constant Boolean := True; + -- Set False for contexts where socket i/o are process blocking -------------------------------- -- VxWorks-specific constants -- @@ -193,14 +212,7 @@ package GNAT.Sockets.Constants is -- These constants may be used only within the VxWorks version of -- GNAT.Sockets.Thin. - OK : constant := 0; -- VxWorks generic success - ERROR : constant := -1; -- VxWorks generic error - - ---------------------- - -- Additional flags -- - ---------------------- - - Thread_Blocking_IO : constant Boolean := True; - -- Set False for contexts where socket i/o are process blocking + OK : constant := 0; -- VxWorks generic success + ERROR : constant := -1; -- VxWorks generic error end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon.ads b/gcc/ada/g-soccon.ads index d7556a12a71..b7f8fe4be77 100644 --- a/gcc/ada/g-soccon.ads +++ b/gcc/ada/g-soccon.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -46,137 +46,138 @@ -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. +with Interfaces.C; package GNAT.Sockets.Constants is -------------- -- Families -- -------------- - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 10; -- IPv6 address family + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 10; -- IPv6 address family ----------- -- Modes -- ----------- - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket ------------------- -- Socket errors -- ------------------- - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 98; -- Address already in use - EADDRNOTAVAIL : constant := 99; -- Cannot assign address - EAFNOSUPPORT : constant := 97; -- Addr family not supported - EALREADY : constant := 114; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 103; -- Connection aborted - ECONNREFUSED : constant := 111; -- Connection refused - ECONNRESET : constant := 104; -- Connection reset by peer - EDESTADDRREQ : constant := 89; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 112; -- Host is down - EHOSTUNREACH : constant := 113; -- No route to host - EINPROGRESS : constant := 115; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 106; -- Socket already connected - ELOOP : constant := 40; -- Too many symbolic links - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 90; -- Message too long - ENAMETOOLONG : constant := 36; -- Name too long - ENETDOWN : constant := 100; -- Network is down - ENETRESET : constant := 102; -- Disconn. on network reset - ENETUNREACH : constant := 101; -- Network is unreachable - ENOBUFS : constant := 105; -- No buffer space available - ENOPROTOOPT : constant := 92; -- Protocol not available - ENOTCONN : constant := 107; -- Socket not connected - ENOTSOCK : constant := 88; -- Operation on non socket - EOPNOTSUPP : constant := 95; -- Operation not supported - EPFNOSUPPORT : constant := 96; -- Unknown protocol family - EPROTONOSUPPORT : constant := 93; -- Unknown protocol - EPROTOTYPE : constant := 91; -- Unknown protocol type - ESHUTDOWN : constant := 108; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 94; -- Socket type not supported - ETIMEDOUT : constant := 110; -- Connection timed out - ETOOMANYREFS : constant := 109; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 98; -- Address already in use + EADDRNOTAVAIL : constant := 99; -- Cannot assign address + EAFNOSUPPORT : constant := 97; -- Addr family not supported + EALREADY : constant := 114; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 103; -- Connection aborted + ECONNREFUSED : constant := 111; -- Connection refused + ECONNRESET : constant := 104; -- Connection reset by peer + EDESTADDRREQ : constant := 89; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 112; -- Host is down + EHOSTUNREACH : constant := 113; -- No route to host + EINPROGRESS : constant := 115; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 106; -- Socket already connected + ELOOP : constant := 40; -- Too many symbolic links + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 90; -- Message too long + ENAMETOOLONG : constant := 36; -- Name too long + ENETDOWN : constant := 100; -- Network is down + ENETRESET : constant := 102; -- Disconn. on network reset + ENETUNREACH : constant := 101; -- Network is unreachable + ENOBUFS : constant := 105; -- No buffer space available + ENOPROTOOPT : constant := 92; -- Protocol not available + ENOTCONN : constant := 107; -- Socket not connected + ENOTSOCK : constant := 88; -- Operation on non socket + EOPNOTSUPP : constant := 95; -- Operation not supported + EPFNOSUPPORT : constant := 96; -- Unknown protocol family + EPROTONOSUPPORT : constant := 93; -- Unknown protocol + EPROTOTYPE : constant := 91; -- Unknown protocol type + ESHUTDOWN : constant := 108; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 94; -- Socket type not supported + ETIMEDOUT : constant := 110; -- Connection timed out + ETOOMANYREFS : constant := 109; -- Too many references + EWOULDBLOCK : constant := 11; -- Operation would block ----------------- -- Host errors -- ----------------- - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors ------------------- -- Control flags -- ------------------- - FIONBIO : constant := 21537; -- Set/clear non-blocking io - FIONREAD : constant := 21531; -- How many bytes to read + FIONBIO : constant := 21537; -- Set/clear non-blocking io + FIONREAD : constant := 21531; -- How many bytes to read -------------------- -- Shutdown modes -- -------------------- - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send --------------------- -- Protocol levels -- --------------------- - SOL_SOCKET : constant := 1; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP + SOL_SOCKET : constant := 1; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP ------------------- -- Request flags -- ------------------- - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 128; -- Send end of record - MSG_WAITALL : constant := 256; -- Wait for full reception - MSG_NOSIGNAL : constant := 16384; -- No SIGPIPE on send - MSG_Forced_Flags : constant := MSG_NOSIGNAL; + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 128; -- Send end of record + MSG_WAITALL : constant := 256; -- Wait for full reception + MSG_NOSIGNAL : constant := 16384; -- No SIGPIPE on send + MSG_Forced_Flags : constant := MSG_NOSIGNAL; -- Flags set on all send(2) calls -------------------- -- Socket options -- -------------------- - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_REUSEADDR : constant := 2; -- Bind reuse local address - SO_REUSEPORT : constant := -1; -- Bind reuse port number - SO_KEEPALIVE : constant := 9; -- Enable keep-alive msgs - SO_LINGER : constant := 13; -- Defer close to flush data - SO_BROADCAST : constant := 6; -- Can send broadcast msgs - SO_SNDBUF : constant := 7; -- Set/get send buffer size - SO_RCVBUF : constant := 8; -- Set/get recv buffer size - SO_SNDTIMEO : constant := 21; -- Emission timeout - SO_RCVTIMEO : constant := 20; -- Reception timeout - SO_ERROR : constant := 4; -- Get/clear error status - IP_MULTICAST_IF : constant := 32; -- Set/get mcast interface - IP_MULTICAST_TTL : constant := 33; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 34; -- Set/get mcast loopback - IP_ADD_MEMBERSHIP : constant := 35; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 36; -- Leave a multicast group - IP_PKTINFO : constant := 8; -- Get datagram info + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 2; -- Bind reuse local address + SO_REUSEPORT : constant := -1; -- Bind reuse port number + SO_KEEPALIVE : constant := 9; -- Enable keep-alive msgs + SO_LINGER : constant := 13; -- Defer close to flush data + SO_BROADCAST : constant := 6; -- Can send broadcast msgs + SO_SNDBUF : constant := 7; -- Set/get send buffer size + SO_RCVBUF : constant := 8; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 21; -- Emission timeout + SO_RCVTIMEO : constant := 20; -- Reception timeout + SO_ERROR : constant := 4; -- Get/clear error status + IP_MULTICAST_IF : constant := 32; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 33; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 34; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 35; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 36; -- Leave a multicast group + IP_PKTINFO : constant := 8; -- Get datagram info ------------------- -- System limits -- ------------------- - IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt + IOV_MAX : constant := 2147483647; -- Maximum writev iovcnt ---------------------- -- Type definitions -- @@ -184,18 +185,29 @@ package GNAT.Sockets.Constants is -- Sizes (in bytes) of the components of struct timeval - SIZEOF_tv_sec : constant := 4; -- tv_sec - SIZEOF_tv_usec : constant := 4; -- tv_usec + SIZEOF_tv_sec : constant := 4; -- tv_sec + SIZEOF_tv_usec : constant := 4; -- tv_usec + + -- Sizes of protocol specific address types (for sockaddr.sa_len) + + SIZEOF_sockaddr_in : constant := 16; -- struct sockaddr_in + SIZEOF_sockaddr_in6 : constant := 28; -- struct sockaddr_in6 + + -- Size of file descriptor sets + + SIZEOF_fd_set : constant := 128; -- fd_set + + -- Fields of struct hostent + + subtype H_Addrtype_T is Interfaces.C.int; + subtype H_Length_T is Interfaces.C.int; ---------------------------------------- -- Properties of supported interfaces -- ---------------------------------------- - Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops - - ---------------------- - -- Additional flags -- - ---------------------- + Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops + Has_Sockaddr_Len : constant := 0; -- Sockaddr has sa_len field Thread_Blocking_IO : constant Boolean := True; -- Set False for contexts where socket i/o are process blocking diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 981495f5cae..4b399405a55 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -36,7 +36,9 @@ with Ada.Exceptions; use Ada.Exceptions; with Ada.Unchecked_Conversion; with Interfaces.C.Strings; + with GNAT.Sockets.Constants; +with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common; with GNAT.Sockets.Thin; use GNAT.Sockets.Thin; with GNAT.Sockets.Thin.Task_Safe_NetDB; use GNAT.Sockets.Thin.Task_Safe_NetDB; @@ -48,6 +50,8 @@ with System; use System; package body GNAT.Sockets is + package C renames Interfaces.C; + use type C.int; Finalized : Boolean := False; @@ -63,10 +67,6 @@ package body GNAT.Sockets is -- Correspondence tables - Families : constant array (Family_Type) of C.int := - (Family_Inet => Constants.AF_INET, - Family_Inet6 => Constants.AF_INET6); - Levels : constant array (Level_Type) of C.int := (Socket_Level => Constants.SOL_SOCKET, IP_Protocol_For_IP_Level => Constants.IPPROTO_IP, @@ -118,9 +118,6 @@ package body GNAT.Sockets is Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF"; -- Use to print in hexadecimal format - function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr); - function To_Int is new Ada.Unchecked_Conversion (In_Addr, C.int); - function Err_Code_Image (E : Integer) return String; -- Return the value of E surrounded with brackets @@ -162,7 +159,7 @@ package body GNAT.Sockets is function Is_IP_Address (Name : String) return Boolean; -- Return true when Name is an IP address in standard dot notation - function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr; + function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr; procedure To_Inet_Addr (Addr : In_Addr; Result : out Inet_Addr_Type); @@ -230,6 +227,18 @@ package body GNAT.Sockets is (Stream : in out Stream_Socket_Stream_Type; Item : Ada.Streams.Stream_Element_Array); + procedure Wait_On_Socket + (Socket : Socket_Type; + For_Read : Boolean; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status); + -- Common code for variants of socket operations supporting a timeout: + -- block in Check_Selector on Socket for at most the indicated timeout. + -- If For_Read is True, Socket is added to the read set for this call, else + -- it is added to the write set. If no selector is provided, a local one is + -- created for this call and destroyed prior to returning. + --------- -- "+" -- --------- @@ -282,6 +291,37 @@ package body GNAT.Sockets is Address.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); end Accept_Socket; + ------------------- + -- Accept_Socket -- + ------------------- + + procedure Accept_Socket + (Server : Socket_Type; + Socket : out Socket_Type; + Address : out Sock_Addr_Type; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status) + is + begin + -- Wait for socket to become available for reading + + Wait_On_Socket + (Socket => Server, + For_Read => True, + Timeout => Timeout, + Selector => Selector, + Status => Status); + + -- Accept connection if available + + if Status = Completed then + Accept_Socket (Server, Socket, Address); + else + Socket := No_Socket; + end if; + end Accept_Socket; + --------------- -- Addresses -- --------------- @@ -356,14 +396,14 @@ package body GNAT.Sockets is Res : C.int; Sin : aliased Sockaddr_In; Len : constant C.int := Sin'Size / 8; + -- This assumes that Address.Family = Family_Inet??? begin if Address.Family = Family_Inet6 then raise Socket_Error with "IPv6 not supported"; end if; - Set_Length (Sin'Unchecked_Access, Len); - Set_Family (Sin'Unchecked_Access, Families (Address.Family)); + Set_Family (Sin.Sin_Family, Address.Family); Set_Address (Sin'Unchecked_Access, To_In_Addr (Address.Addr)); Set_Port (Sin'Unchecked_Access, @@ -387,12 +427,16 @@ package body GNAT.Sockets is Status : out Selector_Status; Timeout : Selector_Duration := Forever) is - E_Socket_Set : Socket_Set_Type; -- (No_Socket, No_Socket_Set) + E_Socket_Set : Socket_Set_Type; -- (No_Socket, No_Fd_Set_Access) begin Check_Selector (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout); end Check_Selector; + -------------------- + -- Check_Selector -- + -------------------- + procedure Check_Selector (Selector : in out Selector_Type; R_Socket_Set : in out Socket_Set_Type; @@ -585,8 +629,7 @@ package body GNAT.Sockets is raise Socket_Error with "IPv6 not supported"; end if; - Set_Length (Sin'Unchecked_Access, Len); - Set_Family (Sin'Unchecked_Access, Families (Server.Family)); + Set_Family (Sin.Sin_Family, Server.Family); Set_Address (Sin'Unchecked_Access, To_In_Addr (Server.Addr)); Set_Port (Sin'Unchecked_Access, @@ -600,6 +643,55 @@ package body GNAT.Sockets is end Connect_Socket; -------------------- + -- Connect_Socket -- + -------------------- + + procedure Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status) + is + Req : Request_Type; + -- Used to set Socket to non-blocking I/O + + begin + -- Set the socket to non-blocking I/O + + Req := (Name => Non_Blocking_IO, Enabled => True); + Control_Socket (Socket, Request => Req); + + -- Start operation (non-blocking), will raise Socket_Error with + -- EINPROGRESS. + + begin + Connect_Socket (Socket, Server); + exception + when E : Socket_Error => + if Resolve_Exception (E) = Operation_Now_In_Progress then + null; + else + raise; + end if; + end; + + -- Wait for socket to become available for writing + + Wait_On_Socket + (Socket => Socket, + For_Read => False, + Timeout => Timeout, + Selector => Selector, + Status => Status); + + -- Reset the socket to blocking I/O + + Req := (Name => Non_Blocking_IO, Enabled => False); + Control_Socket (Socket, Request => Req); + end Connect_Socket; + + -------------------- -- Control_Socket -- -------------------- @@ -704,9 +796,9 @@ package body GNAT.Sockets is procedure Empty (Item : in out Socket_Set_Type) is begin - if Item.Set /= No_Socket_Set then + if Item.Set /= No_Fd_Set_Access then Free_Socket_Set (Item.Set); - Item.Set := No_Socket_Set; + Item.Set := No_Fd_Set_Access; end if; Item.Last := No_Socket; @@ -1257,7 +1349,7 @@ package body GNAT.Sockets is procedure Listen_Socket (Socket : Socket_Type; - Length : Positive := 15) + Length : Natural := 15) is Res : constant C.int := C_Listen (C.int (Socket), C.int (Length)); begin @@ -1273,7 +1365,7 @@ package body GNAT.Sockets is procedure Narrow (Item : in out Socket_Set_Type) is Last : aliased C.int := C.int (Item.Last); begin - if Item.Set /= No_Socket_Set then + if Item.Set /= No_Fd_Set_Access then Last_Socket_In_Set (Item.Set, Last'Unchecked_Access); Item.Last := Socket_Type (Last); end if; @@ -1297,6 +1389,63 @@ package body GNAT.Sockets is return To_String (S.Official); end Official_Name; + -------------------- + -- Wait_On_Socket -- + -------------------- + + procedure Wait_On_Socket + (Socket : Socket_Type; + For_Read : Boolean; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status) + is + type Local_Selector_Access is access Selector_Type; + for Local_Selector_Access'Storage_Size use Selector_Type'Size; + + S : Selector_Access; + -- Selector to use for waiting + + R_Fd_Set : Socket_Set_Type; + W_Fd_Set : Socket_Set_Type; + -- Socket sets, empty at elaboration + + begin + -- Create selector if not provided by the user + + if Selector = null then + declare + Local_S : constant Local_Selector_Access := new Selector_Type; + begin + S := Local_S.all'Unchecked_Access; + Create_Selector (S.all); + end; + + else + S := Selector.all'Access; + end if; + + if For_Read then + Set (R_Fd_Set, Socket); + else + Set (W_Fd_Set, Socket); + end if; + + Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout); + + -- Cleanup actions (required in all cases to avoid memory leaks) + + if For_Read then + Empty (R_Fd_Set); + else + Empty (W_Fd_Set); + end if; + + if Selector = null then + Close_Selector (S.all); + end if; + end Wait_On_Socket; + ----------------- -- Port_Number -- ----------------- @@ -1638,8 +1787,7 @@ package body GNAT.Sockets is Len : constant C.int := Sin'Size / 8; begin - Set_Length (Sin'Unchecked_Access, Len); - Set_Family (Sin'Unchecked_Access, Families (To.Family)); + Set_Family (Sin.Sin_Family, To.Family); Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr)); Set_Port (Sin'Unchecked_Access, @@ -1710,8 +1858,8 @@ package body GNAT.Sockets is procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is begin - if Item.Set = No_Socket_Set then - Item.Set := New_Socket_Set (No_Socket_Set); + if Item.Set = No_Fd_Set_Access then + Item.Set := New_Socket_Set (No_Fd_Set_Access); Item.Last := Socket; elsif Item.Last < Socket then @@ -1972,7 +2120,7 @@ package body GNAT.Sockets is -- To_In_Addr -- ---------------- - function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr is + function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr is begin if Addr.Family = Family_Inet then return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)), diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index 55b68134515..7ebf243904e 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -52,8 +52,6 @@ with Ada.Exceptions; with Ada.Streams; with Ada.Unchecked_Deallocation; -with System; - package GNAT.Sockets is -- Sockets are designed to provide a consistent communication facility @@ -397,6 +395,31 @@ package GNAT.Sockets is No_Socket : constant Socket_Type; + type Selector_Type is limited private; + type Selector_Access is access all Selector_Type; + -- Selector objects are used to wait for i/o events to occur on sockets + + -- Timeval_Duration is a subtype of Standard.Duration because the full + -- range of Standard.Duration cannot be represented in the equivalent C + -- structure. Moreover, negative values are not allowed to avoid system + -- incompatibilities. + + Immediate : constant := 0.0; + Forever : constant := Duration (Integer'Last) * 1.0; + -- Should be Duration 2 ** (Constants.SIZEOF_tv_sec * 8 - 1) - 1 ??? + + subtype Timeval_Duration is Duration range Immediate .. Forever; + + subtype Selector_Duration is Timeval_Duration; + -- Timeout value for selector operations + + type Selector_Status is (Completed, Expired, Aborted); + -- Completion status of a selector operation, indicated as follows: + -- Complete: one of the expected events occurred + -- Expired: no event occurred before the expiration of the timeout + -- Aborted: an external action cancelled the wait operation before + -- any event occurred. + Socket_Error : exception; -- There is only one exception in this package to deal with an error during -- a socket routine. Once raised, its message contains a string describing @@ -435,10 +458,10 @@ package GNAT.Sockets is No_Port : constant Port_Type; type Inet_Addr_Type (Family : Family_Type := Family_Inet) is private; - -- An Internet address depends on an address family (IPv4 contains 4 - -- octets and IPv6 contains 16 octets). Any_Inet_Addr is a special value - -- treated like a wildcard enabling all addresses. No_Inet_Addr provides a - -- special value to denote uninitialized inet addresses. + -- An Internet address depends on an address family (IPv4 contains 4 octets + -- and IPv6 contains 16 octets). Any_Inet_Addr is a special value treated + -- like a wildcard enabling all addresses. No_Inet_Addr provides a special + -- value to denote uninitialized inet addresses. Any_Inet_Addr : constant Inet_Addr_Type; No_Inet_Addr : constant Inet_Addr_Type; @@ -508,8 +531,8 @@ package GNAT.Sockets is function Get_Host_By_Name (Name : String) return Host_Entry_Type; -- Return host entry structure for the given host name. Here name is - -- either a host name, or an IP address. If Name is an IP address, this is - -- equivalent to Get_Host_By_Address (Inet_Addr (Name)). + -- either a host name, or an IP address. If Name is an IP address, this + -- is equivalent to Get_Host_By_Address (Inet_Addr (Name)). function Host_Name return String; -- Return the name of the current host @@ -549,10 +572,10 @@ package GNAT.Sockets is Service_Error : exception; -- Comment required ??? - -- Errors are described by an enumeration type. There is only one - -- exception Socket_Error in this package to deal with an error during a - -- socket routine. Once raised, its message contains the error code - -- between brackets and a string describing the error code. + -- Errors are described by an enumeration type. There is only one exception + -- Socket_Error in this package to deal with an error during a socket + -- routine. Once raised, its message contains the error code between + -- brackets and a string describing the error code. -- The name of the enumeration constant documents the error condition @@ -602,16 +625,6 @@ package GNAT.Sockets is Unknown_Server_Error, Cannot_Resolve_Error); - -- Timeval_Duration is a subtype of Standard.Duration because the full - -- range of Standard.Duration cannot be represented in the equivalent C - -- structure. Moreover, negative values are not allowed to avoid system - -- incompatibilities. - - Immediate : constant := 0.0; - Forever : constant := Duration (Integer'Last) * 1.0; - - subtype Timeval_Duration is Duration range Immediate .. Forever; - -- Get_Socket_Options and Set_Socket_Options manipulate options associated -- with a socket. Options may exist at multiple protocol levels in the -- communication stack. Socket_Level is the uppermost socket level. @@ -722,9 +735,9 @@ package GNAT.Sockets is -- Socket_Stream). Peek_At_Incoming_Data : constant Request_Flag_Type; - -- This flag causes the receive operation to return data from the - -- beginning of the receive queue without removing that data from the - -- queue. A subsequent receive call will return the same data. + -- This flag causes the receive operation to return data from the beginning + -- of the receive queue without removing that data from the queue. A + -- subsequent receive call will return the same data. Wait_For_A_Full_Reception : constant Request_Flag_Type; -- This flag requests that the operation block until the full request is @@ -766,6 +779,20 @@ package GNAT.Sockets is -- is filled in with the address of the connection. Raises Socket_Error on -- error. + procedure Accept_Socket + (Server : Socket_Type; + Socket : out Socket_Type; + Address : out Sock_Addr_Type; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status); + -- Accept a new connection on Server using Accept_Socket, waiting no longer + -- than the given timeout duration. Status is set to indicate whether the + -- operation completed successully, timed out, or was aborted. If Selector + -- is not null, the designated selector is used to wait for the socket to + -- become available, else a private selector object is created by this + -- procedure and destroyed before it returns. + procedure Bind_Socket (Socket : Socket_Type; Address : Sock_Addr_Type); @@ -781,12 +808,25 @@ package GNAT.Sockets is -- Make a connection to another socket which has the address of Server. -- Raises Socket_Error on error. + procedure Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status); + -- Connect Socket to the given Server address using Connect_Socket, waiting + -- no longer than the given timeout duration. Status is set to indicate + -- whether the operation completed successully, timed out, or was aborted. + -- If Selector is not null, the designated selector is used to wait for the + -- socket to become available, else a private selector object is created + -- by this procedure and destroyed before it returns. + procedure Control_Socket (Socket : Socket_Type; Request : in out Request_Type); -- Obtain or set parameter values that control the socket. This control - -- differs from the socket options in that they are not specific to - -- sockets but are available for any device. + -- differs from the socket options in that they are not specific to sockets + -- but are available for any device. function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type; -- Return the peer or remote socket address of a socket. Raise @@ -794,22 +834,23 @@ package GNAT.Sockets is function Get_Socket_Name (Socket : Socket_Type) return Sock_Addr_Type; -- Return the local or current socket address of a socket. Return - -- No_Sock_Addr on error (for instance, socket closed or not locally - -- bound). + -- No_Sock_Addr on error (e.g. socket closed or not locally bound). function Get_Socket_Option (Socket : Socket_Type; Level : Level_Type := Socket_Level; Name : Option_Name) return Option_Type; - -- Get the options associated with a socket. Raises Socket_Error - -- on error. + -- Get the options associated with a socket. Raises Socket_Error on error procedure Listen_Socket (Socket : Socket_Type; - Length : Positive := 15); + Length : Natural := 15); -- To accept connections, a socket is first created with Create_Socket, -- a willingness to accept incoming connections and a queue Length for -- incoming connections are specified. Raise Socket_Error on error. + -- The queue length of 15 is an example value that should be appropriate + -- in usual cases. It can be adjusted according to each application's + -- particular requirements. procedure Receive_Socket (Socket : Socket_Type; @@ -959,11 +1000,6 @@ package GNAT.Sockets is -- operation is typically to add a socket in one of the socket sets when -- the timeout is set to forever. - type Selector_Type is limited private; - type Selector_Access is access all Selector_Type; - - subtype Selector_Duration is Timeval_Duration; - procedure Create_Selector (Selector : out Selector_Type); -- Create a new selector @@ -973,8 +1009,6 @@ package GNAT.Sockets is -- no other task still using Selector (i.e. still executing Check_Selector -- or Abort_Selector on this Selector). - type Selector_Status is (Completed, Expired, Aborted); - procedure Check_Selector (Selector : in out Selector_Type; R_Socket_Set : in out Socket_Set_Type; @@ -1009,6 +1043,16 @@ package GNAT.Sockets is procedure Abort_Selector (Selector : Selector_Type); -- Send an abort signal to the selector + type Fd_Set_Access is private; + No_Fd_Set_Access : constant Fd_Set_Access; + -- ??? This type must not be used directly, it needs to be visible because + -- it is used in the visible part of GNAT.Sockets.Thin_Common. This is + -- really an inversion of abstraction. The private part of GNAT.Sockets + -- needs to have visibility on this type, but since Thin_Common is a child + -- of Sokcets, the type can't be declared there. The correct fix would + -- be to move the thin sockets binding outside of GNAT.Sockets altogether, + -- e.g. by renaming it to GNAT.Sockets_Thin. + private type Socket_Type is new Integer; @@ -1017,18 +1061,19 @@ private type Selector_Type is limited record R_Sig_Socket : Socket_Type := No_Socket; W_Sig_Socket : Socket_Type := No_Socket; + -- Signalling sockets used to abort a select operation end record; pragma Volatile (Selector_Type); - -- The two signalling sockets are used to abort a select operation - - subtype Socket_Set_Access is System.Address; - No_Socket_Set : constant Socket_Set_Access := System.Null_Address; + type Fd_Set is null record; + type Fd_Set_Access is access all Fd_Set; + pragma Convention (C, Fd_Set_Access); + No_Fd_Set_Access : constant Fd_Set_Access := null; type Socket_Set_Type is record Last : Socket_Type := No_Socket; - Set : Socket_Set_Access := No_Socket_Set; + Set : Fd_Set_Access; end record; subtype Inet_Addr_Comp_Type is Natural range 0 .. 255; diff --git a/gcc/ada/g-socthi-mingw.adb b/gcc/ada/g-socthi-mingw.adb index 78d5c3feadc..ad99f9be4da 100644 --- a/gcc/ada/g-socthi-mingw.adb +++ b/gcc/ada/g-socthi-mingw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2007, AdaCore -- +-- Copyright (C) 2001-2008, 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- -- @@ -39,10 +39,12 @@ with Interfaces.C.Strings; use Interfaces.C.Strings; with System; use System; +with GNAT.Sockets.Constants; package body GNAT.Sockets.Thin is use type C.unsigned; + use type C.int; WSAData_Dummy : array (1 .. 512) of C.int; @@ -294,7 +296,7 @@ package body GNAT.Sockets.Thin is RFS : constant Fd_Set_Access := Readfds; WFS : constant Fd_Set_Access := Writefds; - WFSC : Fd_Set_Access := No_Fd_Set; + WFSC : Fd_Set_Access := No_Fd_Set_Access; EFS : Fd_Set_Access := Exceptfds; Res : C.int; S : aliased C.int; @@ -310,10 +312,10 @@ package body GNAT.Sockets.Thin is -- the initial write fd set, then move the socket from the -- exception fd set to the write fd set. - if WFS /= No_Fd_Set then + if WFS /= No_Fd_Set_Access then -- Add any socket present in write fd set into exception fd set - if EFS = No_Fd_Set then + if EFS = No_Fd_Set_Access then EFS := New_Socket_Set (WFS); else @@ -337,7 +339,7 @@ package body GNAT.Sockets.Thin is Res := Standard_Select (Nfds, RFS, WFS, EFS, Timeout); - if EFS /= No_Fd_Set then + if EFS /= No_Fd_Set_Access then declare EFSC : constant Fd_Set_Access := New_Socket_Set (EFS); Flag : constant C.int := Constants.MSG_PEEK + Constants.MSG_OOB; @@ -372,7 +374,7 @@ package body GNAT.Sockets.Thin is -- set. Otherwise, ignore this event since the user -- is not watching for it. - if WFSC /= No_Fd_Set + if WFSC /= No_Fd_Set_Access and then (Is_Socket_In_Set (WFSC, S) /= 0) then Insert_Socket_In_Set (WFS, S); @@ -383,14 +385,14 @@ package body GNAT.Sockets.Thin is Free_Socket_Set (EFSC); end; - if Exceptfds = No_Fd_Set then + if Exceptfds = No_Fd_Set_Access then Free_Socket_Set (EFS); end if; end if; -- Free any copy of write fd set - if WFSC /= No_Fd_Set then + if WFSC /= No_Fd_Set_Access then Free_Socket_Set (WFSC); end if; @@ -473,57 +475,6 @@ package body GNAT.Sockets.Thin is end if; end Initialize; - ----------------- - -- Set_Address -- - ----------------- - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr) - is - begin - Sin.Sin_Addr := Address; - end Set_Address; - - ---------------- - -- Set_Family -- - ---------------- - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int) - is - begin - Sin.Sin_Family := C.unsigned_short (Family); - end Set_Family; - - ---------------- - -- Set_Length -- - ---------------- - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int) - is - pragma Unreferenced (Sin); - pragma Unreferenced (Len); - - begin - null; - end Set_Length; - - -------------- - -- Set_Port -- - -------------- - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short) - is - begin - Sin.Sin_Port := Port; - end Set_Port; - -------------------- -- Signalling_Fds -- -------------------- diff --git a/gcc/ada/g-socthi-mingw.ads b/gcc/ada/g-socthi-mingw.ads index 906b6691e0c..231564012b2 100644 --- a/gcc/ada/g-socthi-mingw.ads +++ b/gcc/ada/g-socthi-mingw.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2007, AdaCore -- +-- Copyright (C) 2001-2008, 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,22 +37,17 @@ -- This version is for NT -with Interfaces.C.Pointers; with Interfaces.C.Strings; -with GNAT.Sockets.Constants; +with GNAT.Sockets.Thin_Common; with System; package GNAT.Sockets.Thin is - package C renames Interfaces.C; - - use type C.int; - -- So that we can declare the Failure constant below + use Thin_Common; - Success : constant C.int := 0; - Failure : constant C.int := -1; + package C renames Interfaces.C; function Socket_Errno return Integer; -- Returns last socket error number @@ -77,158 +72,6 @@ package GNAT.Sockets.Thin is end Host_Error_Messages; - subtype Fd_Set_Access is System.Address; - No_Fd_Set : constant Fd_Set_Access := System.Null_Address; - - type time_t is - range -2 ** (8 * Constants.SIZEOF_tv_sec - 1) - .. 2 ** (8 * Constants.SIZEOF_tv_sec - 1) - 1; - for time_t'Size use 8 * Constants.SIZEOF_tv_sec; - pragma Convention (C, time_t); - - type suseconds_t is - range -2 ** (8 * Constants.SIZEOF_tv_usec - 1) - .. 2 ** (8 * Constants.SIZEOF_tv_usec - 1) - 1; - for suseconds_t'Size use 8 * Constants.SIZEOF_tv_usec; - pragma Convention (C, suseconds_t); - - type Timeval is record - Tv_Sec : time_t; - Tv_Usec : suseconds_t; - end record; - pragma Convention (C, Timeval); - - type Timeval_Access is access all Timeval; - pragma Convention (C, Timeval_Access); - - Immediat : constant Timeval := (0, 0); - - type Int_Access is access all C.int; - pragma Convention (C, Int_Access); - -- Access to C integers - - type Chars_Ptr_Array is array (C.size_t range <>) of - aliased C.Strings.chars_ptr; - - package Chars_Ptr_Pointers is - new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, - C.Strings.Null_Ptr); - -- Arrays of C (char *) - - type In_Addr is record - S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; - end record; - for In_Addr'Alignment use C.int'Alignment; - pragma Convention (C, In_Addr); - -- IPv4 address, represented as a network-order C.int. Note that the - -- underlying operating system may assume that values of this type have - -- C.int alignment, so we need to provide a suitable alignment clause here. - - type In_Addr_Access is access all In_Addr; - pragma Convention (C, In_Addr_Access); - -- Access to internet address - - Inaddr_Any : aliased constant In_Addr := (others => 0); - -- Any internet address (all the interfaces) - - type In_Addr_Access_Array is array (C.size_t range <>) - of aliased In_Addr_Access; - pragma Convention (C, In_Addr_Access_Array); - - package In_Addr_Access_Pointers is - new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); - -- Array of internet addresses - - type Sockaddr is record - Sa_Family : C.unsigned_short; - Sa_Data : C.char_array (1 .. 14); - end record; - pragma Convention (C, Sockaddr); - -- Socket address - - type Sockaddr_Access is access all Sockaddr; - pragma Convention (C, Sockaddr_Access); - -- Access to socket address - - type Sockaddr_In is record - Sin_Family : C.unsigned_short := Constants.AF_INET; - Sin_Port : C.unsigned_short := 0; - Sin_Addr : In_Addr := Inaddr_Any; - Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0)); - end record; - pragma Convention (C, Sockaddr_In); - -- Internet socket address - - type Sockaddr_In_Access is access all Sockaddr_In; - pragma Convention (C, Sockaddr_In_Access); - -- Access to internet socket address - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int); - pragma Inline (Set_Length); - -- Set Sin.Sin_Length to Len. - -- On this platform, nothing is done as there is no such field. - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int); - pragma Inline (Set_Family); - -- Set Sin.Sin_Family to Family - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short); - pragma Inline (Set_Port); - -- Set Sin.Sin_Port to Port - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr); - pragma Inline (Set_Address); - -- Set Sin.Sin_Addr to Address - - type Hostent is record - H_Name : C.Strings.chars_ptr; - H_Aliases : Chars_Ptr_Pointers.Pointer; - H_Addrtype : C.short; - H_Length : C.short; - H_Addr_List : In_Addr_Access_Pointers.Pointer; - end record; - pragma Convention (C, Hostent); - -- Host entry - - type Hostent_Access is access all Hostent; - pragma Convention (C, Hostent_Access); - -- Access to host entry - - 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_Access is access all Servent; - pragma Convention (C, Servent_Access); - -- Access to service entry - - type Two_Ints is array (0 .. 1) of C.int; - pragma Convention (C, Two_Ints); - -- Container for two int values - - subtype Fd_Pair is Two_Ints; - -- Two_Ints as used for Create_Signalling_Fds: a pair of connected file - -- descriptors, one of which (the "read end" of the connection) being used - -- for reading, the other one (the "write end") being used for writing. - - Read_End : constant := 0; - Write_End : constant := 1; - -- Indices into an Fd_Pair value providing access to each of the connected - -- file descriptors. - -------------------------------- -- Standard library functions -- -------------------------------- @@ -382,55 +225,6 @@ package GNAT.Sockets.Thin is end Signalling_Fds; - ---------------------------- - -- Socket sets management -- - ---------------------------- - - procedure Free_Socket_Set - (Set : Fd_Set_Access); - -- Free system-dependent socket set - - procedure Get_Socket_From_Set - (Set : Fd_Set_Access; - Socket : Int_Access; - Last : Int_Access); - -- Get last socket in Socket and remove it from the socket set. The - -- parameter Last is a maximum value of the largest socket. This hint is - -- used to avoid scanning very large socket sets. After a call to - -- Get_Socket_From_Set, Last is set back to the real largest socket in the - -- socket set. - - procedure Insert_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Insert socket in the socket set - - function Is_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int) return C.int; - -- Check whether Socket is in the socket set, return a non-zero - -- value if it is, zero if it is not. - - procedure Last_Socket_In_Set - (Set : Fd_Set_Access; - Last : Int_Access); - -- Find the largest socket in the socket set. This is needed for select(). - -- When Last_Socket_In_Set is called, parameter Last is a maximum value of - -- the largest socket. This hint is used to avoid scanning very large - -- socket sets. After the call, Last is set back to the real largest socket - -- in the socket set. - - function New_Socket_Set - (Set : Fd_Set_Access) return Fd_Set_Access; - -- Allocate a new socket set which is a system-dependent structure and - -- initialize by copying Set if it is non-null, by making it empty - -- otherwise. - - procedure Remove_Socket_From_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Remove socket from the socket set - procedure WSACleanup; procedure Initialize; @@ -461,12 +255,4 @@ private pragma Import (Stdcall, WSAStartup, "WSAStartup"); pragma Import (Stdcall, WSACleanup, "WSACleanup"); - pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); - pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); - pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); - pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); - pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); - pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); - pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); - end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb index 0d620c2e990..f71bb2387de 100644 --- a/gcc/ada/g-socthi-vms.adb +++ b/gcc/ada/g-socthi-vms.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2007, AdaCore -- +-- Copyright (C) 2001-2008, 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,6 +34,7 @@ -- Temporary version for Alpha/VMS with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Sockets.Constants; with GNAT.Task_Lock; with Interfaces.C; use Interfaces.C; @@ -41,7 +42,7 @@ with Interfaces.C; use Interfaces.C; package body GNAT.Sockets.Thin is Non_Blocking_Sockets : constant Fd_Set_Access := - New_Socket_Set (No_Socket_Set); + New_Socket_Set (No_Fd_Set_Access); -- When this package is initialized with Process_Blocking_IO set -- to True, sockets are set in non-blocking mode to avoid blocking -- the whole process when a thread wants to perform a blocking IO @@ -182,15 +183,15 @@ package body GNAT.Sockets.Thin is Now : aliased Timeval; begin - WSet := New_Socket_Set (No_Socket_Set); + WSet := New_Socket_Set (No_Fd_Set_Access); loop Insert_Socket_In_Set (WSet, S); Now := Immediat; Res := C_Select (S + 1, - No_Fd_Set, + No_Fd_Set_Access, WSet, - No_Fd_Set, + No_Fd_Set_Access, Now'Unchecked_Access); exit when Res > 0; @@ -208,10 +209,9 @@ package body GNAT.Sockets.Thin is Res := Syscall_Connect (S, Name, Namelen); - if Res = Failure - and then Errno = Constants.EISCONN - then - return Thin.Success; + if Res = Failure and then Errno = Constants.EISCONN then + return Thin_Common.Success; + else return Res; end if; @@ -410,35 +410,6 @@ package body GNAT.Sockets.Thin is return R; end Non_Blocking_Socket; - ----------------- - -- Set_Address -- - ----------------- - - procedure Set_Address (Sin : Sockaddr_In_Access; Address : In_Addr) is - begin - Sin.Sin_Addr := Address; - end Set_Address; - - ---------------- - -- Set_Family -- - ---------------- - - procedure Set_Family (Sin : Sockaddr_In_Access; Family : C.int) is - begin - Sin.Sin_Family := C.unsigned_short (Family); - end Set_Family; - - ---------------- - -- Set_Length -- - ---------------- - - procedure Set_Length (Sin : Sockaddr_In_Access; Len : C.int) is - pragma Unreferenced (Sin); - pragma Unreferenced (Len); - begin - null; - end Set_Length; - ----------------------------- -- Set_Non_Blocking_Socket -- ----------------------------- @@ -456,15 +427,6 @@ package body GNAT.Sockets.Thin is Task_Lock.Unlock; end Set_Non_Blocking_Socket; - -------------- - -- Set_Port -- - -------------- - - procedure Set_Port (Sin : Sockaddr_In_Access; Port : C.unsigned_short) is - begin - Sin.Sin_Port := Port; - end Set_Port; - -------------------- -- Signalling_Fds -- -------------------- diff --git a/gcc/ada/g-socthi-vms.ads b/gcc/ada/g-socthi-vms.ads index b2af2ca020b..3bcc21b8c67 100644 --- a/gcc/ada/g-socthi-vms.ads +++ b/gcc/ada/g-socthi-vms.ads @@ -37,26 +37,20 @@ -- This is the Alpha/VMS version -with Interfaces.C.Pointers; with Interfaces.C.Strings; with GNAT.OS_Lib; -with GNAT.Sockets.Constants; +with GNAT.Sockets.Thin_Common; with System; -with System.Aux_DEC; package GNAT.Sockets.Thin is -- ??? more comments needed ??? - package C renames Interfaces.C; - - use type C.int; - -- This is so we can declare the Failure constant below + use Thin_Common; - Success : constant C.int := 0; - Failure : constant C.int := -1; + package C renames Interfaces.C; function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; -- Returns last socket error number @@ -81,162 +75,6 @@ package GNAT.Sockets.Thin is end Host_Error_Messages; - subtype Fd_Set_Access is System.Aux_DEC.Short_Address; - No_Fd_Set : constant Fd_Set_Access := System.Null_Address; - - type time_t is - range -2 ** (8 * Constants.SIZEOF_tv_sec - 1) - .. 2 ** (8 * Constants.SIZEOF_tv_sec - 1) - 1; - for time_t'Size use 8 * Constants.SIZEOF_tv_sec; - pragma Convention (C, time_t); - - type suseconds_t is - range -2 ** (8 * Constants.SIZEOF_tv_usec - 1) - .. 2 ** (8 * Constants.SIZEOF_tv_usec - 1) - 1; - for suseconds_t'Size use 8 * Constants.SIZEOF_tv_usec; - pragma Convention (C, suseconds_t); - - type Timeval is record - Tv_Sec : time_t; - Tv_Usec : suseconds_t; - end record; - pragma Convention (C, Timeval); - - type Timeval_Access is access all Timeval; - pragma Convention (C, Timeval_Access); - - Immediat : constant Timeval := (0, 0); - - type Int_Access is access all C.int; - pragma Convention (C, Int_Access); - -- Access to C integers - - type Chars_Ptr_Array is array (C.size_t range <>) of - aliased C.Strings.chars_ptr; - - package Chars_Ptr_Pointers is - new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, - C.Strings.Null_Ptr); - -- Arrays of C (char *) - - type In_Addr is record - S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; - end record; - for In_Addr'Alignment use C.int'Alignment; - pragma Convention (C, In_Addr); - -- IPv4 address, represented as a network-order C.int. Note that the - -- underlying operating system may assume that values of this type have - -- C.int alignment, so we need to provide a suitable alignment clause here. - - type In_Addr_Access is access all In_Addr; - pragma Convention (C, In_Addr_Access); - -- Access to internet address - - Inaddr_Any : aliased constant In_Addr := (others => 0); - -- Any internet address (all the interfaces) - - type In_Addr_Access_Array is array (C.size_t range <>) - of aliased In_Addr_Access; - pragma Convention (C, In_Addr_Access_Array); - - package In_Addr_Access_Pointers is - new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); - -- Array of internet addresses - - type Sockaddr is record - Sa_Family : C.unsigned_short; - Sa_Data : C.char_array (1 .. 14); - end record; - pragma Convention (C, Sockaddr); - -- Socket address - - type Sockaddr_Access is access all Sockaddr; - for Sockaddr_Access'Size use 32; - pragma Convention (C, Sockaddr_Access); - -- Access to socket address - - type Sockaddr_In is record - Sin_Family : C.unsigned_short := Constants.AF_INET; - Sin_Port : C.unsigned_short := 0; - Sin_Addr : In_Addr := Inaddr_Any; - Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0)); - end record; - pragma Convention (C, Sockaddr_In); - -- Internet socket address - - type Sockaddr_In_Access is access all Sockaddr_In; - for Sockaddr_In_Access'Size use 32; - pragma Convention (C, Sockaddr_In_Access); - -- Access to internet socket address - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int); - pragma Inline (Set_Length); - -- Set Sin.Sin_Length to Len. - -- On this platform, nothing is done as there is no such field. - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int); - pragma Inline (Set_Family); - -- Set Sin.Sin_Family to Family - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short); - pragma Inline (Set_Port); - -- Set Sin.Sin_Port to Port - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr); - pragma Inline (Set_Address); - -- Set Sin.Sin_Addr to Address - - type Hostent is record - H_Name : C.Strings.chars_ptr; - H_Aliases : Chars_Ptr_Pointers.Pointer; - H_Addrtype : C.int; - H_Length : C.int; - H_Addr_List : In_Addr_Access_Pointers.Pointer; - end record; - pragma Convention (C, Hostent); - -- Host entry - - type Hostent_Access is access all Hostent; - for Hostent_Access'Size use 32; - pragma Convention (C, Hostent_Access); - -- Access to host entry - - 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_Access is access all Servent; - for Servent_Access'Size use 32; - pragma Convention (C, Servent_Access); - -- Access to service entry - - type Two_Ints is array (0 .. 1) of C.int; - pragma Convention (C, Two_Ints); - -- Container for two int values - - subtype Fd_Pair is Two_Ints; - -- Two_Ints as used for Create_Signalling_Fds: a pair of connected file - -- descriptors, one of which (the "read end" of the connection) being used - -- for reading, the other one (the "write end") being used for writing. - - Read_End : constant := 0; - Write_End : constant := 1; - -- Indices into an Fd_Pair value providing access to each of the connected - -- file descriptors. - -------------------------------- -- Standard library functions -- -------------------------------- @@ -386,55 +224,6 @@ package GNAT.Sockets.Thin is end Signalling_Fds; - ---------------------------- - -- Socket sets management -- - ---------------------------- - - procedure Free_Socket_Set - (Set : Fd_Set_Access); - -- Free system-dependent socket set - - procedure Get_Socket_From_Set - (Set : Fd_Set_Access; - Socket : Int_Access; - Last : Int_Access); - -- Get last socket in Socket and remove it from the socket set. The - -- parameter Last is a maximum value of the largest socket. This hint is - -- used to avoid scanning very large socket sets. After a call to - -- Get_Socket_From_Set, Last is set back to the real largest socket in the - -- socket set. - - procedure Insert_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Insert socket in the socket set - - function Is_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int) return C.int; - -- Check whether Socket is in the socket set, return a non-zero - -- value if it is, zero if it is not. - - procedure Last_Socket_In_Set - (Set : Fd_Set_Access; - Last : Int_Access); - -- Find the largest socket in the socket set. This is needed for select(). - -- When Last_Socket_In_Set is called, parameter Last is a maximum value of - -- the largest socket. This hint is used to avoid scanning very large - -- socket sets. After the call, Last is set back to the real largest socket - -- in the socket set. - - function New_Socket_Set - (Set : Fd_Set_Access) return Fd_Set_Access; - -- Allocate a new socket set which is a system-dependent structure and - -- initialize by copying Set if it is non-null, by making it empty - -- otherwise. - - procedure Remove_Socket_From_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Remove socket from the socket set - ------------------------------------------- -- Nonreentrant network databases access -- ------------------------------------------- @@ -474,14 +263,6 @@ private pragma Import (C, C_Strerror, "DECC$STRERROR"); pragma Import (C, C_System, "DECC$SYSTEM"); - pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); - pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); - pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); - pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); - pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); - pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); - pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); - pragma Import (C, Nonreentrant_Gethostbyname, "DECC$GETHOSTBYNAME"); pragma Import (C, Nonreentrant_Gethostbyaddr, "DECC$GETHOSTBYADDR"); pragma Import (C, Nonreentrant_Getservbyname, "DECC$GETSERVBYNAME"); diff --git a/gcc/ada/g-socthi-vxworks.adb b/gcc/ada/g-socthi-vxworks.adb index 681ea861b42..0077e2777f5 100644 --- a/gcc/ada/g-socthi-vxworks.adb +++ b/gcc/ada/g-socthi-vxworks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2007, AdaCore -- +-- Copyright (C) 2002-2008, 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- -- @@ -38,6 +38,7 @@ -- This version is for VxWorks with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Sockets.Constants; with GNAT.Task_Lock; with Interfaces.C; use Interfaces.C; @@ -45,7 +46,7 @@ with Interfaces.C; use Interfaces.C; package body GNAT.Sockets.Thin is Non_Blocking_Sockets : constant Fd_Set_Access := - New_Socket_Set (No_Socket_Set); + New_Socket_Set (No_Fd_Set_Access); -- When this package is initialized with Process_Blocking_IO set -- to True, sockets are set in non-blocking mode to avoid blocking -- the whole process when a thread wants to perform a blocking IO @@ -195,16 +196,16 @@ package body GNAT.Sockets.Thin is Now : aliased Timeval; begin - WSet := New_Socket_Set (No_Socket_Set); + WSet := New_Socket_Set (No_Fd_Set_Access); loop Insert_Socket_In_Set (WSet, S); Now := Immediat; Res := C_Select (S + 1, - No_Fd_Set, + No_Fd_Set_Access, WSet, - No_Fd_Set, + No_Fd_Set_Access, Now'Unchecked_Access); exit when Res > 0; @@ -225,7 +226,7 @@ package body GNAT.Sockets.Thin is if Res = Failure and then Errno = Constants.EISCONN then - return Thin.Success; + return Thin_Common.Success; else return Res; end if; @@ -425,42 +426,6 @@ package body GNAT.Sockets.Thin is return R; end Non_Blocking_Socket; - ----------------- - -- Set_Address -- - ----------------- - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr) - is - begin - Sin.Sin_Addr := Address; - end Set_Address; - - ---------------- - -- Set_Family -- - ---------------- - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int) - is - begin - Sin.Sin_Family := C.unsigned_char (Family); - end Set_Family; - - ---------------- - -- Set_Length -- - ---------------- - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int) - is - begin - Sin.Sin_Length := C.unsigned_char (Len); - end Set_Length; - ----------------------------- -- Set_Non_Blocking_Socket -- ----------------------------- @@ -477,18 +442,6 @@ package body GNAT.Sockets.Thin is Task_Lock.Unlock; end Set_Non_Blocking_Socket; - -------------- - -- Set_Port -- - -------------- - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short) - is - begin - Sin.Sin_Port := Port; - end Set_Port; - -------------------- -- Signalling_Fds -- -------------------- diff --git a/gcc/ada/g-socthi-vxworks.ads b/gcc/ada/g-socthi-vxworks.ads index 3e006a74089..fa3f82f57e2 100644 --- a/gcc/ada/g-socthi-vxworks.ads +++ b/gcc/ada/g-socthi-vxworks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2007, AdaCore -- +-- Copyright (C) 2002-2008, 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,25 +37,18 @@ -- This is the version for VxWorks -with Interfaces.C.Pointers; with Interfaces.C.Strings; -with Ada.Unchecked_Conversion; - with GNAT.OS_Lib; -with GNAT.Sockets.Constants; +with GNAT.Sockets.Thin_Common; with System; package GNAT.Sockets.Thin is - package C renames Interfaces.C; - - use type C.int; - -- This is so we can declare the Failure constant below + use Thin_Common; - Success : constant C.int := 0; - Failure : constant C.int := -1; + package C renames Interfaces.C; function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; -- Returns last socket error number @@ -80,161 +73,6 @@ package GNAT.Sockets.Thin is end Host_Error_Messages; - subtype Fd_Set_Access is System.Address; - No_Fd_Set : constant Fd_Set_Access := System.Null_Address; - - type time_t is - range -2 ** (8 * Constants.SIZEOF_tv_sec - 1) - .. 2 ** (8 * Constants.SIZEOF_tv_sec - 1) - 1; - for time_t'Size use 8 * Constants.SIZEOF_tv_sec; - pragma Convention (C, time_t); - - type suseconds_t is - range -2 ** (8 * Constants.SIZEOF_tv_usec - 1) - .. 2 ** (8 * Constants.SIZEOF_tv_usec - 1) - 1; - for suseconds_t'Size use 8 * Constants.SIZEOF_tv_usec; - pragma Convention (C, suseconds_t); - - type Timeval is record - Tv_Sec : time_t; - Tv_Usec : suseconds_t; - end record; - pragma Convention (C, Timeval); - - type Timeval_Access is access all Timeval; - pragma Convention (C, Timeval_Access); - - Immediat : constant Timeval := (0, 0); - - type Int_Access is access all C.int; - pragma Convention (C, Int_Access); - -- Access to C integers - - type Chars_Ptr_Array is array (C.size_t range <>) of - aliased C.Strings.chars_ptr; - - package Chars_Ptr_Pointers is - new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, - C.Strings.Null_Ptr); - -- Arrays of C (char *) - - type In_Addr is record - S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; - end record; - for In_Addr'Alignment use C.int'Alignment; - pragma Convention (C, In_Addr); - -- IPv4 address, represented as a network-order C.int. Note that the - -- underlying operating system may assume that values of this type have - -- C.int alignment, so we need to provide a suitable alignment clause here. - - function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr); - - type In_Addr_Access is access all In_Addr; - pragma Convention (C, In_Addr_Access); - -- Access to internet address - - Inaddr_Any : aliased constant In_Addr := (others => 0); - -- Any internet address (all the interfaces) - - type In_Addr_Access_Array is array (C.size_t range <>) - of aliased In_Addr_Access; - pragma Convention (C, In_Addr_Access_Array); - - package In_Addr_Access_Pointers is - new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); - -- Array of internet addresses - - type Sockaddr is record - Sa_Length : C.unsigned_char; - Sa_Family : C.unsigned_char; - Sa_Data : C.char_array (1 .. 14); - end record; - pragma Convention (C, Sockaddr); - -- Socket address - - type Sockaddr_Access is access all Sockaddr; - pragma Convention (C, Sockaddr_Access); - -- Access to socket address - - type Sockaddr_In is record - Sin_Length : C.unsigned_char := 0; - Sin_Family : C.unsigned_char := Constants.AF_INET; - Sin_Port : C.unsigned_short := 0; - Sin_Addr : In_Addr := Inaddr_Any; - Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0)); - end record; - pragma Convention (C, Sockaddr_In); - -- Internet socket address - - type Sockaddr_In_Access is access all Sockaddr_In; - pragma Convention (C, Sockaddr_In_Access); - -- Access to internet socket address - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int); - pragma Inline (Set_Length); - -- Set Sin.Sin_Length to Len - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int); - pragma Inline (Set_Family); - -- Set Sin.Sin_Family to Family - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short); - pragma Inline (Set_Port); - -- Set Sin.Sin_Port to Port - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr); - pragma Inline (Set_Address); - -- Set Sin.Sin_Addr to Address - - type Hostent is record - H_Name : C.Strings.chars_ptr; - H_Aliases : Chars_Ptr_Pointers.Pointer; - H_Addrtype : C.int; - H_Length : C.int; - H_Addr_List : In_Addr_Access_Pointers.Pointer; - end record; - pragma Convention (C, Hostent); - -- Host entry - - type Hostent_Access is access all Hostent; - pragma Convention (C, Hostent_Access); - -- Access to host entry - - 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_Access is access all Servent; - pragma Convention (C, Servent_Access); - -- Access to service entry - - type Two_Ints is array (0 .. 1) of C.int; - pragma Convention (C, Two_Ints); - -- Container for two int values - - subtype Fd_Pair is Two_Ints; - -- Two_Ints as used for Create_Signalling_Fds: a pair of connected file - -- descriptors, one of which (the "read end" of the connection) being used - -- for reading, the other one (the "write end") being used for writing. - - Read_End : constant := 0; - Write_End : constant := 1; - -- Indices into an Fd_Pair value providing access to each of the connected - -- file descriptors. - -------------------------------- -- Standard library functions -- -------------------------------- @@ -384,55 +222,6 @@ package GNAT.Sockets.Thin is end Signalling_Fds; - ---------------------------- - -- Socket sets management -- - ---------------------------- - - procedure Free_Socket_Set - (Set : Fd_Set_Access); - -- Free system-dependent socket set - - procedure Get_Socket_From_Set - (Set : Fd_Set_Access; - Socket : Int_Access; - Last : Int_Access); - -- Get last socket in Socket and remove it from the socket set. The - -- parameter Last is a maximum value of the largest socket. This hint is - -- used to avoid scanning very large socket sets. After a call to - -- Get_Socket_From_Set, Last is set back to the real largest socket in the - -- socket set. - - procedure Insert_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Insert socket in the socket set - - function Is_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int) return C.int; - -- Check whether Socket is in the socket set, return a non-zero - -- value if it is, zero if it is not. - - procedure Last_Socket_In_Set - (Set : Fd_Set_Access; - Last : Int_Access); - -- Find the largest socket in the socket set. This is needed for select(). - -- When Last_Socket_In_Set is called, parameter Last is a maximum value of - -- the largest socket. This hint is used to avoid scanning very large - -- socket sets. After the call, Last is set back to the real largest socket - -- in the socket set. - - function New_Socket_Set - (Set : Fd_Set_Access) return Fd_Set_Access; - -- Allocate a new socket set which is a system-dependent structure and - -- initialize by copying Set if it is non-null, by making it empty - -- otherwise. - - procedure Remove_Socket_From_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Remove socket from the socket set - procedure Initialize; procedure Finalize; @@ -452,13 +241,4 @@ private pragma Import (C, C_Strerror, "strerror"); pragma Import (C, C_System, "system"); pragma Import (C, C_Writev, "writev"); - - pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); - pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); - pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); - pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); - pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); - pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); - pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); - end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi.adb b/gcc/ada/g-socthi.adb index 6ea18f67b47..19642aa893d 100644 --- a/gcc/ada/g-socthi.adb +++ b/gcc/ada/g-socthi.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2007, AdaCore -- +-- Copyright (C) 2001-2008, 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- -- @@ -38,6 +38,7 @@ -- This is the default version with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Sockets.Constants; with GNAT.Task_Lock; with Interfaces.C; use Interfaces.C; @@ -45,7 +46,7 @@ with Interfaces.C; use Interfaces.C; package body GNAT.Sockets.Thin is Non_Blocking_Sockets : constant Fd_Set_Access := - New_Socket_Set (No_Socket_Set); + New_Socket_Set (No_Fd_Set_Access); -- When this package is initialized with Process_Blocking_IO set -- to True, sockets are set in non-blocking mode to avoid blocking -- the whole process when a thread wants to perform a blocking IO @@ -199,15 +200,15 @@ package body GNAT.Sockets.Thin is Now : aliased Timeval; begin - WSet := New_Socket_Set (No_Socket_Set); + WSet := New_Socket_Set (No_Fd_Set_Access); loop Insert_Socket_In_Set (WSet, S); Now := Immediat; Res := C_Select (S + 1, - No_Fd_Set, + No_Fd_Set_Access, WSet, - No_Fd_Set, + No_Fd_Set_Access, Now'Unchecked_Access); exit when Res > 0; @@ -228,7 +229,7 @@ package body GNAT.Sockets.Thin is if Res = Failure and then Errno = Constants.EISCONN then - return Thin.Success; + return Thin_Common.Success; else return Res; end if; @@ -427,45 +428,6 @@ package body GNAT.Sockets.Thin is return R; end Non_Blocking_Socket; - ----------------- - -- Set_Address -- - ----------------- - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr) - is - begin - Sin.Sin_Addr := Address; - end Set_Address; - - ---------------- - -- Set_Family -- - ---------------- - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int) - is - begin - Sin.Sin_Family := C.unsigned_short (Family); - end Set_Family; - - ---------------- - -- Set_Length -- - ---------------- - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int) - is - pragma Unreferenced (Sin); - pragma Unreferenced (Len); - - begin - null; - end Set_Length; - ----------------------------- -- Set_Non_Blocking_Socket -- ----------------------------- @@ -483,18 +445,6 @@ package body GNAT.Sockets.Thin is Task_Lock.Unlock; end Set_Non_Blocking_Socket; - -------------- - -- Set_Port -- - -------------- - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short) - is - begin - Sin.Sin_Port := Port; - end Set_Port; - -------------------- -- Signalling_Fds -- -------------------- diff --git a/gcc/ada/g-socthi.ads b/gcc/ada/g-socthi.ads index 59e9004afd9..01e4d817be3 100644 --- a/gcc/ada/g-socthi.ads +++ b/gcc/ada/g-socthi.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2007, AdaCore -- +-- Copyright (C) 2001-2008, 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,11 +37,10 @@ -- This is the default version -with Interfaces.C.Pointers; with Interfaces.C.Strings; with GNAT.OS_Lib; -with GNAT.Sockets.Constants; +with GNAT.Sockets.Thin_Common; with System; @@ -51,13 +50,9 @@ package GNAT.Sockets.Thin is -- standard interface. It will be used as a default for all the platforms -- that do not have a specific version of this file. - package C renames Interfaces.C; - - use type C.int; - -- This is so we can declare the Failure constant below + use Thin_Common; - Success : constant C.int := 0; - Failure : constant C.int := -1; + package C renames Interfaces.C; function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; -- Returns last socket error number @@ -79,158 +74,6 @@ package GNAT.Sockets.Thin is end Host_Error_Messages; - subtype Fd_Set_Access is System.Address; - No_Fd_Set : constant Fd_Set_Access := System.Null_Address; - - type time_t is - range -2 ** (8 * Constants.SIZEOF_tv_sec - 1) - .. 2 ** (8 * Constants.SIZEOF_tv_sec - 1) - 1; - for time_t'Size use 8 * Constants.SIZEOF_tv_sec; - pragma Convention (C, time_t); - - type suseconds_t is - range -2 ** (8 * Constants.SIZEOF_tv_usec - 1) - .. 2 ** (8 * Constants.SIZEOF_tv_usec - 1) - 1; - for suseconds_t'Size use 8 * Constants.SIZEOF_tv_usec; - pragma Convention (C, suseconds_t); - - type Timeval is record - Tv_Sec : time_t; - Tv_Usec : suseconds_t; - end record; - pragma Convention (C, Timeval); - - type Timeval_Access is access all Timeval; - pragma Convention (C, Timeval_Access); - - Immediat : constant Timeval := (0, 0); - - type Int_Access is access all C.int; - pragma Convention (C, Int_Access); - -- Access to C integers - - type Chars_Ptr_Array is array (C.size_t range <>) of - aliased C.Strings.chars_ptr; - - package Chars_Ptr_Pointers is - new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, - C.Strings.Null_Ptr); - -- Arrays of C (char *) - - type In_Addr is record - S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; - end record; - for In_Addr'Alignment use C.int'Alignment; - pragma Convention (C, In_Addr); - -- IPv4 address, represented as a network-order C.int. Note that the - -- underlying operating system may assume that values of this type have - -- C.int alignment, so we need to provide a suitable alignment clause here. - - type In_Addr_Access is access all In_Addr; - pragma Convention (C, In_Addr_Access); - -- Access to internet address - - Inaddr_Any : aliased constant In_Addr := (others => 0); - -- Any internet address (all the interfaces) - - type In_Addr_Access_Array is array (C.size_t range <>) - of aliased In_Addr_Access; - pragma Convention (C, In_Addr_Access_Array); - - package In_Addr_Access_Pointers is - new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); - -- Array of internet addresses - - type Sockaddr is record - Sa_Family : C.unsigned_short; - Sa_Data : C.char_array (1 .. 14); - end record; - pragma Convention (C, Sockaddr); - -- Socket address - - type Sockaddr_Access is access all Sockaddr; - pragma Convention (C, Sockaddr_Access); - -- Access to socket address - - type Sockaddr_In is record - Sin_Family : C.unsigned_short := Constants.AF_INET; - Sin_Port : C.unsigned_short := 0; - Sin_Addr : In_Addr := Inaddr_Any; - Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0)); - end record; - pragma Convention (C, Sockaddr_In); - -- Internet socket address - - type Sockaddr_In_Access is access all Sockaddr_In; - pragma Convention (C, Sockaddr_In_Access); - -- Access to internet socket address - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int); - pragma Inline (Set_Length); - -- Set Sin.Sin_Length to Len. - -- On this platform, nothing is done as there is no such field. - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int); - pragma Inline (Set_Family); - -- Set Sin.Sin_Family to Family - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short); - pragma Inline (Set_Port); - -- Set Sin.Sin_Port to Port - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr); - pragma Inline (Set_Address); - -- Set Sin.Sin_Addr to Address - - type Hostent is record - H_Name : C.Strings.chars_ptr; - H_Aliases : Chars_Ptr_Pointers.Pointer; - H_Addrtype : C.int; - H_Length : C.int; - H_Addr_List : In_Addr_Access_Pointers.Pointer; - end record; - pragma Convention (C, Hostent); - -- Host entry - - type Hostent_Access is access all Hostent; - pragma Convention (C, Hostent_Access); - -- Access to host entry - - 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_Access is access all Servent; - pragma Convention (C, Servent_Access); - -- Access to service entry - - type Two_Ints is array (0 .. 1) of C.int; - pragma Convention (C, Two_Ints); - -- Container for two int values - - subtype Fd_Pair is Two_Ints; - -- Two_Ints as used for Create_Signalling_Fds: a pair of connected file - -- descriptors, one of which (the "read end" of the connection) being used - -- for reading, the other one (the "write end") being used for writing. - - Read_End : constant := 0; - Write_End : constant := 1; - -- Indices into an Fd_Pair value providing access to each of the connected - -- file descriptors. - -------------------------------- -- Standard library functions -- -------------------------------- @@ -380,55 +223,6 @@ package GNAT.Sockets.Thin is end Signalling_Fds; - ---------------------------- - -- Socket sets management -- - ---------------------------- - - procedure Free_Socket_Set - (Set : Fd_Set_Access); - -- Free system-dependent socket set - - procedure Get_Socket_From_Set - (Set : Fd_Set_Access; - Socket : Int_Access; - Last : Int_Access); - -- Get last socket in Socket and remove it from the socket set. The - -- parameter Last is a maximum value of the largest socket. This hint is - -- used to avoid scanning very large socket sets. After a call to - -- Get_Socket_From_Set, Last is set back to the real largest socket in the - -- socket set. - - procedure Insert_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Insert socket in the socket set - - function Is_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int) return C.int; - -- Check whether Socket is in the socket set, return a non-zero - -- value if it is, zero if it is not. - - procedure Last_Socket_In_Set - (Set : Fd_Set_Access; - Last : Int_Access); - -- Find the largest socket in the socket set. This is needed for select(). - -- When Last_Socket_In_Set is called, parameter Last is a maximum value of - -- the largest socket. This hint is used to avoid scanning very large - -- socket sets. After the call, Last is set back to the real largest socket - -- in the socket set. - - function New_Socket_Set - (Set : Fd_Set_Access) return Fd_Set_Access; - -- Allocate a new socket set which is a system-dependent structure and - -- initialize by copying Set if it is non-null, by making it empty - -- otherwise. - - procedure Remove_Socket_From_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Remove socket from the socket set - ------------------------------------------- -- Nonreentrant network databases access -- ------------------------------------------- @@ -473,14 +267,6 @@ private pragma Import (C, C_System, "system"); pragma Import (C, C_Writev, "writev"); - pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); - pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); - pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); - pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); - pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); - pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); - pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); - pragma Import (C, Nonreentrant_Gethostbyname, "gethostbyname"); pragma Import (C, Nonreentrant_Gethostbyaddr, "gethostbyaddr"); pragma Import (C, Nonreentrant_Getservbyname, "getservbyname"); diff --git a/gcc/ada/g-sothco.adb b/gcc/ada/g-sothco.adb new file mode 100644 index 00000000000..590bffeee80 --- /dev/null +++ b/gcc/ada/g-sothco.adb @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N _ C O M M O N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008, 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- -- +-- ware Foundation; either version 2, 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. -- +-- -- +-- 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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Sockets.Thin_Common is + + ----------------- + -- Set_Address -- + ----------------- + + procedure Set_Address + (Sin : Sockaddr_In_Access; + Address : In_Addr) + is + begin + Sin.Sin_Addr := Address; + end Set_Address; + + ---------------- + -- Set_Family -- + ---------------- + + procedure Set_Family + (Length_And_Family : out Sockaddr_Length_And_Family; + Family : Family_Type) + is + C_Family : C.int renames Families (Family); + Has_Sockaddr_Len : constant Boolean := Constants.Has_Sockaddr_Len /= 0; + begin + if Has_Sockaddr_Len then + Length_And_Family.Length := Lengths (Family); + Length_And_Family.Char_Family := C.unsigned_char (C_Family); + else + Length_And_Family.Short_Family := C.unsigned_short (C_Family); + end if; + end Set_Family; + + -------------- + -- Set_Port -- + -------------- + + procedure Set_Port + (Sin : Sockaddr_In_Access; + Port : C.unsigned_short) + is + begin + Sin.Sin_Port := Port; + end Set_Port; + +end GNAT.Sockets.Thin_Common; diff --git a/gcc/ada/g-sothco.ads b/gcc/ada/g-sothco.ads new file mode 100644 index 00000000000..fee37615fb4 --- /dev/null +++ b/gcc/ada/g-sothco.ads @@ -0,0 +1,326 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N _ C O M M O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008, 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- -- +-- ware Foundation; either version 2, 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. -- +-- -- +-- 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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the target-independent part of the thin sockets mapping. +-- This package should not be directly with'ed by an applications program. + +with Ada.Unchecked_Conversion; + +with Interfaces.C; +with Interfaces.C.Pointers; +with Interfaces.C.Strings; + +with GNAT.Sockets.Constants; + +package GNAT.Sockets.Thin_Common is + + package C renames Interfaces.C; + + use type C.int; + -- This is so we can declare the Failure constant below + + Success : constant C.int := 0; + Failure : constant C.int := -1; + + type time_t is + range -2 ** (8 * Constants.SIZEOF_tv_sec - 1) + .. 2 ** (8 * Constants.SIZEOF_tv_sec - 1) - 1; + for time_t'Size use 8 * Constants.SIZEOF_tv_sec; + pragma Convention (C, time_t); + + type suseconds_t is + range -2 ** (8 * Constants.SIZEOF_tv_usec - 1) + .. 2 ** (8 * Constants.SIZEOF_tv_usec - 1) - 1; + for suseconds_t'Size use 8 * Constants.SIZEOF_tv_usec; + pragma Convention (C, suseconds_t); + + type Timeval is record + Tv_Sec : time_t; + Tv_Usec : suseconds_t; + end record; + pragma Convention (C, Timeval); + + type Timeval_Access is access all Timeval; + pragma Convention (C, Timeval_Access); + + Immediat : constant Timeval := (0, 0); + + ------------------------------------------- + -- Mapping tables to low level constants -- + ------------------------------------------- + + Families : constant array (Family_Type) of C.int := + (Family_Inet => Constants.AF_INET, + Family_Inet6 => Constants.AF_INET6); + + Lengths : constant array (Family_Type) of C.unsigned_char := + (Family_Inet => Constants.SIZEOF_sockaddr_in, + Family_Inet6 => Constants.SIZEOF_sockaddr_in6); + + ---------------------------- + -- Generic socket address -- + ---------------------------- + + -- Common header + + -- All socket address types (struct sockaddr, struct sockaddr_storage, + -- and protocol specific address types) start with the same 2-byte header, + -- which is either a length and a family (one byte each) or just a two-byte + -- family. The following unchecked union describes the two possible layouts + -- and is meant to be constrained with Constants.Have_Sockaddr_Len. + + type Sockaddr_Length_And_Family + (Has_Sockaddr_Len : Boolean := False) + is record + case Has_Sockaddr_Len is + when True => + Length : C.unsigned_char; + Char_Family : C.unsigned_char; + + when False => + Short_Family : C.unsigned_short; + end case; + end record; + pragma Unchecked_Union (Sockaddr_Length_And_Family); + pragma Convention (C, Sockaddr_Length_And_Family); + + procedure Set_Family + (Length_And_Family : out Sockaddr_Length_And_Family; + Family : Family_Type); + -- Set the family component to the appropriate value for Family, and also + -- set Length accordingly if applicable on this platform. + + type Sockaddr is record + Sa_Family : Sockaddr_Length_And_Family; + -- Address family (and address length on some platforms) + + Sa_Data : C.char_array (1 .. 14) := (others => C.nul); + -- Family-specific data + -- Note that some platforms require that all unused (reserved) bytes + -- in addresses be initialized to 0 (e.g. VxWorks). + end record; + pragma Convention (C, Sockaddr); + -- Generic socket address + + type Sockaddr_Access is access all Sockaddr; + pragma Convention (C, Sockaddr_Access); + -- Access to socket address + + ---------------------------- + -- AF_INET socket address -- + ---------------------------- + + type In_Addr is record + S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; + end record; + for In_Addr'Alignment use C.int'Alignment; + pragma Convention (C, In_Addr); + -- IPv4 address, represented as a network-order C.int. Note that the + -- underlying operating system may assume that values of this type have + -- C.int alignment, so we need to provide a suitable alignment clause here. + + function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr); + function To_Int is new Ada.Unchecked_Conversion (In_Addr, C.int); + + type In_Addr_Access is access all In_Addr; + pragma Convention (C, In_Addr_Access); + -- Access to internet address + + Inaddr_Any : aliased constant In_Addr := (others => 0); + -- Any internet address (all the interfaces) + + type In_Addr_Access_Array is array (C.size_t range <>) + of aliased In_Addr_Access; + pragma Convention (C, In_Addr_Access_Array); + + package In_Addr_Access_Pointers is new C.Pointers + (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); + -- Array of internet addresses + + type Sockaddr_In is record + Sin_Family : Sockaddr_Length_And_Family; + -- Address family (and address length on some platforms) + + Sin_Port : C.unsigned_short; + -- Port in network byte order + + Sin_Addr : In_Addr; + -- IPv4 address + + Sin_Zero : C.char_array (1 .. 8) := (others => C.nul); + -- Padding + -- Note that some platforms require that all unused (reserved) bytes + -- in addresses be initialized to 0 (e.g. VxWorks). + end record; + pragma Convention (C, Sockaddr_In); + -- Internet socket address + + type Sockaddr_In_Access is access all Sockaddr_In; + pragma Convention (C, Sockaddr_In_Access); + -- Access to internet socket address + + procedure Set_Port + (Sin : Sockaddr_In_Access; + Port : C.unsigned_short); + pragma Inline (Set_Port); + -- Set Sin.Sin_Port to Port + + procedure Set_Address + (Sin : Sockaddr_In_Access; + Address : In_Addr); + pragma Inline (Set_Address); + -- Set Sin.Sin_Addr to Address + + --------------------- + -- Service entries -- + --------------------- + + type Chars_Ptr_Array is array (C.size_t range <>) of + aliased C.Strings.chars_ptr; + + package Chars_Ptr_Pointers is + new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, + 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_Access is access all Servent; + pragma Convention (C, Servent_Access); + -- Access to service entry + + ------------------ + -- Host entries -- + ------------------ + + type Hostent is record + H_Name : C.Strings.chars_ptr; + H_Aliases : Chars_Ptr_Pointers.Pointer; + H_Addrtype : Constants.H_Addrtype_T; + H_Length : Constants.H_Length_T; + H_Addr_List : In_Addr_Access_Pointers.Pointer; + end record; + pragma Convention (C, Hostent); + -- Host entry + + type Hostent_Access is access all Hostent; + pragma Convention (C, Hostent_Access); + -- Access to host entry + + ---------------------------- + -- Socket sets management -- + ---------------------------- + + type Int_Access is access all C.int; + pragma Convention (C, Int_Access); + -- Access to C integers + + procedure Free_Socket_Set (Set : Fd_Set_Access); + -- Free system-dependent socket set + + procedure Get_Socket_From_Set + (Set : Fd_Set_Access; + Socket : Int_Access; + Last : Int_Access); + -- Get last socket in Socket and remove it from the socket set. The + -- parameter Last is a maximum value of the largest socket. This hint is + -- used to avoid scanning very large socket sets. After a call to + -- Get_Socket_From_Set, Last is set back to the real largest socket in the + -- socket set. + + procedure Insert_Socket_In_Set + (Set : Fd_Set_Access; + Socket : C.int); + -- Insert socket in the socket set + + function Is_Socket_In_Set + (Set : Fd_Set_Access; + Socket : C.int) return C.int; + -- Check whether Socket is in the socket set, return a non-zero + -- value if it is, zero if it is not. + + procedure Last_Socket_In_Set + (Set : Fd_Set_Access; + Last : Int_Access); + -- Find the largest socket in the socket set. This is needed for select(). + -- When Last_Socket_In_Set is called, parameter Last is a maximum value of + -- the largest socket. This hint is used to avoid scanning very large + -- socket sets. After the call, Last is set back to the real largest socket + -- in the socket set. + + function New_Socket_Set + (Set : Fd_Set_Access) return Fd_Set_Access; + -- Allocate a new socket set which is a system-dependent structure and + -- initialize by copying Set if it is non-null, by making it empty + -- otherwise. + + procedure Remove_Socket_From_Set + (Set : Fd_Set_Access; + Socket : C.int); + -- Remove socket from the socket set + + ------------------------------------------ + -- Pairs of signalling file descriptors -- + ------------------------------------------ + + type Two_Ints is array (0 .. 1) of C.int; + pragma Convention (C, Two_Ints); + -- Container for two int values + + subtype Fd_Pair is Two_Ints; + -- Two_Ints as used for Create_Signalling_Fds: a pair of connected file + -- descriptors, one of which (the "read end" of the connection) being used + -- for reading, the other one (the "write end") being used for writing. + + Read_End : constant := 0; + Write_End : constant := 1; + -- Indices into an Fd_Pair value providing access to each of the connected + -- file descriptors. + +private + + pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); + pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); + pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); + pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); + pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); + pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); + pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); +end GNAT.Sockets.Thin_Common; diff --git a/gcc/ada/g-stsifd-sockets.adb b/gcc/ada/g-stsifd-sockets.adb index 5fcaa00b37c..44bf2d8056e 100644 --- a/gcc/ada/g-stsifd-sockets.adb +++ b/gcc/ada/g-stsifd-sockets.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2007, AdaCore -- +-- Copyright (C) 2001-2008, 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- -- @@ -90,15 +90,14 @@ package body Signalling_Fds is -- Bind the socket to an available port on localhost - Len := Sin'Size / 8; - Set_Length (Sin'Unchecked_Access, Len); - Sin.Sin_Family := Constants.AF_INET; + Set_Family (Sin.Sin_Family, Family_Inet); Sin.Sin_Addr.S_B1 := 127; Sin.Sin_Addr.S_B2 := 0; Sin.Sin_Addr.S_B3 := 0; Sin.Sin_Addr.S_B4 := 1; Sin.Sin_Port := 0; + Len := C.int (Lengths (Family_Inet)); Res := C_Bind (L_Sock, Sin'Address, Len); if Res = Failure then @@ -143,7 +142,7 @@ package body Signalling_Fds is -- marked "in use", even though it has been closed (perhaps by some -- other process that has already exited). This causes the above -- C_Connect to fail with EADDRINUSE. In this case, we close the - -- ports, and loop back to try again. This mysterious windows + -- ports, and loop back to try again. This mysterious Windows -- behavior is documented. See, for example: -- http://msdn2.microsoft.com/en-us/library/ms737625.aspx -- In an experiment with 2000 calls, 21 required exactly one retry, 7 @@ -186,7 +185,7 @@ package body Signalling_Fds is Fds.all := (Read_End => R_Sock, Write_End => W_Sock); - return Success; + return Thin_Common.Success; <<Fail>> declare diff --git a/gcc/ada/g-sttsne-vxworks.adb b/gcc/ada/g-sttsne-vxworks.adb index 9dbe0eafc4f..7f14255e47d 100644 --- a/gcc/ada/g-sttsne-vxworks.adb +++ b/gcc/ada/g-sttsne-vxworks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2007, AdaCore -- +-- Copyright (C) 2007-2008, 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 version is used on VxWorks. Note that the corresponding spec is in -- g-sttsne-locking.ads. +with Ada.Unchecked_Conversion; with Interfaces.C; use Interfaces.C; +with GNAT.Sockets.Constants; package body GNAT.Sockets.Thin.Task_Safe_NetDB is diff --git a/gcc/ada/gen-soccon.c b/gcc/ada/gen-soccon.c index 0d0a037320d..62629651384 100644 --- a/gcc/ada/gen-soccon.c +++ b/gcc/ada/gen-soccon.c @@ -51,16 +51,19 @@ #include "gsocket.h" +typedef enum { NUM, TXT } kind_t; + struct line { char *text; char *value; char *comment; + kind_t kind; struct line *next; }; struct line *first = NULL, *last = NULL; -#define TXT(_text) add_line(_text, NULL, NULL); +#define TXT(_text) add_line(_text, NULL, NULL, TXT); /* Plain text */ #define _NL TXT("") @@ -69,13 +72,13 @@ struct line *first = NULL, *last = NULL; #define itoad(n) f_itoa ("%d", (n)) #define itoax(n) f_itoa ("16#%08x#", (n)) -#define CND(name,comment) add_line(#name, itoad (name), comment); +#define CND(name,comment) add_line(#name, itoad (name), comment, NUM); /* Constant (decimal) */ -#define CNX(name,comment) add_line(#name, itoax (name), comment); +#define CNX(name,comment) add_line(#name, itoax (name), comment, NUM); /* Constant (hexadecimal) */ -#define CN_(name,comment) add_line(#name, name, comment); +#define CN_(name,comment) add_line(#name, name, comment, TXT); /* Constant (generic) */ #define STR(p) STR1(p) @@ -87,7 +90,7 @@ void output (void); char *f_itoa (char *, int); /* int to string */ -void add_line (char *, char*, char*); +void add_line (char *, char*, char*, kind_t); #ifdef __MINGW32__ unsigned int _CRT_fmode = _O_BINARY; @@ -137,6 +140,7 @@ TXT("-- This is the version for " TARGET) TXT("-- This file is generated automatically, do not modify it by hand! Instead,") TXT("-- make changes to gen-soccon.c and re-run it on each target.") _NL +TXT("with Interfaces.C;") TXT("package GNAT.Sockets.Constants is") _NL TXT(" --------------") @@ -145,12 +149,14 @@ TXT(" --------------") _NL #ifndef AF_INET -#define AF_INET -1 +# define AF_INET -1 #endif CND(AF_INET, "IPv4 address family") #ifndef AF_INET6 -#define AF_INET6 -1 +# define AF_INET6 -1 +#else +# define HAVE_AF_INET6 1 #endif CND(AF_INET6, "IPv6 address family") _NL @@ -604,7 +610,34 @@ CND(SIZEOF_tv_sec, "tv_sec") #define SIZEOF_tv_usec (sizeof tv.tv_usec) CND(SIZEOF_tv_usec, "tv_usec") } - +_NL +TXT(" -- Sizes of protocol specific address types (for sockaddr.sa_len)") +_NL +#define SIZEOF_sockaddr_in (sizeof (struct sockaddr_in)) +CND(SIZEOF_sockaddr_in, "struct sockaddr_in") +#ifdef HAVE_AF_INET6 +# define SIZEOF_sockaddr_in6 (sizeof (struct sockaddr_in6)) +#else +# define SIZEOF_sockaddr_in6 0 +#endif +CND(SIZEOF_sockaddr_in6, "struct sockaddr_in6") +_NL +TXT(" -- Size of file descriptor sets") +_NL +#define SIZEOF_fd_set (sizeof (fd_set)) +CND(SIZEOF_fd_set, "fd_set"); +_NL +TXT(" -- Fields of struct hostent") +_NL +#ifdef __MINGW32__ +# define h_addrtype_t "short" +# define h_length_t "short" +#else +# define h_addrtype_t "int" +# define h_length_t "int" +#endif +TXT(" subtype H_Addrtype_T is Interfaces.C." h_addrtype_t ";") +TXT(" subtype H_Length_T is Interfaces.C." h_length_t ";") _NL TXT(" ----------------------------------------") TXT(" -- Properties of supported interfaces --") @@ -612,6 +645,10 @@ TXT(" ----------------------------------------") _NL CND(Need_Netdb_Buffer, "Need buffer for Netdb ops") +CND(Has_Sockaddr_Len, "Sockaddr has sa_len field") +_NL +TXT(" Thread_Blocking_IO : constant Boolean := True;") +TXT(" -- Set False for contexts where socket i/o are process blocking") #ifdef __vxworks _NL @@ -641,18 +678,9 @@ CND(WSASYSNOTREADY, "System not ready") CND(WSAVERNOTSUPPORTED, "Version not supported") CND(WSANOTINITIALISED, "Winsock not initialized") CND(WSAEDISCON, "Disconnected") - #endif _NL -TXT(" ----------------------") -TXT(" -- Additional flags --") -TXT(" ----------------------") -_NL -TXT(" Thread_Blocking_IO : constant Boolean := True;") -TXT(" -- Set False for contexts where socket i/o are process blocking") - -_NL TXT("end GNAT.Sockets.Constants;") output (); @@ -672,7 +700,8 @@ output (void) { for (p = first; p != NULL; p = p->next) { if (p->value != NULL) { UPD_MAX(text); - UPD_MAX(value); + if (p->kind == NUM) + UPD_MAX(value); } } sprintf (fmt, " %%-%ds : constant := %%%ds;%%s%%s\n", @@ -700,13 +729,15 @@ f_itoa (char *fmt, int n) { } void -add_line (char *_text, char *_value, char *_comment) { +add_line (char *_text, char *_value, char *_comment, kind_t _kind) { struct line *l = (struct line *) malloc (sizeof (struct line)); - l->text = _text; - l->value = _value; + l->text = _text; + l->value = _value; l->comment = _comment; - l->next = NULL; + l->kind = _kind; + l->next = NULL; + if (last == NULL) first = last = l; else { diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 6654f5d16fe..4d9abacfa5f 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -4021,6 +4021,10 @@ Don't quit; try semantics, even if parse errors. @cindex @option{-gnatQ} (@command{gcc}) Don't quit; generate @file{ALI} and tree files even if illegalities. +@item -gnatr +@cindex @option{-gnatr} (@command{gcc}) +Treat pragma Restrictions as Restriction_Warnings. + @item ^-gnatR[0/1/2/3[s]]^/REPRESENTATION_INFO^ @cindex @option{-gnatR} (@command{gcc}) Output representation information for declared types and objects. @@ -5723,7 +5727,7 @@ turns on all validity checking options except for checking of @code{@b{in out}} procedure arguments. The specification of additional validity checking generates extra code (and -in the case of @option{-gnatVa} the code expansion can be substantial. +in the case of @option{-gnatVa} the code expansion can be substantial). However, these additional checks can be very useful in detecting uninitialized variables, incorrect use of unchecked conversion, and other errors leading to invalid values. The use of pragma @code{Initialize_Scalars} @@ -6023,7 +6027,7 @@ with declarations. @item ^S^STATEMENTS_AFTER_THEN_ELSE^ @emph{Check no statements after THEN/ELSE.} No statements are allowed -on the same line as a THEN OR ELSE keyword following the +on the same line as a THEN or ELSE keyword following the keyword in an IF statement. OR ELSE and AND THEN are not affected, and a special exception allows a pragma to appear after ELSE. @@ -6099,19 +6103,25 @@ around conditions in @code{if} statements, @code{while} statements and @item ^y^ALL_BUILTIN^ @emph{Set all standard style check options} This is equivalent to @code{gnaty3aAbcefhiklmnprst}, that is all checking -options enabled with the exception of @option{-gnatyo}, +options enabled with the exception of @option{-gnatyo}, @option{-gnatyI}, +@option{-gnatyS}, @option{-gnatyLnnn}, @option{-gnatyd}, @option{-gnatyu}, and @option{-gnatyx}. @ifclear vms @item - @emph{Remove style check options} This causes any subsequent options in the string to act as canceling the -corresponding style check option. +corresponding style check option. To cancel maximum nesting level control, +use @option{L} parameter witout any integer value after that, because any +digit following @option{-} in the parameter string of the @option{-gnaty} +option will be threated as canceling indentation check. The same is true +for @option{M} parameter. @option{y} and @option{N} parameters are not +alloved after @option{-}. @item + This causes any subsequent options in the string to enable the corresponding -style check option. It only has an effect if a previous ^-^REMOVE^ has been -encountered. +style check option. That is, it cancels the effect of a previous ^-^REMOVE^, +if any. @end ifclear @ifset vms @@ -6153,8 +6163,8 @@ built-in standard style check options are enabled. the exception of ORDERED_SUBPROGRAMS, UNNECESSARY_BLANK_LINES, XTRA_PARENS, and DOS_LINE_ENDINGS. In addition @end ifset -an indentation level of 3 is set. This is similar to the standard -checking option that is used for the GNAT sources. + + The switch @ifclear vms @@ -6822,6 +6832,16 @@ If the switch @option{-gnatL} is used in conjunction with @option{-gnatDG}, then the original source lines are interspersed in the expanded source (as comment lines with the original line number). +@item -gnatr +@cindex @option{-gnatr} (@command{gcc}) +@cindex pragma Restrictions +This switch causes pragma Restrictions to be treated as Restriction_Warnings +so that violation of restrictions causes warnings rather than illegalities. +This is useful during the development process when new restrictions are added +or investigated. The switch also causes pragma Profile to be treated as +Profile_Warnings, and pragma Restricted_Run_Time and pragma Ravenscar set +restriction warnings rather than restrictions. + @ifclear vms @item -gnatR[0|1|2|3[s]] @cindex @option{-gnatR} (@command{gcc}) @@ -8848,6 +8868,15 @@ This switch is not compatible with a project file (^-P^/PROJECT_FILE=^@var{file}) or with multiple compiling processes (^-j^/PROCESSES=^nnn, when nnn is greater than 1). +@item ^-d^/DISPLAY_PROGRESS^ +@cindex @option{^-d^/DISPLAY_PROGRESS^} (@command{gnatmake}) +Display progress for each source, up to date or not, as a single line + + completed x out of y (zz%) + +If the file needs to be compiled this is displayed after the invocation of +the compiler. These lines are displayed even in quiet output mode. + @item ^-D ^/DIRECTORY_OBJECTS=^@var{dir} @cindex @option{^-D^/DIRECTORY_OBJECTS^} (@command{gnatmake}) Put all object files and ALI file in directory @var{dir}. @@ -11036,7 +11065,8 @@ set of files. The usual form of the @code{gnatname} command is @smallexample -$ gnatname [@var{switches}] @var{naming_pattern} [@var{naming_patterns}] +$ gnatname [@var{switches}] @var{naming_pattern} [@var{naming_patterns}] \ + [--and @var{switches}] @var{naming_pattern} [@var{naming_patterns}]] @end smallexample @noindent @@ -11057,6 +11087,14 @@ A Naming Pattern is a regular expression similar to the wildcard patterns used in file names by the Unix shells or the DOS prompt. @noindent +@code{gnatname} may be called with several sections of directories/patterns. +Sections are separated by switch @code{--and}. In each section, there must be +at least one pattern. If no directory is specified in a section, the current +directory (or the project directory is @code{-P} is used) is implied. +The options other that the directory switches and the patterns apply globally +even if they are in different sections. + +@noindent Examples of Naming Patterns are @smallexample @@ -11071,9 +11109,10 @@ see the second kind of regular expressions described in @file{g-regexp.ads} (the ``Glob'' regular expressions). @noindent -When invoked with no switches, @code{gnatname} will create a configuration -pragmas file @file{gnat.adc} in the current working directory, with pragmas -@code{Source_File_Name} for each file that contains a valid Ada unit. +When invoked with no switch @code{-P}, @code{gnatname} will create a +configuration pragmas file @file{gnat.adc} in the current working directory, +with pragmas @code{Source_File_Name} for each file that contains a valid Ada +unit. @node Switches for gnatname @section Switches for @code{gnatname} @@ -11096,6 +11135,9 @@ Display Copyright and version, then exit disregarding all other options. If @option{--version} was not used, display usage, then exit disregarding all other options. +@item --and +Start another section of directories/patterns. + @item ^-c^/CONFIG_FILE=^@file{file} @cindex @option{^-c^/CONFIG_FILE^} (@code{gnatname}) Create a configuration pragmas file @file{file} (instead of the default @@ -12033,6 +12075,7 @@ project P. @menu * Basic Syntax:: +* Qualified Projects:: * Packages:: * Expressions:: * String Types:: @@ -12090,12 +12133,16 @@ word @code{end} at the end of the project file, followed by a semi-colon. Any name in a project file, such as the project name or a variable name, has the same syntax as an Ada identifier. -The reserved words of project files are the Ada reserved words plus +The reserved words of project files are the Ada 95 reserved words plus @code{extends}, @code{external}, and @code{project}. Note that the only Ada reserved words currently used in project file syntax are: @itemize @bullet @item +@code{all} +@item +@code{at} +@item @code{case} @item @code{end} @@ -12104,6 +12151,10 @@ reserved words currently used in project file syntax are: @item @code{is} @item +@code{limited} +@item +@code{null} +@item @code{others} @item @code{package} @@ -12123,6 +12174,39 @@ reserved words currently used in project file syntax are: Comments in project files have the same syntax as in Ada, two consecutive hyphens through the end of the line. +@node Qualified Projects +@subsection Qualified Projects + +@noindent +Before the reserved @code{project}, there may be one or two "qualifiers", that +is identifiers or other reserved words, to qualify the project. + +The current list of qualifiers is: + +@itemize @bullet +@item +@code{abstract}: qualify a project with no sources. An abstract project must +have a declaration specifying that there are no sources in the project, and, +if it extends another project, the project it extends must also be a qualified +abstract project. + +@item +@code{standard}: a standard project is a non library project with sources. + +@item +@code{aggregate}: for future extension + +@item +@code{aggregate library}: for future extension + +@item +@code{library}: a library project must declare both attributes +@code{Library_Name} and @code{Library_Dir}. + +@item +@code{configuration}: a configuration project cannot be in a project tree. +@end itemize + @node Packages @subsection Packages @@ -13015,8 +13099,8 @@ The original body of @code{Util_IO} will not be considered in program builds. However, the package spec will still be found in the project @code{Utilities}. -A child project can have only one parent but it may import any number of other -projects. +A child project can have only one parent, except when it is qualified as +abstract. But it may import any number of other projects. A project is not allowed to import directly or indirectly at the same time a child project and any of its ancestors. @@ -20259,9 +20343,10 @@ use the rule named @code{Restrictions} or @code{Restriction_Warnings}. @item Style_Checks -To record compiler style checks, use the rule named +To record compiler style checks(@pxref{Style Checking}), use the rule named @code{Style_Checks}. A parameter of this rule can be either @code{All_Checks}, -which enables all the style checks, or a string that has exactly the same +which enables all the standard style checks that corresponds to @option{-gnatyy} +GNAT style check option, or a string that has exactly the same structure and semantics as the @code{string_LITERAL} parameter of GNAT pragma @code{Style_Checks} (for further information about this pragma, @pxref{Pragma Style_Checks,,, gnat_rm, GNAT Reference Manual}). @@ -20271,10 +20356,19 @@ To record compiler warnings (@pxref{Warning Message Control}), use the rule named @code{Warnings} with a parameter that is a valid @i{static_string_expression} argument of GNAT pragma @code{Warnings} (for further information about this pragma, @pxref{Pragma Warnings,,, -gnat_rm, GNAT Reference Manual}). +gnat_rm, GNAT Reference Manual}). Note, that in case of gnatcheck +'s' parameter, that corresponds to the GNAT @option{-gnatws} option, disables +all the specific warnings, but not suppresses the warning mode, +and 'e' parameter, corresponding to @option{-gnatwe} that means +"therat warnings as errors", does not have any effect. @end table +To disable a specific restriction check, use @code{-RStyle_Checks} gnatcheck +option with the corresponding restriction name as a parameter. @code{-R} is +not available for @code{Style_Checks} and @code{Warnings} options, to disable +warnings and style checks, use the corresponding warning and style options. + @node Project-Wide Checks @section Project-Wide Checks @cindex Project-wide checks (for @command{gnatcheck}) diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 906a61abd91..3a1ef9b4dd7 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -935,14 +935,13 @@ procedure Gnatlink is Objs_End := Linker_Objects.Last; - -- Let's continue to compute the Link_Bytes, the linker options are - -- part of command line length. + -- Continue to compute the Link_Bytes, the linker options are part of + -- command line length. Store_File_Context; while Next_Line (Nfirst .. Nlast) /= End_Info loop Link_Bytes := Link_Bytes + Nlast - Nfirst + 2; - -- See comment above Get_Next_Line; end loop; diff --git a/gcc/ada/gnatname.adb b/gcc/ada/gnatname.adb index 299e682bdc5..dbd7f509312 100644 --- a/gcc/ada/gnatname.adb +++ b/gcc/ada/gnatname.adb @@ -23,6 +23,12 @@ -- -- ------------------------------------------------------------------------------ +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Dynamic_Tables; +with GNAT.OS_Lib; use GNAT.OS_Lib; + with Hostparm; with Opt; with Osint; use Osint; @@ -32,13 +38,12 @@ with Prj.Makr; with Switch; use Switch; with Table; -with Ada.Command_Line; use Ada.Command_Line; -with Ada.Text_IO; use Ada.Text_IO; -with GNAT.Command_Line; use GNAT.Command_Line; -with GNAT.OS_Lib; use GNAT.OS_Lib; +with System.Regexp; use System.Regexp; procedure Gnatname is + Subdirs_Switch : constant String := "--subdirs="; + Usage_Output : Boolean := False; -- Set to True when usage is output, to avoid multiple output @@ -61,43 +66,30 @@ procedure Gnatname is -- Set to True by -c or -P switch. -- Used to detect multiple -c/-P switches. - package Excluded_Patterns is new Table.Table + package Patterns is new GNAT.Dynamic_Tables (Table_Component_Type => String_Access, Table_Index_Type => Natural, Table_Low_Bound => 0, Table_Initial => 10, - Table_Increment => 100, - Table_Name => "Gnatname.Excluded_Patterns"); - -- Table to accumulate the negative patterns - - package Foreign_Patterns is new Table.Table - (Table_Component_Type => String_Access, + Table_Increment => 100); + -- Table to accumulate the patterns + + type Argument_Data is record + Directories : Patterns.Instance; + Name_Patterns : Patterns.Instance; + Excluded_Patterns : Patterns.Instance; + Foreign_Patterns : Patterns.Instance; + end record; + + package Arguments is new Table.Table + (Table_Component_Type => Argument_Data, Table_Index_Type => Natural, Table_Low_Bound => 0, Table_Initial => 10, Table_Increment => 100, - Table_Name => "Gnatname.Foreign_Patterns"); + Table_Name => "Gnatname.Arguments"); -- Table to accumulate the foreign patterns - package Patterns is new Table.Table - (Table_Component_Type => String_Access, - Table_Index_Type => Natural, - Table_Low_Bound => 0, - Table_Initial => 10, - Table_Increment => 100, - Table_Name => "Gnatname.Patterns"); - -- Table to accumulate the name patterns - - package Source_Directories is new Table.Table - (Table_Component_Type => String_Access, - Table_Index_Type => Natural, - Table_Low_Bound => 0, - Table_Initial => 10, - Table_Increment => 100, - Table_Name => "Gnatname.Source_Directories"); - -- Table to accumulate the source directories specified directly with -d - -- or indirectly with -D. - package Preprocessor_Switches is new Table.Table (Table_Component_Type => String_Access, Table_Index_Type => Natural, @@ -129,8 +121,8 @@ procedure Gnatname is procedure Add_Source_Directory (S : String) is begin - Source_Directories.Increment_Last; - Source_Directories.Table (Source_Directories.Last) := new String'(S); + Patterns.Append + (Arguments.Table (Arguments.Last).Directories, new String'(S)); end Add_Source_Directory; --------------------- @@ -157,7 +149,7 @@ procedure Gnatname is exception when Name_Error => - Fail ("cannot open source directory """ & From_File & '"'); + Fail ("cannot open source directory file """ & From_File & '"'); end Get_Directories; -------------------- @@ -181,103 +173,282 @@ procedure Gnatname is procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); - -- Start of processing for Scan_Args + Project_File_Name_Expected : Boolean; - begin - -- First check for --version or --help + Pragmas_File_Expected : Boolean; - Check_Version_And_Help ("GNATNAME", "2001"); + Directory_Expected : Boolean; - -- Now scan the other switches - - Initialize_Option_Scan; + Dir_File_Name_Expected : Boolean; - -- Scan options first + Foreign_Pattern_Expected : Boolean; - loop - case Getopt - ("-subdirs=! c: d: gnatep=! gnatep! gnateD! eL D: h P: v x: f:") - is - when ASCII.NUL => - exit; + Excluded_Pattern_Expected : Boolean; - when '-' => - Subdirs := new String'(Parameter); - - when 'c' => - if File_Set then - Fail ("only one -P or -c switch may be specified"); - end if; + procedure Check_Regular_Expression (S : String); + -- Compile string S into a Regexp. Fail if any error. - File_Set := True; - File_Path := new String'(Parameter); - Create_Project := False; + ----------------------------- + -- Check_Regular_Expression-- + ----------------------------- - when 'd' => - Add_Source_Directory (Parameter); - - when 'D' => - Get_Directories (Parameter); + procedure Check_Regular_Expression (S : String) is + Dummy : Regexp; + pragma Warnings (Off, Dummy); + begin + Dummy := Compile (S, Glob => True); + exception + when Error_In_Regexp => + Fail ("invalid regular expression """, S, """"); + end Check_Regular_Expression; + begin + -- First check for --version or --help - when 'e' => - Opt.Follow_Links_For_Files := True; + Check_Version_And_Help ("GNATNAME", "2001"); - when 'f' => - Foreign_Patterns.Increment_Last; - Foreign_Patterns.Table (Foreign_Patterns.Last) := - new String'(Parameter); + -- Now scan the other switches - when 'g' => - Preprocessor_Switches.Increment_Last; - Preprocessor_Switches.Table (Preprocessor_Switches.Last) := - new String'('-' & Full_Switch & Parameter); + Project_File_Name_Expected := False; + Pragmas_File_Expected := False; + Directory_Expected := False; + Dir_File_Name_Expected := False; + Foreign_Pattern_Expected := False; + Excluded_Pattern_Expected := False; + for Next_Arg in 1 .. Argument_Count loop + declare + Next_Argv : constant String := Argument (Next_Arg); + Arg : String (1 .. Next_Argv'Length) := Next_Argv; - when 'h' => - Usage_Needed := True; + begin + if Arg'Length > 0 then + if Project_File_Name_Expected then + -- -P xxx + + if Arg (1) = '-' then + Fail ("project file name missing"); + + else + File_Set := True; + File_Path := new String'(Arg); + Project_File_Name_Expected := False; + end if; + + elsif Pragmas_File_Expected then + -- -c file + + File_Set := True; + File_Path := new String'(Arg); + Create_Project := False; + Pragmas_File_Expected := False; + + elsif Directory_Expected then + -- -d xxx + + Add_Source_Directory (Arg); + Directory_Expected := False; + + elsif Dir_File_Name_Expected then + -- -D xxx + + Get_Directories (Arg); + Dir_File_Name_Expected := False; + + elsif Foreign_Pattern_Expected then + -- -f xxx + + Patterns.Append + (Arguments.Table (Arguments.Last).Foreign_Patterns, + new String'(Arg)); + Check_Regular_Expression (Arg); + Foreign_Pattern_Expected := False; + + elsif Excluded_Pattern_Expected then + -- -x xxx + + Patterns.Append + (Arguments.Table (Arguments.Last).Excluded_Patterns, + new String'(Arg)); + Check_Regular_Expression (Arg); + Excluded_Pattern_Expected := False; + + elsif Arg = "--and" then + + -- There must be at least one Ada pattern or one foreign + -- pattern for the previous section. + + if Patterns.Last + (Arguments.Table (Arguments.Last).Name_Patterns) = 0 + and then + Patterns.Last + (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0 + then + Usage; + return; + end if; + + -- If no directory were specified for the previous section, + -- then the directory is the project directory. + + if Patterns.Last + (Arguments.Table (Arguments.Last).Directories) = 0 + then + Patterns.Append + (Arguments.Table (Arguments.Last).Directories, + new String'(".")); + end if; + + -- Add another component in table Arguments and initialize + -- it. + + Arguments.Increment_Last; + + Patterns.Init + (Arguments.Table (Arguments.Last).Directories); + Patterns.Set_Last + (Arguments.Table (Arguments.Last).Directories, 0); + Patterns.Init + (Arguments.Table (Arguments.Last).Name_Patterns); + Patterns.Set_Last + (Arguments.Table (Arguments.Last).Name_Patterns, 0); + Patterns.Init + (Arguments.Table (Arguments.Last).Excluded_Patterns); + Patterns.Set_Last + (Arguments.Table (Arguments.Last).Excluded_Patterns, 0); + Patterns.Init + (Arguments.Table (Arguments.Last).Foreign_Patterns); + Patterns.Set_Last + (Arguments.Table (Arguments.Last).Foreign_Patterns, 0); + + elsif Arg'Length > Subdirs_Switch'Length + and then Arg (1 .. Subdirs_Switch'Length) = Subdirs_Switch + then + Subdirs := + new String'(Arg (Subdirs_Switch'Length + 1 .. Arg'Last)); + + elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-c" then + if File_Set then + Fail ("only one -P or -c switch may be specified"); + end if; + + if Arg'Length = 2 then + Pragmas_File_Expected := True; + + if Next_Arg = Argument_Count then + Fail ("configuration pragmas file name missing"); + end if; + + else + File_Set := True; + File_Path := new String'(Arg (3 .. Arg'Last)); + Create_Project := False; + end if; + + elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-d" then + if Arg'Length = 2 then + Directory_Expected := True; + + if Next_Arg = Argument_Count then + Fail ("directory name missing"); + end if; + + else + Add_Source_Directory (Arg (3 .. Arg'Last)); + end if; + + elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-D" then + if Arg'Length = 2 then + Dir_File_Name_Expected := True; + + if Next_Arg = Argument_Count then + Fail ("directory list file name missing"); + end if; + + else + Get_Directories (Arg (3 .. Arg'Last)); + end if; + + elsif Arg = "-eL" then + Opt.Follow_Links_For_Files := True; + + elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-f" then + if Arg'Length = 2 then + Foreign_Pattern_Expected := True; + + if Next_Arg = Argument_Count then + Fail ("foreign pattern missing"); + end if; + + else + Patterns.Append + (Arguments.Table (Arguments.Last).Foreign_Patterns, + new String'(Arg (3 .. Arg'Last))); + Check_Regular_Expression (Arg (3 .. Arg'Last)); + end if; + + elsif Arg'Length > 7 and then + (Arg (1 .. 7) = "-gnatep" or else Arg (1 .. 7) = "-gnateD") + then + + Preprocessor_Switches.Append (new String'(Arg)); + + elsif Arg = "-h" then + Usage_Needed := True; + + elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-P" then + if File_Set then + Fail ("only one -c or -P switch may be specified"); + end if; + + if Arg'Length = 2 then + if Next_Arg = Argument_Count then + Fail ("project file name missing"); + + else + Project_File_Name_Expected := True; + end if; + + else + File_Set := True; + File_Path := new String'(Arg (3 .. Arg'Last)); + end if; + + Create_Project := True; + + elsif Arg = "-v" then + if Opt.Verbose_Mode then + Very_Verbose := True; + else + Opt.Verbose_Mode := True; + end if; + + elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-x" then + if Arg'Length = 2 then + Excluded_Pattern_Expected := True; - when 'P' => - if File_Set then - Fail ("only one -c or -P switch may be specified"); - end if; + if Next_Arg = Argument_Count then + Fail ("excluded pattern missing"); + end if; - File_Set := True; - File_Path := new String'(Parameter); - Create_Project := True; + else + Patterns.Append + (Arguments.Table (Arguments.Last).Excluded_Patterns, + new String'(Arg (3 .. Arg'Last))); + Check_Regular_Expression (Arg (3 .. Arg'Last)); + end if; + + elsif Arg (1) = '-' then + Fail ("wrong switch: " & Arg); - when 'v' => - if Opt.Verbose_Mode then - Very_Verbose := True; else - Opt.Verbose_Mode := True; + Canonical_Case_File_Name (Arg); + Patterns.Append + (Arguments.Table (Arguments.Last).Name_Patterns, + new String'(Arg)); + Check_Regular_Expression (Arg); end if; - - when 'x' => - Excluded_Patterns.Increment_Last; - Excluded_Patterns.Table (Excluded_Patterns.Last) := - new String'(Parameter); - - when others => - null; - end case; - end loop; - - -- Now, get the name patterns, if any - - loop - declare - S : String := Get_Argument (Do_Expansion => False); - - begin - exit when S = ""; - Canonical_Case_File_Name (S); - Patterns.Increment_Last; - Patterns.Table (Patterns.Last) := new String'(S); + end if; end; end loop; - - exception - when Invalid_Switch => - Fail ("invalid switch " & Full_Switch); end Scan_Args; ----------- @@ -292,12 +463,16 @@ procedure Gnatname is Write_Str ("Usage: "); Osint.Write_Program_Name; Write_Line (" [switches] naming-pattern [naming-patterns]"); + Write_Line (" {--and [switches] naming-pattern [naming-patterns]}"); Write_Eol; Write_Line ("switches:"); Write_Line (" --subdirs=dir real obj/lib/exec dirs are subdirs"); Write_Eol; + Write_Line (" --and use different patterns"); + Write_Eol; + Write_Line (" -cfile create configuration pragmas file"); Write_Line (" -ddir use dir as one of the source " & "directories"); @@ -339,8 +514,8 @@ begin PATH : constant String := Absolute_Dir & - Path_Separator & - Getenv ("PATH").all; + Path_Separator & + Getenv ("PATH").all; begin Setenv ("PATH", PATH); @@ -354,10 +529,17 @@ begin -- Initialize tables - Excluded_Patterns.Set_Last (0); - Foreign_Patterns.Set_Last (0); - Patterns.Set_Last (0); - Source_Directories.Set_Last (0); + Arguments.Set_Last (0); + Arguments.Increment_Last; + Patterns.Init (Arguments.Table (1).Directories); + Patterns.Set_Last (Arguments.Table (1).Directories, 0); + Patterns.Init (Arguments.Table (1).Name_Patterns); + Patterns.Set_Last (Arguments.Table (1).Name_Patterns, 0); + Patterns.Init (Arguments.Table (1).Excluded_Patterns); + Patterns.Set_Last (Arguments.Table (1).Excluded_Patterns, 0); + Patterns.Init (Arguments.Table (1).Foreign_Patterns); + Patterns.Set_Last (Arguments.Table (1).Foreign_Patterns, 0); + Preprocessor_Switches.Set_Last (0); -- Get the arguments @@ -372,9 +554,12 @@ begin Usage; end if; - -- If no pattern was specified, print the usage and return + -- If no Ada or foreign pattern was specified, print the usage and return - if Patterns.Last = 0 and Foreign_Patterns.Last = 0 then + if Patterns.Last (Arguments.Table (Arguments.Last).Name_Patterns) = 0 + and then + Patterns.Last (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0 + then Usage; return; end if; @@ -384,55 +569,91 @@ begin -- information, the current directory is the directory of the specified -- file. - if Source_Directories.Last = 0 then - Source_Directories.Increment_Last; - Source_Directories.Table (Source_Directories.Last) := new String'("."); + if Patterns.Last + (Arguments.Table (Arguments.Last).Directories) = 0 + then + Patterns.Append + (Arguments.Table (Arguments.Last).Directories, new String'(".")); end if; + -- Initialize + declare - Directories : Argument_List (1 .. Integer (Source_Directories.Last)); - Name_Patterns : Argument_List (1 .. Integer (Patterns.Last)); - Excl_Patterns : Argument_List (1 .. Integer (Excluded_Patterns.Last)); - Frgn_Patterns : Argument_List (1 .. Integer (Foreign_Patterns.Last)); Prep_Switches : Argument_List (1 .. Integer (Preprocessor_Switches.Last)); begin - -- Build the Directories and Name_Patterns arguments - - for Index in Directories'Range loop - Directories (Index) := Source_Directories.Table (Index); - end loop; - - for Index in Name_Patterns'Range loop - Name_Patterns (Index) := Patterns.Table (Index); - end loop; - - for Index in Excl_Patterns'Range loop - Excl_Patterns (Index) := Excluded_Patterns.Table (Index); - end loop; - - for Index in Frgn_Patterns'Range loop - Frgn_Patterns (Index) := Foreign_Patterns.Table (Index); - end loop; - for Index in Prep_Switches'Range loop Prep_Switches (Index) := Preprocessor_Switches.Table (Index); end loop; - -- Call Prj.Makr.Make where the real work is done - - Prj.Makr.Make + Prj.Makr.Initialize (File_Path => File_Path.all, Project_File => Create_Project, - Directories => Directories, - Name_Patterns => Name_Patterns, - Excluded_Patterns => Excl_Patterns, - Foreign_Patterns => Frgn_Patterns, Preproc_Switches => Prep_Switches, Very_Verbose => Very_Verbose); end; + -- Process each section successively + + for J in 1 .. Arguments.Last loop + declare + Directories : Argument_List + (1 .. Integer + (Patterns.Last (Arguments.Table (J).Directories))); + Name_Patterns : Prj.Makr.Regexp_List + (1 .. Integer + (Patterns.Last (Arguments.Table (J).Name_Patterns))); + Excl_Patterns : Prj.Makr.Regexp_List + (1 .. Integer + (Patterns.Last (Arguments.Table (J).Excluded_Patterns))); + Frgn_Patterns : Prj.Makr.Regexp_List + (1 .. Integer + (Patterns.Last (Arguments.Table (J).Foreign_Patterns))); + + begin + -- Build the Directories and Patterns arguments + + for Index in Directories'Range loop + Directories (Index) := + Arguments.Table (J).Directories.Table (Index); + end loop; + + for Index in Name_Patterns'Range loop + Name_Patterns (Index) := + Compile + (Arguments.Table (J).Name_Patterns.Table (Index).all, + Glob => True); + end loop; + + for Index in Excl_Patterns'Range loop + Excl_Patterns (Index) := + Compile + (Arguments.Table (J).Excluded_Patterns.Table (Index).all, + Glob => True); + end loop; + + for Index in Frgn_Patterns'Range loop + Frgn_Patterns (Index) := + Compile + (Arguments.Table (J).Foreign_Patterns.Table (Index).all, + Glob => True); + end loop; + + -- Call Prj.Makr.Process where the real work is done + + Prj.Makr.Process + (Directories => Directories, + Name_Patterns => Name_Patterns, + Excluded_Patterns => Excl_Patterns, + Foreign_Patterns => Frgn_Patterns); + end; + end loop; + + -- Finalize + + Prj.Makr.Finalize; + if Opt.Verbose_Mode then Write_Eol; end if; diff --git a/gcc/ada/gsocket.h b/gcc/ada/gsocket.h index ce4d47801d6..8b8c83808b6 100644 --- a/gcc/ada/gsocket.h +++ b/gcc/ada/gsocket.h @@ -184,3 +184,9 @@ #else # define Need_Netdb_Buffer 0 #endif + +#if defined (__FreeBSD__) || defined (__vxworks) +# define Has_Sockaddr_Len 1 +#else +# define Has_Sockaddr_Len 0 +#endif diff --git a/gcc/ada/i-cobol.ads b/gcc/ada/i-cobol.ads index 34ef56da6aa..21e5d831127 100644 --- a/gcc/ada/i-cobol.ads +++ b/gcc/ada/i-cobol.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (ASCII Version) -- -- -- --- Copyright (C) 1993-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1993-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -42,6 +42,7 @@ -- type Standard.Character. package Interfaces.COBOL is + pragma Preelaborate (COBOL); ------------------------------------------------------------ -- Types And Operations For Internal Data Representations -- diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 5dd78155688..24a6437f26b 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -568,7 +568,7 @@ __gnat_install_handler (void) /*********************/ #elif defined (linux) && (defined (i386) || defined (__x86_64__) \ - || defined (__ia64__)) + || defined (__ia64__) || defined (__powerpc__)) #include <signal.h> @@ -624,7 +624,9 @@ static void __gnat_error_handler (int, siginfo_t *siginfo, void *ucontext); void __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) { +#ifndef __powerpc__ mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; +#endif /* On the i386 and x86-64 architectures, stack checking is performed by means of probes with moving stack pointer, that is to say the probed @@ -657,6 +659,8 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) mcontext->gregs[REG_RIP]++; #elif defined (__ia64__) mcontext->sc_ip++; +#elif defined (__powerpc__) + ((ucontext_t *) ucontext)->uc_mcontext.regs->nip++; #endif } diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 3aa16de88e9..332994ea285 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 65a9bb4bd8d..600231c737a 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1108,6 +1108,11 @@ package Opt is -- Tolerate time stamp and other consistency errors. If this flag is set to -- True (-t), then inconsistencies result in warnings rather than errors. + Treat_Restrictions_As_Warnings : Boolean := False; + -- GNAT + -- Set True to treat pragma Restrictions as Restriction_Warnings. Set by + -- -gnatr switch. + Tree_Output : Boolean := False; -- GNAT -- Set to True (-gnatt) to generate output tree file diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 8eb0e71975c..c2ec59be9dc 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -3931,8 +3931,7 @@ package body Ch3 is if Token = Tok_All then if Ada_Version < Ada_05 then Error_Msg_SP - ("access-all in this context is an Ada 2005 extension"); - Error_Msg_SP ("\unit should be compiled with -gnat05 switch"); + ("ALL is not permitted for anonymous access types"); end if; Scan; -- past ALL diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb index 6a24776e488..fcf2d3c69b4 100644 --- a/gcc/ada/par-ch9.adb +++ b/gcc/ada/par-ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -477,7 +477,7 @@ package body Ch9 is Scan; -- past NEW if Ada_Version < Ada_05 then - Error_Msg_SP ("task interface is an Ada 2005 extension"); + Error_Msg_SP ("protected interface is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; @@ -496,11 +496,6 @@ package body Ch9 is end if; Scan; -- past WITH - - if Token = Tok_Private then - Error_Msg_SP - ("PRIVATE not allowed in protected type declaration"); - end if; end if; Set_Protected_Definition (Protected_Node, P_Protected_Definition); @@ -561,8 +556,8 @@ package body Ch9 is Append (Item_Node, Visible_Declarations (Def_Node)); end loop; - -- Deal with PRIVATE part (including graceful handling - -- of multiple PRIVATE parts). + -- Deal with PRIVATE part (including graceful handling of multiple + -- PRIVATE parts). Private_Loop : while Token = Tok_Private loop if No (Private_Declarations (Def_Node)) then diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 5067f029c92..c8b84ab189e 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -234,7 +234,8 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is elsif Id = Name_No_Dependence then Set_Restriction_No_Dependence (Unit => Expr, - Warn => Prag_Id = Pragma_Restriction_Warnings); + Warn => Prag_Id = Pragma_Restriction_Warnings + or else Treat_Restrictions_As_Warnings); end if; Next (Arg); diff --git a/gcc/ada/prepcomp.adb b/gcc/ada/prepcomp.adb index 818bb49e22b..a2b58be7ab1 100644 --- a/gcc/ada/prepcomp.adb +++ b/gcc/ada/prepcomp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2008, 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- -- @@ -245,8 +245,7 @@ package body Prepcomp is """ not found"); end if; - -- Initialize the scanner and set its behavior for a processing data - -- file + -- Initialize scanner and set its behavior for processing a data file Scn.Scanner.Initialize_Scanner (Source_Index_Of_Preproc_Data_File); Scn.Scanner.Set_End_Of_Line_As_Token (True); diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index d3ff283ada2..1b56e84a077 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -86,6 +86,7 @@ package body Prj.Attr is "LVlocally_removed_files#" & "LVexcluded_source_files#" & "SVsource_list_file#" & + "LVinterfaces#" & -- Libraries @@ -109,6 +110,8 @@ package body Prj.Attr is "LVrun_path_option#" & "Satoolchain_version#" & "Satoolchain_description#" & + "Saobject_generated#" & + "Saobjects_linked#" & -- Configuration - Libraries diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index 593874fad02..1e15fb207da 100644 --- a/gcc/ada/prj-dect.adb +++ b/gcc/ada/prj-dect.adb @@ -184,7 +184,7 @@ package body Prj.Dect is -- an unknown package. if Current_Attribute = Empty_Attribute then - if Current_Package /= Empty_Node + if Present (Current_Package) and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored then Pkg_Id := Package_Id_Of (Current_Package, In_Tree); @@ -194,7 +194,7 @@ package body Prj.Dect is -- If not a valid attribute name, issue an error if inside -- a package that need to be checked. - Ignore := Current_Package /= Empty_Node and then + Ignore := Present (Current_Package) and then Packages_To_Check /= All_Packages; if Ignore then @@ -241,7 +241,7 @@ package body Prj.Dect is -- Change obsolete names of attributes to the new names - if Current_Package /= Empty_Node + if Present (Current_Package) and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored then case Name_Of (Attribute, In_Tree) is @@ -403,7 +403,7 @@ package body Prj.Dect is The_Project := Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Token_Name); - if The_Project = Empty_Node then + if No (The_Project) then Error_Msg ("unknown project", Location); Scan (In_Tree); -- past the project name @@ -414,7 +414,7 @@ package body Prj.Dect is -- If this is inside a package, a dot followed by the -- name of the package must followed the project name. - if Current_Package /= Empty_Node then + if Present (Current_Package) then Expect (Tok_Dot, "`.`"); if Token /= Tok_Dot then @@ -445,7 +445,7 @@ package body Prj.Dect is -- Look for the package node - while The_Package /= Empty_Node + while Present (The_Package) and then Name_Of (The_Package, In_Tree) /= Token_Name loop @@ -457,7 +457,7 @@ package body Prj.Dect is -- If the package cannot be found in the -- project, issue an error. - if The_Package = Empty_Node then + if No (The_Package) then The_Project := Empty_Node; Error_Msg_Name_2 := Project_Name; Error_Msg_Name_1 := Token_Name; @@ -473,7 +473,7 @@ package body Prj.Dect is end if; end if; - if The_Project /= Empty_Node then + if Present (The_Project) then -- Looking for '<same attribute name> @@ -503,7 +503,7 @@ package body Prj.Dect is end if; end if; - if The_Project = Empty_Node then + if No (The_Project) then -- If there were any problem, set the attribute id to null, -- so that the node will not be recorded. @@ -546,7 +546,7 @@ package body Prj.Dect is -- for the attribute, issue an error. if Current_Attribute /= Empty_Attribute - and then Expression /= Empty_Node + and then Present (Expression) and then Variable_Kind_Of (Current_Attribute) /= Expression_Kind_Of (Expression, In_Tree) then @@ -639,10 +639,10 @@ package body Prj.Dect is end if; end if; - if Case_Variable /= Empty_Node then + if Present (Case_Variable) then String_Type := String_Type_Of (Case_Variable, In_Tree); - if String_Type = Empty_Node then + if No (String_Type) then Error_Msg ("variable """ & Get_Name_String (Name_Of (Case_Variable, In_Tree)) & """ is not typed", @@ -813,15 +813,15 @@ package body Prj.Dect is The_Variable : Project_Node_Id := Empty_Node; begin - if Current_Package /= Empty_Node then + if Present (Current_Package) then The_Variable := First_Variable_Of (Current_Package, In_Tree); - elsif Current_Project /= Empty_Node then + elsif Present (Current_Project) then The_Variable := First_Variable_Of (Current_Project, In_Tree); end if; - while The_Variable /= Empty_Node + while Present (The_Variable) and then Name_Of (The_Variable, In_Tree) /= Token_Name loop @@ -831,7 +831,7 @@ package body Prj.Dect is -- It is an error to declare a variable in a case -- construction for the first time. - if The_Variable = Empty_Node then + if No (The_Variable) then Error_Msg ("a variable cannot be declared " & "for the first time here", @@ -928,8 +928,8 @@ package body Prj.Dect is -- Insert an N_Declarative_Item in the tree, but only if -- Current_Declaration is not an empty node. - if Current_Declaration /= Empty_Node then - if Current_Declarative_Item = Empty_Node then + if Present (Current_Declaration) then + if No (Current_Declarative_Item) then Current_Declarative_Item := Default_Project_Node (Of_Kind => N_Declarative_Item, In_Tree => In_Tree); @@ -1056,13 +1056,13 @@ package body Prj.Dect is First_Package_Of (Current_Project, In_Tree); begin - while Current /= Empty_Node + while Present (Current) and then Name_Of (Current, In_Tree) /= Token_Name loop Current := Next_Package_In_Project (Current, In_Tree); end loop; - if Current /= Empty_Node then + if Present (Current) then Error_Msg ("package """ & Get_Name_String (Name_Of (Package_Declaration, In_Tree)) & @@ -1110,22 +1110,22 @@ package body Prj.Dect is (Current_Project, In_Tree), In_Tree); begin - while Clause /= Empty_Node loop + while Present (Clause) loop -- Only non limited imported projects may be used in a -- renames declaration. The_Project := Non_Limited_Project_Node_Of (Clause, In_Tree); - exit when The_Project /= Empty_Node + exit when Present (The_Project) and then Name_Of (The_Project, In_Tree) = Project_Name; Clause := Next_With_Clause_Of (Clause, In_Tree); end loop; - if Clause = Empty_Node then + if No (Clause) then -- As we have not found the project in the imports, we check -- if it's the name of an eventual extended project. - if Extended /= Empty_Node + if Present (Extended) and then Name_Of (Extended, In_Tree) = Project_Name then Set_Project_Of_Renamed_Package_Of @@ -1152,8 +1152,8 @@ package body Prj.Dect is if Name_Of (Package_Declaration, In_Tree) /= Token_Name then Error_Msg ("not the same package name", Token_Ptr); elsif - Project_Of_Renamed_Package_Of - (Package_Declaration, In_Tree) /= Empty_Node + Present (Project_Of_Renamed_Package_Of + (Package_Declaration, In_Tree)) then declare Current : Project_Node_Id := @@ -1163,14 +1163,14 @@ package body Prj.Dect is In_Tree); begin - while Current /= Empty_Node + while Present (Current) and then Name_Of (Current, In_Tree) /= Token_Name loop Current := Next_Package_In_Project (Current, In_Tree); end loop; - if Current = Empty_Node then + if No (Current) then Error_Msg ("""" & Get_Name_String (Token_Name) & @@ -1272,27 +1272,27 @@ package body Prj.Dect is Set_Name_Of (String_Type, In_Tree, To => Token_Name); Current := First_String_Type_Of (Current_Project, In_Tree); - while Current /= Empty_Node + while Present (Current) and then Name_Of (Current, In_Tree) /= Token_Name loop Current := Next_String_Type (Current, In_Tree); end loop; - if Current /= Empty_Node then + if Present (Current) then Error_Msg ("duplicate string type name """ & Get_Name_String (Token_Name) & """", Token_Ptr); else Current := First_Variable_Of (Current_Project, In_Tree); - while Current /= Empty_Node + while Present (Current) and then Name_Of (Current, In_Tree) /= Token_Name loop Current := Next_Variable (Current, In_Tree); end loop; - if Current /= Empty_Node then + if Present (Current) then Error_Msg ("""" & Get_Name_String (Token_Name) & """ is already a variable name", Token_Ptr); @@ -1399,8 +1399,8 @@ package body Prj.Dect is if OK then declare - Current : Project_Node_Id := - First_String_Type_Of (Current_Project, In_Tree); + Proj : Project_Node_Id := Current_Project; + Current : Project_Node_Id := Empty_Node; begin if Project_String_Type_Name /= No_Name then @@ -1414,7 +1414,7 @@ package body Prj.Dect is begin if The_Project_Name_And_Node = - Tree_Private_Part.No_Project_Name_And_Node + Tree_Private_Part.No_Project_Name_And_Node then Error_Msg ("unknown project """ & Get_Name_String @@ -1426,22 +1426,45 @@ package body Prj.Dect is Current := First_String_Type_Of (The_Project_Name_And_Node.Node, In_Tree); + while + Present (Current) + and then + Name_Of (Current, In_Tree) /= String_Type_Name + loop + Current := Next_String_Type (Current, In_Tree); + end loop; end if; end; - end if; - while Current /= Empty_Node - and then Name_Of (Current, In_Tree) /= String_Type_Name - loop - Current := Next_String_Type (Current, In_Tree); - end loop; + else + -- Look for a string type with the correct name in this + -- project or in any of its ancestors. + + loop + Current := + First_String_Type_Of (Proj, In_Tree); + while + Present (Current) + and then + Name_Of (Current, In_Tree) /= String_Type_Name + loop + Current := Next_String_Type (Current, In_Tree); + end loop; + + exit when Present (Current); - if Current = Empty_Node then + Proj := Parent_Project_Of (Proj, In_Tree); + exit when No (Proj); + end loop; + end if; + + if No (Current) then Error_Msg ("unknown string type """ & Get_Name_String (String_Type_Name) & """", Type_Location); OK := False; + else Set_String_Type_Of (Variable, In_Tree, To => Current); @@ -1471,7 +1494,7 @@ package body Prj.Dect is Optional_Index => False); Set_Expression_Of (Variable, In_Tree, To => Expression); - if Expression /= Empty_Node then + if Present (Expression) then -- A typed string must have a single string value, not a list if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration @@ -1491,27 +1514,27 @@ package body Prj.Dect is The_Variable : Project_Node_Id := Empty_Node; begin - if Current_Package /= Empty_Node then + if Present (Current_Package) then The_Variable := First_Variable_Of (Current_Package, In_Tree); - elsif Current_Project /= Empty_Node then - The_Variable := First_Variable_Of (Current_Project, In_Tree); + elsif Present (Current_Project) then + The_Variable := First_Variable_Of (Current_Project, In_Tree); end if; - while The_Variable /= Empty_Node + while Present (The_Variable) and then Name_Of (The_Variable, In_Tree) /= Variable_Name loop The_Variable := Next_Variable (The_Variable, In_Tree); end loop; - if The_Variable = Empty_Node then - if Current_Package /= Empty_Node then + if No (The_Variable) then + if Present (Current_Package) then Set_Next_Variable (Variable, In_Tree, To => First_Variable_Of (Current_Package, In_Tree)); Set_First_Variable_Of (Current_Package, In_Tree, To => Variable); - elsif Current_Project /= Empty_Node then + elsif Present (Current_Project) then Set_Next_Variable (Variable, In_Tree, To => First_Variable_Of (Current_Project, In_Tree)); @@ -1521,8 +1544,8 @@ package body Prj.Dect is else if Expression_Kind_Of (Variable, In_Tree) /= Undefined then - if - Expression_Kind_Of (The_Variable, In_Tree) = Undefined + if Expression_Kind_Of (The_Variable, In_Tree) = + Undefined then Set_Expression_Kind_Of (The_Variable, In_Tree, @@ -1543,7 +1566,6 @@ package body Prj.Dect is end if; end; end if; - end Parse_Variable_Declaration; end Prj.Dect; diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb index 336c676e748..a3997f0968b 100644 --- a/gcc/ada/prj-makr.adb +++ b/gcc/ada/prj-makr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -41,7 +41,6 @@ with GNAT.Directory_Operations; use GNAT.Directory_Operations; with System.Case_Util; use System.Case_Util; with System.CRTL; -with System.Regexp; use System.Regexp; package body Prj.Makr is @@ -50,6 +49,55 @@ package body Prj.Makr is -- All the following need comments ??? All global variables and -- subprograms must be fully commented. + Very_Verbose : Boolean := False; + -- Set in call to Initialize to indicate very verbose output + + Project_File : Boolean := False; + -- True when gnatname is creating/modifying a project file. False when + -- gnatname is creating a configuration pragmas file. + + Tree : constant Project_Node_Tree_Ref := new Project_Node_Tree_Data; + -- The project tree where the project file is parsed + + Args : Argument_List_Access; + -- The list of arguments for calls to the compiler to get the unit names + -- and kinds (spec or body) in the Ada sources. + + Path_Name : String_Access; + + Path_Last : Natural; + + Directory_Last : Natural := 0; + + Output_Name : String_Access; + Output_Name_Last : Natural; + Output_Name_Id : Name_Id; + + Project_Naming_File_Name : String_Access; + -- String (1 .. Output_Name'Length + Naming_File_Suffix'Length); + + Project_Naming_Last : Natural; + Project_Naming_Id : Name_Id := No_Name; + + Source_List_Path : String_Access; + -- (1 .. Output_Name'Length + Source_List_File_Suffix'Length); + Source_List_Last : Natural; + + Source_List_FD : File_Descriptor; + + Project_Node : Project_Node_Id := Empty_Node; + Project_Declaration : Project_Node_Id := Empty_Node; + Source_Dirs_List : Project_Node_Id := Empty_Node; + + Project_Naming_Node : Project_Node_Id := Empty_Node; + Project_Naming_Decl : Project_Node_Id := Empty_Node; + Naming_Package : Project_Node_Id := Empty_Node; + Naming_Package_Comments : Project_Node_Id := Empty_Node; + + Source_Files_Comments : Project_Node_Id := Empty_Node; + Source_Dirs_Comments : Project_Node_Id := Empty_Node; + Source_List_File_Comments : Project_Node_Id := Empty_Node; + Naming_String : aliased String := "naming"; Gnatname_Packages : aliased String_List := (1 => Naming_String'Access); @@ -91,6 +139,36 @@ package body Prj.Makr is Table_Initial => 10, Table_Increment => 100, Table_Name => "Prj.Makr.Processed_Directories"); + -- The list of already processed directories for each section, to avoid + -- processing several times the same directory in the same section. + + package Source_Directories is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Prj.Makr.Source_Directories"); + -- The complete list of directories to be put in attribute Source_Dirs in + -- the project file. + + type Source is record + File_Name : Name_Id; + Unit_Name : Name_Id; + Index : Int := 0; + Spec : Boolean; + end record; + + package Sources is new Table.Table + (Table_Component_Type => Source, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Prj.Makr.Sources"); + -- The list of Ada sources found, with their unit name and kind, to be put + -- in the source attribute and package Naming of the project file, or in + -- the pragmas Source_File_Name in the configuration pragmas file. --------- -- Dup -- @@ -112,566 +190,588 @@ package body Prj.Makr is Fd := System.CRTL.dup2 (Integer (Old_Fd), Integer (New_Fd)); end Dup2; - ---------- - -- Make -- - ---------- - - procedure Make - (File_Path : String; - Project_File : Boolean; - Directories : Argument_List; - Name_Patterns : Argument_List; - Excluded_Patterns : Argument_List; - Foreign_Patterns : Argument_List; - Preproc_Switches : Argument_List; - Very_Verbose : Boolean) - is - Tree : constant Project_Node_Tree_Ref := new Project_Node_Tree_Data; - - Path_Name : String (1 .. File_Path'Length + - Project_File_Extension'Length); - Path_Last : Natural := File_Path'Length; - - Directory_Last : Natural := 0; - - Output_Name : String (Path_Name'Range); - Output_Name_Last : Natural; - Output_Name_Id : Name_Id; - - Project_Node : Project_Node_Id := Empty_Node; - Project_Declaration : Project_Node_Id := Empty_Node; - Source_Dirs_List : Project_Node_Id := Empty_Node; - Current_Source_Dir : Project_Node_Id := Empty_Node; - - Project_Naming_Node : Project_Node_Id := Empty_Node; - Project_Naming_Decl : Project_Node_Id := Empty_Node; - Naming_Package : Project_Node_Id := Empty_Node; - Naming_Package_Comments : Project_Node_Id := Empty_Node; + -------------- + -- Finalize -- + -------------- - Source_Files_Comments : Project_Node_Id := Empty_Node; - Source_Dirs_Comments : Project_Node_Id := Empty_Node; - Source_List_File_Comments : Project_Node_Id := Empty_Node; + procedure Finalize is + Discard : Boolean; + pragma Warnings (Off, Discard); - Project_Naming_File_Name : String (1 .. Output_Name'Length + - Naming_File_Suffix'Length); + Current_Source_Dir : Project_Node_Id := Empty_Node; - Project_Naming_Last : Natural; - Project_Naming_Id : Name_Id := No_Name; + begin + if Project_File then + -- If there were no already existing project file, or if the parsing + -- was unsuccessful, create an empty project node with the correct + -- name and its project declaration node. - Excluded_Expressions : array (Excluded_Patterns'Range) of Regexp; - Regular_Expressions : array (Name_Patterns'Range) of Regexp; - Foreign_Expressions : array (Foreign_Patterns'Range) of Regexp; + if No (Project_Node) then + Project_Node := + Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree); + Set_Name_Of (Project_Node, Tree, To => Output_Name_Id); + Set_Project_Declaration_Of + (Project_Node, Tree, + To => Default_Project_Node + (Of_Kind => N_Project_Declaration, In_Tree => Tree)); - Source_List_Path : String (1 .. Output_Name'Length + - Source_List_File_Suffix'Length); - Source_List_Last : Natural; + end if; - Source_List_FD : File_Descriptor; + end if; - Args : Argument_List (1 .. Preproc_Switches'Length + 6); + -- Delete the file if it already exists - type SFN_Pragma is record - Unit : Name_Id; - File : Name_Id; - Index : Int := 0; - Spec : Boolean; - end record; + Delete_File + (Path_Name (Directory_Last + 1 .. Path_Last), + Success => Discard); - package SFN_Pragmas is new Table.Table - (Table_Component_Type => SFN_Pragma, - Table_Index_Type => Natural, - Table_Low_Bound => 0, - Table_Initial => 50, - Table_Increment => 100, - Table_Name => "Prj.Makr.SFN_Pragmas"); + -- Create a new one - procedure Process_Directory (Dir_Name : String; Recursively : Boolean); - -- Look for Ada and foreign sources in a directory, according to the - -- patterns. When Recursively is True, after looking for sources in - -- Dir_Name, look also in its subdirectories, if any. + if Opt.Verbose_Mode then + Output.Write_Str ("Creating new file """); + Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last)); + Output.Write_Line (""""); + end if; - ----------------------- - -- Process_Directory -- - ----------------------- + Output_FD := Create_New_File + (Path_Name (Directory_Last + 1 .. Path_Last), + Fmode => Text); - procedure Process_Directory (Dir_Name : String; Recursively : Boolean) is - Matched : Matched_Type := False; - Str : String (1 .. 2_000); - Canon : String (1 .. 2_000); - Last : Natural; - Dir : Dir_Type; - Process : Boolean := True; + -- Fails if project file cannot be created - Temp_File_Name : String_Access := null; - Save_Last_Pragma_Index : Natural := 0; - File_Name_Id : Name_Id := No_Name; - SFN_Prag : SFN_Pragma; + if Output_FD = Invalid_FD then + Prj.Com.Fail + ("cannot create new """, Path_Name (1 .. Path_Last), """"); + end if; - begin - -- Avoid processing the same directory more than once + if Project_File then - for Index in 1 .. Processed_Directories.Last loop - if Processed_Directories.Table (Index).all = Dir_Name then - Process := False; - exit; - end if; - end loop; + -- Delete the source list file, if it already exists - if Process then - if Opt.Verbose_Mode then - Output.Write_Str ("Processing directory """); - Output.Write_Str (Dir_Name); - Output.Write_Line (""""); - end if; + declare + Discard : Boolean; + pragma Warnings (Off, Discard); + begin + Delete_File + (Source_List_Path (1 .. Source_List_Last), + Success => Discard); + end; - Processed_Directories. Increment_Last; - Processed_Directories.Table (Processed_Directories.Last) := - new String'(Dir_Name); + -- And create a new source list file. Fail if file cannot be created. - -- Get the source file names from the directory. Fails if the - -- directory does not exist. + Source_List_FD := Create_New_File + (Name => Source_List_Path (1 .. Source_List_Last), + Fmode => Text); - begin - Open (Dir, Dir_Name); - exception - when Directory_Error => - Prj.Com.Fail ("cannot open directory """, Dir_Name, """"); - end; + if Source_List_FD = Invalid_FD then + Prj.Com.Fail + ("cannot create file """, + Source_List_Path (1 .. Source_List_Last), + """"); + end if; - -- Process each regular file in the directory + if Opt.Verbose_Mode then + Output.Write_Str ("Naming project file name is """); + Output.Write_Str + (Project_Naming_File_Name (1 .. Project_Naming_Last)); + Output.Write_Line (""""); + end if; - File_Loop : loop - Read (Dir, Str, Last); - exit File_Loop when Last = 0; + -- Create the naming project node - -- Copy the file name and put it in canonical case to match - -- against the patterns that have themselves already been put - -- in canonical case. + Project_Naming_Node := + Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree); + Set_Name_Of (Project_Naming_Node, Tree, To => Project_Naming_Id); + Project_Naming_Decl := + Default_Project_Node + (Of_Kind => N_Project_Declaration, In_Tree => Tree); + Set_Project_Declaration_Of + (Project_Naming_Node, Tree, Project_Naming_Decl); + Naming_Package := + Default_Project_Node + (Of_Kind => N_Package_Declaration, In_Tree => Tree); + Set_Name_Of (Naming_Package, Tree, To => Name_Naming); - Canon (1 .. Last) := Str (1 .. Last); - Canonical_Case_File_Name (Canon (1 .. Last)); + -- Add an attribute declaration for Source_Files as an empty list (to + -- indicate there are no sources in the naming project) and a package + -- Naming (that will be filled later). - if Is_Regular_File - (Dir_Name & Directory_Separator & Str (1 .. Last)) - then - Matched := True; + declare + Decl_Item : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Declarative_Item, In_Tree => Tree); - Name_Len := Last; - Name_Buffer (1 .. Name_Len) := Str (1 .. Last); - File_Name_Id := Name_Find; + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Attribute_Declaration, + In_Tree => Tree, + And_Expr_Kind => List); - -- First, check if the file name matches at least one of - -- the excluded expressions; + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + In_Tree => Tree, + And_Expr_Kind => List); - for Index in Excluded_Expressions'Range loop - if - Match (Canon (1 .. Last), Excluded_Expressions (Index)) - then - Matched := Excluded; - exit; - end if; - end loop; + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + In_Tree => Tree, + And_Expr_Kind => List); - -- If it does not match any of the excluded expressions, - -- check if the file name matches at least one of the - -- regular expressions. + Empty_List : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Literal_String_List, + In_Tree => Tree); - if Matched = True then - Matched := False; + begin + Set_First_Declarative_Item_Of + (Project_Naming_Decl, Tree, To => Decl_Item); + Set_Next_Declarative_Item (Decl_Item, Tree, Naming_Package); + Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); + Set_Name_Of (Attribute, Tree, To => Name_Source_Files); + Set_Expression_Of (Attribute, Tree, To => Expression); + Set_First_Term (Expression, Tree, To => Term); + Set_Current_Term (Term, Tree, To => Empty_List); + end; - for Index in Regular_Expressions'Range loop - if - Match - (Canon (1 .. Last), Regular_Expressions (Index)) - then - Matched := True; - exit; - end if; - end loop; - end if; + -- Add a with clause on the naming project in the main project, if + -- there is not already one. - if Very_Verbose - or else (Matched = True and then Opt.Verbose_Mode) - then - Output.Write_Str (" Checking """); - Output.Write_Str (Str (1 .. Last)); - Output.Write_Line (""": "); - end if; + declare + With_Clause : Project_Node_Id := + First_With_Clause_Of (Project_Node, Tree); - -- If the file name matches one of the regular expressions, - -- parse it to get its unit name. + begin + while Present (With_Clause) loop + exit when + Prj.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id; + With_Clause := Next_With_Clause_Of (With_Clause, Tree); + end loop; - if Matched = True then - declare - FD : File_Descriptor; - Success : Boolean; - Saved_Output : File_Descriptor; - Saved_Error : File_Descriptor; + if No (With_Clause) then + With_Clause := Default_Project_Node + (Of_Kind => N_With_Clause, In_Tree => Tree); + Set_Next_With_Clause_Of + (With_Clause, Tree, + To => First_With_Clause_Of (Project_Node, Tree)); + Set_First_With_Clause_Of + (Project_Node, Tree, To => With_Clause); + Set_Name_Of (With_Clause, Tree, To => Project_Naming_Id); - begin - -- If we don't have the path of the compiler yet, - -- get it now. The compiler name may have a prefix, - -- so we get the potentially prefixed name. + -- We set the project node to something different than + -- Empty_Node, so that Prj.PP does not generate a limited + -- with clause. - if Gcc_Path = null then - declare - Prefix_Gcc : String_Access := - Program_Name (Gcc); - begin - Gcc_Path := - Locate_Exec_On_Path (Prefix_Gcc.all); - Free (Prefix_Gcc); - end; + Set_Project_Node_Of (With_Clause, Tree, Non_Empty_Node); - if Gcc_Path = null then - Prj.Com.Fail ("could not locate " & Gcc); - end if; - end if; + Name_Len := Project_Naming_Last; + Name_Buffer (1 .. Name_Len) := + Project_Naming_File_Name (1 .. Project_Naming_Last); + Set_String_Value_Of (With_Clause, Tree, To => Name_Find); + end if; + end; - -- If we don't have yet the file name of the - -- temporary file, get it now. + Project_Declaration := Project_Declaration_Of (Project_Node, Tree); - if Temp_File_Name = null then - Create_Temp_File (FD, Temp_File_Name); + -- Add a package Naming in the main project, that is a renaming of + -- package Naming in the naming project. - if FD = Invalid_FD then - Prj.Com.Fail - ("could not create temporary file"); - end if; + declare + Decl_Item : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Declarative_Item, + In_Tree => Tree); - Close (FD); - Delete_File (Temp_File_Name.all, Success); - end if; + Naming : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Package_Declaration, + In_Tree => Tree); - Args (Args'Last) := new String' - (Dir_Name & - Directory_Separator & - Str (1 .. Last)); + begin + Set_Next_Declarative_Item + (Decl_Item, Tree, + To => First_Declarative_Item_Of (Project_Declaration, Tree)); + Set_First_Declarative_Item_Of + (Project_Declaration, Tree, To => Decl_Item); + Set_Current_Item_Node (Decl_Item, Tree, To => Naming); + Set_Name_Of (Naming, Tree, To => Name_Naming); + Set_Project_Of_Renamed_Package_Of + (Naming, Tree, To => Project_Naming_Node); - -- Create the temporary file + -- Attach the comments, if any, that were saved for package + -- Naming. - FD := Create_Output_Text_File - (Name => Temp_File_Name.all); + Tree.Project_Nodes.Table (Naming).Comments := + Naming_Package_Comments; + end; - if FD = Invalid_FD then - Prj.Com.Fail - ("could not create temporary file"); - end if; + -- Add an attribute declaration for Source_Dirs, initialized as an + -- empty list. - -- Save the standard output and error + declare + Decl_Item : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Declarative_Item, + In_Tree => Tree); - Saved_Output := Dup (Standout); - Saved_Error := Dup (Standerr); + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Attribute_Declaration, + In_Tree => Tree, + And_Expr_Kind => List); - -- Set standard output and error to the temporary file + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + In_Tree => Tree, + And_Expr_Kind => List); - Dup2 (FD, Standout); - Dup2 (FD, Standerr); + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, In_Tree => Tree, + And_Expr_Kind => List); - -- And spawn the compiler + begin + Set_Next_Declarative_Item + (Decl_Item, Tree, + To => First_Declarative_Item_Of (Project_Declaration, Tree)); + Set_First_Declarative_Item_Of + (Project_Declaration, Tree, To => Decl_Item); + Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); + Set_Name_Of (Attribute, Tree, To => Name_Source_Dirs); + Set_Expression_Of (Attribute, Tree, To => Expression); + Set_First_Term (Expression, Tree, To => Term); + Source_Dirs_List := + Default_Project_Node + (Of_Kind => N_Literal_String_List, + In_Tree => Tree, + And_Expr_Kind => List); + Set_Current_Term (Term, Tree, To => Source_Dirs_List); - Spawn (Gcc_Path.all, Args, Success); + -- Attach the comments, if any, that were saved for attribute + -- Source_Dirs. - -- Restore the standard output and error + Tree.Project_Nodes.Table (Attribute).Comments := + Source_Dirs_Comments; + end; - Dup2 (Saved_Output, Standout); - Dup2 (Saved_Error, Standerr); + -- Put the source directories in attribute Source_Dirs - -- Close the temporary file + for Source_Dir_Index in 1 .. Source_Directories.Last loop + declare + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + In_Tree => Tree, + And_Expr_Kind => Single); - Close (FD); + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + In_Tree => Tree, + And_Expr_Kind => Single); - -- And close the saved standard output and error to - -- avoid too many file descriptors. + Value : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Literal_String, + In_Tree => Tree, + And_Expr_Kind => Single); - Close (Saved_Output); - Close (Saved_Error); + begin + if No (Current_Source_Dir) then + Set_First_Expression_In_List + (Source_Dirs_List, Tree, To => Expression); + else + Set_Next_Expression_In_List + (Current_Source_Dir, Tree, To => Expression); + end if; - -- Now that standard output is restored, check if - -- the compiler ran correctly. + Current_Source_Dir := Expression; + Set_First_Term (Expression, Tree, To => Term); + Set_Current_Term (Term, Tree, To => Value); + Name_Len := 0; + Add_Str_To_Name_Buffer + (Source_Directories.Table (Source_Dir_Index).all); + Set_String_Value_Of (Value, Tree, To => Name_Find); + end; + end loop; - -- Read the lines of the temporary file: - -- they should contain the kind and name of the unit. + -- Add an attribute declaration for Source_Files or Source_List_File + -- with the source list file name that will be created. - declare - File : Text_File; - Text_Line : String (1 .. 1_000); - Text_Last : Natural; + declare + Decl_Item : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Declarative_Item, + In_Tree => Tree); - begin - Open (File, Temp_File_Name.all); + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Attribute_Declaration, + In_Tree => Tree, + And_Expr_Kind => Single); - if not Is_Valid (File) then - Prj.Com.Fail - ("could not read temporary file"); - end if; + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + In_Tree => Tree, + And_Expr_Kind => Single); - Save_Last_Pragma_Index := SFN_Pragmas.Last; + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + In_Tree => Tree, + And_Expr_Kind => Single); - if End_Of_File (File) then - if Opt.Verbose_Mode then - if not Success then - Output.Write_Str (" (process died) "); - end if; - end if; + Value : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Literal_String, + In_Tree => Tree, + And_Expr_Kind => Single); - else - Line_Loop : while not End_Of_File (File) loop - Get_Line (File, Text_Line, Text_Last); + begin + Set_Next_Declarative_Item + (Decl_Item, Tree, + To => First_Declarative_Item_Of (Project_Declaration, Tree)); + Set_First_Declarative_Item_Of + (Project_Declaration, Tree, To => Decl_Item); + Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); - -- Find the first closing parenthesis + Set_Name_Of (Attribute, Tree, To => Name_Source_List_File); + Set_Expression_Of (Attribute, Tree, To => Expression); + Set_First_Term (Expression, Tree, To => Term); + Set_Current_Term (Term, Tree, To => Value); + Name_Len := Source_List_Last; + Name_Buffer (1 .. Name_Len) := + Source_List_Path (1 .. Source_List_Last); + Set_String_Value_Of (Value, Tree, To => Name_Find); - Char_Loop : for J in 1 .. Text_Last loop - if Text_Line (J) = ')' then - if J >= 13 and then - Text_Line (1 .. 4) = "Unit" - then - -- Add entry to SFN_Pragmas table + -- If there was no comments for attribute Source_List_File, put + -- those for Source_Files, if they exist. - Name_Len := J - 12; - Name_Buffer (1 .. Name_Len) := - Text_Line (6 .. J - 7); - SFN_Prag := - (Unit => Name_Find, - File => File_Name_Id, - Index => 0, - Spec => Text_Line (J - 5 .. J) = - "(spec)"); + if Present (Source_List_File_Comments) then + Tree.Project_Nodes.Table (Attribute).Comments := + Source_List_File_Comments; + else + Tree.Project_Nodes.Table (Attribute).Comments := + Source_Files_Comments; + end if; + end; - SFN_Pragmas.Increment_Last; - SFN_Pragmas.Table - (SFN_Pragmas.Last) := SFN_Prag; - end if; - exit Char_Loop; - end if; - end loop Char_Loop; - end loop Line_Loop; - end if; + -- Put the sources in the source list files and in the naming + -- project. - if Save_Last_Pragma_Index = SFN_Pragmas.Last then - if Opt.Verbose_Mode then - Output.Write_Line (" not a unit"); - end if; + for Source_Index in 1 .. Sources.Last loop - else - if SFN_Pragmas.Last > - Save_Last_Pragma_Index + 1 - then - for Index in Save_Last_Pragma_Index + 1 .. - SFN_Pragmas.Last - loop - SFN_Pragmas.Table (Index).Index := - Int (Index - Save_Last_Pragma_Index); - end loop; - end if; + -- Add the corresponding attribute in the + -- Naming package of the naming project. - for Index in Save_Last_Pragma_Index + 1 .. - SFN_Pragmas.Last - loop - SFN_Prag := SFN_Pragmas.Table (Index); + declare + Current_Source : constant Source := + Sources.Table (Source_Index); - if Opt.Verbose_Mode then - if SFN_Prag.Spec then - Output.Write_Str (" spec of "); + Decl_Item : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => + N_Declarative_Item, + In_Tree => Tree); - else - Output.Write_Str (" body of "); - end if; + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => + N_Attribute_Declaration, + In_Tree => Tree); + + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + And_Expr_Kind => Single, + In_Tree => Tree); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + And_Expr_Kind => Single, + In_Tree => Tree); + + Value : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Literal_String, + And_Expr_Kind => Single, + In_Tree => Tree); - Output.Write_Line - (Get_Name_String (SFN_Prag.Unit)); - end if; + begin + -- Add source file name to the source list file - if Project_File then + 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; - -- Add the corresponding attribute in the - -- Naming package of the naming project. + -- For an Ada source, add entry in package Naming + + if Current_Source.Unit_Name /= No_Name then + Set_Next_Declarative_Item + (Decl_Item, + To => First_Declarative_Item_Of + (Naming_Package, Tree), + In_Tree => Tree); + Set_First_Declarative_Item_Of + (Naming_Package, + To => Decl_Item, + In_Tree => Tree); + Set_Current_Item_Node + (Decl_Item, + To => Attribute, + In_Tree => Tree); + + -- Is it a spec or a body? + + if Current_Source.Spec then + Set_Name_Of + (Attribute, Tree, + To => Name_Spec); + else + Set_Name_Of + (Attribute, Tree, + To => Name_Body); + end if; - declare - Decl_Item : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => - N_Declarative_Item, - In_Tree => Tree); + -- Get the name of the unit - Attribute : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => - N_Attribute_Declaration, - In_Tree => Tree); - - Expression : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Expression, - And_Expr_Kind => Single, - In_Tree => Tree); - - Term : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Term, - And_Expr_Kind => Single, - In_Tree => Tree); - - Value : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Literal_String, - And_Expr_Kind => Single, - In_Tree => Tree); - - begin - Set_Next_Declarative_Item - (Decl_Item, - To => First_Declarative_Item_Of - (Naming_Package, Tree), - In_Tree => Tree); - Set_First_Declarative_Item_Of - (Naming_Package, - To => Decl_Item, - In_Tree => Tree); - Set_Current_Item_Node - (Decl_Item, - To => Attribute, - In_Tree => Tree); - - -- Is it a spec or a body? - - if SFN_Prag.Spec then - Set_Name_Of - (Attribute, Tree, - To => Name_Spec); - else - Set_Name_Of - (Attribute, Tree, - To => Name_Body); - end if; + Get_Name_String (Current_Source.Unit_Name); + To_Lower (Name_Buffer (1 .. Name_Len)); + Set_Associative_Array_Index_Of + (Attribute, Tree, To => Name_Find); - -- Get the name of the unit + Set_Expression_Of + (Attribute, Tree, To => Expression); + Set_First_Term + (Expression, Tree, To => Term); + Set_Current_Term + (Term, Tree, To => Value); - Get_Name_String (SFN_Prag.Unit); - To_Lower (Name_Buffer (1 .. Name_Len)); - Set_Associative_Array_Index_Of - (Attribute, Tree, To => Name_Find); + -- And set the name of the file - Set_Expression_Of - (Attribute, Tree, To => Expression); - Set_First_Term - (Expression, Tree, To => Term); - Set_Current_Term - (Term, Tree, To => Value); + Set_String_Value_Of + (Value, Tree, To => Current_Source.File_Name); + Set_Source_Index_Of + (Value, Tree, To => Current_Source.Index); + end if; + end; + end loop; - -- And set the name of the file + -- Close the source list file - Set_String_Value_Of - (Value, Tree, To => File_Name_Id); - Set_Source_Index_Of - (Value, Tree, To => SFN_Prag.Index); - end; - end if; - end loop; + Close (Source_List_FD); - if Project_File then - -- Add source file name to source list - -- file. + -- Output the project file - Last := Last + 1; - Str (Last) := ASCII.LF; + Prj.PP.Pretty_Print + (Project_Node, Tree, + W_Char => Write_A_Char'Access, + W_Eol => Write_Eol'Access, + W_Str => Write_A_String'Access, + Backward_Compatibility => False); + Close (Output_FD); - if Write (Source_List_FD, - Str (1)'Address, - Last) /= Last - then - Prj.Com.Fail ("disk full"); - end if; - end if; - end if; + -- Delete the naming project file if it already exists - Close (File); + Delete_File + (Project_Naming_File_Name (1 .. Project_Naming_Last), + Success => Discard); - Delete_File (Temp_File_Name.all, Success); - end; - end; + -- Create a new one - -- File name matches none of the regular expressions + if Opt.Verbose_Mode then + Output.Write_Str ("Creating new naming project file """); + Output.Write_Str (Project_Naming_File_Name + (1 .. Project_Naming_Last)); + Output.Write_Line (""""); + end if; - else - -- If file is not excluded, see if this is foreign source + Output_FD := Create_New_File + (Project_Naming_File_Name (1 .. Project_Naming_Last), + Fmode => Text); - if Matched /= Excluded then - for Index in Foreign_Expressions'Range loop - if Match (Canon (1 .. Last), - Foreign_Expressions (Index)) - then - Matched := True; - exit; - end if; - end loop; - end if; + -- Fails if naming project file cannot be created - if Very_Verbose then - case Matched is - when False => - Output.Write_Line ("no match"); + if Output_FD = Invalid_FD then + Prj.Com.Fail + ("cannot create new """, + Project_Naming_File_Name (1 .. Project_Naming_Last), + """"); + end if; - when Excluded => - Output.Write_Line ("excluded"); + -- Output the naming project file - when True => - Output.Write_Line ("foreign source"); - end case; - end if; + Prj.PP.Pretty_Print + (Project_Naming_Node, Tree, + W_Char => Write_A_Char'Access, + W_Eol => Write_Eol'Access, + W_Str => Write_A_String'Access, + Backward_Compatibility => False); + Close (Output_FD); - if Project_File and Matched = True then + else + -- For each Ada source, write a pragma Source_File_Name to the + -- configuration pragmas file. - -- Add source file name to source list file + for Index in 1 .. Sources.Last loop + if Sources.Table (Index).Unit_Name /= No_Name then + Write_A_String ("pragma Source_File_Name"); + Write_Eol; + Write_A_String (" ("); + Write_A_String + (Get_Name_String (Sources.Table (Index).Unit_Name)); + Write_A_String (","); + Write_Eol; - Last := Last + 1; - Str (Last) := ASCII.LF; + if Sources.Table (Index).Spec then + Write_A_String (" Spec_File_Name => """); - if Write (Source_List_FD, - Str (1)'Address, - Last) /= Last - then - Prj.Com.Fail ("disk full"); - end if; - end if; - end if; + else + Write_A_String (" Body_File_Name => """); end if; - end loop File_Loop; - - Close (Dir); - end if; - -- If Recursively is True, call itself for each subdirectory. - -- We do that, even when this directory has already been processed, - -- because all of its subdirectories may not have been processed. - - if Recursively then - Open (Dir, Dir_Name); - - loop - Read (Dir, Str, Last); - exit when Last = 0; + Write_A_String + (Get_Name_String (Sources.Table (Index).File_Name)); - -- Do not call itself for "." or ".." + Write_A_String (""""); - if Is_Directory - (Dir_Name & Directory_Separator & Str (1 .. Last)) - and then Str (1 .. Last) /= "." - and then Str (1 .. Last) /= ".." - then - Process_Directory - (Dir_Name & Directory_Separator & Str (1 .. Last), - Recursively => True); + if Sources.Table (Index).Index /= 0 then + Write_A_String (", Index =>"); + Write_A_String (Sources.Table (Index).Index'Img); end if; - end loop; - Close (Dir); - end if; - end Process_Directory; + Write_A_String (");"); + Write_Eol; + end if; + end loop; - -- Start of processing for Make + Close (Output_FD); + end if; + end Finalize; + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (File_Path : String; + Project_File : Boolean; + Preproc_Switches : Argument_List; + Very_Verbose : Boolean) + is begin + Makr.Very_Verbose := Initialize.Very_Verbose; + Makr.Project_File := Initialize.Project_File; + -- Do some needed initializations Csets.Initialize; @@ -680,12 +780,12 @@ package body Prj.Makr is Prj.Initialize (No_Project_Tree); Prj.Tree.Initialize (Tree); - SFN_Pragmas.Set_Last (0); - - Processed_Directories.Set_Last (0); + Sources.Set_Last (0); + Source_Directories.Set_Last (0); -- Initialize the compiler switches + Args := new Argument_List (1 .. Preproc_Switches'Length + 6); Args (1) := new String'("-c"); Args (2) := new String'("-gnats"); Args (3) := new String'("-gnatu"); @@ -695,6 +795,10 @@ package body Prj.Makr is -- Get the path and file names + Path_Name := new + String (1 .. File_Path'Length + Project_File_Extension'Length); + Path_Last := File_Path'Length; + if File_Names_Case_Sensitive then Path_Name (1 .. Path_Last) := File_Path; else @@ -722,8 +826,8 @@ package body Prj.Makr is Path_Last := Path_Name'Last; end if; - Output_Name (1 .. Path_Last) := To_Lower (Path_Name (1 .. Path_Last)); - Output_Name_Last := Path_Last - Project_File_Extension'Length; + Output_Name := new String'(To_Lower (Path_Name (1 .. Path_Last))); + Output_Name_Last := Output_Name'Last - 4; -- If there is already a project file with the specified name, parse -- it to get the components that are not automatically generated. @@ -731,14 +835,14 @@ package body Prj.Makr is if Is_Regular_File (Output_Name (1 .. Path_Last)) then if Opt.Verbose_Mode then Output.Write_Str ("Parsing already existing project file """); - Output.Write_Str (Output_Name (1 .. Output_Name_Last)); + Output.Write_Str (Output_Name.all); Output.Write_Line (""""); end if; Part.Parse (In_Tree => Tree, Project => Project_Node, - Project_File_Name => Output_Name (1 .. Output_Name_Last), + Project_File_Name => Output_Name.all, Always_Errout_Finalize => False, Store_Comments => True, Current_Directory => Get_Current_Dir, @@ -746,7 +850,7 @@ package body Prj.Makr is -- Fail if parsing was not successful - if Project_Node = Empty_Node then + if No (Project_Node) then Fail ("parsing of existing project file failed"); else @@ -762,11 +866,11 @@ package body Prj.Makr is Previous : Project_Node_Id := Empty_Node; begin - while With_Clause /= Empty_Node loop + while Present (With_Clause) loop if Prj.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id then - if Previous = Empty_Node then + if No (Previous) then Set_First_With_Clause_Of (Project_Node, Tree, To => Next_With_Clause_Of (With_Clause, Tree)); @@ -803,7 +907,7 @@ package body Prj.Makr is Comments : Project_Node_Id; begin - while Declaration /= Empty_Node loop + while Present (Declaration) loop Current_Node := Current_Item_Node (Declaration, Tree); Kind_Of_Node := Kind_Of (Current_Node, Tree); @@ -834,7 +938,7 @@ package body Prj.Makr is Naming_Package_Comments := Comments; end if; - if Previous = Empty_Node then + if No (Previous) then Set_First_Declarative_Item_Of (Project_Declaration_Of (Project_Node, Tree), Tree, @@ -874,12 +978,10 @@ package body Prj.Makr is -- Create the project naming file name Project_Naming_Last := Output_Name_Last; - Project_Naming_File_Name (1 .. Project_Naming_Last) := - Output_Name (1 .. Project_Naming_Last); - Project_Naming_File_Name - (Project_Naming_Last + 1 .. - Project_Naming_Last + Naming_File_Suffix'Length) := - Naming_File_Suffix; + Project_Naming_File_Name := + new String'(Output_Name (1 .. Output_Name_Last) & + Naming_File_Suffix & + Project_File_Extension); Project_Naming_Last := Project_Naming_Last + Naming_File_Suffix'Length; @@ -890,23 +992,17 @@ package body Prj.Makr is Project_Naming_File_Name (1 .. Name_Len); Project_Naming_Id := Name_Find; - Project_Naming_File_Name - (Project_Naming_Last + 1 .. - Project_Naming_Last + Project_File_Extension'Length) := - Project_File_Extension; Project_Naming_Last := Project_Naming_Last + Project_File_Extension'Length; -- Create the source list file name Source_List_Last := Output_Name_Last; - Source_List_Path (1 .. Source_List_Last) := - Output_Name (1 .. Source_List_Last); - Source_List_Path - (Source_List_Last + 1 .. - Source_List_Last + Source_List_File_Suffix'Length) := - Source_List_File_Suffix; - Source_List_Last := Source_List_Last + Source_List_File_Suffix'Length; + Source_List_Path := + new String'(Output_Name (1 .. Output_Name_Last) & + Source_List_File_Suffix); + Source_List_Last := + Output_Name_Last + Source_List_File_Suffix'Length; -- Add the project file extension to the project name @@ -915,6 +1011,7 @@ package body Prj.Makr is Output_Name_Last + Project_File_Extension'Length) := Project_File_Extension; Output_Name_Last := Output_Name_Last + Project_File_Extension'Length; + end if; -- Change the current directory to the directory of the project file, @@ -931,544 +1028,443 @@ package body Prj.Makr is """"); end; end if; + end Initialize; + + ------------- + -- Process -- + ------------- + + procedure Process + (Directories : Argument_List; + Name_Patterns : Regexp_List; + Excluded_Patterns : Regexp_List; + Foreign_Patterns : Regexp_List) + is + procedure Process_Directory (Dir_Name : String; Recursively : Boolean); + -- Look for Ada and foreign sources in a directory, according to the + -- patterns. When Recursively is True, after looking for sources in + -- Dir_Name, look also in its subdirectories, if any. - if Project_File then - - -- Delete the source list file, if it already exists - - declare - Discard : Boolean; - pragma Warnings (Off, Discard); - begin - Delete_File - (Source_List_Path (1 .. Source_List_Last), - Success => Discard); - end; + ----------------------- + -- Process_Directory -- + ----------------------- - -- And create a new source list file. - -- Fail if file cannot be created. + procedure Process_Directory (Dir_Name : String; Recursively : Boolean) is + Matched : Matched_Type := False; + Str : String (1 .. 2_000); + Canon : String (1 .. 2_000); + Last : Natural; + Dir : Dir_Type; + Do_Process : Boolean := True; - Source_List_FD := Create_New_File - (Name => Source_List_Path (1 .. Source_List_Last), - Fmode => Text); + Temp_File_Name : String_Access := null; + Save_Last_Source_Index : Natural := 0; + File_Name_Id : Name_Id := No_Name; - if Source_List_FD = Invalid_FD then - Prj.Com.Fail - ("cannot create file """, - Source_List_Path (1 .. Source_List_Last), - """"); - end if; - end if; + Current_Source : Source; - -- Compile the regular expressions. Fails immediately if any of - -- the specified strings is in error. + begin + -- Avoid processing the same directory more than once - for Index in Excluded_Expressions'Range loop - if Very_Verbose then - Output.Write_Str ("Excluded pattern: """); - Output.Write_Str (Excluded_Patterns (Index).all); - Output.Write_Line (""""); - end if; + for Index in 1 .. Processed_Directories.Last loop + if Processed_Directories.Table (Index).all = Dir_Name then + Do_Process := False; + exit; + end if; + end loop; - begin - Excluded_Expressions (Index) := - Compile (Pattern => Excluded_Patterns (Index).all, Glob => True); - exception - when Error_In_Regexp => - Prj.Com.Fail - ("invalid regular expression """, - Excluded_Patterns (Index).all, - """"); - end; - end loop; + if Do_Process then + if Opt.Verbose_Mode then + Output.Write_Str ("Processing directory """); + Output.Write_Str (Dir_Name); + Output.Write_Line (""""); + end if; - for Index in Foreign_Expressions'Range loop - if Very_Verbose then - Output.Write_Str ("Foreign pattern: """); - Output.Write_Str (Foreign_Patterns (Index).all); - Output.Write_Line (""""); - end if; + Processed_Directories. Increment_Last; + Processed_Directories.Table (Processed_Directories.Last) := + new String'(Dir_Name); - begin - Foreign_Expressions (Index) := - Compile (Pattern => Foreign_Patterns (Index).all, Glob => True); - exception - when Error_In_Regexp => - Prj.Com.Fail - ("invalid regular expression """, - Foreign_Patterns (Index).all, - """"); - end; - end loop; + -- Get the source file names from the directory. Fails if the + -- directory does not exist. - for Index in Regular_Expressions'Range loop - if Very_Verbose then - Output.Write_Str ("Pattern: """); - Output.Write_Str (Name_Patterns (Index).all); - Output.Write_Line (""""); - end if; + begin + Open (Dir, Dir_Name); + exception + when Directory_Error => + Prj.Com.Fail ("cannot open directory """, Dir_Name, """"); + end; - begin - Regular_Expressions (Index) := - Compile (Pattern => Name_Patterns (Index).all, Glob => True); + -- Process each regular file in the directory - exception - when Error_In_Regexp => - Prj.Com.Fail - ("invalid regular expression """, - Name_Patterns (Index).all, - """"); - end; - end loop; + File_Loop : loop + Read (Dir, Str, Last); + exit File_Loop when Last = 0; - if Project_File then - if Opt.Verbose_Mode then - Output.Write_Str ("Naming project file name is """); - Output.Write_Str - (Project_Naming_File_Name (1 .. Project_Naming_Last)); - Output.Write_Line (""""); - end if; + -- Copy the file name and put it in canonical case to match + -- against the patterns that have themselves already been put + -- in canonical case. - -- If there were no already existing project file, or if the parsing - -- was unsuccessful, create an empty project node with the correct - -- name and its project declaration node. + Canon (1 .. Last) := Str (1 .. Last); + Canonical_Case_File_Name (Canon (1 .. Last)); - if Project_Node = Empty_Node then - Project_Node := - Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree); - Set_Name_Of (Project_Node, Tree, To => Output_Name_Id); - Set_Project_Declaration_Of - (Project_Node, Tree, - To => Default_Project_Node - (Of_Kind => N_Project_Declaration, In_Tree => Tree)); + if Is_Regular_File + (Dir_Name & Directory_Separator & Str (1 .. Last)) + then + Matched := True; - end if; + Name_Len := Last; + Name_Buffer (1 .. Name_Len) := Str (1 .. Last); + File_Name_Id := Name_Find; - -- Create the naming project node, and add an attribute declaration - -- for Source_Files as an empty list, to indicate there are no - -- sources in the naming project. + -- First, check if the file name matches at least one of + -- the excluded expressions; - Project_Naming_Node := - Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree); - Set_Name_Of (Project_Naming_Node, Tree, To => Project_Naming_Id); - Project_Naming_Decl := - Default_Project_Node - (Of_Kind => N_Project_Declaration, In_Tree => Tree); - Set_Project_Declaration_Of - (Project_Naming_Node, Tree, Project_Naming_Decl); - Naming_Package := - Default_Project_Node - (Of_Kind => N_Package_Declaration, In_Tree => Tree); - Set_Name_Of (Naming_Package, Tree, To => Name_Naming); + for Index in Excluded_Patterns'Range loop + if + Match (Canon (1 .. Last), Excluded_Patterns (Index)) + then + Matched := Excluded; + exit; + end if; + end loop; - declare - Decl_Item : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Declarative_Item, In_Tree => Tree); + -- If it does not match any of the excluded expressions, + -- check if the file name matches at least one of the + -- regular expressions. - Attribute : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Attribute_Declaration, - In_Tree => Tree, - And_Expr_Kind => List); + if Matched = True then + Matched := False; - Expression : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Expression, - In_Tree => Tree, - And_Expr_Kind => List); + for Index in Name_Patterns'Range loop + if + Match + (Canon (1 .. Last), Name_Patterns (Index)) + then + Matched := True; + exit; + end if; + end loop; + end if; - Term : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Term, - In_Tree => Tree, - And_Expr_Kind => List); + if Very_Verbose + or else (Matched = True and then Opt.Verbose_Mode) + then + Output.Write_Str (" Checking """); + Output.Write_Str (Str (1 .. Last)); + Output.Write_Line (""": "); + end if; - Empty_List : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Literal_String_List, - In_Tree => Tree); + -- If the file name matches one of the regular expressions, + -- parse it to get its unit name. - begin - Set_First_Declarative_Item_Of - (Project_Naming_Decl, Tree, To => Decl_Item); - Set_Next_Declarative_Item (Decl_Item, Tree, Naming_Package); - Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); - Set_Name_Of (Attribute, Tree, To => Name_Source_Files); - Set_Expression_Of (Attribute, Tree, To => Expression); - Set_First_Term (Expression, Tree, To => Term); - Set_Current_Term (Term, Tree, To => Empty_List); - end; + if Matched = True then + declare + FD : File_Descriptor; + Success : Boolean; + Saved_Output : File_Descriptor; + Saved_Error : File_Descriptor; - -- Add a with clause on the naming project in the main project, if - -- there is not already one. + begin + -- If we don't have the path of the compiler yet, + -- get it now. The compiler name may have a prefix, + -- so we get the potentially prefixed name. - declare - With_Clause : Project_Node_Id := - First_With_Clause_Of (Project_Node, Tree); + if Gcc_Path = null then + declare + Prefix_Gcc : String_Access := + Program_Name (Gcc); + begin + Gcc_Path := + Locate_Exec_On_Path (Prefix_Gcc.all); + Free (Prefix_Gcc); + end; - begin - while With_Clause /= Empty_Node loop - exit when - Prj.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id; - With_Clause := Next_With_Clause_Of (With_Clause, Tree); - end loop; + if Gcc_Path = null then + Prj.Com.Fail ("could not locate " & Gcc); + end if; + end if; - if With_Clause = Empty_Node then - With_Clause := Default_Project_Node - (Of_Kind => N_With_Clause, In_Tree => Tree); - Set_Next_With_Clause_Of - (With_Clause, Tree, - To => First_With_Clause_Of (Project_Node, Tree)); - Set_First_With_Clause_Of - (Project_Node, Tree, To => With_Clause); - Set_Name_Of (With_Clause, Tree, To => Project_Naming_Id); + -- If we don't have yet the file name of the + -- temporary file, get it now. - -- We set the project node to something different than - -- Empty_Node, so that Prj.PP does not generate a limited - -- with clause. + if Temp_File_Name = null then + Create_Temp_File (FD, Temp_File_Name); - Set_Project_Node_Of (With_Clause, Tree, Non_Empty_Node); + if FD = Invalid_FD then + Prj.Com.Fail + ("could not create temporary file"); + end if; - Name_Len := Project_Naming_Last; - Name_Buffer (1 .. Name_Len) := - Project_Naming_File_Name (1 .. Project_Naming_Last); - Set_String_Value_Of (With_Clause, Tree, To => Name_Find); - end if; - end; + Close (FD); + Delete_File (Temp_File_Name.all, Success); + end if; - Project_Declaration := Project_Declaration_Of (Project_Node, Tree); + Args (Args'Last) := new String' + (Dir_Name & + Directory_Separator & + Str (1 .. Last)); - -- Add a renaming declaration for package Naming in the main project + -- Create the temporary file - declare - Decl_Item : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Declarative_Item, - In_Tree => Tree); + FD := Create_Output_Text_File + (Name => Temp_File_Name.all); - Naming : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Package_Declaration, - In_Tree => Tree); + if FD = Invalid_FD then + Prj.Com.Fail + ("could not create temporary file"); + end if; - begin - Set_Next_Declarative_Item - (Decl_Item, Tree, - To => First_Declarative_Item_Of (Project_Declaration, Tree)); - Set_First_Declarative_Item_Of - (Project_Declaration, Tree, To => Decl_Item); - Set_Current_Item_Node (Decl_Item, Tree, To => Naming); - Set_Name_Of (Naming, Tree, To => Name_Naming); - Set_Project_Of_Renamed_Package_Of - (Naming, Tree, To => Project_Naming_Node); + -- Save the standard output and error - -- Attach the comments, if any, that were saved for package - -- Naming. + Saved_Output := Dup (Standout); + Saved_Error := Dup (Standerr); - Tree.Project_Nodes.Table (Naming).Comments := - Naming_Package_Comments; - end; + -- Set standard output and error to the temporary file - -- Add an attribute declaration for Source_Dirs, initialized as an - -- empty list. Directories will be added as they are read from the - -- directory list file. + Dup2 (FD, Standout); + Dup2 (FD, Standerr); - declare - Decl_Item : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Declarative_Item, - In_Tree => Tree); + -- And spawn the compiler - Attribute : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Attribute_Declaration, - In_Tree => Tree, - And_Expr_Kind => List); + Spawn (Gcc_Path.all, Args.all, Success); - Expression : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Expression, - In_Tree => Tree, - And_Expr_Kind => List); + -- Restore the standard output and error - Term : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Term, In_Tree => Tree, - And_Expr_Kind => List); + Dup2 (Saved_Output, Standout); + Dup2 (Saved_Error, Standerr); - begin - Set_Next_Declarative_Item - (Decl_Item, Tree, - To => First_Declarative_Item_Of (Project_Declaration, Tree)); - Set_First_Declarative_Item_Of - (Project_Declaration, Tree, To => Decl_Item); - Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); - Set_Name_Of (Attribute, Tree, To => Name_Source_Dirs); - Set_Expression_Of (Attribute, Tree, To => Expression); - Set_First_Term (Expression, Tree, To => Term); - Source_Dirs_List := - Default_Project_Node - (Of_Kind => N_Literal_String_List, - In_Tree => Tree, - And_Expr_Kind => List); - Set_Current_Term (Term, Tree, To => Source_Dirs_List); + -- Close the temporary file - -- Attach the comments, if any, that were saved for attribute - -- Source_Dirs. + Close (FD); - Tree.Project_Nodes.Table (Attribute).Comments := - Source_Dirs_Comments; - end; + -- And close the saved standard output and error to + -- avoid too many file descriptors. - -- Add an attribute declaration for Source_List_File with the - -- source list file name that will be created. + Close (Saved_Output); + Close (Saved_Error); - declare - Decl_Item : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Declarative_Item, - In_Tree => Tree); + -- Now that standard output is restored, check if + -- the compiler ran correctly. - Attribute : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Attribute_Declaration, - In_Tree => Tree, - And_Expr_Kind => Single); + -- Read the lines of the temporary file: + -- they should contain the kind and name of the unit. - Expression : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Expression, - In_Tree => Tree, - And_Expr_Kind => Single); + declare + File : Text_File; + Text_Line : String (1 .. 1_000); + Text_Last : Natural; - Term : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Term, - In_Tree => Tree, - And_Expr_Kind => Single); + begin + Open (File, Temp_File_Name.all); - Value : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Literal_String, - In_Tree => Tree, - And_Expr_Kind => Single); + if not Is_Valid (File) then + Prj.Com.Fail + ("could not read temporary file"); + end if; - begin - Set_Next_Declarative_Item - (Decl_Item, Tree, - To => First_Declarative_Item_Of (Project_Declaration, Tree)); - Set_First_Declarative_Item_Of - (Project_Declaration, Tree, To => Decl_Item); - Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); - Set_Name_Of (Attribute, Tree, To => Name_Source_List_File); - Set_Expression_Of (Attribute, Tree, To => Expression); - Set_First_Term (Expression, Tree, To => Term); - Set_Current_Term (Term, Tree, To => Value); - Name_Len := Source_List_Last; - Name_Buffer (1 .. Name_Len) := - Source_List_Path (1 .. Source_List_Last); - Set_String_Value_Of (Value, Tree, To => Name_Find); + Save_Last_Source_Index := Sources.Last; - -- If there was no comments for attribute Source_List_File, put - -- those for Source_Files, if they exist. + if End_Of_File (File) then + if Opt.Verbose_Mode then + if not Success then + Output.Write_Str (" (process died) "); + end if; + end if; - if Source_List_File_Comments /= Empty_Node then - Tree.Project_Nodes.Table (Attribute).Comments := - Source_List_File_Comments; - else - Tree.Project_Nodes.Table (Attribute).Comments := - Source_Files_Comments; - end if; - end; - end if; + else + Line_Loop : while not End_Of_File (File) loop + Get_Line (File, Text_Line, Text_Last); - -- Process each directory + -- Find the first closing parenthesis - for Index in Directories'Range loop + Char_Loop : for J in 1 .. Text_Last loop + if Text_Line (J) = ')' then + if J >= 13 and then + Text_Line (1 .. 4) = "Unit" + then + -- Add entry to Sources table - declare - Dir_Name : constant String := Directories (Index).all; - Last : Natural := Dir_Name'Last; - Recursively : Boolean := False; + Name_Len := J - 12; + Name_Buffer (1 .. Name_Len) := + Text_Line (6 .. J - 7); + Current_Source := + (Unit_Name => Name_Find, + File_Name => File_Name_Id, + Index => 0, + Spec => Text_Line (J - 5 .. J) = + "(spec)"); - begin - if Dir_Name'Length >= 4 - and then (Dir_Name (Last - 2 .. Last) = "/**") - then - Last := Last - 3; - Recursively := True; - end if; + Sources.Append (Current_Source); + end if; - if Project_File then + exit Char_Loop; + end if; + end loop Char_Loop; + end loop Line_Loop; + end if; - -- Add the directory in the list for attribute Source_Dirs + if Save_Last_Source_Index = Sources.Last then + if Opt.Verbose_Mode then + Output.Write_Line (" not a unit"); + end if; - declare - Expression : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Expression, - In_Tree => Tree, - And_Expr_Kind => Single); - - Term : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Term, - In_Tree => Tree, - And_Expr_Kind => Single); - - Value : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Literal_String, - In_Tree => Tree, - And_Expr_Kind => Single); + else + if Sources.Last > + Save_Last_Source_Index + 1 + then + for Index in Save_Last_Source_Index + 1 .. + Sources.Last + loop + Sources.Table (Index).Index := + Int (Index - Save_Last_Source_Index); + end loop; + end if; - begin - if Current_Source_Dir = Empty_Node then - Set_First_Expression_In_List - (Source_Dirs_List, Tree, To => Expression); - else - Set_Next_Expression_In_List - (Current_Source_Dir, Tree, To => Expression); - end if; + for Index in Save_Last_Source_Index + 1 .. + Sources.Last + loop + Current_Source := Sources.Table (Index); - Current_Source_Dir := Expression; - Set_First_Term (Expression, Tree, To => Term); - Set_Current_Term (Term, Tree, To => Value); - Name_Len := Dir_Name'Length; - Name_Buffer (1 .. Name_Len) := Dir_Name; - Set_String_Value_Of (Value, Tree, To => Name_Find); - end; - end if; + if Opt.Verbose_Mode then + if Current_Source.Spec then + Output.Write_Str (" spec of "); - Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively); - end; + else + Output.Write_Str (" body of "); + end if; - end loop; + Output.Write_Line + (Get_Name_String + (Current_Source.Unit_Name)); + end if; + end loop; + end if; - if Project_File then - Close (Source_List_FD); - end if; + Close (File); - declare - Discard : Boolean; - pragma Warnings (Off, Discard); + Delete_File (Temp_File_Name.all, Success); + end; + end; - begin - -- Delete the file if it already exists + -- File name matches none of the regular expressions - Delete_File - (Path_Name (Directory_Last + 1 .. Path_Last), - Success => Discard); + else + -- If file is not excluded, see if this is foreign source - -- Create a new one + if Matched /= Excluded then + for Index in Foreign_Patterns'Range loop + if Match (Canon (1 .. Last), + Foreign_Patterns (Index)) + then + Matched := True; + exit; + end if; + end loop; + end if; - if Opt.Verbose_Mode then - Output.Write_Str ("Creating new file """); - Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last)); - Output.Write_Line (""""); - end if; + if Very_Verbose then + case Matched is + when False => + Output.Write_Line ("no match"); - Output_FD := Create_New_File - (Path_Name (Directory_Last + 1 .. Path_Last), - Fmode => Text); + when Excluded => + Output.Write_Line ("excluded"); - -- Fails if project file cannot be created + when True => + Output.Write_Line ("foreign source"); + end case; + end if; - if Output_FD = Invalid_FD then - Prj.Com.Fail - ("cannot create new """, Path_Name (1 .. Path_Last), """"); - end if; + if Matched = True then - if Project_File then + -- Add source file name without unit name - -- Output the project file + Name_Len := 0; + Add_Str_To_Name_Buffer (Canon (1 .. Last)); + Sources.Append + ((File_Name => Name_Find, + Unit_Name => No_Name, + Index => 0, + Spec => False)); + end if; + end if; + end if; + end loop File_Loop; - Prj.PP.Pretty_Print - (Project_Node, Tree, - W_Char => Write_A_Char'Access, - W_Eol => Write_Eol'Access, - W_Str => Write_A_String'Access, - Backward_Compatibility => False); - Close (Output_FD); + Close (Dir); + end if; - -- Delete the naming project file if it already exists + -- If Recursively is True, call itself for each subdirectory. + -- We do that, even when this directory has already been processed, + -- because all of its subdirectories may not have been processed. - Delete_File - (Project_Naming_File_Name (1 .. Project_Naming_Last), - Success => Discard); + if Recursively then + Open (Dir, Dir_Name); - -- Create a new one + loop + Read (Dir, Str, Last); + exit when Last = 0; - if Opt.Verbose_Mode then - Output.Write_Str ("Creating new naming project file """); - Output.Write_Str (Project_Naming_File_Name - (1 .. Project_Naming_Last)); - Output.Write_Line (""""); - end if; + -- Do not call itself for "." or ".." - Output_FD := Create_New_File - (Project_Naming_File_Name (1 .. Project_Naming_Last), - Fmode => Text); + if Is_Directory + (Dir_Name & Directory_Separator & Str (1 .. Last)) + and then Str (1 .. Last) /= "." + and then Str (1 .. Last) /= ".." + then + Process_Directory + (Dir_Name & Directory_Separator & Str (1 .. Last), + Recursively => True); + end if; + end loop; - -- Fails if naming project file cannot be created + Close (Dir); + end if; + end Process_Directory; - if Output_FD = Invalid_FD then - Prj.Com.Fail - ("cannot create new """, - Project_Naming_File_Name (1 .. Project_Naming_Last), - """"); - end if; + -- Start of processing for Process - -- Output the naming project file + begin + Processed_Directories.Set_Last (0); - Prj.PP.Pretty_Print - (Project_Naming_Node, Tree, - W_Char => Write_A_Char'Access, - W_Eol => Write_Eol'Access, - W_Str => Write_A_String'Access, - Backward_Compatibility => False); - Close (Output_FD); + -- Process each directory - else - -- Write to the output file each entry in the SFN_Pragmas table - -- as an pragma Source_File_Name. + for Index in Directories'Range loop - for Index in 1 .. SFN_Pragmas.Last loop - Write_A_String ("pragma Source_File_Name"); - Write_Eol; - Write_A_String (" ("); - Write_A_String - (Get_Name_String (SFN_Pragmas.Table (Index).Unit)); - Write_A_String (","); - Write_Eol; + declare + Dir_Name : constant String := Directories (Index).all; + Last : Natural := Dir_Name'Last; + Recursively : Boolean := False; + Found : Boolean; + Canonical : String (1 .. Dir_Name'Length) := Dir_Name; - if SFN_Pragmas.Table (Index).Spec then - Write_A_String (" Spec_File_Name => """); + begin + Canonical_Case_File_Name (Canonical); - else - Write_A_String (" Body_File_Name => """); + Found := False; + for J in 1 .. Source_Directories.Last loop + if Source_Directories.Table (J).all = Canonical then + Found := True; + exit; end if; + end loop; - Write_A_String - (Get_Name_String (SFN_Pragmas.Table (Index).File)); - - Write_A_String (""""); - - if SFN_Pragmas.Table (Index).Index /= 0 then - Write_A_String (", Index =>"); - Write_A_String (SFN_Pragmas.Table (Index).Index'Img); - end if; + if not Found then + Source_Directories.Append (new String'(Canonical)); + end if; - Write_A_String (");"); - Write_Eol; - end loop; + if Dir_Name'Length >= 4 + and then (Dir_Name (Last - 2 .. Last) = "/**") + then + Last := Last - 3; + Recursively := True; + end if; - Close (Output_FD); - end if; - end; + Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively); + end; - end Make; + end loop; + end Process; ---------------- -- Write_Char -- diff --git a/gcc/ada/prj-makr.ads b/gcc/ada/prj-makr.ads index 74b90f69f67..50a97e93b51 100644 --- a/gcc/ada/prj-makr.ads +++ b/gcc/ada/prj-makr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -25,44 +25,58 @@ -- Support for procedure Gnatname --- For arbitrary naming schemes, create or update a project file, --- or create a configuration pragmas file. +-- For arbitrary naming schemes, create or update a project file, or create a +-- configuration pragmas file. + +with System.Regexp; use System.Regexp; package Prj.Makr is - procedure Make + procedure Initialize (File_Path : String; Project_File : Boolean; - Directories : Argument_List; - Name_Patterns : Argument_List; - Excluded_Patterns : Argument_List; - Foreign_Patterns : Argument_List; Preproc_Switches : Argument_List; Very_Verbose : Boolean); - -- Create a project file or a configuration pragmas file + -- Start the creation of a configuration pragmas file or the creation or + -- modification of a project file, for gnatname. + -- + -- When Project_File is False, File_Path is the name of a configuration + -- pragmas file to create. When Project_File is True, File_Path is the name + -- of a project file to create if it does not exist or to modify if it + -- already exists. + -- + -- Preproc_Switches is a list of switches to be used when invoking the + -- compiler to get the name and kind of unit of a source file. + -- + -- Very_Verbose controls the verbosity of the output, in conjunction with + -- Opt.Verbose_Mode. + + type Regexp_List is array (Positive range <>) of Regexp; + + procedure Process + (Directories : Argument_List; + Name_Patterns : Regexp_List; + Excluded_Patterns : Regexp_List; + Foreign_Patterns : Regexp_List); + -- Look for source files in the specified directories, with the specified + -- patterns. + -- + -- Directories is the list of source directories where to look for sources. -- - -- Project_File is the path name of the project file. If the project - -- file already exists parse it and keep all the elements that are not - -- automatically generated. + -- Name_Patterns is a potentially empty list of file name patterns to check + -- for Ada Sources. -- - -- Directory_List_File is the path name of a text file that - -- contains on each non empty line the path names of the source - -- directories for the project file. The source directories - -- are relative to the directory of the project file. + -- Excluded_Patterns is a potentially empty list of file name patterns that + -- should not be checked for Ada or non Ada sources. -- - -- File_Name_Patterns is a GNAT.Regexp string pattern such as - -- ".*\.ads|.*\.adb" or any other pattern. + -- Foreign_Patterns is a potentially empty list of file name patterns to + -- check for non Ada sources. -- - -- A project file (without any sources) is automatically generated - -- with the name <project>_naming. It contains a package Naming with - -- all the specs and bodies for the project. - -- A file containing the source file names is automatically - -- generated and used as the Source_File_List for the project file. - -- It includes all sources that follow the Foreign_Patterns (except those - -- that follow Excluded_Patterns). + -- At least one of Name_Patterns and Foreign_Patterns is not empty - -- Preproc_switches is a list of optional preprocessor switches -gnatep= - -- and -gnateD that are used when invoking the compiler to find the - -- unit name and kind. + procedure Finalize; + -- Write the configuration pragmas file or the project file indicated in a + -- call to procedure Initialize, after one or several calls to procedure + -- Process. end Prj.Makr; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index a3e9806bf17..01cef315b7d 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -138,6 +138,9 @@ package body Prj.Nmsc is Unit : Name_Id; Next : Ada_Naming_Exception_Id := No_Ada_Naming_Exception; end record; + -- Comment needed??? + + -- Why is the following commented out ??? -- No_Unit : constant Unit_Info := -- (Specification, No_Name, No_Ada_Naming_Exception); @@ -165,6 +168,7 @@ package body Prj.Nmsc is Location : Source_Ptr := No_Location; end record; No_File_Found : constant File_Found := (No_File, False, No_Location); + -- Comments needed ??? package Excluded_Sources_Htable is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, @@ -223,6 +227,7 @@ package body Prj.Nmsc is -- Add a new source to the different lists: list of all sources in the -- project tree, list of source of a project and list of sources of a -- language. + -- -- If Path is specified, the file is also added to Source_Paths_HT. -- If Source_To_Replace is specified, it points to the source in the -- extended project that the new file is overriding. @@ -272,6 +277,13 @@ package body Prj.Nmsc is -- Check attribute Externally_Built of project Project in project tree -- In_Tree and modify its data Data if it has the value "true". + procedure Check_Interfaces + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Data : in out Project_Data); + -- If a list of sources is specified in attribute Interfaces, set + -- In_Interfaces only for the sources specified in the list. + procedure Check_Library_Attributes (Project : Project_Id; In_Tree : Project_Tree_Ref; @@ -317,10 +329,10 @@ package body Prj.Nmsc is -- efficiency to avoid system calls to recompute it. procedure Get_Path_Names_And_Record_Ada_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Data : in out Project_Data; - Current_Dir : String); + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Data : in out Project_Data; + Current_Dir : String); -- Find the path names of the source files in the Source_Names table -- in the source directories and record those that are Ada sources. @@ -356,10 +368,10 @@ package body Prj.Nmsc is -- a specified language. procedure Search_Directories - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Data : in out Project_Data; - For_All_Sources : Boolean); + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Data : in out Project_Data; + For_All_Sources : Boolean); -- Search the source directories to find the sources. -- If For_All_Sources is True, check each regular file name against the -- naming schemes of the different languages. Otherwise consider only the @@ -407,8 +419,10 @@ package body Prj.Nmsc is Kind : out Source_Kind); -- Check if the file name File_Name conforms to one of the naming -- schemes of the project. + -- -- If the file does not match one of the naming schemes, set Language -- to No_Language_Index. + -- -- Filename is the name of the file being investigated. It has been -- normalized (case-folded). File_Name is the same value. @@ -422,6 +436,7 @@ package body Prj.Nmsc is Data : in out Project_Data); -- Get the object directory, the exec directory and the source directories -- of a project. + -- -- Current_Dir should represent the current directory, and is passed for -- efficiency to avoid system calls to recompute it. @@ -448,6 +463,7 @@ package body Prj.Nmsc is Data : in out Project_Data); -- Process the Source_Files and Source_List_File attributes, and store -- the list of source files into the Source_Names htable. + -- -- Lang indicates which language is being processed when in Ada_Only mode -- (all languages are processed anyway when in Multi_Language mode). @@ -488,24 +504,26 @@ package body Prj.Nmsc is -- is True and Create is a non null string, an attempt is made to create -- the directory. If the directory does not exist and Project_Setup is -- false, then Dir and Display are set to No_Name. + -- -- Current_Dir should represent the current directory, and is passed for -- efficiency to avoid system calls to recompute it. procedure Look_For_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Data : in out Project_Data; - Current_Dir : String); + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Data : in out Project_Data; + Current_Dir : String); -- Find all the sources of project Project in project tree In_Tree and -- update its Data accordingly. + -- -- Current_Dir should represent the current directory, and is passed for -- efficiency to avoid system calls to recompute it. function Path_Name_Of (File_Name : File_Name_Type; Directory : Path_Name_Type) return String; - -- Returns the path name of a (non project) file. - -- Returns an empty string if file cannot be found. + -- Returns the path name of a (non project) file. Returns an empty string + -- if file cannot be found. procedure Prepare_Ada_Naming_Exceptions (List : Array_Element_Id; @@ -533,6 +551,7 @@ package body Prj.Nmsc is Current_Dir : String); -- Put a unit in the list of units of a project, if the file name -- corresponds to a valid unit name. + -- -- Current_Dir should represent the current directory, and is passed for -- efficiency to avoid system calls to recompute it. @@ -542,9 +561,9 @@ package body Prj.Nmsc is Data : in out Project_Data; Language : Language_Index; Naming_Exceptions : Boolean); - -- Record the sources of a language in a project. - -- When Naming_Exceptions is True, mark the found sources as such, to - -- later remove those that are not named in a list of sources. + -- Record the sources of a language in a project. When Naming_Exceptions is + -- True, mark the found sources as such, to later remove those that are not + -- named in a list of sources. procedure Remove_Source (Id : Source_Id; @@ -555,10 +574,11 @@ package body Prj.Nmsc is -- ??? needs comment procedure Report_No_Sources - (Project : Project_Id; - Lang_Name : String; - In_Tree : Project_Tree_Ref; - Location : Source_Ptr); + (Project : Project_Id; + Lang_Name : String; + In_Tree : Project_Tree_Ref; + Location : Source_Ptr; + Continuation : Boolean := False); -- Report an error or a warning depending on the value of When_No_Sources -- when there are no sources for language Lang_Name. @@ -570,8 +590,8 @@ package body Prj.Nmsc is (Language : Language_Index; Naming : Naming_Data; In_Tree : Project_Tree_Ref) return File_Name_Type; - -- Get the suffix for the source of a language from a package naming. - -- If not specified, return the default for the language. + -- Get the suffix for the source of a language from a package naming. If + -- not specified, return the default for the language. procedure Warn_If_Not_Sources (Project : Project_Id; @@ -608,6 +628,8 @@ package body Prj.Nmsc is is Source : constant Source_Id := Data.Last_Source; Src_Data : Source_Data := No_Source_Data; + Config : constant Language_Config := + In_Tree.Languages_Data.Table (Lang_Id).Config; begin -- This is a new source so create an entry for it in the Sources table @@ -639,6 +661,14 @@ package body Prj.Nmsc is Src_Data.Kind := Kind; Src_Data.Alternate_Languages := Alternate_Languages; Src_Data.Other_Part := Other_Part; + + Src_Data.Object_Exists := Config.Object_Generated; + Src_Data.Object_Linked := Config.Objects_Linked; + + if Other_Part /= No_Source then + In_Tree.Sources.Table (Other_Part).Other_Part := Id; + end if; + Src_Data.Unit := Unit; Src_Data.Index := Index; Src_Data.File := File_Name; @@ -741,8 +771,7 @@ package body Prj.Nmsc is if Data.Qualifier = Dry and then Data.Source_Dirs /= Nil_String then Error_Msg - (Project, - In_Tree, + (Project, In_Tree, "an abstract project need to have no language, no sources or no " & "source directories", Data.Location); @@ -804,6 +833,7 @@ package body Prj.Nmsc is Src_Data : Source_Data; Alt_Lang : Alternate_Language_Id; Alt_Lang_Data : Alternate_Language_Data; + Continuation : Boolean := False; begin Language := Data.First_Language_Processing; @@ -835,7 +865,9 @@ package body Prj.Nmsc is (In_Tree.Languages_Data.Table (Language).Display_Name), In_Tree, - Data.Location); + Data.Location, + Continuation); + Continuation := True; end if; Language := In_Tree.Languages_Data.Table (Language).Next; @@ -844,6 +876,14 @@ package body Prj.Nmsc is end if; end if; + if Get_Mode = Multi_Language then + + -- If a list of sources is specified in attribute Interfaces, set + -- In_Interfaces only for the sources specified in the list. + + Check_Interfaces (Project, In_Tree, Data); + end if; + -- If it is a library project file, check if it is a standalone library if Data.Library then @@ -2197,6 +2237,69 @@ package body Prj.Nmsc is (Lang_Index).Config.Runtime_Library_Dir := Element.Value.Value; + when Name_Object_Generated => + declare + pragma Unsuppress (All_Checks); + Value : Boolean; + + begin + Value := + Boolean'Value + (Get_Name_String (Element.Value.Value)); + + In_Tree.Languages_Data.Table + (Lang_Index).Config.Object_Generated := Value; + + -- If no object is generated, no object may be + -- linked. + + if not Value then + In_Tree.Languages_Data.Table + (Lang_Index).Config.Objects_Linked := False; + end if; + + exception + when Constraint_Error => + Error_Msg + (Project, + In_Tree, + "invalid value """ + & Get_Name_String (Element.Value.Value) + & """ for Object_Generated", + Element.Value.Location); + end; + + when Name_Objects_Linked => + declare + pragma Unsuppress (All_Checks); + Value : Boolean; + + begin + Value := + Boolean'Value + (Get_Name_String (Element.Value.Value)); + + -- No change if Object_Generated is False, as this + -- forces Objects_Linked to be False too. + + if In_Tree.Languages_Data.Table + (Lang_Index).Config.Object_Generated + then + In_Tree.Languages_Data.Table + (Lang_Index).Config.Objects_Linked := + Value; + end if; + + exception + when Constraint_Error => + Error_Msg + (Project, + In_Tree, + "invalid value """ + & Get_Name_String (Element.Value.Value) + & """ for Objects_Linked", + Element.Value.Location); + end; when others => null; end case; @@ -2661,6 +2764,139 @@ package body Prj.Nmsc is end if; end Check_If_Externally_Built; + ---------------------- + -- Check_Interfaces -- + ---------------------- + + procedure Check_Interfaces + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Data : in out Project_Data) + is + Interfaces : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Interfaces, + Data.Decl.Attributes, + In_Tree); + + List : String_List_Id; + Element : String_Element; + Name : File_Name_Type; + + Source : Source_Id; + Src_Data : Source_Data; + + Project_2 : Project_Id; + Data_2 : Project_Data; + + begin + if not Interfaces.Default then + + -- Set In_Interfaces to False for all sources. It will be set to True + -- later for the sources in the Interfaces list. + + Project_2 := Project; + Data_2 := Data; + loop + Source := Data_2.First_Source; + while Source /= No_Source loop + Src_Data := In_Tree.Sources.Table (Source); + Src_Data.In_Interfaces := False; + In_Tree.Sources.Table (Source) := Src_Data; + Source := Src_Data.Next_In_Project; + end loop; + + Project_2 := Data_2.Extends; + + exit when Project_2 = No_Project; + + Data_2 := In_Tree.Projects.Table (Project_2); + end loop; + + List := Interfaces.Values; + while List /= Nil_String loop + Element := In_Tree.String_Elements.Table (List); + Get_Name_String (Element.Value); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Name := Name_Find; + + Project_2 := Project; + Data_2 := Data; + Big_Loop : + loop + Source := Data_2.First_Source; + while Source /= No_Source loop + Src_Data := In_Tree.Sources.Table (Source); + if Src_Data.File = Name then + if not Src_Data.Locally_Removed then + In_Tree.Sources.Table (Source).In_Interfaces := True; + In_Tree.Sources.Table + (Source).Declared_In_Interfaces := True; + + if Src_Data.Other_Part /= No_Source then + In_Tree.Sources.Table + (Src_Data.Other_Part).In_Interfaces := True; + In_Tree.Sources.Table + (Src_Data.Other_Part).Declared_In_Interfaces := + True; + end if; + + if Current_Verbosity = High then + Write_Str (" interface: "); + Write_Line (Get_Name_String (Src_Data.Path)); + end if; + end if; + + exit Big_Loop; + end if; + + Source := Src_Data.Next_In_Project; + end loop; + + Project_2 := Data_2.Extends; + + exit Big_Loop when Project_2 = No_Project; + + Data_2 := In_Tree.Projects.Table (Project_2); + end loop Big_Loop; + + if Source = No_Source then + Error_Msg_File_1 := File_Name_Type (Element.Value); + Error_Msg_Name_1 := Data.Name; + + Error_Msg + (Project, + In_Tree, + "{ cannot be an interface of project %% " & + "as it is not one of its sources", + Element.Location); + end if; + + List := Element.Next; + end loop; + + Data.Interfaces_Defined := True; + + elsif Data.Extends /= No_Project then + Data.Interfaces_Defined := + In_Tree.Projects.Table (Data.Extends).Interfaces_Defined; + + if Data.Interfaces_Defined then + Source := Data.First_Source; + while Source /= No_Source loop + Src_Data := In_Tree.Sources.Table (Source); + + if not Src_Data.Declared_In_Interfaces then + Src_Data.In_Interfaces := False; + In_Tree.Sources.Table (Source) := Src_Data; + end if; + + Source := Src_Data.Next_In_Project; + end loop; + end if; + end if; + end Check_Interfaces; + -------------------------- -- Check_Naming_Schemes -- -------------------------- @@ -3616,17 +3852,17 @@ package body Prj.Nmsc is "library project %% cannot extend project %% " & "that is not a library project", Data.Location); + Continuation := Continuation_String'Access; - else + elsif Data.Library_Kind /= Static then Error_Msg (Project, In_Tree, Continuation.all & - "library project %% cannot import project %% " & - "that is not a library project", + "shared library project %% cannot import project %% " & + "that is not a shared library project", Data.Location); + Continuation := Continuation_String'Access; end if; - - Continuation := Continuation_String'Access; end if; elsif Data.Library_Kind /= Static and then @@ -5525,11 +5761,12 @@ package body Prj.Nmsc is if Msg (First) = '\' then First := First + 1; + end if; - -- Warning character is always the first one in this package - -- this is an undocumented kludge??? + -- Warning character is always the first one in this package + -- this is an undocumented kludge??? - elsif Msg (First) = '?' then + if Msg (First) = '?' then First := First + 1; Add ("Warning: "); @@ -7364,7 +7601,9 @@ package body Prj.Nmsc is end loop; -- In Multi_Language mode, check whether the file is - -- already there (??? Is this really needed, and why ?) + -- already there: the same file name may be in the list; if + -- the source is missing, the error will be on the first + -- mention of the source file name. case Get_Mode is when Ada_Only => @@ -7475,6 +7714,62 @@ package body Prj.Nmsc is (Project, In_Tree, Data, For_All_Sources => Sources.Default and then Source_List_File.Default); + + -- Check if all exceptions have been found. + -- For Ada, it is an error if an exception is not found. + -- For other language, the source is removed. + + declare + Source : Source_Id; + Src_Data : Source_Data; + + begin + Source := Data.First_Source; + while Source /= No_Source loop + Src_Data := In_Tree.Sources.Table (Source); + + if Src_Data.Naming_Exception + and then Src_Data.Path = No_Path + then + if Src_Data.Unit /= No_Name then + Error_Msg_Name_1 := Name_Id (Src_Data.Display_File); + Error_Msg_Name_2 := Name_Id (Src_Data.Unit); + Error_Msg + (Project, In_Tree, + "source file %% for unit %% not found", + No_Location); + + else + Remove_Source + (Source, No_Source, Project, Data, In_Tree); + end if; + end if; + + Source := Src_Data.Next_In_Project; + end loop; + end; + + -- Check that all sources in Source_Files or the file + -- Source_List_File has been found. + + declare + Name_Loc : Name_Location; + + begin + Name_Loc := Source_Names.Get_First; + while Name_Loc /= No_Name_Location loop + if (not Name_Loc.Except) and then (not Name_Loc.Found) then + Error_Msg_Name_1 := Name_Id (Name_Loc.Name); + Error_Msg + (Project, + In_Tree, + "file %% not found", + Name_Loc.Location); + end if; + + Name_Loc := Source_Names.Get_Next; + end loop; + end; end if; if Get_Mode = Ada_Only @@ -7496,12 +7791,12 @@ package body Prj.Nmsc is ------------------------------------------- procedure Get_Path_Names_And_Record_Ada_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Data : in out Project_Data; - Current_Dir : String) + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Data : in out Project_Data; + Current_Dir : String) is - Source_Dir : String_List_Id := Data.Source_Dirs; + Source_Dir : String_List_Id; Element : String_Element; Path : Path_Name_Type; Dir : Dir_Type; @@ -7515,9 +7810,10 @@ package body Prj.Nmsc is Source_Recorded : Boolean := False; begin - -- We look in all source directories for the file names in the - -- hash table Source_Names + -- We look in all source directories for the file names in the hash + -- table Source_Names. + Source_Dir := Data.Source_Dirs; while Source_Dir /= Nil_String loop Source_Recorded := False; Element := In_Tree.String_Elements.Table (Source_Dir); @@ -8042,6 +8338,7 @@ package body Prj.Nmsc is Alternate_Languages : Alternate_Language_Id := No_Alternate_Language; Language : Language_Index; Source : Source_Id; + Other_Part : Source_Id; Add_Src : Boolean; Src_Ind : Source_File_Index; Src_Data : Source_Data; @@ -8084,6 +8381,8 @@ package body Prj.Nmsc is else Name_Loc.Found := True; + Source_Names.Set (File_Name, Name_Loc); + if Name_Loc.Source = No_Source then Check_Name := True; @@ -8115,6 +8414,8 @@ package body Prj.Nmsc is end if; if Check_Name then + Other_Part := No_Source; + Check_Naming_Schemes (In_Tree => In_Tree, Data => Data, @@ -8149,11 +8450,16 @@ package body Prj.Nmsc is while Source /= No_Source loop Src_Data := In_Tree.Sources.Table (Source); - if (Unit /= No_Name - and then Src_Data.Unit = Unit - and then Src_Data.Kind = Kind) - or else (Unit = No_Name - and then Src_Data.File = File_Name) + if Unit /= No_Name + and then Src_Data.Unit = Unit + and then Src_Data.Kind /= Kind + then + Other_Part := Source; + + elsif (Unit /= No_Name + and then Src_Data.Unit = Unit + and then Src_Data.Kind = Kind) + or else (Unit = No_Name and then Src_Data.File = File_Name) then -- Duplication of file/unit in same project is only -- allowed if order of source directories is known. @@ -8165,17 +8471,13 @@ package body Prj.Nmsc is elsif Unit /= No_Name then Error_Msg_Name_1 := Unit; Error_Msg - (Project, In_Tree, - "duplicate unit %%", - No_Location); + (Project, In_Tree, "duplicate unit %%", No_Location); Add_Src := False; else Error_Msg_File_1 := File_Name; Error_Msg - (Project, In_Tree, - "duplicate source file " & - "name {", + (Project, In_Tree, "duplicate source file name {", No_Location); Add_Src := False; end if; @@ -8203,17 +8505,13 @@ package body Prj.Nmsc is Error_Msg_Name_1 := In_Tree.Projects.Table (Project).Name; Error_Msg_Name_2 := Name_Id (Display_Path_Id); Error_Msg - (Project, In_Tree, - "\ project %%, %%", - No_Location); + (Project, In_Tree, "\ project %%, %%", No_Location); Error_Msg_Name_1 := In_Tree.Projects.Table (Src_Data.Project).Name; Error_Msg_Name_2 := Name_Id (Src_Data.Display_Path); Error_Msg - (Project, In_Tree, - "\ project %%, %%", - No_Location); + (Project, In_Tree, "\ project %%, %%", No_Location); Add_Src := False; end if; @@ -8235,6 +8533,7 @@ package body Prj.Nmsc is Alternate_Languages => Alternate_Languages, File_Name => File_Name, Display_File => Display_File_Name, + Other_Part => Other_Part, Unit => Unit, Path => Path_Id, Display_Path => Display_Path_Id, @@ -8249,10 +8548,10 @@ package body Prj.Nmsc is ------------------------ procedure Search_Directories - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Data : in out Project_Data; - For_All_Sources : Boolean) + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Data : in out Project_Data; + For_All_Sources : Boolean) is Source_Dir : String_List_Id; Element : String_Element; @@ -8278,11 +8577,12 @@ package body Prj.Nmsc is declare Source_Directory : constant String := - Name_Buffer (1 .. Name_Len) & - Directory_Separator; - Dir_Last : constant Natural := - Compute_Directory_Last - (Source_Directory); + Name_Buffer (1 .. Name_Len) & + Directory_Separator; + + Dir_Last : constant Natural := + Compute_Directory_Last + (Source_Directory); begin if Current_Verbosity = High then @@ -8302,6 +8602,7 @@ package body Prj.Nmsc is -- ??? Duplicate system call here, we just did a -- a similar one. Maybe Ada.Directories would be more -- appropriate here + if Is_Regular_File (Source_Directory & Name (1 .. Last)) then @@ -8324,7 +8625,7 @@ package body Prj.Nmsc is declare FF : File_Found := - Excluded_Sources_Htable.Get (File_Name); + Excluded_Sources_Htable.Get (File_Name); begin if FF /= No_File_Found then @@ -8364,6 +8665,7 @@ package body Prj.Nmsc is when Directory_Error => null; end; + Source_Dir := Element.Next; end loop; @@ -8377,10 +8679,10 @@ package body Prj.Nmsc is ---------------------- procedure Look_For_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Data : in out Project_Data; - Current_Dir : String) + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Data : in out Project_Data; + Current_Dir : String) is procedure Remove_Locally_Removed_Files_From_Units; -- Mark all locally removed sources as such in the Units table @@ -8396,11 +8698,13 @@ package body Prj.Nmsc is --------------------------------------------- procedure Remove_Locally_Removed_Files_From_Units is - Excluded : File_Found := Excluded_Sources_Htable.Get_First; + Excluded : File_Found; OK : Boolean; Unit : Unit_Data; Extended : Project_Id; + begin + Excluded := Excluded_Sources_Htable.Get_First; while Excluded /= No_File_Found loop OK := False; @@ -8513,9 +8817,9 @@ package body Prj.Nmsc is File_Id := Name_Find; end if; - -- Put each naming exception in the Source_Names - -- hash table, but if there are repetition, don't - -- bother after the first instance. + -- Put each naming exception in the Source_Names hash + -- table, but if there are repetition, don't bother + -- after the first instance. if Source_Names.Get (File_Id) = No_Name_Location then Source_Found := True; @@ -8564,17 +8868,18 @@ package body Prj.Nmsc is -------------------------------------------- procedure Process_Sources_In_Multi_Language_Mode is - Source : Source_Id := Data.First_Source; - Src_Data : Source_Data; - Name_Loc : Name_Location; - OK : Boolean; - FF : File_Found; + Source : Source_Id; + Src_Data : Source_Data; + Name_Loc : Name_Location; + OK : Boolean; + FF : File_Found; + begin - -- First, put all the naming exceptions, if any, in the Source_Names - -- table. + -- First, put all naming exceptions if any, in the Source_Names table Unit_Exceptions.Reset; + Source := Data.First_Source; while Source /= No_Source loop Src_Data := In_Tree.Sources.Table (Source); @@ -8585,8 +8890,7 @@ package body Prj.Nmsc is then Error_Msg_File_1 := Src_Data.File; Error_Msg - (Project, - In_Tree, + (Project, In_Tree, "{ cannot be both excluded and an exception file name", No_Location); end if; @@ -8612,7 +8916,7 @@ package body Prj.Nmsc is if Src_Data.Unit /= No_Name then declare Unit_Except : Unit_Exception := - Unit_Exceptions.Get (Src_Data.Unit); + Unit_Exceptions.Get (Src_Data.Unit); begin Unit_Except.Name := Src_Data.Unit; @@ -8634,7 +8938,6 @@ package body Prj.Nmsc is (Ada_Language_Index, Current_Dir, Project, In_Tree, Data); FF := Excluded_Sources_Htable.Get_First; - while FF /= No_File_Found loop OK := False; Source := In_Tree.First_Source; @@ -8644,13 +8947,14 @@ package body Prj.Nmsc is if Src_Data.File = FF.File then - -- Check that this is from this project or a - -- project that the current project extends. + -- Check that this is from this project or a project that + -- the current project extends. if Src_Data.Project = Project or else Is_Extending (Project, Src_Data.Project, In_Tree) then Src_Data.Locally_Removed := True; + Src_Data.In_Interfaces := False; In_Tree.Sources.Table (Source) := Src_Data; Add_Forbidden_File_Name (FF.File); OK := True; @@ -8772,6 +9076,7 @@ package body Prj.Nmsc is In_Tree : Project_Tree_Ref) return Boolean is Current : Project_Id := Extending; + begin loop if Current = No_Project then @@ -8830,11 +9135,11 @@ package body Prj.Nmsc is declare Canonical_Path : constant String := - Normalize_Pathname - (Get_Name_String (Path_Name), - Directory => Current_Dir, - Resolve_Links => Opt.Follow_Links_For_Files, - Case_Sensitive => False); + Normalize_Pathname + (Get_Name_String (Path_Name), + Directory => Current_Dir, + Resolve_Links => Opt.Follow_Links_For_Files, + Case_Sensitive => False); begin Name_Len := 0; Add_Str_To_Name_Buffer (Canonical_Path); @@ -8854,8 +9159,8 @@ package body Prj.Nmsc is Unit_Kind => Unit_Kind, Needs_Pragma => Needs_Pragma); - if Exception_Id = No_Ada_Naming_Exception and then - Unit_Name = No_Name + if Exception_Id = No_Ada_Naming_Exception + and then Unit_Name = No_Name then if Current_Verbosity = High then Write_Str (" """); @@ -8902,31 +9207,27 @@ package body Prj.Nmsc is -- Put the file name in the list of sources of the project - String_Element_Table.Increment_Last - (In_Tree.String_Elements); + String_Element_Table.Increment_Last (In_Tree.String_Elements); In_Tree.String_Elements.Table - (String_Element_Table.Last - (In_Tree.String_Elements)) := - (Value => Name_Id (Canonical_File_Name), - Display_Value => Name_Id (File_Name), - Location => No_Location, - Flag => False, - Next => Nil_String, - Index => Unit_Ind); + (String_Element_Table.Last (In_Tree.String_Elements)) := + (Value => Name_Id (Canonical_File_Name), + Display_Value => Name_Id (File_Name), + Location => No_Location, + Flag => False, + Next => Nil_String, + Index => Unit_Ind); if Current_Source = Nil_String then - Data.Ada_Sources := String_Element_Table.Last - (In_Tree.String_Elements); + Data.Ada_Sources := + String_Element_Table.Last (In_Tree.String_Elements); Data.Sources := Data.Ada_Sources; else - In_Tree.String_Elements.Table - (Current_Source).Next := - String_Element_Table.Last - (In_Tree.String_Elements); + In_Tree.String_Elements.Table (Current_Source).Next := + String_Element_Table.Last (In_Tree.String_Elements); end if; - Current_Source := String_Element_Table.Last - (In_Tree.String_Elements); + Current_Source := + String_Element_Table.Last (In_Tree.String_Elements); -- Put the unit in unit list @@ -8951,9 +9252,9 @@ package body Prj.Nmsc is The_Unit_Data := In_Tree.Units.Table (The_Unit); if (The_Unit_Data.File_Names (Unit_Kind).Name = - Canonical_File_Name - and then - The_Unit_Data.File_Names (Unit_Kind).Path = Slash) + Canonical_File_Name + and then + The_Unit_Data.File_Names (Unit_Kind).Path = Slash) or else The_Unit_Data.File_Names (Unit_Kind).Name = No_File or else Project_Extends (Data.Extends, @@ -8981,21 +9282,21 @@ package body Prj.Nmsc is Display_Path => Path_Name, Project => Project, Needs_Pragma => Needs_Pragma); - In_Tree.Units.Table (The_Unit) := - The_Unit_Data; + In_Tree.Units.Table (The_Unit) := The_Unit_Data; Source_Recorded := True; elsif The_Unit_Data.File_Names (Unit_Kind).Project = Project - and then (Data.Known_Order_Of_Source_Dirs or else - The_Unit_Data.File_Names (Unit_Kind).Path = - Canonical_Path_Name) + and then (Data.Known_Order_Of_Source_Dirs + or else + The_Unit_Data.File_Names (Unit_Kind).Path = + Canonical_Path_Name) then if Previous_Source = Nil_String then Data.Ada_Sources := Nil_String; Data.Sources := Nil_String; else - In_Tree.String_Elements.Table - (Previous_Source).Next := Nil_String; + In_Tree.String_Elements.Table (Previous_Source).Next := + Nil_String; String_Element_Table.Decrement_Last (In_Tree.String_Elements); end if; @@ -9008,8 +9309,7 @@ package body Prj.Nmsc is if The_Location = No_Location then The_Location := - In_Tree.Projects.Table - (Project).Location; + In_Tree.Projects.Table (Project).Location; end if; Err_Vars.Error_Msg_Name_1 := Unit_Name; @@ -9039,20 +9339,18 @@ package body Prj.Nmsc is else -- First, check if there is no other unit with this file - -- name in another project. If it is, report an error. - -- Of course, we do that only for the first unit in the - -- source file. + -- name in another project. If it is, report error but note + -- we do that only for the first unit in the source file. - Unit_Prj := Files_Htable.Get - (In_Tree.Files_HT, Canonical_File_Name); + Unit_Prj := + Files_Htable.Get (In_Tree.Files_HT, Canonical_File_Name); if not File_Name_Recorded and then Unit_Prj /= No_Unit_Project then Error_Msg_File_1 := File_Name; Error_Msg_Name_1 := - In_Tree.Projects.Table - (Unit_Prj.Project).Name; + In_Tree.Projects.Table (Unit_Prj.Project).Name; Error_Msg (Project, In_Tree, "{ is already a source of project %%", @@ -9077,8 +9375,7 @@ package body Prj.Nmsc is Display_Path => Path_Name, Project => Project, Needs_Pragma => Needs_Pragma); - In_Tree.Units.Table (The_Unit) := - The_Unit_Data; + In_Tree.Units.Table (The_Unit) := The_Unit_Data; Source_Recorded := True; end if; end if; @@ -9129,7 +9426,6 @@ package body Prj.Nmsc is if Naming_Exceptions then Write_Str ("naming exceptions"); - else Write_Str ("sources"); end if; @@ -9205,15 +9501,13 @@ package body Prj.Nmsc is if First_Error then Error_Msg - (Project, In_Tree, - "source file { cannot be found", + (Project, In_Tree, "source file { cannot be found", NL.Location); First_Error := False; else Error_Msg - (Project, In_Tree, - "\source file { cannot be found", + (Project, In_Tree, "\source file { cannot be found", NL.Location); end if; end if; @@ -9225,11 +9519,13 @@ package body Prj.Nmsc is -- of sources must be removed. declare - Source_Id : Other_Source_Id := Data.First_Other_Source; - Prev_Id : Other_Source_Id := No_Other_Source; + Source_Id : Other_Source_Id; + Prev_Id : Other_Source_Id; Source : Other_Source; begin + Prev_Id := No_Other_Source; + Source_Id := Data.First_Other_Source; while Source_Id /= No_Other_Source loop Source := In_Tree.Other_Sources.Table (Source_Id); @@ -9245,10 +9541,8 @@ package body Prj.Nmsc is if Prev_Id = No_Other_Source then Data.First_Other_Source := Source.Next; - else - In_Tree.Other_Sources.Table - (Prev_Id).Next := Source.Next; + In_Tree.Other_Sources.Table (Prev_Id).Next := Source.Next; end if; Source_Id := Source.Next; @@ -9278,7 +9572,6 @@ package body Prj.Nmsc is In_Tree : Project_Tree_Ref) is Src_Data : constant Source_Data := In_Tree.Sources.Table (Id); - Source : Source_Id; begin @@ -9287,7 +9580,11 @@ package body Prj.Nmsc is Write_Line (Id'Img); end if; - In_Tree.Sources.Table (Id).Replaced_By := Replaced_By; + if Replaced_By /= No_Source then + In_Tree.Sources.Table (Id).Replaced_By := Replaced_By; + In_Tree.Sources.Table (Replaced_By).Declared_In_Interfaces := + In_Tree.Sources.Table (Id).Declared_In_Interfaces; + end if; -- Remove the source from the global source list @@ -9379,10 +9676,11 @@ package body Prj.Nmsc is ----------------------- procedure Report_No_Sources - (Project : Project_Id; - Lang_Name : String; - In_Tree : Project_Tree_Ref; - Location : Source_Ptr) + (Project : Project_Id; + Lang_Name : String; + In_Tree : Project_Tree_Ref; + Location : Source_Ptr; + Continuation : Boolean := False) is begin case When_No_Sources is @@ -9390,11 +9688,24 @@ package body Prj.Nmsc is null; when Warning | Error => - Error_Msg_Warn := When_No_Sources = Warning; - Error_Msg - (Project, In_Tree, - "<there are no " & Lang_Name & " sources in this project", - Location); + declare + Msg : constant String := + "<there are no " & + Lang_Name & + " sources in this project"; + + begin + Error_Msg_Warn := When_No_Sources = Warning; + + if Continuation then + Error_Msg + (Project, In_Tree, "\" & Msg, Location); + + else + Error_Msg + (Project, In_Tree, Msg, Location); + end if; + end; end case; end Report_No_Sources; @@ -9438,6 +9749,7 @@ package body Prj.Nmsc is Src_Index => 0, In_Array => Naming.Body_Suffix, In_Tree => In_Tree); + begin -- If no suffix for this language in package Naming, use the default @@ -9481,29 +9793,25 @@ package body Prj.Nmsc is Specs : Boolean; Extending : Boolean) is - Conv : Array_Element_Id := Conventions; + Conv : Array_Element_Id; Unit : Name_Id; The_Unit_Id : Unit_Index; The_Unit_Data : Unit_Data; Location : Source_Ptr; begin + Conv := Conventions; while Conv /= No_Array_Element loop Unit := In_Tree.Array_Elements.Table (Conv).Index; Error_Msg_Name_1 := Unit; Get_Name_String (Unit); To_Lower (Name_Buffer (1 .. Name_Len)); Unit := Name_Find; - The_Unit_Id := Units_Htable.Get - (In_Tree.Units_HT, Unit); - Location := In_Tree.Array_Elements.Table - (Conv).Value.Location; + The_Unit_Id := Units_Htable.Get (In_Tree.Units_HT, Unit); + Location := In_Tree.Array_Elements.Table (Conv).Value.Location; if The_Unit_Id = No_Unit_Index then - Error_Msg - (Project, In_Tree, - "?unknown unit %%", - Location); + Error_Msg (Project, In_Tree, "?unknown unit %%", Location); else The_Unit_Data := In_Tree.Units.Table (The_Unit_Id); diff --git a/gcc/ada/prj-pars.adb b/gcc/ada/prj-pars.adb index fb277b4bc0f..0cdd9ad3604 100644 --- a/gcc/ada/prj-pars.adb +++ b/gcc/ada/prj-pars.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2008, 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- -- @@ -70,7 +70,7 @@ package body Prj.Pars is -- If there were no error, process the tree - if Project_Node /= Empty_Node then + if Present (Project_Node) then Prj.Proc.Process (In_Tree => In_Tree, Project => The_Project, diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 00f3c32ba3c..ab9208f9e94 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -333,7 +333,8 @@ package body Prj.Part is E => (Name => Virtual_Name_Id, Node => Virtual_Project, Canonical_Path => No_Path, - Extended => False)); + Extended => False, + Proj_Qualifier => Unspecified)); end Create_Virtual_Extending_Project; ---------------------------- @@ -396,21 +397,21 @@ package body Prj.Part is -- Nothing to do if Proj is not defined or if it has already been -- processed. - if Proj /= Empty_Node and then not Processed_Hash.Get (Proj) then + if Present (Proj) and then not Processed_Hash.Get (Proj) then -- Make sure the project will not be processed again Processed_Hash.Set (Proj, True); Declaration := Project_Declaration_Of (Proj, In_Tree); - if Declaration /= Empty_Node then + if Present (Declaration) then Extended := Extended_Project_Of (Declaration, In_Tree); end if; -- If this is a project that may need a virtual extending project -- and it is not itself an extending project, put it in the list. - if Potentially_Virtual and then Extended = Empty_Node then + if Potentially_Virtual and then No (Extended) then Virtual_Hash.Set (Proj, Proj); end if; @@ -418,10 +419,10 @@ package body Prj.Part is With_Clause := First_With_Clause_Of (Proj, In_Tree); - while With_Clause /= Empty_Node loop + while Present (With_Clause) loop Imported := Project_Node_Of (With_Clause, In_Tree); - if Imported /= Empty_Node then + if Present (Imported) then Look_For_Virtual_Projects_For (Imported, In_Tree, Potentially_Virtual => True); end if; @@ -512,7 +513,7 @@ package body Prj.Part is -- virtual extending projects and check that there are no illegally -- imported projects. - if Project /= Empty_Node + if Present (Project) and then Is_Extending_All (Project, In_Tree) then -- First look for projects that potentially need a virtual @@ -549,10 +550,10 @@ package body Prj.Part is begin With_Clause := First_With_Clause_Of (Project, In_Tree); - while With_Clause /= Empty_Node loop + while Present (With_Clause) loop Imported := Project_Node_Of (With_Clause, In_Tree); - if Imported /= Empty_Node then + if Present (Imported) then Declaration := Project_Declaration_Of (Imported, In_Tree); if Extended_Project_Of (Declaration, In_Tree) /= @@ -561,7 +562,7 @@ package body Prj.Part is loop Imported := Extended_Project_Of (Declaration, In_Tree); - exit when Imported = Empty_Node; + exit when No (Imported); Virtual_Hash.Remove (Imported); Declaration := Project_Declaration_Of (Imported, In_Tree); @@ -578,7 +579,7 @@ package body Prj.Part is declare Proj : Project_Node_Id := Virtual_Hash.Get_First; begin - while Proj /= Empty_Node loop + while Present (Proj) loop Create_Virtual_Extending_Project (Proj, Project, In_Tree); Proj := Virtual_Hash.Get_Next; end loop; @@ -592,7 +593,7 @@ package body Prj.Part is Project := Empty_Node; end if; - if Project = Empty_Node or else Always_Errout_Finalize then + if No (Project) or else Always_Errout_Finalize then Prj.Err.Finalize; end if; end; @@ -738,9 +739,9 @@ package body Prj.Part is -- Set Current_Project to the last project in the current list, if the -- list is not empty. - if Current_Project /= Empty_Node then + if Present (Current_Project) then while - Next_With_Clause_Of (Current_Project, In_Tree) /= Empty_Node + Present (Next_With_Clause_Of (Current_Project, In_Tree)) loop Current_Project := Next_With_Clause_Of (Current_Project, In_Tree); end loop; @@ -797,7 +798,7 @@ package body Prj.Part is Previous_Project := Current_Project; - if Current_Project = Empty_Node then + if No (Current_Project) then -- First with clause of the context clause @@ -848,7 +849,7 @@ package body Prj.Part is -- Parse the imported project, if its project id is unknown - if Withed_Project = Empty_Node then + if No (Withed_Project) then Parse_Single_Project (In_Tree => In_Tree, Project => Withed_Project, @@ -865,13 +866,13 @@ package body Prj.Part is Extends_All := Is_Extending_All (Withed_Project, In_Tree); end if; - if Withed_Project = Empty_Node then + if No (Withed_Project) then -- If parsing unsuccessful, remove the context clause Current_Project := Previous_Project; - if Current_Project = Empty_Node then + if No (Current_Project) then Imported_Projects := Empty_Node; else @@ -936,8 +937,11 @@ package body Prj.Part is Tree_Private_Part.Projects_Htable.Get_First (In_Tree.Projects_HT); - Name_From_Path : constant Name_Id := Project_Name_From (Path_Name); - Name_Of_Project : Name_Id := No_Name; + Name_From_Path : constant Name_Id := Project_Name_From (Path_Name); + Name_Of_Project : Name_Id := No_Name; + + Duplicated : Boolean := False; + First_With : With_Id; Imported_Projects : Project_Node_Id := Empty_Node; @@ -1021,9 +1025,11 @@ package body Prj.Part is if Extended then if A_Project_Name_And_Node.Extended then - Error_Msg - ("cannot extend the same project file several times", - Token_Ptr); + if A_Project_Name_And_Node.Proj_Qualifier /= Dry then + Error_Msg + ("cannot extend the same project file several times", + Token_Ptr); + end if; else Error_Msg ("cannot extend an already imported project file", @@ -1092,7 +1098,7 @@ package body Prj.Part is Tree.Reset_State; Scan (In_Tree); - if (not In_Configuration) and then (Name_From_Path = No_Name) then + if not In_Configuration and then Name_From_Path = No_Name then -- The project file name is not correct (no or bad extension, or not -- following Ada identifier's syntax). @@ -1122,7 +1128,6 @@ package body Prj.Part is Project_Stack.Table (Project_Stack.Last).Id := Project; Set_Directory_Of (Project, In_Tree, Project_Directory); Set_Path_Name_Of (Project, In_Tree, Normed_Path_Name); - Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects); -- Check if there is a qualifier before the reserved word "project" @@ -1279,7 +1284,7 @@ package body Prj.Part is begin -- Output a warning if the actual name is not the expected name - if (not In_Configuration) + if not In_Configuration and then (Name_From_Path /= No_Name) and then Expected_Name /= Name_From_Path then @@ -1350,6 +1355,7 @@ package body Prj.Part is -- Report an error if we already have a project with this name if Project_Name /= No_Name then + Duplicated := True; Error_Msg_Name_1 := Project_Name; Error_Msg ("duplicate project name %%", @@ -1358,19 +1364,6 @@ package body Prj.Part is Name_Id (Path_Name_Of (Name_And_Node.Node, In_Tree)); Error_Msg ("\already in %%", Location_Of (Project, In_Tree)); - - else - -- Otherwise, add the name of the project to the hash table, - -- so that we can check that no other subsequent project - -- will have the same name. - - Tree_Private_Part.Projects_Htable.Set - (T => In_Tree.Projects_HT, - K => Name_Of_Project, - E => (Name => Name_Of_Project, - Node => Project, - Canonical_Path => Canonical_Path_Name, - Extended => Extended)); end if; end; end if; @@ -1444,13 +1437,28 @@ package body Prj.Part is Current_Dir => Current_Dir); end; - -- A project that extends an extending-all project is also - -- an extending-all project. + if Present (Extended_Project) then + + -- A project that extends an extending-all project is + -- also an extending-all project. + + if Is_Extending_All (Extended_Project, In_Tree) then + Set_Is_Extending_All (Project, In_Tree); + end if; + + -- An abstract project can only extend an abstract + -- project, otherwise we may have an abstract project + -- with sources, if it inherits sources from the project + -- it extends. - if Extended_Project /= Empty_Node - and then Is_Extending_All (Extended_Project, In_Tree) - then - Set_Is_Extending_All (Project, In_Tree); + if Proj_Qualifier = Dry and then + Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry + then + Error_Msg + ("an abstract project can only extend " & + "another abstract project", + Qualifier_Location); + end if; end if; end if; end; @@ -1470,7 +1478,7 @@ package body Prj.Part is begin With_Clause_Loop : - while With_Clause /= Empty_Node loop + while Present (With_Clause) loop Imported := Project_Node_Of (With_Clause, In_Tree); if Is_Extending_All (With_Clause, In_Tree) then @@ -1510,13 +1518,15 @@ package body Prj.Part is declare Parent_Name : constant Name_Id := Name_Find; Parent_Found : Boolean := False; + Parent_Node : Project_Node_Id := Empty_Node; With_Clause : Project_Node_Id := First_With_Clause_Of (Project, In_Tree); begin -- If there is an extended project, check its name - if Extended_Project /= Empty_Node then + if Present (Extended_Project) then + Parent_Node := Extended_Project; Parent_Found := Name_Of (Extended_Project, In_Tree) = Parent_Name; end if; @@ -1524,16 +1534,18 @@ package body Prj.Part is -- If the parent project is not the extended project, -- check each imported project until we find the parent project. - while not Parent_Found and then With_Clause /= Empty_Node loop - Parent_Found := - Name_Of (Project_Node_Of (With_Clause, In_Tree), In_Tree) = - Parent_Name; + while not Parent_Found and then Present (With_Clause) loop + Parent_Node := Project_Node_Of (With_Clause, In_Tree); + Parent_Found := Name_Of (Parent_Node, In_Tree) = Parent_Name; With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop; - -- If the parent project was not found, report an error + if Parent_Found then + Set_Parent_Project_Of (Project, In_Tree, To => Parent_Node); + + else + -- If the parent project was not found, report an error - if not Parent_Found then Error_Msg_Name_1 := Name_Of_Project; Error_Msg_Name_2 := Parent_Name; Error_Msg ("project %% does not import or extend project %%", @@ -1561,7 +1573,9 @@ package body Prj.Part is Packages_To_Check => Packages_To_Check); Set_Project_Declaration_Of (Project, In_Tree, Project_Declaration); - if Extended_Project /= Empty_Node then + if Present (Extended_Project) + and then Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry + then Set_Extending_Project_Of (Project_Declaration_Of (Extended_Project, In_Tree), In_Tree, To => Project); @@ -1636,6 +1650,21 @@ package body Prj.Part is end if; end if; + if not Duplicated and then Name_Of_Project /= No_Name then + + -- Add the name of the project to the hash table, so that we can + -- check that no other subsequent project will have the same name. + + Tree_Private_Part.Projects_Htable.Set + (T => In_Tree.Projects_HT, + K => Name_Of_Project, + E => (Name => Name_Of_Project, + Node => Project, + Canonical_Path => Canonical_Path_Name, + Extended => Extended, + Proj_Qualifier => Proj_Qualifier)); + end if; + declare From_Ext : Extension_Origin := None; @@ -1723,19 +1752,19 @@ package body Prj.Part is -- If we have a dot, check that it is followed by the correct extension if First > 0 and then Canonical (First) = '.' then - if ((not In_Configuration) and then - Canonical (First .. Last) = Project_File_Extension and then - First /= 1) - or else - (In_Configuration and then - Canonical (First .. Last) = Config_Project_File_Extension and then - First /= 1) + if (not In_Configuration + and then Canonical (First .. Last) = Project_File_Extension + and then First /= 1) + or else + (In_Configuration + and then + Canonical (First .. Last) = Config_Project_File_Extension + and then First /= 1) then -- Look for the last directory separator, if any First := First - 1; Last := First; - while First > 0 and then Canonical (First) /= '/' and then Canonical (First) /= Dir_Sep diff --git a/gcc/ada/prj-pp.adb b/gcc/ada/prj-pp.adb index db2a655748f..717a769c531 100644 --- a/gcc/ada/prj-pp.adb +++ b/gcc/ada/prj-pp.adb @@ -319,13 +319,13 @@ package body Prj.PP is procedure Print (Node : Project_Node_Id; Indent : Natural) is begin - if Node /= Empty_Node then + if Present (Node) then case Kind_Of (Node, In_Tree) is when N_Project => pragma Debug (Indicate_Tested (N_Project)); - if First_With_Clause_Of (Node, In_Tree) /= Empty_Node then + if Present (First_With_Clause_Of (Node, In_Tree)) then -- with clause(s) @@ -424,7 +424,7 @@ package body Prj.PP is pragma Debug (Indicate_Tested (N_Project_Declaration)); if - First_Declarative_Item_Of (Node, In_Tree) /= Empty_Node + Present (First_Declarative_Item_Of (Node, In_Tree)) then Print (First_Declarative_Item_Of (Node, In_Tree), @@ -498,12 +498,12 @@ package body Prj.PP is First_Literal_String (Node, In_Tree); begin - while String_Node /= Empty_Node loop + while Present (String_Node) loop Output_String (String_Value_Of (String_Node, In_Tree)); String_Node := Next_Literal_String (String_Node, In_Tree); - if String_Node /= Empty_Node then + if Present (String_Node) then Write_String (", "); end if; end loop; @@ -543,7 +543,44 @@ package body Prj.PP is end if; Write_String (" use "); - Print (Expression_Of (Node, In_Tree), Indent); + + if Present (Expression_Of (Node, In_Tree)) then + Print (Expression_Of (Node, In_Tree), Indent); + + else + -- Full associative array declaration + + if + Present (Associative_Project_Of (Node, In_Tree)) + then + Output_Name + (Name_Of + (Associative_Project_Of (Node, In_Tree), + In_Tree)); + + if + Present (Associative_Package_Of (Node, In_Tree)) + then + Write_String ("."); + Output_Name + (Name_Of + (Associative_Package_Of (Node, In_Tree), + In_Tree)); + end if; + + elsif + Present (Associative_Package_Of (Node, In_Tree)) + then + Output_Name + (Name_Of + (Associative_Package_Of (Node, In_Tree), + In_Tree)); + end if; + + Write_String ("'"); + Output_Attribute_Name (Name_Of (Node, In_Tree)); + end if; + Write_String (";"); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent); @@ -580,11 +617,11 @@ package body Prj.PP is Term : Project_Node_Id := First_Term (Node, In_Tree); begin - while Term /= Empty_Node loop + while Present (Term) loop Print (Term, Indent); Term := Next_Term (Term, In_Tree); - if Term /= Empty_Node then + if Present (Term) then Write_String (" & "); end if; end loop; @@ -603,12 +640,12 @@ package body Prj.PP is First_Expression_In_List (Node, In_Tree); begin - while Expression /= Empty_Node loop + while Present (Expression) loop Print (Expression, Indent); Expression := Next_Expression_In_List (Expression, In_Tree); - if Expression /= Empty_Node then + if Present (Expression) then Write_String (", "); end if; end loop; @@ -618,13 +655,13 @@ package body Prj.PP is when N_Variable_Reference => pragma Debug (Indicate_Tested (N_Variable_Reference)); - if Project_Node_Of (Node, In_Tree) /= Empty_Node then + if Present (Project_Node_Of (Node, In_Tree)) then Output_Name (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree)); Write_String ("."); end if; - if Package_Node_Of (Node, In_Tree) /= Empty_Node then + if Present (Package_Node_Of (Node, In_Tree)) then Output_Name (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree)); Write_String ("."); @@ -637,7 +674,7 @@ package body Prj.PP is Write_String ("external ("); Print (External_Reference_Of (Node, In_Tree), Indent); - if External_Default_Of (Node, In_Tree) /= Empty_Node then + if Present (External_Default_Of (Node, In_Tree)) then Write_String (", "); Print (External_Default_Of (Node, In_Tree), Indent); end if; @@ -647,19 +684,19 @@ package body Prj.PP is when N_Attribute_Reference => pragma Debug (Indicate_Tested (N_Attribute_Reference)); - if Project_Node_Of (Node, In_Tree) /= Empty_Node + if Present (Project_Node_Of (Node, In_Tree)) and then Project_Node_Of (Node, In_Tree) /= Project then Output_Name (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree)); - if Package_Node_Of (Node, In_Tree) /= Empty_Node then + if Present (Package_Node_Of (Node, In_Tree)) then Write_String ("."); Output_Name (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree)); end if; - elsif Package_Node_Of (Node, In_Tree) /= Empty_Node then + elsif Present (Package_Node_Of (Node, In_Tree)) then Output_Name (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree)); @@ -691,10 +728,10 @@ package body Prj.PP is begin Case_Item := First_Case_Item_Of (Node, In_Tree); - while Case_Item /= Empty_Node loop - if First_Declarative_Item_Of (Case_Item, In_Tree) /= - Empty_Node - or else not Eliminate_Empty_Case_Constructions + while Present (Case_Item) loop + if Present + (First_Declarative_Item_Of (Case_Item, In_Tree)) + or else not Eliminate_Empty_Case_Constructions then Is_Non_Empty := True; exit; @@ -721,7 +758,7 @@ package body Prj.PP is Case_Item : Project_Node_Id := First_Case_Item_Of (Node, In_Tree); begin - while Case_Item /= Empty_Node loop + while Present (Case_Item) loop pragma Assert (Kind_Of (Case_Item, In_Tree) = N_Case_Item); Print (Case_Item, Indent + Increment); @@ -742,7 +779,7 @@ package body Prj.PP is when N_Case_Item => pragma Debug (Indicate_Tested (N_Case_Item)); - if First_Declarative_Item_Of (Node, In_Tree) /= Empty_Node + if Present (First_Declarative_Item_Of (Node, In_Tree)) or else not Eliminate_Empty_Case_Constructions then Write_Empty_Line; @@ -750,7 +787,7 @@ package body Prj.PP is Start_Line (Indent); Write_String ("when "); - if First_Choice_Of (Node, In_Tree) = Empty_Node then + if No (First_Choice_Of (Node, In_Tree)) then Write_String ("others"); else @@ -758,11 +795,11 @@ package body Prj.PP is Label : Project_Node_Id := First_Choice_Of (Node, In_Tree); begin - while Label /= Empty_Node loop + while Present (Label) loop Print (Label, Indent); Label := Next_Literal_String (Label, In_Tree); - if Label /= Empty_Node then + if Present (Label) then Write_String (" | "); end if; end loop; @@ -779,7 +816,7 @@ package body Prj.PP is First : constant Project_Node_Id := First_Declarative_Item_Of (Node, In_Tree); begin - if First = Empty_Node then + if No (First) then Write_Empty_Line; else Print (First, Indent + Increment); diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 638bf18ca48..13f1d947804 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -463,7 +463,7 @@ package body Prj.Proc is -- Process each term of the expression, starting with First_Term - while The_Term /= Empty_Node loop + while Present (The_Term) loop The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree); case Kind_Of (The_Current_Term, From_Project_Node_Tree) is @@ -535,7 +535,7 @@ package body Prj.Proc is Value : Variable_Value; begin - if String_Node /= Empty_Node then + if Present (String_Node) then -- If String_Node is nil, it is an empty list, -- there is nothing to do @@ -586,7 +586,7 @@ package body Prj.Proc is Next_Expression_In_List (String_Node, From_Project_Node_Tree); - exit when String_Node = Empty_Node; + exit when No (String_Node); Value := Expression @@ -637,7 +637,7 @@ package body Prj.Proc is Index : Name_Id := No_Name; begin - if Term_Project /= Empty_Node and then + if Present (Term_Project) and then Term_Project /= From_Project_Node then -- This variable or attribute comes from another project @@ -650,7 +650,7 @@ package body Prj.Proc is With_Name => The_Name); end if; - if Term_Package /= Empty_Node then + if Present (Term_Package) then -- This is an attribute of a package @@ -1003,11 +1003,11 @@ package body Prj.Proc is -- If there is a default value for the external reference, -- get its value. - if Default_Node /= Empty_Node then + if Present (Default_Node) then Def_Var := Expression (Project => Project, In_Tree => In_Tree, - From_Project_Node => Default_Node, + From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, Pkg => Pkg, First_Term => @@ -1252,7 +1252,7 @@ package body Prj.Proc is Current_Item := Empty_Node; Current_Declarative_Item := Item; - while Current_Declarative_Item /= Empty_Node loop + while Present (Current_Declarative_Item) loop -- Get its data @@ -1314,7 +1314,7 @@ package body Prj.Proc is In_Tree.Packages.Table (New_Pkg) := The_New_Package; - if Project_Of_Renamed_Package /= Empty_Node then + if Present (Project_Of_Renamed_Package) then -- Renamed package @@ -1472,9 +1472,9 @@ package body Prj.Proc is if Pkg /= No_Package then In_Tree.Arrays.Table (New_Array) := - (Name => Current_Item_Name, - Value => No_Array_Element, - Next => + (Name => Current_Item_Name, + Value => No_Array_Element, + Next => In_Tree.Packages.Table (Pkg).Decl.Arrays); In_Tree.Packages.Table (Pkg).Decl.Arrays := @@ -1482,9 +1482,9 @@ package body Prj.Proc is else In_Tree.Arrays.Table (New_Array) := - (Name => Current_Item_Name, - Value => No_Array_Element, - Next => + (Name => Current_Item_Name, + Value => No_Array_Element, + Next => In_Tree.Projects.Table (Project).Decl.Arrays); In_Tree.Projects.Table (Project).Decl.Arrays := @@ -1515,8 +1515,8 @@ package body Prj.Proc is pragma Assert (Orig_Project /= No_Project, "original project not found"); - if Associative_Package_Of - (Current_Item, From_Project_Node_Tree) = Empty_Node + if No (Associative_Package_Of + (Current_Item, From_Project_Node_Tree)) then Orig_Array := In_Tree.Projects.Table @@ -1732,7 +1732,7 @@ package body Prj.Proc is (String_Type_Of (Current_Item, From_Project_Node_Tree), From_Project_Node_Tree); - while Current_String /= Empty_Node + while Present (Current_String) and then String_Value_Of (Current_String, From_Project_Node_Tree) /= @@ -1746,7 +1746,7 @@ package body Prj.Proc is -- Report an error if the string value is not -- one for the string type. - if Current_String = Empty_Node then + if No (Current_String) then Error_Msg_Name_1 := New_Value.Value; Error_Msg_Name_2 := Name_Of @@ -1849,21 +1849,21 @@ package body Prj.Proc is if Pkg /= No_Package then In_Tree.Variable_Elements.Table (The_Variable) := - (Next => + (Next => In_Tree.Packages.Table (Pkg).Decl.Variables, - Name => Current_Item_Name, - Value => New_Value); + Name => Current_Item_Name, + Value => New_Value); In_Tree.Packages.Table (Pkg).Decl.Variables := The_Variable; else In_Tree.Variable_Elements.Table (The_Variable) := - (Next => + (Next => In_Tree.Projects.Table (Project).Decl.Variables, - Name => Current_Item_Name, - Value => New_Value); + Name => Current_Item_Name, + Value => New_Value); In_Tree.Projects.Table (Project).Decl.Variables := The_Variable; @@ -1957,9 +1957,9 @@ package body Prj.Proc is if Pkg /= No_Package then In_Tree.Arrays.Table (The_Array) := - (Name => Current_Item_Name, - Value => No_Array_Element, - Next => + (Name => Current_Item_Name, + Value => No_Array_Element, + Next => In_Tree.Packages.Table (Pkg).Decl.Arrays); @@ -1968,9 +1968,9 @@ package body Prj.Proc is else In_Tree.Arrays.Table (The_Array) := - (Name => Current_Item_Name, - Value => No_Array_Element, - Next => + (Name => Current_Item_Name, + Value => No_Array_Element, + Next => In_Tree.Projects.Table (Project).Decl.Arrays); @@ -2019,7 +2019,7 @@ package body Prj.Proc is not Case_Insensitive (Current_Item, From_Project_Node_Tree), Value => New_Value, - Next => In_Tree.Arrays.Table + Next => In_Tree.Arrays.Table (The_Array).Value); In_Tree.Arrays.Table (The_Array).Value := The_Array_Element; @@ -2068,8 +2068,8 @@ package body Prj.Proc is -- If a project was specified for the case variable, -- get its id. - if Project_Node_Of - (Variable_Node, From_Project_Node_Tree) /= Empty_Node + if Present (Project_Node_Of + (Variable_Node, From_Project_Node_Tree)) then Name := Name_Of @@ -2084,8 +2084,8 @@ package body Prj.Proc is -- If a package were specified for the case variable, -- get its id. - if Package_Node_Of - (Variable_Node, From_Project_Node_Tree) /= Empty_Node + if Present (Package_Node_Of + (Variable_Node, From_Project_Node_Tree)) then Name := Name_Of @@ -2121,8 +2121,8 @@ package body Prj.Proc is if Var_Id = No_Variable and then - Package_Node_Of - (Variable_Node, From_Project_Node_Tree) = Empty_Node + No (Package_Node_Of + (Variable_Node, From_Project_Node_Tree)) then Var_Id := In_Tree.Projects.Table (The_Project).Decl.Variables; @@ -2172,14 +2172,14 @@ package body Prj.Proc is Case_Item := First_Case_Item_Of (Current_Item, From_Project_Node_Tree); Case_Item_Loop : - while Case_Item /= Empty_Node loop + while Present (Case_Item) loop Choice_String := First_Choice_Of (Case_Item, From_Project_Node_Tree); -- When Choice_String is nil, it means that it is -- the "when others =>" alternative. - if Choice_String = Empty_Node then + if No (Choice_String) then Decl_Item := First_Declarative_Item_Of (Case_Item, From_Project_Node_Tree); @@ -2189,7 +2189,7 @@ package body Prj.Proc is -- Look into all the alternative of this case item Choice_Loop : - while Choice_String /= Empty_Node loop + while Present (Choice_String) loop if Case_Value = String_Value_Of (Choice_String, From_Project_Node_Tree) @@ -2211,7 +2211,7 @@ package body Prj.Proc is -- If there is an alternative, then we process it - if Decl_Item /= Empty_Node then + if Present (Decl_Item) then Process_Declarative_Items (Project => Project, In_Tree => In_Tree, @@ -2486,7 +2486,7 @@ package body Prj.Proc is With_Clause : Project_Node_Id; begin - if From_Project_Node = Empty_Node then + if No (From_Project_Node) then Project := No_Project; else @@ -2591,7 +2591,7 @@ package body Prj.Proc is With_Clause := First_With_Clause_Of (From_Project_Node, From_Project_Node_Tree); - while With_Clause /= Empty_Node loop + while Present (With_Clause) loop declare New_Project : Project_Id; New_Data : Project_Data; @@ -2602,7 +2602,7 @@ package body Prj.Proc is Non_Limited_Project_Node_Of (With_Clause, From_Project_Node_Tree); - if Proj_Node /= Empty_Node then + if Present (Proj_Node) then Recursive_Process (In_Tree => In_Tree, Project => New_Project, @@ -2799,7 +2799,7 @@ package body Prj.Proc is With_Clause := First_With_Clause_Of (From_Project_Node, From_Project_Node_Tree); - while With_Clause /= Empty_Node loop + while Present (With_Clause) loop declare New_Project : Project_Id; New_Data : Project_Data; @@ -2810,7 +2810,7 @@ package body Prj.Proc is Non_Limited_Project_Node_Of (With_Clause, From_Project_Node_Tree); - if Proj_Node = Empty_Node then + if No (Proj_Node) then Recursive_Process (In_Tree => In_Tree, Project => New_Project, diff --git a/gcc/ada/prj-strt.adb b/gcc/ada/prj-strt.adb index 28c5b34a304..862b6ff6302 100644 --- a/gcc/ada/prj-strt.adb +++ b/gcc/ada/prj-strt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2008, 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- -- @@ -244,7 +244,7 @@ package body Prj.Strt is -- Change name of obsolete attributes - if Reference /= Empty_Node then + if Present (Reference) then case Name_Of (Reference, In_Tree) is when Snames.Name_Specification => Set_Name_Of (Reference, In_Tree, To => Snames.Name_Spec); @@ -716,7 +716,7 @@ package body Prj.Strt is (Current_Project, In_Tree, Names.Table (1).Name); end if; - if The_Project = Empty_Node then + if No (The_Project) then -- If it is neither a project name nor a package name, -- report an error. @@ -734,7 +734,7 @@ package body Prj.Strt is The_Package := First_Package_Of (Current_Project, In_Tree); - while The_Package /= Empty_Node + while Present (The_Package) and then Name_Of (The_Package, In_Tree) /= Names.Table (1).Name loop @@ -745,7 +745,7 @@ package body Prj.Strt is -- If it has not been already declared, report an -- error. - if The_Package = Empty_Node then + if No (The_Package) then Error_Msg_Name_1 := Names.Table (1).Name; Error_Msg ("package % not yet defined", Names.Table (1).Location); @@ -820,7 +820,7 @@ package body Prj.Strt is -- If the long project exists, then this is the prefix -- of the attribute. - if The_Project /= Empty_Node then + if Present (The_Project) then First_Attribute := Attribute_First; The_Package := Empty_Node; @@ -841,7 +841,7 @@ package body Prj.Strt is -- If short project does not exist, report an error - if The_Project = Empty_Node then + if No (The_Project) then Error_Msg_Name_1 := Long_Project; Error_Msg_Name_2 := Short_Project; Error_Msg ("unknown projects % or %", @@ -855,7 +855,7 @@ package body Prj.Strt is The_Package := First_Package_Of (The_Project, In_Tree); - while The_Package /= Empty_Node + while Present (The_Package) and then Name_Of (The_Package, In_Tree) /= Names.Table (Names.Last).Name loop @@ -865,7 +865,7 @@ package body Prj.Strt is -- If it has not, then we report an error - if The_Package = Empty_Node then + if No (The_Package) then Error_Msg_Name_1 := Names.Table (Names.Last).Name; Error_Msg_Name_2 := Short_Project; @@ -926,7 +926,7 @@ package body Prj.Strt is The_Package := First_Package_Of (Current_Project, In_Tree); - while The_Package /= Empty_Node + while Present (The_Package) and then Name_Of (The_Package, In_Tree) /= Names.Table (1).Name loop @@ -939,10 +939,10 @@ package body Prj.Strt is The_Project := Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Names.Table (1).Name); - if The_Project /= Empty_Node then + if Present (The_Project) then Specified_Project := The_Project; - elsif The_Package = Empty_Node then + elsif No (The_Package) then Error_Msg_Name_1 := Names.Table (1).Name; Error_Msg ("unknown package or project %", Names.Table (1).Location); @@ -1004,7 +1004,7 @@ package body Prj.Strt is The_Project := Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Long_Project); - if The_Project /= Empty_Node then + if Present (The_Project) then Specified_Project := The_Project; else @@ -1017,7 +1017,7 @@ package body Prj.Strt is Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Short_Project); - if The_Project = Empty_Node then + if No (The_Project) then -- Unknown prefix, report an error Error_Msg_Name_1 := Long_Project; @@ -1034,7 +1034,7 @@ package body Prj.Strt is The_Package := First_Package_Of (The_Project, In_Tree); - while The_Package /= Empty_Node + while Present (The_Package) and then Name_Of (The_Package, In_Tree) /= Names.Table (Names.Last - 1).Name loop @@ -1042,7 +1042,7 @@ package body Prj.Strt is Next_Package_In_Project (The_Package, In_Tree); end loop; - if The_Package = Empty_Node then + if No (The_Package) then -- The package does not exist, report an error @@ -1065,7 +1065,7 @@ package body Prj.Strt is Set_Project_Node_Of (Variable, In_Tree, To => Specified_Project); Set_Package_Node_Of (Variable, In_Tree, To => Specified_Package); - if Specified_Project /= Empty_Node then + if Present (Specified_Project) then The_Project := Specified_Project; else The_Project := Current_Project; @@ -1078,10 +1078,10 @@ package body Prj.Strt is -- If a package was specified, check if the variable has been -- declared in this package. - if Specified_Package /= Empty_Node then + if Present (Specified_Package) then Current_Variable := First_Variable_Of (Specified_Package, In_Tree); - while Current_Variable /= Empty_Node + while Present (Current_Variable) and then Name_Of (Current_Variable, In_Tree) /= Variable_Name loop @@ -1093,12 +1093,12 @@ package body Prj.Strt is -- a package, first check if the variable has been declared in -- the package. - if Specified_Project = Empty_Node - and then Current_Package /= Empty_Node + if No (Specified_Project) + and then Present (Current_Package) then Current_Variable := First_Variable_Of (Current_Package, In_Tree); - while Current_Variable /= Empty_Node + while Present (Current_Variable) and then Name_Of (Current_Variable, In_Tree) /= Variable_Name loop Current_Variable := @@ -1107,29 +1107,47 @@ package body Prj.Strt is end if; -- If we have not found the variable in the package, check if the - -- variable has been declared in the project. + -- variable has been declared in the project, or in any of its + -- ancestors. - if Current_Variable = Empty_Node then - Current_Variable := First_Variable_Of (The_Project, In_Tree); - while Current_Variable /= Empty_Node - and then Name_Of (Current_Variable, In_Tree) /= Variable_Name - loop - Current_Variable := - Next_Variable (Current_Variable, In_Tree); - end loop; + if No (Current_Variable) then + declare + Proj : Project_Node_Id := The_Project; + + begin + loop + Current_Variable := First_Variable_Of (Proj, In_Tree); + while + Present (Current_Variable) + and then + Name_Of (Current_Variable, In_Tree) /= Variable_Name + loop + Current_Variable := + Next_Variable (Current_Variable, In_Tree); + end loop; + + exit when Present (Current_Variable); + + Proj := Parent_Project_Of (Proj, In_Tree); + + Set_Project_Node_Of (Variable, In_Tree, To => Proj); + + exit when No (Proj); + end loop; + end; end if; end if; -- If the variable was not found, report an error - if Current_Variable = Empty_Node then + if No (Current_Variable) then Error_Msg_Name_1 := Variable_Name; Error_Msg ("unknown variable %", Names.Table (Names.Last).Location); end if; end if; - if Current_Variable /= Empty_Node then + if Present (Current_Variable) then Set_Expression_Kind_Of (Variable, In_Tree, To => Expression_Kind_Of (Current_Variable, In_Tree)); @@ -1185,9 +1203,9 @@ package body Prj.Strt is -- Add the literal of the string type to the Choices table - if String_Type /= Empty_Node then + if Present (String_Type) then Current_String := First_Literal_String (String_Type, In_Tree); - while Current_String /= Empty_Node loop + while Present (Current_String) loop Add (This_String => String_Value_Of (Current_String, In_Tree)); Current_String := Next_Literal_String (Current_String, In_Tree); end loop; @@ -1290,7 +1308,7 @@ package body Prj.Strt is -- If Current_Expression is empty, it means that the -- expression is the first in the string list. - if Current_Expression = Empty_Node then + if No (Current_Expression) then Set_First_Expression_In_List (Term_Id, In_Tree, To => Next_Expression); else @@ -1382,7 +1400,7 @@ package body Prj.Strt is Current_Package => Current_Package); Set_Current_Term (Term, In_Tree, To => Reference); - if Reference /= Empty_Node then + if Present (Reference) then -- If we don't know the expression kind (first term), then it -- has the kind of the variable or attribute reference. @@ -1425,7 +1443,7 @@ package body Prj.Strt is -- Same checks as above for the expression kind - if Reference /= Empty_Node then + if Present (Reference) then if Expr_Kind = Undefined then Expr_Kind := Expression_Kind_Of (Reference, In_Tree); diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb index 83ee5f936b6..0f9f5de986f 100644 --- a/gcc/ada/prj-tree.adb +++ b/gcc/ada/prj-tree.adb @@ -94,13 +94,13 @@ package body Prj.Tree is begin pragma Assert - (To /= Empty_Node + (Present (To) and then In_Tree.Project_Nodes.Table (To).Kind /= N_Comment); Zone := In_Tree.Project_Nodes.Table (To).Comments; - if Zone = Empty_Node then + if No (Zone) then -- Create new N_Comment_Zones node @@ -122,6 +122,7 @@ package body Prj.Tree is Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, + Field4 => Empty_Node, Flag1 => False, Flag2 => False, Comments => Empty_Node); @@ -171,12 +172,13 @@ package body Prj.Tree is Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, + Field4 => Empty_Node, Comments => Empty_Node); -- If this is the first comment, put it in the right field of -- the node Zone. - if Previous = Empty_Node then + if No (Previous) then case Where is when Before => In_Tree.Project_Nodes.Table (Zone).Field1 := @@ -228,7 +230,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration or else @@ -246,7 +248,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration)); return In_Tree.Project_Nodes.Table (Node).Field3; @@ -262,7 +264,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration)); return In_Tree.Project_Nodes.Table (Node).Field2; @@ -277,7 +279,7 @@ package body Prj.Tree is In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration or else @@ -295,7 +297,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); return In_Tree.Project_Nodes.Table (Node).Field1; @@ -312,13 +314,13 @@ package body Prj.Tree is Zone : Project_Node_Id; begin - pragma Assert (Node /= Empty_Node); + pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; -- If there is not already an N_Comment_Zones associated, create a new -- one and associate it with node Node. - if Zone = Empty_Node then + if No (Zone) then Project_Node_Table.Increment_Last (In_Tree.Project_Nodes); Zone := Project_Node_Table.Last (In_Tree.Project_Nodes); In_Tree.Project_Nodes.Table (Zone) := @@ -337,6 +339,7 @@ package body Prj.Tree is Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, + Field4 => Empty_Node, Flag1 => False, Flag2 => False, Comments => Empty_Node); @@ -356,7 +359,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); return In_Tree.Project_Nodes.Table (Node).Field1; @@ -372,7 +375,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term); return In_Tree.Project_Nodes.Table (Node).Field1; @@ -412,6 +415,7 @@ package body Prj.Tree is Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, + Field4 => Empty_Node, Flag1 => False, Flag2 => False, Comments => Empty_Node); @@ -447,6 +451,7 @@ package body Prj.Tree is Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, + Field4 => Empty_Node, Flag1 => False, Flag2 => False, Comments => Empty_Node); @@ -480,12 +485,13 @@ package body Prj.Tree is Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, + Field4 => Empty_Node, Comments => Empty_Node); -- Link it to the N_Comment_Zones node, if it is the first, -- otherwise to the previous one. - if Previous = Empty_Node then + if No (Previous) then In_Tree.Project_Nodes.Table (Zone).Field1 := Project_Node_Table.Last (In_Tree.Project_Nodes); @@ -518,7 +524,7 @@ package body Prj.Tree is In_Tree : Project_Node_Tree_Ref) return Path_Name_Type is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Directory; @@ -534,10 +540,10 @@ package body Prj.Tree is Zone : Project_Node_Id := Empty_Node; begin - pragma Assert (Node /= Empty_Node); + pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; - if Zone = Empty_Node then + if No (Zone) then return No_Name; else return In_Tree.Project_Nodes.Table (Zone).Value; @@ -553,7 +559,7 @@ package body Prj.Tree is In_Tree : Project_Node_Tree_Ref) return Variable_Kind is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String or else @@ -588,7 +594,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration @@ -612,7 +618,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); return In_Tree.Project_Nodes.Table (Node).Field2; @@ -628,7 +634,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return Path_Name_Type (In_Tree.Project_Nodes.Table (Node).Value); @@ -643,7 +649,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); return In_Tree.Project_Nodes.Table (Node).Field3; @@ -659,7 +665,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); return In_Tree.Project_Nodes.Table (Node).Field1; @@ -676,7 +682,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); return In_Tree.Project_Nodes.Table (Node).Field2; @@ -692,7 +698,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); return In_Tree.Project_Nodes.Table (Node).Field2; @@ -709,7 +715,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); return In_Tree.Project_Nodes.Table (Node).Field1; @@ -725,10 +731,10 @@ package body Prj.Tree is is Zone : Project_Node_Id := Empty_Node; begin - pragma Assert (Node /= Empty_Node); + pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; - if Zone = Empty_Node then + if No (Zone) then return Empty_Node; else @@ -748,10 +754,10 @@ package body Prj.Tree is Zone : Project_Node_Id := Empty_Node; begin - pragma Assert (Node /= Empty_Node); + pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; - if Zone = Empty_Node then + if No (Zone) then return Empty_Node; else @@ -770,10 +776,10 @@ package body Prj.Tree is Zone : Project_Node_Id := Empty_Node; begin - pragma Assert (Node /= Empty_Node); + pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; - if Zone = Empty_Node then + if No (Zone) then return Empty_Node; else @@ -792,10 +798,10 @@ package body Prj.Tree is Zone : Project_Node_Id := Empty_Node; begin - pragma Assert (Node /= Empty_Node); + pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; - if Zone = Empty_Node then + if No (Zone) then return Empty_Node; else @@ -813,7 +819,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration or else @@ -838,7 +844,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String_List); return In_Tree.Project_Nodes.Table (Node).Field1; @@ -854,7 +860,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); @@ -871,7 +877,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Packages; @@ -887,7 +893,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Field3; @@ -903,7 +909,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); return In_Tree.Project_Nodes.Table (Node).Field1; @@ -919,7 +925,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else @@ -938,7 +944,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Field1; @@ -953,7 +959,7 @@ package body Prj.Tree is In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); return In_Tree.Project_Nodes.Table (Node).Flag1; @@ -988,7 +994,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); return In_Tree.Project_Nodes.Table (Node).Flag2; @@ -1003,7 +1009,7 @@ package body Prj.Tree is In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else @@ -1020,7 +1026,7 @@ package body Prj.Tree is In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); return In_Tree.Project_Nodes.Table (Node).Flag1; @@ -1042,27 +1048,27 @@ package body Prj.Tree is begin -- First check all the imported projects - while With_Clause /= Empty_Node loop + while Present (With_Clause) loop -- Only non limited imported project may be used as prefix -- of variable or attributes. Result := Non_Limited_Project_Node_Of (With_Clause, In_Tree); - exit when Result /= Empty_Node + exit when Present (Result) and then Name_Of (Result, In_Tree) = With_Name; With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop; -- If it is not an imported project, it might be an extended project - if With_Clause = Empty_Node then + if No (With_Clause) then Result := Project; loop Result := Extended_Project_Of (Project_Declaration_Of (Result, In_Tree), In_Tree); - exit when Result = Empty_Node + exit when No (Result) or else Name_Of (Result, In_Tree) = With_Name; end loop; end if; @@ -1078,7 +1084,7 @@ package body Prj.Tree is (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Kind is begin - pragma Assert (Node /= Empty_Node); + pragma Assert (Present (Node)); return In_Tree.Project_Nodes.Table (Node).Kind; end Kind_Of; @@ -1090,7 +1096,7 @@ package body Prj.Tree is (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Source_Ptr is begin - pragma Assert (Node /= Empty_Node); + pragma Assert (Present (Node)); return In_Tree.Project_Nodes.Table (Node).Location; end Location_Of; @@ -1102,7 +1108,7 @@ package body Prj.Tree is (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Name_Id is begin - pragma Assert (Node /= Empty_Node); + pragma Assert (Present (Node)); return In_Tree.Project_Nodes.Table (Node).Name; end Name_Of; @@ -1116,7 +1122,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); return In_Tree.Project_Nodes.Table (Node).Field3; @@ -1131,7 +1137,7 @@ package body Prj.Tree is In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); return In_Tree.Project_Nodes.Table (Node).Comments; @@ -1147,7 +1153,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); return In_Tree.Project_Nodes.Table (Node).Field2; @@ -1163,7 +1169,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); return In_Tree.Project_Nodes.Table (Node).Field2; @@ -1180,7 +1186,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String); return In_Tree.Project_Nodes.Table (Node).Field1; @@ -1196,7 +1202,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); return In_Tree.Project_Nodes.Table (Node).Field3; @@ -1213,7 +1219,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); @@ -1230,7 +1236,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term); return In_Tree.Project_Nodes.Table (Node).Field2; @@ -1247,7 +1253,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration @@ -1268,12 +1274,21 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); return In_Tree.Project_Nodes.Table (Node).Field2; end Next_With_Clause_Of; + -------- + -- No -- + -------- + + function No (Node : Project_Node_Id) return Boolean is + begin + return Node = Empty_Node; + end No; + --------------------------------- -- Non_Limited_Project_Node_Of -- --------------------------------- @@ -1284,7 +1299,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause)); return In_Tree.Project_Nodes.Table (Node).Field3; @@ -1300,7 +1315,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); return In_Tree.Project_Nodes.Table (Node).Pkg_Id; @@ -1316,7 +1331,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference or else @@ -1334,7 +1349,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else @@ -1342,6 +1357,15 @@ package body Prj.Tree is return In_Tree.Project_Nodes.Table (Node).Path_Name; end Path_Name_Of; + ------------- + -- Present -- + ------------- + + function Present (Node : Project_Node_Id) return Boolean is + begin + return Node /= Empty_Node; + end Present; + ---------------------------- -- Project_Declaration_Of -- ---------------------------- @@ -1352,7 +1376,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Field2; @@ -1368,12 +1392,28 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Qualifier; end Project_Qualifier_Of; + ----------------------- + -- Parent_Project_Of -- + ----------------------- + + function Parent_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + return In_Tree.Project_Nodes.Table (Node).Field4; + end Parent_Project_Of; + ------------------------------------------- -- Project_File_Includes_Unkept_Comments -- ------------------------------------------- @@ -1398,7 +1438,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause or else @@ -1418,7 +1458,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); return In_Tree.Project_Nodes.Table (Node).Field1; @@ -1534,7 +1574,7 @@ package body Prj.Tree is -- an end of line node specified, associate the comment with -- this node. - elsif End_Of_Line_Node /= Empty_Node then + elsif Present (End_Of_Line_Node) then declare Zones : constant Project_Node_Id := Comment_Zones_Of (End_Of_Line_Node, In_Tree); @@ -1559,13 +1599,13 @@ package body Prj.Tree is if Comments.Last > 0 and then not Comments.Table (1).Follows_Empty_Line then - if Previous_Line_Node /= Empty_Node then + if Present (Previous_Line_Node) then Add_Comments (To => Previous_Line_Node, Where => After, In_Tree => In_Tree); - elsif Previous_End_Node /= Empty_Node then + elsif Present (Previous_End_Node) then Add_Comments (To => Previous_End_Node, Where => After_End, @@ -1617,7 +1657,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration or else @@ -1636,7 +1676,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration); In_Tree.Project_Nodes.Table (Node).Field3 := To; @@ -1653,7 +1693,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration)); @@ -1671,7 +1711,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration or else @@ -1690,7 +1730,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); In_Tree.Project_Nodes.Table (Node).Field1 := To; @@ -1707,7 +1747,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); In_Tree.Project_Nodes.Table (Node).Field1 := To; @@ -1724,7 +1764,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term); In_Tree.Project_Nodes.Table (Node).Field1 := To; @@ -1741,7 +1781,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Directory := To; @@ -1767,7 +1807,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String or else @@ -1802,7 +1842,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration @@ -1826,7 +1866,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); In_Tree.Project_Nodes.Table (Node).Field1 := To; @@ -1843,7 +1883,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); In_Tree.Project_Nodes.Table (Node).Field2 := To; @@ -1860,7 +1900,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); In_Tree.Project_Nodes.Table (Node).Field2 := To; @@ -1877,7 +1917,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); In_Tree.Project_Nodes.Table (Node).Field1 := To; @@ -1951,7 +1991,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); In_Tree.Project_Nodes.Table (Node).Field3 := To; @@ -1968,7 +2008,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); In_Tree.Project_Nodes.Table (Node).Comments := To; @@ -1985,7 +2025,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration or else @@ -2011,7 +2051,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String_List); In_Tree.Project_Nodes.Table (Node).Field1 := To; @@ -2028,7 +2068,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); @@ -2046,7 +2086,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Packages := To; @@ -2063,7 +2103,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Field3 := To; @@ -2080,7 +2120,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); In_Tree.Project_Nodes.Table (Node).Field1 := To; @@ -2097,7 +2137,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else @@ -2116,7 +2156,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Field1 := To; @@ -2132,7 +2172,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else @@ -2150,7 +2190,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); In_Tree.Project_Nodes.Table (Node).Flag1 := True; @@ -2166,7 +2206,7 @@ package body Prj.Tree is To : Project_Node_Kind) is begin - pragma Assert (Node /= Empty_Node); + pragma Assert (Present (Node)); In_Tree.Project_Nodes.Table (Node).Kind := To; end Set_Kind_Of; @@ -2180,7 +2220,7 @@ package body Prj.Tree is To : Source_Ptr) is begin - pragma Assert (Node /= Empty_Node); + pragma Assert (Present (Node)); In_Tree.Project_Nodes.Table (Node).Location := To; end Set_Location_Of; @@ -2195,7 +2235,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); In_Tree.Project_Nodes.Table (Node).Field2 := To; @@ -2212,7 +2252,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Value := Name_Id (To); @@ -2229,7 +2269,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); In_Tree.Project_Nodes.Table (Node).Field3 := To; @@ -2245,7 +2285,7 @@ package body Prj.Tree is To : Name_Id) is begin - pragma Assert (Node /= Empty_Node); + pragma Assert (Present (Node)); In_Tree.Project_Nodes.Table (Node).Name := To; end Set_Name_Of; @@ -2260,7 +2300,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); In_Tree.Project_Nodes.Table (Node).Field2 := To; @@ -2287,7 +2327,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); In_Tree.Project_Nodes.Table (Node).Field2 := To; @@ -2304,7 +2344,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String); In_Tree.Project_Nodes.Table (Node).Field1 := To; @@ -2321,7 +2361,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); In_Tree.Project_Nodes.Table (Node).Field3 := To; @@ -2338,7 +2378,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); @@ -2356,7 +2396,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term); In_Tree.Project_Nodes.Table (Node).Field2 := To; @@ -2373,7 +2413,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration @@ -2394,7 +2434,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); In_Tree.Project_Nodes.Table (Node).Field2 := To; @@ -2411,7 +2451,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); In_Tree.Project_Nodes.Table (Node).Pkg_Id := To; @@ -2428,7 +2468,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference or else @@ -2447,7 +2487,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Project or else @@ -2483,7 +2523,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Field2 := To; @@ -2500,11 +2540,27 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Qualifier := To; end Set_Project_Qualifier_Of; + --------------------------- + -- Set_Parent_Project_Of -- + --------------------------- + + procedure Set_Parent_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id) + is + begin + pragma Assert + (Present (Node) + and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + In_Tree.Project_Nodes.Table (Node).Field4 := To; + end Set_Parent_Project_Of; + ----------------------------------------------- -- Set_Project_File_Includes_Unkept_Comments -- ----------------------------------------------- @@ -2532,7 +2588,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause or else @@ -2559,7 +2615,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); In_Tree.Project_Nodes.Table (Node).Field1 := To; @@ -2576,7 +2632,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String or else @@ -2596,7 +2652,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference @@ -2624,7 +2680,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause or else @@ -2644,7 +2700,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String or else @@ -2663,7 +2719,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference @@ -2688,7 +2744,7 @@ package body Prj.Tree is is begin pragma Assert - (Node /= Empty_Node + (Present (Node) and then (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause or else @@ -2709,7 +2765,7 @@ package body Prj.Tree is is begin pragma Assert - (For_Typed_Variable /= Empty_Node + (Present (For_Typed_Variable) and then (In_Tree.Project_Nodes.Table (For_Typed_Variable).Kind = N_Typed_Variable_Declaration)); @@ -2721,7 +2777,7 @@ package body Prj.Tree is In_Tree); begin - while Current_String /= Empty_Node + while Present (Current_String) and then String_Value_Of (Current_String, In_Tree) /= Value loop @@ -2729,7 +2785,7 @@ package body Prj.Tree is Next_Literal_String (Current_String, In_Tree); end loop; - return Current_String /= Empty_Node; + return Present (Current_String); end; end Value_Is_Valid; diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads index 9649adddec8..94526660e20 100644 --- a/gcc/ada/prj-tree.ads +++ b/gcc/ada/prj-tree.ads @@ -90,6 +90,14 @@ package Prj.Tree is -- of the fields in each node of Project_Node_Kind, look at package -- Tree_Private_Part. + function Present (Node : Project_Node_Id) return Boolean; + pragma Inline (Present); + -- Return True iff Node /= Empty_Node + + function No (Node : Project_Node_Id) return Boolean; + pragma Inline (No); + -- Return True iff Node = Empty_Node + procedure Initialize (Tree : Project_Node_Tree_Ref); -- Initialize the Project File tree: empty the Project_Nodes table -- and reset the Projects_Htable. @@ -262,10 +270,15 @@ package Prj.Tree is In_Tree : Project_Node_Tree_Ref) return Boolean; -- Valid only for N_Comment nodes + function Parent_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; + pragma Inline (Parent_Project_Of); + -- Valid only for N_Project nodes + function Project_File_Includes_Unkept_Comments (Node : Project_Node_Id; - In_Tree : Project_Node_Tree_Ref) - return Boolean; + In_Tree : Project_Node_Tree_Ref) return Boolean; -- Valid only for N_Project nodes function Directory_Of @@ -631,6 +644,11 @@ package Prj.Tree is To : Project_Node_Id); pragma Inline (Set_Next_Comment); + procedure Set_Parent_Project_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Project_Node_Id); + procedure Set_Project_File_Includes_Unkept_Comments (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; @@ -972,6 +990,9 @@ package Prj.Tree is Field3 : Project_Node_Id := Empty_Node; -- See below the meaning for each Project_Node_Kind + Field4 : Project_Node_Id := Empty_Node; + -- See below the meaning for each Project_Node_Kind + Flag1 : Boolean := False; -- This flag is significant only for: -- N_Attribute_Declaration and N_Attribute_Reference @@ -1019,6 +1040,7 @@ package Prj.Tree is -- -- Field1: first with clause -- -- Field2: project declaration -- -- Field3: first string type + -- -- Field4: parent project, if any -- -- Value: extended project path name (if any) -- N_With_Clause, @@ -1028,6 +1050,7 @@ package Prj.Tree is -- -- Field1: project node -- -- Field2: next with clause -- -- Field3: project node or empty if "limited with" + -- -- Field4: not used -- -- Value: literal string withed -- N_Project_Declaration, @@ -1037,6 +1060,7 @@ package Prj.Tree is -- -- Field1: first declarative item -- -- Field2: extended project -- -- Field3: extending project + -- -- Field4: not used -- -- Value: not used -- N_Declarative_Item, @@ -1046,6 +1070,7 @@ package Prj.Tree is -- -- Field1: current item node -- -- Field2: next declarative item -- -- Field3: not used + -- -- Field4: not used -- -- Value: not used -- N_Package_Declaration, @@ -1055,6 +1080,7 @@ package Prj.Tree is -- -- Field1: project of renamed package (if any) -- -- Field2: first declarative item -- -- Field3: next package in project + -- -- Field4: not used -- -- Value: not used -- N_String_Type_Declaration, @@ -1064,6 +1090,7 @@ package Prj.Tree is -- -- Field1: first literal string -- -- Field2: next string type -- -- Field3: not used + -- -- Field4: not used -- -- Value: not used -- N_Literal_String, @@ -1073,6 +1100,7 @@ package Prj.Tree is -- -- Field1: next literal string -- -- Field2: not used -- -- Field3: not used + -- -- Field4: not used -- -- Value: string value -- N_Attribute_Declaration, @@ -1082,6 +1110,7 @@ package Prj.Tree is -- -- Field1: expression -- -- Field2: project of full associative array -- -- Field3: package of full associative array + -- -- Field4: not used -- -- Value: associative array index -- -- (if an associative array element) @@ -1092,6 +1121,7 @@ package Prj.Tree is -- -- Field1: expression -- -- Field2: type of variable (N_String_Type_Declaration) -- -- Field3: next variable + -- -- Field4: not used -- -- Value: not used -- N_Variable_Declaration, @@ -1105,6 +1135,7 @@ package Prj.Tree is -- -- N_Variable_Declaration and -- -- N_Typed_Variable_Declaration -- -- Field3: next variable + -- -- Field4: not used -- -- Value: not used -- N_Expression, @@ -1123,6 +1154,7 @@ package Prj.Tree is -- -- Field1: current term -- -- Field2: next term in the expression -- -- Field3: not used + -- -- Field4: not used -- -- Value: not used -- N_Literal_String_List, @@ -1135,6 +1167,7 @@ package Prj.Tree is -- -- Field1: first expression -- -- Field2: not used -- -- Field3: not used + -- -- Field4: not used -- -- Value: not used -- N_Variable_Reference, @@ -1144,6 +1177,7 @@ package Prj.Tree is -- -- Field1: project (if specified) -- -- Field2: package (if specified) -- -- Field3: type of variable (N_String_Type_Declaration), if any + -- -- Field4: not used -- -- Value: not used -- N_External_Value, @@ -1162,6 +1196,7 @@ package Prj.Tree is -- -- Field1: project -- -- Field2: package (if attribute of a package) -- -- Field3: not used + -- -- Field4: not used -- -- Value: associative array index -- -- (if an associative array element) @@ -1172,6 +1207,7 @@ package Prj.Tree is -- -- Field1: case variable reference -- -- Field2: first case item -- -- Field3: not used + -- -- Field4: not used -- -- Value: not used -- N_Case_Item @@ -1182,6 +1218,7 @@ package Prj.Tree is -- -- for when others -- -- Field2: first declarative item -- -- Field3: next case item + -- -- Field4: not used -- -- Value: not used -- N_Comment_zones @@ -1192,6 +1229,7 @@ package Prj.Tree is -- -- Field2: comment after the construct -- -- Field3: comment before the "end" of the construct -- -- Value: end of line comment + -- -- Field4: not used -- -- Comments: comment after the "end" of the construct -- N_Comment @@ -1201,6 +1239,7 @@ package Prj.Tree is -- -- Field1: not used -- -- Field2: not used -- -- Field3: not used + -- -- Field4: not used -- -- Value: comment -- -- Flag1: comment is preceded by an empty line -- -- Flag2: comment is followed by an empty line @@ -1229,13 +1268,17 @@ package Prj.Tree is Extended : Boolean; -- True when the project is being extended by another project + + Proj_Qualifier : Project_Qualifier; + -- The project qualifier of the project, if any end record; No_Project_Name_And_Node : constant Project_Name_And_Node := (Name => No_Name, Node => Empty_Node, Canonical_Path => No_Path, - Extended => True); + Extended => True, + Proj_Qualifier => Unspecified); package Projects_Htable is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index a362fb8bd22..0435509988e 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -122,6 +122,7 @@ package body Prj is Sources => Nil_String, First_Source => No_Source, Last_Source => No_Source, + Interfaces_Defined => False, Unit_Based_Language_Name => No_Name, Unit_Based_Language_Index => No_Language_Index, Imported_Directories_Switches => null, @@ -599,6 +600,11 @@ package body Prj is return Hash (Get_Name_String (Name)); end Hash; + function Hash (Project : Project_Id) return Header_Num is + begin + return Header_Num (Project mod Max_Header_Num); + end Hash; + ----------- -- Image -- ----------- diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 5b62ec9e017..c547eb66397 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -307,7 +307,8 @@ package Prj is Language : Language_Index); -- Output the name of a language - type Header_Num is range 0 .. 6150; + Max_Header_Num : constant := 6150; + type Header_Num is range 0 .. Max_Header_Num; -- Size for hash table below. The upper bound is an arbitrary value, the -- value here was chosen after testing to determine a good compromise -- between speed of access and memory usage. @@ -317,6 +318,9 @@ package Prj is function Hash (Name : Path_Name_Type) 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 hash tables where Project_Id is the Key + type Language_Kind is (File_Based, Unit_Based); -- Type for the kind of language. All languages are file based, except Ada -- which is unit based. @@ -420,6 +424,13 @@ package Prj is -- shared libraries. Specified in the configuration. When not specified, -- there is no need for such switch. + Object_Generated : Boolean := True; + -- False in no object file is generated + + Objects_Linked : Boolean := True; + -- False if object files are not use to link executables and build + -- libraries. + Runtime_Library_Dir : Name_Id := No_Name; -- Path name of the runtime library directory, if any @@ -527,6 +538,8 @@ package Prj is Compiler_Driver_Path => null, Compiler_Required_Switches => No_Name_List, Compilation_PIC_Option => No_Name_List, + Object_Generated => True, + Objects_Linked => True, Runtime_Library_Dir => No_Name, Mapping_File_Switches => No_Name_List, Mapping_Spec_Suffix => No_File, @@ -616,6 +629,13 @@ package Prj is Compiled : Boolean := True; -- False when there is no compiler for the language + In_Interfaces : Boolean := True; + -- False when the source is not included in interfaces, when attribute + -- Interfaces is declared. + + Declared_In_Interfaces : Boolean := False; + -- True when source is declared in attribute Interfaces + Alternate_Languages : Alternate_Language_Id := No_Alternate_Language; -- List of languages a header file may also be, in addition of -- language Language_Name. @@ -667,6 +687,10 @@ package Prj is Object_Exists : Boolean := True; -- True if an object file exists + Object_Linked : Boolean := True; + -- False if the object file is not use to link executables or included + -- in libraries. + Object : File_Name_Type := No_File; -- File name of the object file @@ -714,42 +738,45 @@ package Prj is end record; No_Source_Data : constant Source_Data := - (Project => No_Project, - Language_Name => No_Name, - Language => No_Language_Index, - Lang_Kind => File_Based, - Compiled => True, - Alternate_Languages => No_Alternate_Language, - Kind => Spec, - Dependency => None, - Other_Part => No_Source, - Unit => No_Name, - Index => 0, - Locally_Removed => False, - Get_Object => False, - Replaced_By => No_Source, - File => No_File, - Display_File => No_File, - Path => No_Path, - Display_Path => No_Path, - Source_TS => Empty_Time_Stamp, - Object_Project => No_Project, - Object_Exists => True, - Object => No_File, - Current_Object_Path => No_Path, - Object_Path => No_Path, - Object_TS => Empty_Time_Stamp, - Dep_Name => No_File, - Current_Dep_Path => No_Path, - Dep_Path => No_Path, - Dep_TS => Empty_Time_Stamp, - Switches => No_File, - Switches_Path => No_Path, - Switches_TS => Empty_Time_Stamp, - Naming_Exception => False, - Next_In_Sources => No_Source, - Next_In_Project => No_Source, - Next_In_Lang => No_Source); + (Project => No_Project, + Language_Name => No_Name, + Language => No_Language_Index, + Lang_Kind => File_Based, + Compiled => True, + In_Interfaces => True, + Declared_In_Interfaces => False, + Alternate_Languages => No_Alternate_Language, + Kind => Spec, + Dependency => None, + Other_Part => No_Source, + Unit => No_Name, + Index => 0, + Locally_Removed => False, + Get_Object => False, + Replaced_By => No_Source, + File => No_File, + Display_File => No_File, + Path => No_Path, + Display_Path => No_Path, + Source_TS => Empty_Time_Stamp, + Object_Project => No_Project, + Object_Exists => True, + Object_Linked => True, + Object => No_File, + Current_Object_Path => No_Path, + Object_Path => No_Path, + Object_TS => Empty_Time_Stamp, + Dep_Name => No_File, + Current_Dep_Path => No_Path, + Dep_Path => No_Path, + Dep_TS => Empty_Time_Stamp, + Switches => No_File, + Switches_Path => No_Path, + Switches_TS => Empty_Time_Stamp, + Naming_Exception => False, + Next_In_Sources => No_Source, + Next_In_Project => No_Source, + Next_In_Lang => No_Source); package Source_Data_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Source_Data, @@ -1267,9 +1294,6 @@ package Prj is Dir_Path : String_Access; -- Same as Directory, but as an access to String - Library : Boolean := False; - -- True if this is a library project - Library_Dir : Path_Name_Type := No_Path; -- If a library project, path name of the directory where the library -- resides. @@ -1303,6 +1327,9 @@ package Prj is -- be different from Library_ALI_Dir for platforms where the file names -- are case-insensitive. + Library : Boolean := False; + -- True if this is a library project + Library_Name : Name_Id := No_Name; -- If a library project, name of the library @@ -1339,6 +1366,10 @@ package Prj is Last_Source : Source_Id := No_Source; -- Head and tail of the list of sources + Interfaces_Defined : Boolean := False; + -- True if attribute Interfaces is declared for the project or any + -- project it extends. + Unit_Based_Language_Name : Name_Id := No_Name; Unit_Based_Language_Index : Language_Index := No_Language_Index; -- The name and index, if any, of the unit-based language of some diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index 9dacefb3005..fbc8a8a54f8 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -277,11 +277,12 @@ package Restrict is (P : Profile_Name; N : Node_Id; Warn : Boolean); - -- Sets the set of restrictions associated with the given profile - -- name. N is the node of the construct to which error messages - -- are to be attached as required. Warn is set True for the case - -- of Profile_Warnings where the restrictions are set as warnings - -- rather than legality requirements. + -- Sets the set of restrictions associated with the given profile name. N + -- is the node of the construct to which error messages are to be attached + -- as required. Warn is set True for the case of Profile_Warnings where the + -- restrictions are set as warnings rather than legality requirements, and + -- is also True for Profile if the Treat_Restrictions_As_Warnings flag is + -- set. It is false for Profile if this flag is not set. procedure Set_Restriction (R : All_Boolean_Restrictions; @@ -301,7 +302,9 @@ package Restrict is (Unit : Node_Id; Warn : Boolean); -- Sets given No_Dependence restriction in table if not there already. - -- Warn is True if from Restriction_Warnings, False if from Restrictions. + -- Warn is True if from Restriction_Warnings, or for Restrictions if flag + -- Treat_Restrictions_As_Warnings is set. False if from Restrictions and + -- this flag is not set. function Tasking_Allowed return Boolean; pragma Inline (Tasking_Allowed); diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index ef61b8fd0e5..83f745499e2 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -83,7 +83,7 @@ package Rtsfind is -- Names of the form System_Tasking_xxx are second level children of the -- package System.Tasking. For example, System_Tasking_Stages refers to - -- refers to the package System.Tasking.Stages. + -- the package System.Tasking.Stages. -- Other names stand for themselves (e.g. System for package System) @@ -1255,6 +1255,7 @@ package Rtsfind is RE_Shared_Var_ROpen, -- System.Shared_Storage RE_Shared_Var_Unlock, -- System.Shared_Storage RE_Shared_Var_WOpen, -- System.Shared_Storage + RE_Shared_Var_Procs, -- System.Shared_Storage RE_Abort_Undefer_Direct, -- System.Standard_Library RE_Exception_Code, -- System.Standard_Library @@ -2382,6 +2383,7 @@ package Rtsfind is RE_Shared_Var_ROpen => System_Shared_Storage, RE_Shared_Var_Unlock => System_Shared_Storage, RE_Shared_Var_WOpen => System_Shared_Storage, + RE_Shared_Var_Procs => System_Shared_Storage, RE_Abort_Undefer_Direct => System_Standard_Library, RE_Exception_Code => System_Standard_Library, diff --git a/gcc/ada/s-linux-hppa.ads b/gcc/ada/s-linux-hppa.ads index 3c746de3a92..72d1673d832 100644 --- a/gcc/ada/s-linux-hppa.ads +++ b/gcc/ada/s-linux-hppa.ads @@ -97,21 +97,18 @@ package System.Linux is -- struct_sigaction offsets - sa_flags_pos : constant := Standard'Address_Size / 8; - sa_mask_pos : constant := sa_flags_pos * 2; + sa_flags_pos : constant := Standard'Address_Size / 8; + sa_mask_pos : constant := sa_flags_pos * 2; - SA_SIGINFO : constant := 16#10#; - SA_ONSTACK : constant := 16#01#; + SA_SIGINFO : constant := 16#10#; + SA_ONSTACK : constant := 16#01#; type lock_array is array (1 .. 4) of Integer; type atomic_lock_t is record lock : lock_array; end record; pragma Convention (C, atomic_lock_t); - -- ??? Alignment should be 16 but this is larger than BIGGEST_ALIGNMENT. - -- This causes an erroneous pointer value to sometimes be passed to free - -- during deallocation. See PR ada/24533 for more details. - for atomic_lock_t'Alignment use 8; + for atomic_lock_t'Alignment use 16; type struct_pthread_fast_lock is record spinlock : atomic_lock_t; diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb index ff65720d6e4..f3e369cf853 100755 --- a/gcc/ada/s-os_lib.adb +++ b/gcc/ada/s-os_lib.adb @@ -1896,7 +1896,7 @@ package body System.OS_Lib is and then Path_Buffer (2) /= Directory_Separator then declare - Cur_Dir : String := Get_Directory (""); + Cur_Dir : constant String := Get_Directory (""); -- Get the current directory to get the drive letter begin diff --git a/gcc/ada/s-osinte-irix.ads b/gcc/ada/s-osinte-irix.ads index 15bd4007225..01b01b54222 100644 --- a/gcc/ada/s-osinte-irix.ads +++ b/gcc/ada/s-osinte-irix.ads @@ -261,6 +261,13 @@ package System.OS_Interface is PTHREAD_CREATE_DETACHED : constant := 1; + ----------- + -- Stack -- + ----------- + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + --------------------------------------- -- Nonstandard Thread Initialization -- --------------------------------------- diff --git a/gcc/ada/s-shasto.adb b/gcc/ada/s-shasto.adb index 5dd775725bb..c4ef8628c0b 100644 --- a/gcc/ada/s-shasto.adb +++ b/gcc/ada/s-shasto.adb @@ -6,8 +6,8 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- --- -- +-- Copyright (C) 1998-2008, 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- -- @@ -364,6 +364,43 @@ package body System.Shared_Storage is end Shared_Var_Lock; ---------------------- + -- Shared_Var_Procs -- + ---------------------- + + package body Shared_Var_Procs is + + use type SIO.Stream_Access; + + ---------- + -- Read -- + ---------- + + procedure Read is + S : SIO.Stream_Access := null; + begin + S := Shared_Var_ROpen (Full_Name); + if S /= null then + Typ'Read (S, V); + Shared_Var_Close (S); + end if; + end Read; + + ------------ + -- Write -- + ------------ + + procedure Write is + S : SIO.Stream_Access := null; + begin + S := Shared_Var_WOpen (Full_Name); + Typ'Write (S, V); + Shared_Var_Close (S); + return; + end Write; + + end Shared_Var_Procs; + + ---------------------- -- Shared_Var_ROpen -- ---------------------- diff --git a/gcc/ada/s-shasto.ads b/gcc/ada/s-shasto.ads index fc4055b9826..8046fd5b2f6 100644 --- a/gcc/ada/s-shasto.ads +++ b/gcc/ada/s-shasto.ads @@ -79,48 +79,18 @@ -- The approach is as follows: --- For each shared variable, var, an access routine varR is created whose --- body has the following form (this example is for Pkg.Var): - --- procedure varR is --- S : Ada.Streams.Stream_IO.Stream_Access; --- begin --- S := Shared_Var_ROpen ("pkg.var"); --- if S /= null then --- typ'Read (S); --- Shared_Var_Close (S); --- end if; --- end varR; +-- For each shared variable, var, an instanciation of the below generic +-- package is created which provides Read and Write supporting procedures. -- The routine Shared_Var_ROpen in package System.Shared_Storage -- either returns null if the storage does not exist, or otherwise a -- Stream_Access value that references the corresponding shared -- storage, ready to read the current value. --- Each reference to the shared variable, var, is preceded by a --- call to the corresponding varR procedure, which either leaves the --- initial value unchanged if the storage does not exist, or reads --- the current value from the shared storage. - --- In addition, for each shared variable, var, an assignment routine --- is created whose body has the following form (again for Pkg.Var) - --- procedure VarA is --- S : Ada.Streams.Stream_IO.Stream_Access; --- begin --- S := Shared_Var_WOpen ("pkg.var"); --- typ'Write (S, var); --- Shared_Var_Close (S); --- end VarA; - -- The routine Shared_Var_WOpen in package System.Shared_Storage -- returns a Stream_Access value that references the corresponding -- shared storage, ready to write the new value. --- Each assignment to the shared variable, var, is followed by a call --- to the corresponding varA procedure, which writes the new value to --- the shared storage. - -- Note that there is no general synchronization for these storage -- read and write operations, since it is assumed that a correctly -- operating programs will provide appropriate synchronization. In @@ -219,4 +189,35 @@ package System.Shared_Storage is -- generated as the last operation in the body of a protected -- subprogram. + -- This generic package is instantiated for each shared passive + -- variable. It provides supporting procedures called upon each + -- read or write access by the expanded code. + + generic + + type Typ is limited private; + -- Shared passive variable type + + V : in out Typ; + -- Shared passive variable + + Full_Name : String; + -- Shared passive variable storage name + + package Shared_Var_Procs is + + procedure Read; + -- Shared passive variable access routine. Each reference to the + -- shared variable, V, is preceded by a call to the corresponding + -- Read procedure, which either leaves the initial value unchanged + -- if the storage does not exist, or reads the current value from + -- the shared storage. + + procedure Write; + -- Shared passive variable assignement routine. Each assignment to + -- the shared variable, V, is followed by a call to the corresponding + -- Write procedure, which writes the new value to the shared storage. + + end Shared_Var_Procs; + end System.Shared_Storage; diff --git a/gcc/ada/s-taspri-vxworks.ads b/gcc/ada/s-taspri-vxworks.ads index b499b217bec..19998db97ed 100644 --- a/gcc/ada/s-taspri-vxworks.ads +++ b/gcc/ada/s-taspri-vxworks.ads @@ -62,6 +62,18 @@ package System.Task_Primitives is -- A component of this type is guaranteed to be included in the -- Ada_Task_Control_Block. + subtype Task_Address is System.Address; + -- In some versions of Task_Primitives, notably for VMS, Task_Address is + -- the short version of address defined in System.Aux_DEC. To avoid + -- dragging Aux_DEC into tasking packages a tasking specific subtype is + -- defined here. + + Task_Address_Size : constant := Standard'Address_Size; + -- The size of Task_Address + + Alternate_Stack_Size : constant := 0; + -- No alternate signal stack is used on this platform + private type Priority_Type is (Prio_None, Prio_Protect, Prio_Inherit); diff --git a/gcc/ada/s-unstyp.ads b/gcc/ada/s-unstyp.ads index 0609e0b0345..c951140ff09 100644 --- a/gcc/ada/s-unstyp.ads +++ b/gcc/ada/s-unstyp.ads @@ -32,7 +32,7 @@ ------------------------------------------------------------------------------ -- This package contains definitions of standard unsigned types that --- correspond in size to the standard signed types declared in Standard. +-- correspond in size to the standard signed types declared in Standard, -- and (unlike the types in Interfaces) have corresponding names. It -- also contains some related definitions for other specialized types -- used by the compiler in connection with packed array types. diff --git a/gcc/ada/s-winext.ads b/gcc/ada/s-winext.ads index a0091ff74d3..e00ae7bdd17 100644 --- a/gcc/ada/s-winext.ads +++ b/gcc/ada/s-winext.ads @@ -98,37 +98,7 @@ package System.Win32.Ext is wReserved1 : WORD; end record; pragma Convention (C, DCB); - - for DCB use record - DCBLENGTH at 0 range 0 .. 31; - BaudRate at 4 range 0 .. 31; - fBinary at 8 range 0 .. 0; - fParity at 8 range 1 .. 1; - fOutxCtsFlow at 8 range 2 .. 2; - fOutxDsrFlow at 8 range 3 .. 3; - fDtrControl at 8 range 4 .. 5; - fDsrSensitivity at 8 range 6 .. 6; - fTXContinueOnXoff at 8 range 7 .. 7; - fOutX at 9 range 0 .. 0; - fInX at 9 range 1 .. 1; - fErrorChar at 9 range 2 .. 2; - fNull at 9 range 3 .. 3; - fRtsControl at 9 range 4 .. 5; - fAbortOnError at 9 range 6 .. 6; - fDummy2 at 9 range 7 .. 23; - wReserved at 12 range 0 .. 15; - XonLim at 14 range 0 .. 15; - XoffLim at 16 range 0 .. 15; - ByteSize at 18 range 0 .. 7; - Parity at 19 range 0 .. 7; - StopBits at 20 range 0 .. 7; - XonChar at 21 range 0 .. 7; - XoffChar at 22 range 0 .. 7; - ErrorChar at 23 range 0 .. 7; - EofChar at 24 range 0 .. 7; - EvtChar at 25 range 0 .. 7; - wReserved1 at 26 range 0 .. 15; - end record; + pragma Pack (DCB); type COMMTIMEOUTS is record ReadIntervalTimeout : DWORD; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 051a650f9c2..21d620716f0 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -2113,7 +2113,7 @@ package body Sem_Aggr is function Valid_Ancestor_Type return Boolean; -- Verify that the type of the ancestor part is a non-private ancestor - -- of the expected type. + -- of the expected type, which must be a type extension. ---------------------------- -- Valid_Limited_Ancestor -- @@ -2159,8 +2159,8 @@ package body Sem_Aggr is Imm_Type := Etype (Base_Type (Imm_Type)); end loop; - if Etype (Imm_Type) /= Base_Type (A_Type) - or else Base_Type (Typ) = Base_Type (A_Type) + if not Is_Derived_Type (Base_Type (Typ)) + or else Etype (Imm_Type) /= Base_Type (A_Type) then Error_Msg_NE ("expect ancestor type of &", A, Typ); return False; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 6a7846eacba..c2536dfc70c 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1278,7 +1278,8 @@ package body Sem_Attr is and then Convention (Etype (P)) = Convention_CPP and then Is_CPP_Class (Root_Type (Etype (P))) then - Error_Attr_P ("invalid use of % attribute with CPP tagged type"); + Error_Attr_P + ("invalid use of % attribute with 'C'P'P tagged type"); end if; end Check_Not_CPP_Type; @@ -1459,6 +1460,14 @@ package body Sem_Attr is Etyp : Entity_Id; Btyp : Entity_Id; + In_Shared_Var_Procs : Boolean; + -- True when compiling the body of System.Shared_Storage. + -- Shared_Var_Procs. For this runtime package (always compiled in + -- GNAT mode), we allow stream attributes references for limited + -- types for the case where shared passive objects are implemented + -- using stream attributes, which is the default in GNAT's persistent + -- storage implementation. + begin Validate_Non_Static_Attribute_Function_Call; @@ -1492,7 +1501,19 @@ package body Sem_Attr is -- in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp -- (with no visibility restriction). - if Comes_From_Source (N) + declare + Gen_Body : constant Node_Id := Enclosing_Generic_Body (N); + begin + if Present (Gen_Body) then + In_Shared_Var_Procs := + Is_RTE (Corresponding_Spec (Gen_Body), RE_Shared_Var_Procs); + else + In_Shared_Var_Procs := False; + end if; + end; + + if (Comes_From_Source (N) + and then not (In_Shared_Var_Procs or In_Instance)) and then not Stream_Attribute_Available (P_Type, Nam) and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert) then diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index bbce51f7240..cc96974425a 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -76,7 +76,7 @@ package body Sem_Cat is -- at any place. function In_RCI_Declaration (N : Node_Id) return Boolean; - -- Determines if a declaration is within the visible part of a Remote + -- Determines if a declaration is within the visible part of a Remote -- Call Interface compilation unit, for semantic checking purposes only, -- (returns false within an instance and within the package body). @@ -98,15 +98,10 @@ package body Sem_Cat is procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id); -- Check validity of declaration if RCI or RT unit. It should not contain - -- the declaration of an access-to-object type unless it is a - -- general access type that designates a class-wide limited - -- private type. There are also constraints about the primitive - -- subprograms of the class-wide type. RM E.2 (9, 13, 14) - - function Is_Recursively_Limited_Private (E : Entity_Id) return Boolean; - -- Return True if E is a limited private type, or if E is a private - -- extension of a type whose parent verifies this property (hence the - -- recursive keyword). + -- the declaration of an access-to-object type unless it is a general + -- access type that designates a class-wide limited private type. There are + -- also constraints about the primitive subprograms of the class-wide type. + -- RM E.2 (9, 13, 14) --------------------------------------- -- Check_Categorization_Dependencies -- @@ -446,6 +441,9 @@ package body Sem_Cat is (Specification (Unit_Declaration_Node (Unit_Entity))) and then not In_Package_Body (Unit_Entity) and then not In_Instance; + + -- What about the case of a nested package in the visible part??? + -- This case is missed by the List_Containing check above??? end In_RCI_Declaration; ----------------------- @@ -531,47 +529,6 @@ package body Sem_Cat is and then not Is_Remote_Access_To_Subprogram_Type (U_E); end Is_Non_Remote_Access_Type; - ------------------------------------ - -- Is_Recursively_Limited_Private -- - ------------------------------------ - - function Is_Recursively_Limited_Private (E : Entity_Id) return Boolean is - P : constant Node_Id := Parent (E); - - begin - if Nkind (P) = N_Private_Type_Declaration - and then Is_Limited_Record (E) - then - return True; - - -- A limited interface is not currently a legal ancestor for the - -- designated type of an RACW type, because a type that implements - -- such an interface need not be limited. However, the ARG seems to - -- incline towards allowing an access to classwide limited interface - -- type as a remote access type. This may be revised when the ARG - -- rules on this question, but it seems safe to allow it for now, - -- in order to see whether it is a useful extension for distributed - -- programming, in particular for Brad Moore's buffer taxonomy. - - elsif Is_Limited_Record (E) - and then Is_Limited_Interface (E) - then - return True; - - elsif Nkind (P) = N_Private_Extension_Declaration then - return Is_Recursively_Limited_Private (Etype (E)); - - elsif Nkind (P) = N_Formal_Type_Declaration - and then Ekind (E) = E_Record_Type_With_Private - and then Is_Generic_Type (E) - and then Is_Limited_Record (E) - then - return True; - else - return False; - end if; - end Is_Recursively_Limited_Private; - ---------------------------------- -- Missing_Read_Write_Attribute -- ---------------------------------- @@ -755,7 +712,10 @@ package body Sem_Cat is end if; end if; - Set_Is_Remote_Types (E, Is_Remote_Types (Scop)); + Set_Is_Remote_Types + (E, Is_Remote_Types (Scop) + and then not (In_Private_Part (Scop) + or else In_Package_Body (Scop))); end Set_Categorization_From_Scope; ------------------------------ @@ -1399,6 +1359,18 @@ package body Sem_Cat is ("limited return type must have Read and Write attributes", Parent (Subprogram)); Explain_Limited_Type (Rtyp, Parent (Subprogram)); + + -- Check that the return type supports external streaming. + -- Note that the language of the standard (E.2.2(14)) does not + -- explicitly mention that case, but it really does not make + -- sense to return a value containing a local access type. + + elsif Missing_Read_Write_Attributes (Rtyp) + and then not Error_Posted (Rtyp) + then + Illegal_RACW ("return type containing non-remote access " + & "must have Read and Write attributes", + Parent (Subprogram)); end if; end if; @@ -1422,8 +1394,9 @@ package body Sem_Cat is elsif Ekind (Param_Type) = E_Anonymous_Access_Type or else Ekind (Param_Type) = E_Anonymous_Access_Subprogram_Type then - -- From RM E.2.2(14), no access parameter other than - -- controlling ones may be used. + -- From RM E.2.2(14), no anonumous access parameter other than + -- controlling ones may be used (because an anonymous access + -- type never supports external streaming). Illegal_RACW ("non-controlling access parameter", Param_Spec); @@ -1441,6 +1414,12 @@ package body Sem_Cat is Param_Spec); Explain_Limited_Type (Param_Type, Param_Spec); end if; + + elsif Missing_Read_Write_Attributes (Param_Type) + and then not Error_Posted (Param_Type) + then + Illegal_RACW ("parameter containing non-remote access " + & "must have Read and Write attributes", Param_Spec); end if; -- Check next parameter in this subprogram @@ -1522,12 +1501,14 @@ package body Sem_Cat is Error_Node : Node_Id := N; begin - -- There are two possible cases in which this procedure is called: + -- This procedure enforces rules on subprogram and access to subprogram + -- declarations in RCI units. These rules do not apply to expander + -- generated routines, which are not remote subprograms. It is called: - -- 1. called from Analyze_Subprogram_Declaration. - -- 2. called from Validate_Object_Declaration (access to subprogram). + -- 1. from Analyze_Subprogram_Declaration. + -- 2. from Validate_Object_Declaration (access to subprogram). - if not In_RCI_Declaration (N) then + if not (Comes_From_Source (N) and then In_RCI_Declaration (N)) then return; end if; @@ -1535,6 +1516,10 @@ package body Sem_Cat is Profile := Parameter_Specifications (Specification (N)); else pragma Assert (K = N_Object_Declaration); + -- The above assertion is dubious, the visible declarations of an + -- RCI unit never contain an object declaration, this should be an + -- ACCESS-to-object declaration??? + Id := Defining_Identifier (N); if Nkind (Id) = N_Defining_Identifier @@ -1550,7 +1535,7 @@ package body Sem_Cat is -- Iterate through the parameter specification list, checking that -- no access parameter and no limited type parameter in the list. - -- RM E.2.3 (14) + -- RM E.2.3(14). if Present (Profile) then Param_Spec := First (Profile); @@ -1570,7 +1555,7 @@ package body Sem_Cat is (Defining_Entity (Specification (N))) then Error_Msg_N - ("subprogram in rci unit cannot have access parameter", + ("subprogram in 'R'C'I unit cannot have access parameter", Error_Node); end if; @@ -1649,21 +1634,48 @@ package body Sem_Cat is if Ada_Version >= Ada_05 then Error_Msg_N - ("limited parameter in rci unit " + ("limited parameter in 'R'C'I unit " & "must have visible read/write attributes ", Error_Node); else Error_Msg_N - ("limited parameter in rci unit " + ("limited parameter in 'R'C'I unit " & "must have read/write attributes ", Error_Node); end if; Explain_Limited_Type (Param_Type, Error_Node); end if; - end if; + -- In Ada 95, any non-remote access type (or any type with a + -- component of a non-remote access type) that is visible in an + -- RCI unit comes from a Remote_Types or Remote_Call_Interface + -- unit, and thus is already guaranteed to support external + -- streaming. However in Ada 2005 we have to account for the case + -- of named access types from declared pure units as well, which + -- may or may not support external streaming, and so we need to + -- perform a specific check for E.2.3(14/2) here. + + -- Note that if the declaration of the type itself is illegal, we + -- do not perform this check since it might be a cascaded error. + + else + if K = N_Subprogram_Declaration then + Error_Node := Param_Spec; + end if; + + if Missing_Read_Write_Attributes (Param_Type) + and then not Error_Posted (Param_Type) + then + Error_Msg_N + ("parameter containing non-remote access in 'R'C'I " + & "subprogram must have visible " + & "Read and Write attributes", Error_Node); + end if; + end if; Next (Param_Spec); end loop; + + -- No check on return type??? end if; end Validate_RCI_Subprogram_Declaration; @@ -1672,6 +1684,61 @@ package body Sem_Cat is ---------------------------------------------------- procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id) is + + function Is_Valid_Remote_Object_Type (E : Entity_Id) return Boolean; + -- True if tagged type E is a valid candidate as the root type of the + -- designated type for a RACW, i.e. a tagged limited private type, or a + -- limited interface type, or a private extension of such a type. + + --------------------------------- + -- Is_Valid_Remote_Object_Type -- + --------------------------------- + + function Is_Valid_Remote_Object_Type (E : Entity_Id) return Boolean is + P : constant Node_Id := Parent (E); + + begin + pragma Assert (Is_Tagged_Type (E)); + + -- Simple case: a limited private type + + if Nkind (P) = N_Private_Type_Declaration + and then Is_Limited_Record (E) + then + return True; + + -- A limited interface is not currently a legal ancestor for the + -- designated type of an RACW type, because a type that implements + -- such an interface need not be limited. However, the ARG seems to + -- incline towards allowing an access to classwide limited interface + -- type as a remote access type, as resolved in AI05-060. But note + -- that the expansion circuitry for RACWs that designate classwide + -- interfaces is not complete yet. + + elsif Is_Limited_Record (E) and then Is_Limited_Interface (E) then + return True; + + -- A generic tagged limited type is a valid candidate. Limitedness + -- will be checked again on the actual at instantiation point. + + elsif Nkind (P) = N_Formal_Type_Declaration + and then Ekind (E) = E_Record_Type_With_Private + and then Is_Generic_Type (E) + and then Is_Limited_Record (E) + then + return True; + + -- A private extension declaration is a valid candidate if its parent + -- type is. + + elsif Nkind (P) = N_Private_Extension_Declaration then + return Is_Valid_Remote_Object_Type (Etype (E)); + + else + return False; + end if; + end Is_Valid_Remote_Object_Type; + Direct_Designated_Type : Entity_Id; Desig_Type : Entity_Id; @@ -1718,20 +1785,16 @@ package body Sem_Cat is Direct_Designated_Type := Designated_Type (T); Desig_Type := Etype (Direct_Designated_Type); - if not Is_Recursively_Limited_Private (Desig_Type) then + -- Why is the check below not in + -- Validate_Remote_Access_To_Class_Wide_Type??? + + if not Is_Valid_Remote_Object_Type (Desig_Type) then Error_Msg_N ("error in designated type of remote access to class-wide type", T); Error_Msg_N ("\must be tagged limited private or private extension", T); return; end if; - - -- Now this is an RCI unit access-to-class-wide-limited-private type - -- declaration. Set the type entity to be Is_Remote_Call_Interface to - -- optimize later checks by avoiding tree traversal to find out if this - -- entity is inside an RCI unit. - - Set_Is_Remote_Call_Interface (T); end Validate_Remote_Access_Object_Type_Declaration; ----------------------------------------------- @@ -1749,7 +1812,7 @@ package body Sem_Cat is -- Storage_Pool and Storage_Size are not defined for such types -- - -- The expected type of allocator must not not be such a type. + -- The expected type of allocator must not be such a type. -- The actual parameter of generic instantiation must not be such a -- type if the formal parameter is of an access type. diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 60833fc2bdb..75f4512c72c 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -2729,7 +2729,7 @@ package body Sem_Ch12 is Save_Parent : Node_Id; begin - -- Create copy of generic unit,and save for instantiation. If the unit + -- Create copy of generic unit, and save for instantiation. If the unit -- is a child unit, do not copy the specifications for the parent, which -- are not part of the generic tree. @@ -4040,14 +4040,15 @@ package body Sem_Ch12 is Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); -- Copy original generic tree, to produce text for instantiation - -- Inherit overriding indicator from instance node. Act_Tree := Copy_Generic_Node (Original_Node (Gen_Decl), Empty, Instantiating => True); + -- Inherit overriding indicator from instance node + Act_Spec := Specification (Act_Tree); - Set_Must_Override (Act_Spec, Must_Override (N)); + Set_Must_Override (Act_Spec, Must_Override (N)); Set_Must_Not_Override (Act_Spec, Must_Not_Override (N)); Renaming_List := @@ -4634,7 +4635,7 @@ package body Sem_Ch12 is -- Verify that the actual subprograms match. Note that actuals -- that are attributes are rewritten as subprograms. If the -- subprogram in the formal package is defaulted, no check is - -- needed. Note that this can only happen in Ada2005 when the + -- needed. Note that this can only happen in Ada 2005 when the -- formal package can be partially parametrized. if Nkind (Unit_Declaration_Node (E1)) = @@ -9982,7 +9983,9 @@ package body Sem_Ch12 is Check_Restriction (No_Fixed_Point, Actual); end if; - -- Deal with error of using incomplete type as generic actual + -- Deal with error of using incomplete type as generic actual. + -- This includes limited views of a type, even if the non-limited + -- view may be available. if Ekind (Act_T) = E_Incomplete_Type or else (Is_Class_Wide_Type (Act_T) diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index dd08710e37e..1b367373720 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2404,16 +2404,34 @@ package body Sem_Ch3 is if Is_Imported (Defining_Identifier (N)) and then - (T = RTE (RE_Tag) - or else (Present (Full_View (T)) - and then Full_View (T) = RTE (RE_Tag))) + (T = RTE (RE_Tag) + or else + (Present (Full_View (T)) + and then Full_View (T) = RTE (RE_Tag))) then null; - elsif not Is_Package_Or_Generic_Package (Current_Scope) then + -- A deferred constant may appear in the declarative part of the + -- following constructs: + + -- blocks + -- entry bodies + -- extended return statements + -- package specs + -- package bodies + -- subprogram bodies + -- task bodies + + -- When declared inside a package spec, a deferred constant must be + -- completed by a full constant declaration or pragma Import. In all + -- other cases, the only proper completion is pragma Import. Extended + -- return statements are flagged as invalid contexts because they do + -- not have a declarative part and so cannot accommodate the pragma. + + elsif Ekind (Current_Scope) = E_Return_Statement then Error_Msg_N ("invalid context for deferred constant declaration (RM 7.4)", - N); + N); Error_Msg_N ("\declaration requires an initialization expression", N); @@ -2482,10 +2500,16 @@ package body Sem_Ch3 is -- (primitive that is not available in CPP tagged types). if Is_Class_Wide_Type (Act_T) - and then Convention (Act_T) = Convention_CPP + and then + (Is_CPP_Class (Root_Type (Etype (Act_T))) + or else + (Present (Full_View (Root_Type (Etype (Act_T)))) + and then + Is_CPP_Class (Full_View (Root_Type (Etype (Act_T)))))) then Error_Msg_N - ("predefined assignment not available in CPP tagged types", E); + ("predefined assignment not available for 'C'P'P tagged types", + E); end if; Mark_Coextensions (N, E); @@ -3844,8 +3868,9 @@ package body Sem_Ch3 is Validate_Access_Type_Declaration (T, N); - -- If we are in a Remote_Call_Interface package and define - -- a RACW, Read and Write attribute must be added. + -- If we are in a Remote_Call_Interface package and define a + -- RACW, then calling stubs and specific stream attributes + -- must be added. if Is_Remote and then Is_Remote_Access_To_Class_Wide_Type (Def_Id) @@ -3908,10 +3933,10 @@ package body Sem_Ch3 is B : constant Entity_Id := Base_Type (T); begin - -- In the case where the base type is different from the first - -- subtype, we pre-allocate a freeze node, and set the proper link - -- to the first subtype. Freeze_Entity will use this preallocated - -- freeze node when it freezes the entity. + -- In the case where the base type differs from the first subtype, we + -- pre-allocate a freeze node, and set the proper link to the first + -- subtype. Freeze_Entity will use this preallocated freeze node when + -- it freezes the entity. if B /= T then Ensure_Freeze_Node (B); @@ -3929,11 +3954,11 @@ package body Sem_Ch3 is if T /= Def_Id and then Is_Private_Type (Def_Id) then Process_Full_View (N, T, Def_Id); - -- Record the reference. The form of this is a little strange, - -- since the full declaration has been swapped in. So the first - -- parameter here represents the entity to which a reference is - -- made which is the "real" entity, i.e. the one swapped in, - -- and the second parameter provides the reference location. + -- Record the reference. The form of this is a little strange, since + -- the full declaration has been swapped in. So the first parameter + -- here represents the entity to which a reference is made which is + -- the "real" entity, i.e. the one swapped in, and the second + -- parameter provides the reference location. -- Also, we want to kill Has_Pragma_Unreferenced temporarily here -- since we don't want a complaint about the full type being an @@ -3985,12 +4010,12 @@ package body Sem_Ch3 is procedure Analyze_Variant_Part (N : Node_Id) is procedure Non_Static_Choice_Error (Choice : Node_Id); - -- Error routine invoked by the generic instantiation below when - -- the variant part has a non static choice. + -- Error routine invoked by the generic instantiation below when the + -- variant part has a non static choice. procedure Process_Declarations (Variant : Node_Id); - -- Analyzes all the declarations associated with a Variant. - -- Needed by the generic instantiation below. + -- Analyzes all the declarations associated with a Variant. Needed by + -- the generic instantiation below. package Variant_Choices_Processing is new Generic_Choices_Processing @@ -4097,9 +4122,9 @@ package body Sem_Ch3 is Index := First (Subtype_Marks (Def)); end if; - -- Find proper names for the implicit types which may be public. - -- in case of anonymous arrays we use the name of the first object - -- of that type as prefix. + -- Find proper names for the implicit types which may be public. In case + -- of anonymous arrays we use the name of the first object of that type + -- as prefix. if No (T) then Related_Id := Defining_Identifier (P); @@ -4120,9 +4145,9 @@ package body Sem_Ch3 is -- type Table is array (Index) of ... -- end; - -- This is currently required by the expander to generate the - -- internally generated equality subprogram of records with variant - -- parts in which the etype of some component is such private type. + -- This is currently required by the expander for the internally + -- generated equality subprogram of records with variant parts in + -- which the etype of some component is such private type. if Ekind (Current_Scope) = E_Package and then In_Private_Part (Current_Scope) @@ -4195,9 +4220,9 @@ package body Sem_Ch3 is Set_Parent (Element_Type, Parent (T)); - -- Ada 2005 (AI-230): In case of components that are anonymous - -- access types the level of accessibility depends on the enclosing - -- type declaration + -- Ada 2005 (AI-230): In case of components that are anonymous access + -- types the level of accessibility depends on the enclosing type + -- declaration Set_Scope (Element_Type, Current_Scope); -- Ada 2005 (AI-230) @@ -4296,8 +4321,8 @@ package body Sem_Ch3 is if Null_Exclusion_Present (Component_Definition (Def)) - -- No need to check itypes because in their case this check - -- was done at their point of creation + -- No need to check itypes because in their case this check was + -- done at their point of creation and then not Is_Itype (Element_Type) then @@ -4331,8 +4356,8 @@ package body Sem_Ch3 is end if; end if; - -- A syntax error in the declaration itself may lead to an empty - -- index list, in which case do a minimal patch. + -- A syntax error in the declaration itself may lead to an empty index + -- list, in which case do a minimal patch. if No (First_Index (T)) then Error_Msg_N ("missing index definition in array type declaration", T); @@ -7631,7 +7656,16 @@ package body Sem_Ch3 is Set_First_Entity (Def_Id, First_Entity (T)); Set_Last_Entity (Def_Id, Last_Entity (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + + -- If the subtype is the completion of a private declaration, there may + -- have been representation clauses for the partial view, and they must + -- be preserved. Build_Derived_Type chains the inherited clauses with + -- the ones appearing on the extension. If this comes from a subtype + -- declaration, all clauses are inherited. + + if No (First_Rep_Item (Def_Id)) then + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + end if; if Is_Tagged_Type (T) then Set_Is_Tagged_Type (Def_Id); @@ -9922,7 +9956,7 @@ package body Sem_Ch3 is -- discriminant is declared in the private entity. or else (Is_Private_Type (Typ) - and then Chars (Discrim_Scope) = Chars (Typ)) + and then Chars (Discrim_Scope) = Chars (Typ)) -- Or we are constrained the corresponding record of a -- synchronized type that completes a private declaration. @@ -9935,7 +9969,7 @@ package body Sem_Ch3 is -- discriminant found belongs to the root type. or else (Is_Class_Wide_Type (Typ) - and then Etype (Typ) = Discrim_Scope)); + and then Etype (Typ) = Discrim_Scope)); return True; end if; @@ -12892,6 +12926,31 @@ package body Sem_Ch3 is New_Id : Entity_Id; Prev_Par : Node_Id; + procedure Tag_Mismatch; + -- Diagnose a tagged partial view whose full view is untagged; + -- We post the message on the full view, with a reference to + -- the previous partial view. The partial view can be private + -- or incomplete, and these are handled in a different manner, + -- so we determine the position of the error message from the + -- respective slocs of both. + + ------------------ + -- Tag_Mismatch -- + ------------------ + + procedure Tag_Mismatch is + begin + if Sloc (Prev) < Sloc (Id) then + Error_Msg_NE + ("full declaration of } must be a tagged type ", Id, Prev); + else + Error_Msg_NE + ("full declaration of } must be a tagged type ", Prev, Id); + end if; + end Tag_Mismatch; + + -- Start processing for Find_Type_Name + begin -- Find incomplete declaration, if one was given @@ -13024,7 +13083,7 @@ package body Sem_Ch3 is New_Id := Prev; end if; - -- Verify that full declaration conforms to incomplete one + -- Verify that full declaration conforms to partial one if Is_Incomplete_Or_Private_Type (Prev) and then Present (Discriminant_Specifications (Prev_Par)) @@ -13048,9 +13107,10 @@ package body Sem_Ch3 is end if; end if; - -- A prior untagged private type can have an associated class-wide + -- A prior untagged partial view can have an associated class-wide -- type due to use of the class attribute, and in this case also the - -- full type is required to be tagged. + -- full type is required to be tagged. This Ada95 usage is deprecated + -- in favor of incomplete tagged declarations but we check for it. if Is_Type (Prev) and then (Is_Tagged_Type (Prev) @@ -13066,8 +13126,7 @@ package body Sem_Ch3 is if No (Interface_List (N)) and then not Error_Posted (N) then - Error_Msg_NE - ("full declaration of } must be a tagged type ", Id, Prev); + Tag_Mismatch; end if; elsif Nkind (Type_Definition (N)) = N_Record_Definition then @@ -13076,8 +13135,7 @@ package body Sem_Ch3 is -- or private declaration) requires the same on the full one. if not Tagged_Present (Type_Definition (N)) then - Error_Msg_NE - ("full declaration of } must be tagged", Prev, Id); + Tag_Mismatch; Set_Is_Tagged_Type (Id); Set_Primitive_Operations (Id, New_Elmt_List); end if; @@ -13092,9 +13150,7 @@ package body Sem_Ch3 is end if; else - Error_Msg_NE - ("full declaration of } must be a tagged type", Prev, Id); - + Tag_Mismatch; end if; end if; @@ -17074,11 +17130,12 @@ package body Sem_Ch3 is elsif Has_Controlled_Component (Etype (Component)) or else (Chars (Component) /= Name_uParent - and then Is_Controlled (Etype (Component))) + and then Is_Controlled (Etype (Component))) then Set_Has_Controlled_Component (T, True); - Final_Storage_Only := Final_Storage_Only - and then Finalize_Storage_Only (Etype (Component)); + Final_Storage_Only := + Final_Storage_Only + and then Finalize_Storage_Only (Etype (Component)); Ctrl_Components := True; end if; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 60d3cd3f689..db5c112f059 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -691,11 +691,14 @@ package body Sem_Ch4 is Success : Boolean := False; function Name_Denotes_Function return Boolean; - -- If the type of the name is an access to subprogram, this may be - -- the type of a name, or the return type of the function being called. - -- If the name is not an entity then it can denote a protected function. - -- Until we distinguish Etype from Return_Type, we must use this - -- routine to resolve the meaning of the name in the call. + -- If the type of the name is an access to subprogram, this may be the + -- type of a name, or the return type of the function being called. If + -- the name is not an entity then it can denote a protected function. + -- Until we distinguish Etype from Return_Type, we must use this routine + -- to resolve the meaning of the name in the call. + + procedure No_Interpretation; + -- Output error message when no valid interpretation exists --------------------------- -- Name_Denotes_Function -- @@ -714,6 +717,43 @@ package body Sem_Ch4 is end if; end Name_Denotes_Function; + ----------------------- + -- No_Interpretation -- + ----------------------- + + procedure No_Interpretation is + L : constant Boolean := Is_List_Member (N); + K : constant Node_Kind := Nkind (Parent (N)); + + begin + -- If the node is in a list whose parent is not an expression then it + -- must be an attempted procedure call. + + if L and then K not in N_Subexpr then + if Ekind (Entity (Nam)) = E_Generic_Procedure then + Error_Msg_NE + ("must instantiate generic procedure& before call", + Nam, Entity (Nam)); + else + Error_Msg_N + ("procedure or entry name expected", Nam); + end if; + + -- Check for tasking cases where only an entry call will do + + elsif not L + and then Nkind_In (K, N_Entry_Call_Alternative, + N_Triggering_Alternative) + then + Error_Msg_N ("entry name expected", Nam); + + -- Otherwise give general error message + + else + Error_Msg_N ("invalid prefix in call", Nam); + end if; + end No_Interpretation; + -- Start of processing for Analyze_Call begin @@ -734,13 +774,19 @@ package body Sem_Ch4 is -- name, or if it is a function name in the context of a procedure -- call. In this latter case, we have a call to a parameterless -- function that returns a pointer_to_procedure which is the entity - -- being called. + -- being called. Finally, F (X) may be a call to a parameterless + -- function that returns a pointer to a function with parameters. elsif Is_Access_Type (Etype (Nam)) and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type and then (not Name_Denotes_Function - or else Nkind (N) = N_Procedure_Call_Statement) + or else Nkind (N) = N_Procedure_Call_Statement + or else + (Nkind (Parent (N)) /= N_Explicit_Dereference + and then Is_Entity_Name (Nam) + and then No (First_Formal (Entity (Nam))) + and then Present (Actuals))) then Nam_Ent := Designated_Type (Etype (Nam)); Insert_Explicit_Dereference (Nam); @@ -786,41 +832,17 @@ package body Sem_Ch4 is -- If no interpretations, give error message if not Is_Overloadable (Nam_Ent) then - declare - L : constant Boolean := Is_List_Member (N); - K : constant Node_Kind := Nkind (Parent (N)); - - begin - -- If the node is in a list whose parent is not an - -- expression then it must be an attempted procedure call. - - if L and then K not in N_Subexpr then - if Ekind (Entity (Nam)) = E_Generic_Procedure then - Error_Msg_NE - ("must instantiate generic procedure& before call", - Nam, Entity (Nam)); - else - Error_Msg_N - ("procedure or entry name expected", Nam); - end if; - - -- Check for tasking cases where only an entry call will do - - elsif not L - and then Nkind_In (K, N_Entry_Call_Alternative, - N_Triggering_Alternative) - then - Error_Msg_N ("entry name expected", Nam); + No_Interpretation; + return; + end if; + end if; - -- Otherwise give general error message + -- Operations generated for RACW stub types are called only through + -- dispatching, and can never be the static interpretation of a call. - else - Error_Msg_N ("invalid prefix in call", Nam); - end if; - - return; - end; - end if; + if Is_RACW_Stub_Type_Operation (Nam_Ent) then + No_Interpretation; + return; end if; Analyze_One_Call (N, Nam_Ent, True, Success); @@ -840,9 +862,9 @@ package body Sem_Ch4 is end if; else - -- An overloaded selected component must denote overloaded - -- operations of a concurrent type. The interpretations are - -- attached to the simple name of those operations. + -- An overloaded selected component must denote overloaded operations + -- of a concurrent type. The interpretations are attached to the + -- simple name of those operations. if Nkind (Nam) = N_Selected_Component then Nam := Selector_Name (Nam); @@ -2223,6 +2245,16 @@ package body Sem_Ch4 is end if; + -- If the call has been transformed into a slice, it is of the form + -- F (Subtype) where F is paramterless. The node has ben rewritten in + -- Try_Indexed_Call and there is nothing else to do. + + if Is_Indexed + and then Nkind (N) = N_Slice + then + return; + end if; + Normalize_Actuals (N, Nam, (Report and not Is_Indexed), Norm_OK); if not Norm_OK then @@ -5535,9 +5567,10 @@ package body Sem_Ch4 is Typ : Entity_Id; Skip_First : Boolean) return Boolean is - Actuals : constant List_Id := Parameter_Associations (N); - Actual : Node_Id; - Index : Entity_Id; + Loc : constant Source_Ptr := Sloc (N); + Actuals : constant List_Id := Parameter_Associations (N); + Actual : Node_Id; + Index : Entity_Id; begin Actual := First (Actuals); @@ -5559,7 +5592,21 @@ package body Sem_Ch4 is return False; end if; - if not Has_Compatible_Type (Actual, Etype (Index)) then + if Is_Entity_Name (Actual) + and then Is_Type (Entity (Actual)) + and then No (Next (Actual)) + then + Rewrite (N, + Make_Slice (Loc, + Prefix => Make_Function_Call (Loc, + Name => Relocate_Node (Name (N))), + Discrete_Range => + New_Occurrence_Of (Entity (Actual), Sloc (Actual)))); + + Analyze (N); + return True; + + elsif not Has_Compatible_Type (Actual, Etype (Index)) then return False; end if; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index a1cd552dfe3..e5de05b3a58 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -870,6 +870,7 @@ package body Sem_Ch5 is if Present (Decls) then Analyze_Declarations (Decls); Check_Completion; + Inspect_Deferred_Constant_Completion (Decls); end if; Analyze (HSS); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index fbac48cd1af..b4b1dcf9e04 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1257,10 +1257,10 @@ package body Sem_Ch6 is procedure Analyze_Subprogram_Body (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); + Body_Deleted : constant Boolean := False; Body_Spec : constant Node_Id := Specification (N); Body_Id : Entity_Id := Defining_Entity (Body_Spec); Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id); - Body_Deleted : constant Boolean := False; Conformant : Boolean; HSS : Node_Id; Missing_Ret : Boolean; @@ -1369,7 +1369,8 @@ package body Sem_Ch6 is Plist : List_Id; function Is_Inline_Pragma (N : Node_Id) return Boolean; - -- Simple predicate, used twice. + -- True when N is a pragma Inline or Inline_Awlays that applies + -- to this subprogram. ----------------------- -- Is_Inline_Pragma -- @@ -2045,6 +2046,7 @@ package body Sem_Ch6 is -- Check completion, and analyze the statements Check_Completion; + Inspect_Deferred_Constant_Completion (Declarations (N)); Analyze (HSS); -- Deal with end of scope processing for the body diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index fe1bcb5f24f..ee3300bb938 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -100,12 +100,6 @@ package body Sem_Ch7 is -- created at the beginning of the corresponding package body and inserted -- before other body declarations. - procedure Inspect_Deferred_Constant_Completion (Decls : List_Id); - -- Examines the deferred constants in the private part of the package - -- specification, or in a package body. Emits the error message - -- "constant declaration requires initialization expression" if not - -- completed by an Import pragma. - procedure Install_Package_Entity (Id : Entity_Id); -- Supporting procedure for Install_{Visible,Private}_Declarations. -- Places one entity on its visibility chain, and recurses on the visible @@ -1604,41 +1598,6 @@ package body Sem_Ch7 is Set_Homonym (Full_Id, H2); end Exchange_Declarations; - ------------------------------------------ - -- Inspect_Deferred_Constant_Completion -- - ------------------------------------------ - - procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is - Decl : Node_Id; - - begin - Decl := First (Decls); - while Present (Decl) loop - - -- Deferred constant signature - - if Nkind (Decl) = N_Object_Declaration - and then Constant_Present (Decl) - and then No (Expression (Decl)) - - -- No need to check internally generated constants - - and then Comes_From_Source (Decl) - - -- The constant is not completed. A full object declaration - -- or a pragma Import complete a deferred constant. - - and then not Has_Completion (Defining_Identifier (Decl)) - then - Error_Msg_N - ("constant declaration requires initialization expression", - Defining_Identifier (Decl)); - end if; - - Decl := Next (Decl); - end loop; - end Inspect_Deferred_Constant_Completion; - ---------------------------- -- Install_Package_Entity -- ---------------------------- diff --git a/gcc/ada/sem_ch7.ads b/gcc/ada/sem_ch7.ads index bcdaf000839..0445b242949 100644 --- a/gcc/ada/sem_ch7.ads +++ b/gcc/ada/sem_ch7.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 3b28bdfe868..6ebb647b86f 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1721,24 +1721,28 @@ package body Sem_Ch8 is Set_Corresponding_Spec (N, Rename_Spec); - -- Deal with special case of Input and Output stream functions + -- Deal with special case of stream functions of abstract types + -- and interfaces. if Nkind (Unit_Declaration_Node (Rename_Spec)) = N_Abstract_Subprogram_Declaration then - -- Input and Output stream functions are abstract if the object - -- type is abstract. However, these functions may receive explicit - -- declarations in representation clauses, making the attribute - -- subprograms usable as defaults in subsequent type extensions. + -- Input stream functions are abstract if the object type is + -- abstract. Similarly, all default stream functions for an + -- interface type are abstract. However, these suprograms may + -- receive explicit declarations in representation clauses, making + -- the attribute subprograms usable as defaults in subsequent + -- type extensions. -- In this case we rewrite the declaration to make the subprogram -- non-abstract. We remove the previous declaration, and insert -- the new one at the point of the renaming, to prevent premature -- access to unfrozen types. The new declaration reuses the -- specification of the previous one, and must not be analyzed. - pragma Assert (Is_TSS (Rename_Spec, TSS_Stream_Output) - or else Is_TSS (Rename_Spec, TSS_Stream_Input)); - + pragma Assert + (Is_Primitive (Entity (Nam)) + and then + Is_Abstract_Type (Find_Dispatching_Type (Entity (Nam)))); declare Old_Decl : constant Node_Id := Unit_Declaration_Node (Rename_Spec); @@ -3777,8 +3781,8 @@ package body Sem_Ch8 is E := Homonyms; while Present (E) loop - -- If entity is immediately visible or potentially use - -- visible, then process the entity and we are done. + -- If entity is immediately visible or potentially use visible, then + -- process the entity and we are done. if Is_Immediately_Visible (E) then goto Immediately_Visible_Entity; @@ -3958,15 +3962,15 @@ package body Sem_Ch8 is -- Come here with E set to the first immediately visible entity on -- the homonym chain. This is the one we want unless there is another - -- immediately visible entity further on in the chain for a more - -- inner scope (RM 8.3(8)). + -- immediately visible entity further on in the chain for an inner + -- scope (RM 8.3(8)). <<Immediately_Visible_Entity>> declare Level : Int; Scop : Entity_Id; begin - -- Find scope level of initial entity. When compiling through + -- Find scope level of initial entity. When compiling through -- Rtsfind, the previous context is not completely invisible, and -- an outer entity may appear on the chain, whose scope is below -- the entry for Standard that delimits the current scope stack. @@ -4243,8 +4247,8 @@ package body Sem_Ch8 is P_Name := Entity (Prefix (N)); O_Name := P_Name; - -- If the prefix is a renamed package, look for the entity - -- in the original package. + -- If the prefix is a renamed package, look for the entity in the + -- original package. if Ekind (P_Name) = E_Package and then Present (Renamed_Object (P_Name)) @@ -4335,10 +4339,10 @@ package body Sem_Ch8 is if No (Id) or else Chars (Id) /= Chars (Selector) then Set_Etype (N, Any_Type); - -- If we are looking for an entity defined in System, try to - -- find it in the child package that may have been provided as - -- an extension to System. The Extend_System pragma will have - -- supplied the name of the extension, which may have to be loaded. + -- If we are looking for an entity defined in System, try to find it + -- in the child package that may have been provided as an extension + -- to System. The Extend_System pragma will have supplied the name of + -- the extension, which may have to be loaded. if Chars (P_Name) = Name_System and then Scope (P_Name) = Standard_Standard @@ -4368,9 +4372,8 @@ package body Sem_Ch8 is return; else - -- If the prefix is a single concurrent object, use its - -- name in the error message, rather than that of the - -- anonymous type. + -- If the prefix is a single concurrent object, use its name in + -- the error message, rather than that of the anonymous type. if Is_Concurrent_Type (P_Name) and then Is_Internal_Name (Chars (P_Name)) @@ -4917,7 +4920,6 @@ package body Sem_Ch8 is -- in the expansion of record equality). elsif Present (Entity (Selector_Name (N))) then - if No (Etype (N)) or else Etype (N) = Any_Type then @@ -6145,6 +6147,16 @@ package body Sem_Ch8 is end; end if; + -- Finally, if the current use clause is in the context then + -- the clause is redundant when it is nested within the unit. + + elsif Nkind (Parent (Cur_Use)) = N_Compilation_Unit + and then Nkind (Parent (Parent (Clause))) /= N_Compilation_Unit + and then Get_Source_Unit (Cur_Use) = Get_Source_Unit (Clause) + then + Redundant := Clause; + Prev_Use := Cur_Use; + else null; end if; diff --git a/gcc/ada/sem_ch8.ads b/gcc/ada/sem_ch8.ads index 45fb07b32cc..0d17cd10500 100644 --- a/gcc/ada/sem_ch8.ads +++ b/gcc/ada/sem_ch8.ads @@ -77,8 +77,8 @@ package Sem_Ch8 is procedure Find_Direct_Name (N : Node_Id); -- Given a direct name (Identifier or Operator_Symbol), this routine scans -- the homonym chain for the name searching for corresponding visible - -- entities to find the referenced entity (or in the case of overloading), - -- entities. On return, the Entity and Etype fields are set. In the + -- entities to find the referenced entity (or in the case of overloading, + -- entities). On return, the Entity and Etype fields are set. In the -- non-overloaded case, these are the correct final entries. In the -- overloaded case, Is_Overloaded is set, Etype and Entity refer to an -- arbitrary element of the overloads set, and an appropriate list of diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index fe3634e8fe9..9482b565feb 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -795,6 +795,7 @@ package body Sem_Ch9 is if Present (Decls) then Analyze_Declarations (Decls); + Inspect_Deferred_Constant_Completion (Decls); end if; if Present (Stats) then @@ -1908,6 +1909,7 @@ package body Sem_Ch9 is Last_E := Last_Entity (Spec_Id); Analyze_Declarations (Decls); + Inspect_Deferred_Constant_Completion (Decls); -- For visibility purposes, all entities in the body are private. Set -- First_Private_Entity accordingly, if there was no private part in the diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index 50cf65aff58..0be68edc9f3 100644 --- a/gcc/ada/sem_dist.adb +++ b/gcc/ada/sem_dist.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,6 +35,7 @@ with Namet; use Namet; with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; @@ -268,12 +269,33 @@ package body Sem_Dist is end if; end Is_All_Remote_Call; + --------------------------------- + -- Is_RACW_Stub_Type_Operation -- + --------------------------------- + + function Is_RACW_Stub_Type_Operation (Op : Entity_Id) return Boolean is + Dispatching_Type : Entity_Id; + + begin + case Ekind (Op) is + when E_Function | E_Procedure => + Dispatching_Type := Find_Dispatching_Type (Op); + return Present (Dispatching_Type) + and then Is_RACW_Stub_Type (Dispatching_Type) + and then not Is_Internal (Op); + + when others => + return False; + end case; + end Is_RACW_Stub_Type_Operation; + ------------------------------------ -- Package_Specification_Of_Scope -- ------------------------------------ function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is N : Node_Id := Parent (E); + begin while Nkind (N) /= N_Package_Specification loop N := Parent (N); diff --git a/gcc/ada/sem_dist.ads b/gcc/ada/sem_dist.ads index 9f9b95d3e69..38a164a418f 100644 --- a/gcc/ada/sem_dist.ads +++ b/gcc/ada/sem_dist.ads @@ -100,4 +100,7 @@ package Sem_Dist is function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id; -- Return the N_Package_Specification corresponding to a scope E + function Is_RACW_Stub_Type_Operation (Op : Entity_Id) return Boolean; + -- True when Op is a primitive operation of an RACW stub type + end Sem_Dist; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 9801df625e5..c03f11ab0af 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -2678,6 +2678,35 @@ package body Sem_Eval is Check_Non_Static_Context (Low_Bound (Drange)); Check_Non_Static_Context (High_Bound (Drange)); end if; + + -- A slice of the form A (subtype), when the subtype is the index of + -- the type of A, is redundant, the slice can be replaced with A, and + -- this is worth a warning. + + if Is_Entity_Name (Prefix (N)) then + declare + E : constant Entity_Id := Entity (Prefix (N)); + T : constant Entity_Id := Etype (E); + begin + if Ekind (E) = E_Constant + and then Is_Array_Type (T) + and then Is_Entity_Name (Drange) + then + if Is_Entity_Name (Original_Node (First_Index (T))) + and then Entity (Original_Node (First_Index (T))) + = Entity (Drange) + then + if Warn_On_Redundant_Constructs then + Error_Msg_N ("redundant slice denotes whole array?", N); + end if; + + -- The following might be a useful optimization ???? + + -- Rewrite (N, New_Occurrence_Of (E, Sloc (N))); + end if; + end if; + end; + end if; end Eval_Slice; ------------------------- @@ -3309,9 +3338,12 @@ package body Sem_Eval is -- For a result of type integer, substitute an N_Integer_Literal node -- for the result of the compile time evaluation of the expression. + -- For ASIS use, set a link to the original named number when not in + -- a generic context. if Is_Integer_Type (Typ) then Rewrite (N, Make_Integer_Literal (Loc, Val)); + Set_Original_Entity (N, Ent); -- Otherwise we have an enumeration type, and we substitute either @@ -3355,6 +3387,9 @@ package body Sem_Eval is end if; Rewrite (N, Make_Real_Literal (Loc, Realval => Val)); + + -- Set link to original named number, for ASIS use. + Set_Original_Entity (N, Ent); -- Both the actual and expected type comes from the original expression diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb index 9d7319759b3..0b7adc45224 100644 --- a/gcc/ada/sem_intr.adb +++ b/gcc/ada/sem_intr.adb @@ -418,9 +418,7 @@ package body Sem_Intr is Ptyp1, N); return; - elsif Is_Modular_Integer_Type (Typ1) - and then Non_Binary_Modulus (Typ1) - then + elsif Non_Binary_Modulus (Typ1) then Errint ("shifts not allowed for non-binary modular types", Ptyp1, N); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 6b819803705..15f4e181f7a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -671,7 +671,9 @@ package body Sem_Prag is procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean); -- Common processing for Restrictions and Restriction_Warnings pragmas. - -- Warn is False for Restrictions, True for Restriction_Warnings. + -- Warn is True for Restriction_Warnings, or for Restrictions if the + -- flag Treat_Restrictions_As_Warnings is set, and False if this flag + -- is not set in the Restrictions case. procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean); -- Common processing for Suppress and Unsuppress. The boolean parameter @@ -4770,7 +4772,8 @@ package body Sem_Prag is -- Set the corresponding restrictions - Set_Profile_Restrictions (Ravenscar, N, Warn => False); + Set_Profile_Restrictions + (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings); end Set_Ravenscar_Profile; -- Start of processing for Analyze_Pragma @@ -9790,7 +9793,8 @@ package body Sem_Prag is if Chars (Argx) = Name_Ravenscar then Set_Ravenscar_Profile (N); elsif Chars (Argx) = Name_Restricted then - Set_Profile_Restrictions (Restricted, N, Warn => False); + Set_Profile_Restrictions + (Restricted, N, Warn => Treat_Restrictions_As_Warnings); else Error_Pragma_Arg ("& is not a valid profile", Argx); end if; @@ -10285,7 +10289,8 @@ package body Sem_Prag is GNAT_Pragma; Check_Arg_Count (0); Check_Valid_Configuration_Pragma; - Set_Profile_Restrictions (Restricted, N, Warn => False); + Set_Profile_Restrictions + (Restricted, N, Warn => Treat_Restrictions_As_Warnings); if Warn_On_Obsolescent_Feature then Error_Msg_N @@ -10305,7 +10310,8 @@ package body Sem_Prag is -- | restriction_parameter_IDENTIFIER => EXPRESSION when Pragma_Restrictions => - Process_Restrictions_Or_Restriction_Warnings (Warn => False); + Process_Restrictions_Or_Restriction_Warnings + (Warn => Treat_Restrictions_As_Warnings); -------------------------- -- Restriction_Warnings -- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 39cd89514fb..9cc285f1100 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6975,6 +6975,19 @@ package body Sem_Res is Error_Msg_N ("?not expression should be parenthesized here!", N); end if; + -- Warn on double negation if checking redundant constructs + + if Warn_On_Redundant_Constructs + and then Comes_From_Source (N) + and then Comes_From_Source (Right_Opnd (N)) + and then Root_Type (Typ) = Standard_Boolean + and then Nkind (Right_Opnd (N)) = N_Op_Not + then + Error_Msg_N ("redundant double negation?", N); + end if; + + -- Complete resolution and evaluation of NOT + Resolve (Right_Opnd (N), B_Typ); Check_Unset_Reference (Right_Opnd (N)); Set_Etype (N, B_Typ); diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index b118c37034a..c36125f52aa 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -39,6 +39,7 @@ with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Ch12; use Sem_Ch12; with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; with Sem_Util; use Sem_Util; with Stand; use Stand; with Sinfo; use Sinfo; @@ -403,10 +404,9 @@ package body Sem_Type is return; end if; - -- In an instance, an abstract non-dispatching operation cannot - -- be a candidate interpretation, because it could not have been - -- one in the generic (it may be a spurious overloading in the - -- instance). + -- In an instance, an abstract non-dispatching operation cannot be a + -- candidate interpretation, because it could not have been one in the + -- generic (it may be a spurious overloading in the instance). elsif In_Instance and then Is_Overloadable (E) @@ -415,9 +415,9 @@ package body Sem_Type is then return; - -- An inherited interface operation that is implemented by some - -- derived type does not participate in overload resolution, only - -- the implementation operation does. + -- An inherited interface operation that is implemented by some derived + -- type does not participate in overload resolution, only the + -- implementation operation does. elsif Is_Hidden (E) and then Is_Subprogram (E) @@ -438,6 +438,12 @@ package body Sem_Type is end if; return; + + -- Calling stubs for an RACW operation never participate in resolution, + -- they are executed only through dispatching calls. + + elsif Is_RACW_Stub_Type_Operation (E) then + return; end if; -- If this is the first interpretation of N, N has type Any_Type. @@ -681,9 +687,15 @@ package body Sem_Type is if All_Interp.Last = First_Interp + 1 then - -- The original interpretation is in fact not overloaded + -- The final interpretation is in fact not overloaded. Note that the + -- unique legal interpretation may or may not be the original one, + -- so we need to update N's entity and etype now, because once N + -- is marked as not overloaded it is also expected to carry the + -- proper interpretation. Set_Is_Overloaded (N, False); + Set_Entity (N, All_Interp.Table (First_Interp).Nam); + Set_Etype (N, All_Interp.Table (First_Interp).Typ); end if; end Collect_Interps; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index c335417d1b7..95fd0c59c9e 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1992,7 +1992,6 @@ package body Sem_Util is function Current_Subprogram return Entity_Id is Scop : constant Entity_Id := Current_Scope; - begin if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then return Scop; @@ -5510,6 +5509,41 @@ package body Sem_Util is end if; end Insert_Explicit_Dereference; + ------------------------------------------ + -- Inspect_Deferred_Constant_Completion -- + ------------------------------------------ + + procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is + Decl : Node_Id; + + begin + Decl := First (Decls); + while Present (Decl) loop + + -- Deferred constant signature + + if Nkind (Decl) = N_Object_Declaration + and then Constant_Present (Decl) + and then No (Expression (Decl)) + + -- No need to check internally generated constants + + and then Comes_From_Source (Decl) + + -- The constant is not completed. A full object declaration + -- or a pragma Import complete a deferred constant. + + and then not Has_Completion (Defining_Identifier (Decl)) + then + Error_Msg_N + ("constant declaration requires initialization expression", + Defining_Identifier (Decl)); + end if; + + Decl := Next (Decl); + end loop; + end Inspect_Deferred_Constant_Completion; + ------------------- -- Is_AAMP_Float -- ------------------- @@ -6740,60 +6774,13 @@ package body Sem_Util is function Is_Remote_Access_To_Class_Wide_Type (E : Entity_Id) return Boolean is - D : Entity_Id; - - function Comes_From_Limited_Private_Type_Declaration - (E : Entity_Id) return Boolean; - -- Check that the type is declared by a limited type declaration, - -- or else is derived from a Remote_Type ancestor through private - -- extensions. - - ------------------------------------------------- - -- Comes_From_Limited_Private_Type_Declaration -- - ------------------------------------------------- - - function Comes_From_Limited_Private_Type_Declaration - (E : Entity_Id) return Boolean - is - N : constant Node_Id := Declaration_Node (E); - - begin - if Nkind (N) = N_Private_Type_Declaration - and then Limited_Present (N) - then - return True; - end if; - - if Nkind (N) = N_Private_Extension_Declaration then - return - Comes_From_Limited_Private_Type_Declaration (Etype (E)) - or else - (Is_Remote_Types (Etype (E)) - and then Is_Limited_Record (Etype (E)) - and then Has_Private_Declaration (Etype (E))); - end if; - - return False; - end Comes_From_Limited_Private_Type_Declaration; - - -- Start of processing for Is_Remote_Access_To_Class_Wide_Type - begin - if not (Is_Remote_Call_Interface (E) - or else Is_Remote_Types (E)) - or else Ekind (E) /= E_General_Access_Type - then - return False; - end if; - - D := Designated_Type (E); - - if Ekind (D) /= E_Class_Wide_Type then - return False; - end if; + -- A remote access to class-wide type is a general access to object type + -- declared in the visible part of a Remote_Types or Remote_Call_ + -- Interface unit. - return Comes_From_Limited_Private_Type_Declaration - (Defining_Identifier (Parent (D))); + return Ekind (E) = E_General_Access_Type + and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); end Is_Remote_Access_To_Class_Wide_Type; ----------------------------------------- @@ -6807,8 +6794,7 @@ package body Sem_Util is return (Ekind (E) = E_Access_Subprogram_Type or else (Ekind (E) = E_Record_Type and then Present (Corresponding_Remote_Type (E)))) - and then (Is_Remote_Call_Interface (E) - or else Is_Remote_Types (E)); + and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); end Is_Remote_Access_To_Subprogram_Type; -------------------- @@ -6863,8 +6849,8 @@ package body Sem_Util is Subp_Decl : Node_Id := Parent (Parent (Proc_Nam)); function Is_Entry (Nam : Node_Id) return Boolean; - -- Determine whether Nam is an entry. Traverse selectors - -- if there are nested selected components. + -- Determine whether Nam is an entry. Traverse selectors if there are + -- nested selected components. -------------- -- Is_Entry -- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 866bd7f98a5..175b3156cd8 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -547,10 +547,10 @@ package Sem_Util is function Has_Overriding_Initialize (T : Entity_Id) return Boolean; -- Predicate to determine whether a controlled type has a user-defined - -- initialize procedure, which makes the type not preelaborable. + -- Initialize primitive, which makes the type not preelaborable. function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean; - -- Return True iff type E has preelaborable initialisation as defined in + -- Return True iff type E has preelaborable initialization as defined in -- Ada 2005 (see AI-161 for details of the definition of this attribute). function Has_Private_Component (Type_Id : Entity_Id) return Boolean; @@ -611,6 +611,11 @@ package Sem_Util is -- 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 + -- whether they have been completed by a full constant declaration or an + -- 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 diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 4686a7ac096..536118f9586 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -5797,9 +5797,9 @@ package Sinfo is -- Note: overriding indicator is an Ada 2005 feature - ------------------------------ - -- 12.3 Generic Actual Part -- - ------------------------------ + ------------------------------- + -- 12.3 Generic Actual Part -- + ------------------------------- -- GENERIC_ACTUAL_PART ::= -- (GENERIC_ASSOCIATION {, GENERIC_ASSOCIATION}) @@ -5812,9 +5812,10 @@ package Sinfo is -- [generic_formal_parameter_SELECTOR_NAME =>] -- Note: unlike the procedure call case, a generic association node - -- is generated for every association, even if no formal is present. - -- In this case the parser will leave the Selector_Name field set - -- to Empty, to be filled in later by the semantic pass. + -- is generated for every association, even if no formal parameter + -- selector name is present. In this case the parser will leave the + -- Selector_Name field set to Empty, to be filled in later by the + -- semantic pass. -- In Ada 2005, a formal may be associated with a box, if the -- association is part of the list of actuals for a formal package. diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index 3132f23ebde..7e589fbfd4c 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -771,6 +771,8 @@ package body Snames is "mapping_body_suffix#" & "metrics#" & "naming#" & + "object_generated#" & + "objects_linked#" & "objects_path#" & "objects_path_file#" & "object_dir#" & diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index 4d2a11ecb3e..17779913af6 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -1092,56 +1092,58 @@ package Snames is Name_Mapping_Body_Suffix : constant Name_Id := N + 710; Name_Metrics : constant Name_Id := N + 711; Name_Naming : constant Name_Id := N + 712; - Name_Objects_Path : constant Name_Id := N + 713; - Name_Objects_Path_File : constant Name_Id := N + 714; - Name_Object_Dir : constant Name_Id := N + 715; - Name_Pic_Option : constant Name_Id := N + 716; - Name_Pretty_Printer : constant Name_Id := N + 717; - Name_Prefix : constant Name_Id := N + 718; - Name_Project : constant Name_Id := N + 719; - Name_Roots : constant Name_Id := N + 720; - Name_Required_Switches : constant Name_Id := N + 721; - Name_Run_Path_Option : constant Name_Id := N + 722; - Name_Runtime_Project : constant Name_Id := N + 723; - Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 724; - Name_Shared_Library_Prefix : constant Name_Id := N + 725; - Name_Shared_Library_Suffix : constant Name_Id := N + 726; - Name_Separate_Suffix : constant Name_Id := N + 727; - Name_Source_Dirs : constant Name_Id := N + 728; - Name_Source_Files : constant Name_Id := N + 729; - Name_Source_List_File : constant Name_Id := N + 730; - Name_Spec : constant Name_Id := N + 731; - Name_Spec_Suffix : constant Name_Id := N + 732; - Name_Specification : constant Name_Id := N + 733; - Name_Specification_Exceptions : constant Name_Id := N + 734; - Name_Specification_Suffix : constant Name_Id := N + 735; - Name_Stack : constant Name_Id := N + 736; - Name_Switches : constant Name_Id := N + 737; - Name_Symbolic_Link_Supported : constant Name_Id := N + 738; - Name_Sync : constant Name_Id := N + 739; - Name_Synchronize : constant Name_Id := N + 740; - Name_Toolchain_Description : constant Name_Id := N + 741; - Name_Toolchain_Version : constant Name_Id := N + 742; - Name_Runtime_Library_Dir : constant Name_Id := N + 743; + Name_Object_Generated : constant Name_Id := N + 713; + Name_Objects_Linked : constant Name_Id := N + 714; + Name_Objects_Path : constant Name_Id := N + 715; + Name_Objects_Path_File : constant Name_Id := N + 716; + Name_Object_Dir : constant Name_Id := N + 717; + Name_Pic_Option : constant Name_Id := N + 718; + Name_Pretty_Printer : constant Name_Id := N + 719; + Name_Prefix : constant Name_Id := N + 720; + Name_Project : constant Name_Id := N + 721; + Name_Roots : constant Name_Id := N + 722; + Name_Required_Switches : constant Name_Id := N + 723; + Name_Run_Path_Option : constant Name_Id := N + 724; + Name_Runtime_Project : constant Name_Id := N + 725; + Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 726; + Name_Shared_Library_Prefix : constant Name_Id := N + 727; + Name_Shared_Library_Suffix : constant Name_Id := N + 728; + Name_Separate_Suffix : constant Name_Id := N + 729; + Name_Source_Dirs : constant Name_Id := N + 730; + Name_Source_Files : constant Name_Id := N + 731; + Name_Source_List_File : constant Name_Id := N + 732; + Name_Spec : constant Name_Id := N + 733; + Name_Spec_Suffix : constant Name_Id := N + 734; + Name_Specification : constant Name_Id := N + 735; + Name_Specification_Exceptions : constant Name_Id := N + 736; + Name_Specification_Suffix : constant Name_Id := N + 737; + Name_Stack : constant Name_Id := N + 738; + Name_Switches : constant Name_Id := N + 739; + Name_Symbolic_Link_Supported : constant Name_Id := N + 740; + Name_Sync : constant Name_Id := N + 741; + Name_Synchronize : constant Name_Id := N + 742; + Name_Toolchain_Description : constant Name_Id := N + 743; + Name_Toolchain_Version : constant Name_Id := N + 744; + Name_Runtime_Library_Dir : constant Name_Id := N + 745; -- Other miscellaneous names used in front end - Name_Unaligned_Valid : constant Name_Id := N + 744; + Name_Unaligned_Valid : constant Name_Id := N + 746; -- Ada 2005 reserved words - First_2005_Reserved_Word : constant Name_Id := N + 745; - Name_Interface : constant Name_Id := N + 745; - Name_Overriding : constant Name_Id := N + 746; - Name_Synchronized : constant Name_Id := N + 747; - Last_2005_Reserved_Word : constant Name_Id := N + 747; + First_2005_Reserved_Word : constant Name_Id := N + 747; + Name_Interface : constant Name_Id := N + 747; + Name_Overriding : constant Name_Id := N + 748; + Name_Synchronized : constant Name_Id := N + 749; + Last_2005_Reserved_Word : constant Name_Id := N + 749; subtype Ada_2005_Reserved_Words is Name_Id range First_2005_Reserved_Word .. Last_2005_Reserved_Word; -- Mark last defined name for consistency check in Snames body - Last_Predefined_Name : constant Name_Id := N + 747; + Last_Predefined_Name : constant Name_Id := N + 749; --------------------------------------- -- Subtypes Defining Name Categories -- diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 2ead1c33019..0545f2585cd 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -3732,7 +3732,14 @@ package body Sprint is end loop; Write_Str (") of "); - Sprint_Node (Component_Type (Typ)); + X := Component_Type (Typ); + + -- Preserve sloc of component type, which is defined + -- elsewhere than the itype (see comment above). + + Old_Sloc := Sloc (X); + Sprint_Node (X); + Set_Sloc (X, Old_Sloc); -- Array subtypes and string subtypes diff --git a/gcc/ada/styleg-c.adb b/gcc/ada/styleg-c.adb index ca33050dcc3..003a75140d5 100644 --- a/gcc/ada/styleg-c.adb +++ b/gcc/ada/styleg-c.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -175,8 +175,10 @@ package body Styleg.C is -- Case of definition in package Standard - elsif Sdef = Standard_Location then - + elsif Sdef = Standard_Location + or else + Sdef = Standard_ASCII_Location + then -- Check case of identifiers in Standard if Style_Check_Standard then @@ -190,19 +192,14 @@ package body Styleg.C is -- Otherwise determine required casing of Standard entity else - -- ASCII entities are in all upper case + -- ASCII is all upper case if Entity (Ref) = Standard_ASCII then Cas := All_Upper_Case; -- Special names in ASCII are also all upper case - elsif Entity (Ref) in SE (S_LC_A) .. SE (S_LC_Z) - or else - Entity (Ref) in SE (S_NUL) .. SE (S_US) - or else - Entity (Ref) = SE (S_DEL) - then + elsif Sdef = Standard_ASCII_Location then Cas := All_Upper_Case; -- All other entities are in mixed case diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index bd63fae88f8..cf59c8198cd 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2008, 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- -- @@ -660,13 +660,19 @@ package body Switch.C is Ptr := Ptr + 1; Try_Semantics := True; - -- Processing for q switch + -- Processing for Q switch when 'Q' => Ptr := Ptr + 1; Force_ALI_Tree_File := True; Try_Semantics := True; + -- Processing for r switch + + when 'r' => + Ptr := Ptr + 1; + Treat_Restrictions_As_Warnings := True; + -- Processing for R switch when 'R' => diff --git a/gcc/ada/system-linux-ppc.ads b/gcc/ada/system-linux-ppc.ads index 599bdcc9dc3..08c08a36068 100644 --- a/gcc/ada/system-linux-ppc.ads +++ b/gcc/ada/system-linux-ppc.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/PPC Version) -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -139,7 +139,7 @@ private Preallocated_Stacks : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_64_Bit_Divides : constant Boolean := True; Support_Aggregates : constant Boolean := True; diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c index 65c1828badd..8a69057ed77 100644 --- a/gcc/ada/tracebak.c +++ b/gcc/ada/tracebak.c @@ -6,8 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2000-2007, AdaCore * - * Copyright (C) 2008, Free Software Foundation, Inc. * + * Copyright (C) 2000-2008, 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- * @@ -230,9 +229,10 @@ struct layout #define BASE_SKIP 1 -/*---------------------------- PPC VxWorks------------------------------*/ +/*-------------------- PPC ELF (GNU/Linux & VxWorks) ---------------------*/ -#elif defined (_ARCH_PPC) && defined (__vxworks) +#elif (defined (_ARCH_PPC) && defined (__vxworks)) || \ + (defined (linux) && defined (__powerpc__)) #define USE_GENERIC_UNWINDER diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index f7dd9b9aadf..76592fe2b46 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -4777,45 +4777,71 @@ gnat_to_gnu (Node_Id gnat_node) break; case N_Validate_Unchecked_Conversion: - /* If the result is a pointer type, see if we are either converting - from a non-pointer or from a pointer to a type with a different - alias set and warn if so. If the result defined in the same unit as - this unchecked conversion, we can allow this because we can know to - make that type have alias set 0. */ { + Entity_Id gnat_target_type = Target_Type (gnat_node); tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node)); - tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node)); - - if (POINTER_TYPE_P (gnu_target_type) - && !In_Same_Source_Unit (Target_Type (gnat_node), gnat_node) - && get_alias_set (TREE_TYPE (gnu_target_type)) != 0 - && !No_Strict_Aliasing (Underlying_Type (Target_Type (gnat_node))) - && (!POINTER_TYPE_P (gnu_source_type) - || (get_alias_set (TREE_TYPE (gnu_source_type)) - != get_alias_set (TREE_TYPE (gnu_target_type))))) + tree gnu_target_type = gnat_to_gnu_type (gnat_target_type); + + /* No need for any warning in this case. */ + if (!flag_strict_aliasing) + ; + + /* If the result is a pointer type, see if we are either converting + from a non-pointer or from a pointer to a type with a different + alias set and warn if so. If the result is defined in the same + unit as this unchecked conversion, we can allow this because we + can know to make the pointer type behave properly. */ + else if (POINTER_TYPE_P (gnu_target_type) + && !In_Same_Source_Unit (gnat_target_type, gnat_node) + && !No_Strict_Aliasing (Underlying_Type (gnat_target_type))) { - post_error_ne - ("?possible aliasing problem for type&", - gnat_node, Target_Type (gnat_node)); - post_error - ("\\?use -fno-strict-aliasing switch for references", - gnat_node); - post_error_ne - ("\\?or use `pragma No_Strict_Aliasing (&);`", - gnat_node, Target_Type (gnat_node)); + tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type) + ? TREE_TYPE (gnu_source_type) + : NULL_TREE; + tree gnu_target_desig_type = TREE_TYPE (gnu_target_type); + + if ((TYPE_DUMMY_P (gnu_target_desig_type) + || get_alias_set (gnu_target_desig_type) != 0) + && (!POINTER_TYPE_P (gnu_source_type) + || (TYPE_DUMMY_P (gnu_source_desig_type) + != TYPE_DUMMY_P (gnu_target_desig_type)) + || (TYPE_DUMMY_P (gnu_source_desig_type) + && gnu_source_desig_type != gnu_target_desig_type) + || (get_alias_set (gnu_source_desig_type) + != get_alias_set (gnu_target_desig_type)))) + { + post_error_ne + ("?possible aliasing problem for type&", + gnat_node, Target_Type (gnat_node)); + post_error + ("\\?use -fno-strict-aliasing switch for references", + gnat_node); + post_error_ne + ("\\?or use `pragma No_Strict_Aliasing (&);`", + gnat_node, Target_Type (gnat_node)); + } } - /* The No_Strict_Aliasing flag is not propagated to the back-end for - fat pointers so unconditionally warn in problematic cases. */ + /* But if the result is a fat pointer type, we have no mechanism to + do that, so we unconditionally warn in problematic cases. */ else if (TYPE_FAT_POINTER_P (gnu_target_type)) { - tree array_type + tree gnu_source_array_type + = TYPE_FAT_POINTER_P (gnu_source_type) + ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type))) + : NULL_TREE; + tree gnu_target_array_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type))); - if (get_alias_set (array_type) != 0 + if ((TYPE_DUMMY_P (gnu_target_array_type) + || get_alias_set (gnu_target_array_type) != 0) && (!TYPE_FAT_POINTER_P (gnu_source_type) - || (get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))) - != get_alias_set (array_type)))) + || (TYPE_DUMMY_P (gnu_source_array_type) + != TYPE_DUMMY_P (gnu_target_array_type)) + || (TYPE_DUMMY_P (gnu_source_array_type) + && gnu_source_array_type != gnu_target_array_type) + || (get_alias_set (gnu_source_array_type) + != get_alias_set (gnu_target_array_type)))) { post_error_ne ("?possible aliasing problem for type&", diff --git a/gcc/ada/ug_words b/gcc/ada/ug_words index c167596477a..7f8e9577e86 100644 --- a/gcc/ada/ug_words +++ b/gcc/ada/ug_words @@ -89,6 +89,7 @@ gcc -c ^ GNAT COMPILE -gnatR3 ^ /REPRESENTATION_INFO=SYMBOLIC -gnatq ^ /TRY_SEMANTICS -gnatQ ^ /FORCE_ALI +-gnatr ^ /TREAT_RESTRICTIONS_AS_WARNINGS -gnats ^ /SYNTAX_ONLY -gnatS ^ /PRINT_STANDARD -gnatt ^ /TREE_OUTPUT @@ -177,6 +178,7 @@ gcc -c ^ GNAT COMPILE -gnatW8 ^ /WIDE_CHARACTER_ENCODING=UTF8 -gnatW? ^ /WIDE_CHARACTER_ENCODING=? -gnaty ^ /STYLE_CHECKS +-gnatyy ^ /STYLE_CHECKS=ALL_BUILTIN -gnatZ ^ /ZERO_COST_EXCEPTIONS -gnatzc ^ /DISTRIBUTION_STUBS=CALLER -gnatzr ^ /DISTRIBUTION_STUBS=RECEIVER diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb index ffc636771d1..416d5d88681 100644 --- a/gcc/ada/uintp.adb +++ b/gcc/ada/uintp.adb @@ -683,14 +683,11 @@ package body Uintp is begin Release (M); - Uints.Increment_Last; + Uints.Append ((Length => UE_Len, Loc => Udigits.Last + 1)); UI := Uints.Last; - Uints.Table (UI) := (UE_Len, Udigits.Last + 1); - for J in 1 .. UE_Len loop - Udigits.Increment_Last; - Udigits.Table (Udigits.Last) := UD (J); + Udigits.Append (UD (J)); end loop; end; end if; @@ -721,24 +718,18 @@ package body Uintp is begin Release (M); - Uints.Increment_Last; + Uints.Append ((Length => UE1_Len, Loc => Udigits.Last + 1)); UI1 := Uints.Last; - Uints.Table (UI1) := (UE1_Len, Udigits.Last + 1); - for J in 1 .. UE1_Len loop - Udigits.Increment_Last; - Udigits.Table (Udigits.Last) := UD1 (J); + Udigits.Append (UD1 (J)); end loop; - Uints.Increment_Last; + Uints.Append ((Length => UE2_Len, Loc => Udigits.Last + 1)); UI2 := Uints.Last; - Uints.Table (UI2) := (UE2_Len, Udigits.Last + 1); - for J in 1 .. UE2_Len loop - Udigits.Increment_Last; - Udigits.Table (Udigits.Last) := UD2 (J); + Udigits.Append (UD2 (J)); end loop; end; end if; @@ -2745,21 +2736,18 @@ package body Uintp is -- the count and digits. The index of the new table entry will be -- returned as the result. - Uints.Increment_Last; - Uints.Table (Uints.Last).Length := Size; - Uints.Table (Uints.Last).Loc := Udigits.Last + 1; - - Udigits.Increment_Last; + Uints.Append ((Length => Size, Loc => Udigits.Last + 1)); if Negative then - Udigits.Table (Udigits.Last) := -In_Vec (J); + Val := -In_Vec (J); else - Udigits.Table (Udigits.Last) := +In_Vec (J); + Val := +In_Vec (J); end if; + Udigits.Append (Val); + for K in 2 .. Size loop - Udigits.Increment_Last; - Udigits.Table (Udigits.Last) := In_Vec (J + K - 1); + Udigits.Append (In_Vec (J + K - 1)); end loop; return Uints.Last; diff --git a/gcc/ada/urealp.adb b/gcc/ada/urealp.adb index 737e4b4e80e..17dd9178e2c 100644 --- a/gcc/ada/urealp.adb +++ b/gcc/ada/urealp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -441,8 +441,7 @@ package body Urealp is function Store_Ureal (Val : Ureal_Entry) return Ureal is begin - Ureals.Increment_Last; - Ureals.Table (Ureals.Last) := Val; + Ureals.Append (Val); -- Normalize representation of signed values diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 0d131e1f2e5..5a1f4827eab 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -289,6 +289,11 @@ begin Write_Switch_Char ("Q"); Write_Line ("Don't quit, write ali/tree file even if compile errors"); + -- Line for -gnatr switch + + Write_Switch_Char ("r"); + Write_Line ("Treat pragma Restrictions as Restriction_Warnings"); + -- Lines for -gnatR switch Write_Switch_Char ("R?"); diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 4a48396aec7..545080f11f6 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -881,154 +881,6 @@ package VMS_Data is S_Check_Verb 'Access); ---------------------------- - -- Switches for GNAT SYNC -- - ---------------------------- - - S_Sync_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & - "-aP*"; - -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) - -- - -- Add directories to the project search path. - - S_Sync_All : aliased constant S := "/ALL " & - "-a"; - -- /NOALL (D) - -- /ALL - -- - -- Also check the components of the GNAT run time and process the needed - -- components of the GNAT RTL when building and analyzing the global - -- structure for checking the global rules. - - S_Sync_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & - "-X" & '"'; - -- /EXTERNAL_REFERENCE="name=val" - -- - -- Specifies an external reference to the project manager. Useful only if - -- /PROJECT_FILE is used. - -- - -- Example: - -- /EXTERNAL_REFERENCE="DEBUG=TRUE" - - S_Sync_Files : aliased constant S := "/FILES=@" & - "-files=@"; - -- /FILES=filename - -- - -- Take as arguments the files that are listed in the specified - -- text file. - - S_Sync_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & - "-eL"; - -- /NOFOLLOW_LINKS_FOR_FILES (D) - -- /FOLLOW_LINKS_FOR_FILES - -- - -- Follow links when parsing project files - - S_Sync_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & - "DEFAULT " & - "-vP0 " & - "MEDIUM " & - "-vP1 " & - "HIGH " & - "-vP2"; - -- /MESSAGES_PROJECT_FILE[=messages-option] - -- - -- Specifies the "verbosity" of the parsing of project files. - -- messages-option may be one of the following: - -- - -- DEFAULT (D) No messages are output if there is no error or warning. - -- - -- MEDIUM A small number of messages are output. - -- - -- HIGH A great number of messages are output, most of them not - -- being useful for the user. - - S_Sync_Project : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; - -- /PROJECT_FILE=filename - -- - -- Specifies the main project file to be used. The project files rooted - -- at the main project file will be parsed before the invocation of the - -- gnatcheck. The source directories to be searched will be communicated - -- to gnatcheck through logical name ADA_PRJ_INCLUDE_FILE. - - S_Sync_Quiet : aliased constant S := "/QUIET " & - "-q"; - -- /NOQUIET (D) - -- /QUIET - -- - -- Work quietly, only output warnings and errors. - - S_Sync_Subdirs : aliased constant S := "/SUBDIRS=<" & - "--subdirs=>"; - -- /SUBDIRS=dir - -- - -- The actual directories (object, exec, library, ...) are subdirectories - -- of the directory specified in the project file. If the subdirectory - -- does not exist, it is created automatically. - - S_Sync_Verb : aliased constant S := "/VERBOSE " & - "-v"; - -- /NOVERBOSE (D) - -- /VERBOSE - -- - -- The version number and copyright notice are output, as well as exact - -- copies of the gnat1 commands spawned to obtain the chop control - -- information. - - S_Sync_Exec : aliased constant S := "/EXECUTION_TIME " & - "-t"; - -- /NOEXECUTION_TIME (D) - -- /EXECUTION_TIME - -- - -- Output the execution time - - S_Sync_Details : aliased constant S := "/DETAILs=" & - "MEDIUM " & - "-om " & - "SHORT " & - "-os " & - "FULL " & - "-of"; - -- /DETAILS[=options] - -- - -- Specifies the details of the output. - -- Options may be one of the following: - -- - -- MEDIUM (D) - -- SHORT - -- FULL - - S_Sync_Warnoff : aliased constant S := "/WARNINGS_OFF " & - "-wq"; - -- - -- /WARNINGS_OFF - -- - -- Turn warnings off - - S_Sync_Output : aliased constant S := "/OUTPUT_FILE=<" & - "-out_file=>"; - -- - -- /OUTPUT_FILE=filename - -- - -- Redirect output to a text file - - Sync_Switches : aliased constant Switches := - (S_Sync_Add 'Access, - S_Sync_All 'Access, - S_Sync_Ext 'Access, - S_Sync_Follow 'Access, - S_Sync_Files 'Access, - S_Sync_Mess 'Access, - S_Sync_Project 'Access, - S_Sync_Quiet 'Access, - S_Sync_Subdirs 'Access, - S_Sync_Verb 'Access, - S_Sync_Exec 'Access, - S_Sync_Details 'Access, - S_Sync_Warnoff 'Access, - S_Sync_Output 'Access); - - ---------------------------- -- Switches for GNAT CHOP -- ---------------------------- @@ -2109,6 +1961,16 @@ package VMS_Data is -- readable to any Ada programmer, and is useful to determine the -- characteristics of target dependent types in package Standard. + S_GCC_Reswarn : aliased constant S := "/TREAT_RESTRICTIONS_AS_WARNINGS " & + "-gnatr"; + + -- /NO_TREAT_RESTRICTIONS_AS_WARNINGS (D) + -- /TREAT_RESTRICTIONS_AS_WARNINGS + -- + -- Causes all restrictions to be treated as warnings (pragma Restriction + -- treated as Restriction_Warnings, pragma Profile as Profile_Warnings, + -- and pragma Ravenscar sets restriction warnings instead of restrictions) + S_GCC_Report : aliased constant S := "/REPORT_ERRORS=" & "VERBOSE " & "-gnatv " & @@ -4440,6 +4302,17 @@ package VMS_Data is -- Put all object files and .ALI files in <file>. -- This qualifier is not compatible with /PROJECT_FILE. + S_Make_Disprog : aliased constant S := "/DISPLAY_PROGRESS " & + "-d"; + -- /NOPLAY_PROGRESS (D) + -- /DISPLAY_PROGRESS + -- + -- Display progress for each source, up to date or not, as a single line + -- completed x out of y (zz%) + -- If the file needs to be compiled this is displayed after the + -- invocation of the compiler. These lines are displayed even in quiet + -- output mode (/QUIET). + S_Make_Doobj : aliased constant S := "/DO_OBJECT_CHECK " & "-n"; -- /NODO_OBJECT_CHECK (D) @@ -4801,6 +4674,7 @@ package VMS_Data is S_Make_Current 'Access, S_Make_Dep 'Access, S_Make_Dirobj 'Access, + S_Make_Disprog 'Access, S_Make_Doobj 'Access, S_Make_Execut 'Access, S_Make_Ext 'Access, @@ -6626,6 +6500,154 @@ package VMS_Data is S_Stub_Verbose 'Access); ---------------------------- + -- Switches for GNAT SYNC -- + ---------------------------- + + S_Sync_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & + "-aP*"; + -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) + -- + -- Add directories to the project search path. + + S_Sync_All : aliased constant S := "/ALL " & + "-a"; + -- /NOALL (D) + -- /ALL + -- + -- Also check the components of the GNAT run time and process the needed + -- components of the GNAT RTL when building and analyzing the global + -- structure for checking the global rules. + + S_Sync_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & + "-X" & '"'; + -- /EXTERNAL_REFERENCE="name=val" + -- + -- Specifies an external reference to the project manager. Useful only if + -- /PROJECT_FILE is used. + -- + -- Example: + -- /EXTERNAL_REFERENCE="DEBUG=TRUE" + + S_Sync_Files : aliased constant S := "/FILES=@" & + "-files=@"; + -- /FILES=filename + -- + -- Take as arguments the files that are listed in the specified + -- text file. + + S_Sync_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & + "-eL"; + -- /NOFOLLOW_LINKS_FOR_FILES (D) + -- /FOLLOW_LINKS_FOR_FILES + -- + -- Follow links when parsing project files + + S_Sync_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & + "DEFAULT " & + "-vP0 " & + "MEDIUM " & + "-vP1 " & + "HIGH " & + "-vP2"; + -- /MESSAGES_PROJECT_FILE[=messages-option] + -- + -- Specifies the "verbosity" of the parsing of project files. + -- messages-option may be one of the following: + -- + -- DEFAULT (D) No messages are output if there is no error or warning. + -- + -- MEDIUM A small number of messages are output. + -- + -- HIGH A great number of messages are output, most of them not + -- being useful for the user. + + S_Sync_Project : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + -- /PROJECT_FILE=filename + -- + -- Specifies the main project file to be used. The project files rooted + -- at the main project file will be parsed before the invocation of the + -- gnatcheck. The source directories to be searched will be communicated + -- to gnatcheck through logical name ADA_PRJ_INCLUDE_FILE. + + S_Sync_Quiet : aliased constant S := "/QUIET " & + "-q"; + -- /NOQUIET (D) + -- /QUIET + -- + -- Work quietly, only output warnings and errors. + + S_Sync_Subdirs : aliased constant S := "/SUBDIRS=<" & + "--subdirs=>"; + -- /SUBDIRS=dir + -- + -- The actual directories (object, exec, library, ...) are subdirectories + -- of the directory specified in the project file. If the subdirectory + -- does not exist, it is created automatically. + + S_Sync_Verb : aliased constant S := "/VERBOSE " & + "-v"; + -- /NOVERBOSE (D) + -- /VERBOSE + -- + -- The version number and copyright notice are output, as well as exact + -- copies of the gnat1 commands spawned to obtain the chop control + -- information. + + S_Sync_Exec : aliased constant S := "/EXECUTION_TIME " & + "-t"; + -- /NOEXECUTION_TIME (D) + -- /EXECUTION_TIME + -- + -- Output the execution time + + S_Sync_Details : aliased constant S := "/DETAILs=" & + "MEDIUM " & + "-om " & + "SHORT " & + "-os " & + "FULL " & + "-of"; + -- /DETAILS[=options] + -- + -- Specifies the details of the output. + -- Options may be one of the following: + -- + -- MEDIUM (D) + -- SHORT + -- FULL + + S_Sync_Warnoff : aliased constant S := "/WARNINGS_OFF " & + "-wq"; + -- + -- /WARNINGS_OFF + -- + -- Turn warnings off + + S_Sync_Output : aliased constant S := "/OUTPUT_FILE=<" & + "-out_file=>"; + -- + -- /OUTPUT_FILE=filename + -- + -- Redirect output to a text file + + Sync_Switches : aliased constant Switches := + (S_Sync_Add 'Access, + S_Sync_All 'Access, + S_Sync_Ext 'Access, + S_Sync_Follow 'Access, + S_Sync_Files 'Access, + S_Sync_Mess 'Access, + S_Sync_Project 'Access, + S_Sync_Quiet 'Access, + S_Sync_Subdirs 'Access, + S_Sync_Verb 'Access, + S_Sync_Exec 'Access, + S_Sync_Details 'Access, + S_Sync_Warnoff 'Access, + S_Sync_Output 'Access); + + ---------------------------- -- Switches for GNAT XREF -- ---------------------------- diff --git a/gcc/basilys.h b/gcc/basilys.h index 1119d435a63..74c76e7704f 100644 --- a/gcc/basilys.h +++ b/gcc/basilys.h @@ -45,6 +45,10 @@ along with GCC; see the file COPYING3. If not see *****/ +/* declared in toplev.h which we want to avoid #include-ing */ +extern void fatal_error (const char *, ...) ATTRIBUTE_GCC_DIAG(1,2) + ATTRIBUTE_NORETURN; + /* use -fdump-ipa-basilys */ #define dbgprintf_raw(Fmt,...) do{if (dump_file) \ diff --git a/gcc/builtins.c b/gcc/builtins.c index 4211e6247a1..3060f80ae00 100644 --- a/gcc/builtins.c +++ b/gcc/builtins.c @@ -1669,10 +1669,15 @@ expand_builtin_classify_type (tree exp) fcodel = BUILT_IN_MATHFN##L_R ; break; /* Return mathematic function equivalent to FN but operating directly - on TYPE, if available. If we can't do the conversion, return zero. */ -tree -mathfn_built_in (tree type, enum built_in_function fn) + on TYPE, if available. If IMPLICIT is true find the function in + implicit_built_in_decls[], otherwise use built_in_decls[]. If we + can't do the conversion, return zero. */ + +static tree +mathfn_built_in_1 (tree type, enum built_in_function fn, bool implicit) { + tree const *const fn_arr + = implicit ? implicit_built_in_decls : built_in_decls; enum built_in_function fcode, fcodef, fcodel; switch (fn) @@ -1747,6 +1752,7 @@ mathfn_built_in (tree type, enum built_in_function fn) CASE_MATHFN (BUILT_IN_SCALB) CASE_MATHFN (BUILT_IN_SCALBLN) CASE_MATHFN (BUILT_IN_SCALBN) + CASE_MATHFN (BUILT_IN_SIGNBIT) CASE_MATHFN (BUILT_IN_SIGNIFICAND) CASE_MATHFN (BUILT_IN_SIN) CASE_MATHFN (BUILT_IN_SINCOS) @@ -1765,15 +1771,23 @@ mathfn_built_in (tree type, enum built_in_function fn) } if (TYPE_MAIN_VARIANT (type) == double_type_node) - return implicit_built_in_decls[fcode]; + return fn_arr[fcode]; else if (TYPE_MAIN_VARIANT (type) == float_type_node) - return implicit_built_in_decls[fcodef]; + return fn_arr[fcodef]; else if (TYPE_MAIN_VARIANT (type) == long_double_type_node) - return implicit_built_in_decls[fcodel]; + return fn_arr[fcodel]; else return NULL_TREE; } +/* Like mathfn_built_in_1(), but always use the implicit array. */ + +tree +mathfn_built_in (tree type, enum built_in_function fn) +{ + return mathfn_built_in_1 (type, fn, /*implicit=*/ 1); +} + /* If errno must be maintained, expand the RTL to check if the result, TARGET, of a built-in function call, EXP, is NaN, and if so set errno to EDOM. */ @@ -9668,6 +9682,37 @@ fold_builtin_classify (tree fndecl, tree arg, int builtin_index) return NULL_TREE; + case BUILT_IN_ISINF_SIGN: + { + /* isinf_sign(x) -> isinf(x) ? (signbit(x) ? -1 : 1) : 0 */ + /* In a boolean context, GCC will fold the inner COND_EXPR to + 1. So e.g. "if (isinf_sign(x))" would be folded to just + "if (isinf(x) ? 1 : 0)" which becomes "if (isinf(x))". */ + tree signbit_fn = mathfn_built_in_1 (TREE_TYPE (arg), BUILT_IN_SIGNBIT, 0); + tree isinf_fn = built_in_decls[BUILT_IN_ISINF]; + tree tmp = NULL_TREE; + + arg = builtin_save_expr (arg); + + if (signbit_fn && isinf_fn) + { + tree signbit_call = build_call_expr (signbit_fn, 1, arg); + tree isinf_call = build_call_expr (isinf_fn, 1, arg); + + signbit_call = fold_build2 (NE_EXPR, integer_type_node, + signbit_call, integer_zero_node); + isinf_call = fold_build2 (NE_EXPR, integer_type_node, + isinf_call, integer_zero_node); + + tmp = fold_build3 (COND_EXPR, integer_type_node, signbit_call, + integer_minus_one_node, integer_one_node); + tmp = fold_build3 (COND_EXPR, integer_type_node, isinf_call, tmp, + integer_zero_node); + } + + return tmp; + } + case BUILT_IN_ISFINITE: if (!HONOR_NANS (TYPE_MODE (TREE_TYPE (arg))) && !HONOR_INFINITIES (TYPE_MODE (TREE_TYPE (arg)))) @@ -10074,6 +10119,9 @@ fold_builtin_1 (tree fndecl, tree arg0, bool ignore) case BUILT_IN_ISINFD128: return fold_builtin_classify (fndecl, arg0, BUILT_IN_ISINF); + case BUILT_IN_ISINF_SIGN: + return fold_builtin_classify (fndecl, arg0, BUILT_IN_ISINF_SIGN); + CASE_FLT_FN (BUILT_IN_ISNAN): case BUILT_IN_ISNAND32: case BUILT_IN_ISNAND64: diff --git a/gcc/builtins.def b/gcc/builtins.def index 722f81c7e3e..8bae2bd467c 100644 --- a/gcc/builtins.def +++ b/gcc/builtins.def @@ -655,6 +655,7 @@ DEF_EXT_LIB_BUILTIN (BUILT_IN_FINITED32, "finited32", BT_FN_INT_DFLOAT32, ATT DEF_EXT_LIB_BUILTIN (BUILT_IN_FINITED64, "finited64", BT_FN_INT_DFLOAT64, ATTR_CONST_NOTHROW_LIST) DEF_EXT_LIB_BUILTIN (BUILT_IN_FINITED128, "finited128", BT_FN_INT_DFLOAT128, ATTR_CONST_NOTHROW_LIST) DEF_GCC_BUILTIN (BUILT_IN_ISFINITE, "isfinite", BT_FN_INT_VAR, ATTR_CONST_NOTHROW_TYPEGENERIC) +DEF_GCC_BUILTIN (BUILT_IN_ISINF_SIGN, "isinf_sign", BT_FN_INT_VAR, ATTR_CONST_NOTHROW_TYPEGENERIC) DEF_C99_C90RES_BUILTIN (BUILT_IN_ISINF, "isinf", BT_FN_INT_VAR, ATTR_CONST_NOTHROW_TYPEGENERIC) DEF_EXT_LIB_BUILTIN (BUILT_IN_ISINFF, "isinff", BT_FN_INT_FLOAT, ATTR_CONST_NOTHROW_LIST) DEF_EXT_LIB_BUILTIN (BUILT_IN_ISINFL, "isinfl", BT_FN_INT_LONGDOUBLE, ATTR_CONST_NOTHROW_LIST) diff --git a/gcc/c-common.c b/gcc/c-common.c index 415807f1c5b..67c9c0b538f 100644 --- a/gcc/c-common.c +++ b/gcc/c-common.c @@ -6674,6 +6674,7 @@ check_builtin_function_arguments (tree fndecl, int nargs, tree *args) case BUILT_IN_ISFINITE: case BUILT_IN_ISINF: + case BUILT_IN_ISINF_SIGN: case BUILT_IN_ISNAN: case BUILT_IN_ISNORMAL: if (validate_nargs (fndecl, nargs, 1)) diff --git a/gcc/c-incpath.c b/gcc/c-incpath.c index f8b524d6e11..4d055542820 100644 --- a/gcc/c-incpath.c +++ b/gcc/c-incpath.c @@ -37,15 +37,18 @@ #ifdef VMS # define INO_T_EQ(A, B) (!memcmp (&(A), &(B), sizeof (A))) # define INO_T_COPY(DEST, SRC) memcpy(&(DEST), &(SRC), sizeof (SRC)) -#else -# if (defined _WIN32 && !defined (_UWIN)) || defined __MSDOS__ -# define INO_T_EQ(A, B) 0 -# else -# define INO_T_EQ(A, B) ((A) == (B)) -# endif +#elif !((defined _WIN32 && !defined (_UWIN)) || defined __MSDOS__) +# define INO_T_EQ(A, B) ((A) == (B)) # define INO_T_COPY(DEST, SRC) (DEST) = (SRC) #endif +#if defined INO_T_EQ +#define DIRS_EQ(A, B) ((A)->dev == (B)->dev \ + && INO_T_EQ((A)->ino, (B)->ino)) +#else +#define DIRS_EQ(A, B) (!strcasecmp ((A)->name, (B)->name)) +#endif + static const char dir_separator_str[] = { DIR_SEPARATOR, 0 }; static void add_env_var_paths (const char *, int); @@ -241,14 +244,15 @@ remove_duplicates (cpp_reader *pfile, struct cpp_dir *head, "%s: not a directory", cur->name); else { +#if defined (INO_T_COPY) INO_T_COPY (cur->ino, st.st_ino); cur->dev = st.st_dev; +#endif /* Remove this one if it is in the system chain. */ reason = REASON_DUP_SYS; for (tmp = system; tmp; tmp = tmp->next) - if (INO_T_EQ (tmp->ino, cur->ino) && tmp->dev == cur->dev - && cur->construct == tmp->construct) + if (DIRS_EQ (tmp, cur) && cur->construct == tmp->construct) break; if (!tmp) @@ -256,16 +260,14 @@ remove_duplicates (cpp_reader *pfile, struct cpp_dir *head, /* Duplicate of something earlier in the same chain? */ reason = REASON_DUP; for (tmp = head; tmp != cur; tmp = tmp->next) - if (INO_T_EQ (cur->ino, tmp->ino) && cur->dev == tmp->dev - && cur->construct == tmp->construct) + if (DIRS_EQ (cur, tmp) && cur->construct == tmp->construct) break; if (tmp == cur /* Last in the chain and duplicate of JOIN? */ && !(cur->next == NULL && join - && INO_T_EQ (cur->ino, join->ino) - && cur->dev == join->dev - && cur->construct == join->construct)) + && DIRS_EQ (cur, join) + && cur->construct == join->construct)) { /* Unique, so keep this directory. */ pcur = &cur->next; @@ -297,8 +299,8 @@ add_sysroot_to_chain (const char *sysroot, int chain) } /* Merge the four include chains together in the order quote, bracket, - system, after. Remove duplicate dirs (as determined by - INO_T_EQ()). + system, after. Remove duplicate dirs (determined in + system-specific manner). We can't just merge the lists and then uniquify them because then we may lose directories from the <> search path that should be diff --git a/gcc/cfgexpand.c b/gcc/cfgexpand.c index 3e36985b3d8..69a911eac8e 100644 --- a/gcc/cfgexpand.c +++ b/gcc/cfgexpand.c @@ -1920,9 +1920,9 @@ tree_expand_cfg (void) /* We're done expanding trees to RTL. */ currently_expanding_to_rtl = 0; - /* Convert tree EH labels to RTL EH labels, and clean out any unreachable - EH regions. */ + /* Convert tree EH labels to RTL EH labels and zap the tree EH table. */ convert_from_eh_region_ranges (); + set_eh_throw_stmt_table (cfun, NULL); rebuild_jump_labels (get_insns ()); find_exception_handler_labels (); diff --git a/gcc/config.gcc b/gcc/config.gcc index 04b46c38fe7..c2fd4efea02 100644 --- a/gcc/config.gcc +++ b/gcc/config.gcc @@ -70,6 +70,10 @@ # This helps to keep OS specific stuff out of the CPU # defining header ${cpu_type}/${cpu_type.h}. # +# It is possible to include automatically-generated +# build-directory files by prefixing them with "./". +# All other files should relative to $srcdir/config. +# # tm_p_file Location of file with declarations for functions # in $out_file. # @@ -2356,13 +2360,14 @@ sparc-*-elf*) sparc-*-linux*) # SPARC's running GNU/Linux, libc6 tm_file="${tm_file} dbxelf.h elfos.h svr4.h sparc/sysv4.h linux.h" extra_options="${extra_options} sparc/long-double-switch.opt" + tmake_file="${tmake_file} sparc/t-linux" if test x$enable_targets = xall; then tm_file="sparc/biarch64.h ${tm_file} sparc/linux64.h" - tmake_file="${tmake_file} sparc/t-linux64 sparc/t-crtfm" + tmake_file="${tmake_file} sparc/t-linux64" else tm_file="${tm_file} sparc/linux.h" - tmake_file="${tmake_file} sparc/t-linux sparc/t-crtfm" fi + tmake_file="${tmake_file} sparc/t-crtfm" ;; sparc-*-rtems*) tm_file="${tm_file} dbxelf.h elfos.h svr4.h sparc/sysv4.h sparc/sp-elf.h sparc/rtemself.h rtems.h" diff --git a/gcc/config/avr/avr.c b/gcc/config/avr/avr.c index 9a860533e9a..1293a4b3463 100644 --- a/gcc/config/avr/avr.c +++ b/gcc/config/avr/avr.c @@ -52,6 +52,7 @@ static int avr_naked_function_p (tree); static int interrupt_function_p (tree); static int signal_function_p (tree); static int avr_OS_task_function_p (tree); +static int avr_OS_main_function_p (tree); static int avr_regs_to_save (HARD_REG_SET *); static int sequent_regs_live (void); static const char *ptrreg_to_str (int); @@ -446,6 +447,19 @@ avr_OS_task_function_p (tree func) return a != NULL_TREE; } +/* Return nonzero if FUNC is a OS_main function. */ + +static int +avr_OS_main_function_p (tree func) +{ + tree a; + + gcc_assert (TREE_CODE (func) == FUNCTION_DECL); + + a = lookup_attribute ("OS_main", TYPE_ATTRIBUTES (TREE_TYPE (func))); + return a != NULL_TREE; +} + /* Return the number of hard registers to push/pop in the prologue/epilogue of the current function, and optionally store these registers in SET. */ @@ -464,9 +478,10 @@ avr_regs_to_save (HARD_REG_SET *set) count = 0; /* No need to save any registers if the function never returns or - is have "OS_task" attribute. */ + is have "OS_task" or "OS_main" attribute. */ if (TREE_THIS_VOLATILE (current_function_decl) - || cfun->machine->is_OS_task) + || cfun->machine->is_OS_task + || cfun->machine->is_OS_main) return 0; for (reg = 0; reg < 32; reg++) @@ -593,6 +608,7 @@ expand_prologue (void) cfun->machine->is_interrupt = interrupt_function_p (current_function_decl); cfun->machine->is_signal = signal_function_p (current_function_decl); cfun->machine->is_OS_task = avr_OS_task_function_p (current_function_decl); + cfun->machine->is_OS_main = avr_OS_main_function_p (current_function_decl); /* Prologue: naked. */ if (cfun->machine->is_naked) @@ -606,6 +622,7 @@ expand_prologue (void) && !cfun->machine->is_interrupt && !cfun->machine->is_signal && !cfun->machine->is_OS_task + && !cfun->machine->is_OS_main && live_seq); if (cfun->machine->is_interrupt || cfun->machine->is_signal) @@ -675,7 +692,7 @@ expand_prologue (void) } if (frame_pointer_needed) { - if(!cfun->machine->is_OS_task) + if (!(cfun->machine->is_OS_task || cfun->machine->is_OS_main)) { /* Push frame pointer. */ insn = emit_move_insn (pushword, frame_pointer_rtx); @@ -829,6 +846,7 @@ expand_epilogue (void) && !cfun->machine->is_interrupt && !cfun->machine->is_signal && !cfun->machine->is_OS_task + && !cfun->machine->is_OS_main && live_seq); if (minimize && (frame_pointer_needed || live_seq > 4)) @@ -891,7 +909,7 @@ expand_epilogue (void) emit_move_insn (stack_pointer_rtx, frame_pointer_rtx); } } - if(!cfun->machine->is_OS_task) + if (!(cfun->machine->is_OS_task || cfun->machine->is_OS_main)) { /* Restore previous frame_pointer. */ emit_insn (gen_pophi (frame_pointer_rtx)); @@ -4593,6 +4611,7 @@ const struct attribute_spec avr_attribute_table[] = { "interrupt", 0, 0, true, false, false, avr_handle_fndecl_attribute }, { "naked", 0, 0, false, true, true, avr_handle_fntype_attribute }, { "OS_task", 0, 0, false, true, true, avr_handle_fntype_attribute }, + { "OS_main", 0, 0, false, true, true, avr_handle_fntype_attribute }, { NULL, 0, 0, false, false, false, NULL } }; diff --git a/gcc/config/avr/avr.h b/gcc/config/avr/avr.h index 5261d9d6ba5..4cd0f24517e 100644 --- a/gcc/config/avr/avr.h +++ b/gcc/config/avr/avr.h @@ -1042,7 +1042,11 @@ struct machine_function GTY(()) as specified by the "signal" attribute. */ int is_signal; - /* 'true' - if current function is a signal function + /* 'true' - if current function is a 'task' function as specified by the "OS_task" attribute. */ int is_OS_task; + + /* 'true' - if current function is a 'main' function + as specified by the "OS_main" attribute. */ + int is_OS_main; }; diff --git a/gcc/config/i386/i386-interix.h b/gcc/config/i386/i386-interix.h index 74e2892b545..40106d85869 100644 --- a/gcc/config/i386/i386-interix.h +++ b/gcc/config/i386/i386-interix.h @@ -357,5 +357,6 @@ extern void i386_pe_unique_section (tree, int); #define DEFAULT_PCC_STRUCT_RETURN 0 -#undef TARGET_RETURN_IN_MEMORY -#define TARGET_RETURN_IN_MEMORY ix86_i386interix_return_in_memory +#define SUBTARGET_RETURN_IN_MEMORY(TYPE, FNTYPE) \ + (TYPE_MODE (TYPE) == BLKmode \ + || (AGGREGATE_TYPE_P (TYPE) && int_size_in_bytes (TYPE) > 8 ))
\ No newline at end of file diff --git a/gcc/config/i386/i386-protos.h b/gcc/config/i386/i386-protos.h index 5e3a5caf352..aee90eb65bd 100644 --- a/gcc/config/i386/i386-protos.h +++ b/gcc/config/i386/i386-protos.h @@ -134,10 +134,7 @@ extern rtx ix86_libcall_value (enum machine_mode); extern bool ix86_function_value_regno_p (int); extern bool ix86_function_arg_regno_p (int); extern int ix86_function_arg_boundary (enum machine_mode, tree); -extern bool ix86_return_in_memory (const_tree, const_tree); extern bool ix86_sol10_return_in_memory (const_tree,const_tree); -extern bool ix86_i386elf_return_in_memory (const_tree,const_tree); -extern bool ix86_i386interix_return_in_memory (const_tree,const_tree); extern rtx ix86_force_to_memory (enum machine_mode, rtx); extern void ix86_free_from_memory (enum machine_mode); extern void ix86_split_fp_branch (enum rtx_code code, rtx, rtx, diff --git a/gcc/config/i386/i386.c b/gcc/config/i386/i386.c index af1e6c60b55..c61cc8a87cf 100644 --- a/gcc/config/i386/i386.c +++ b/gcc/config/i386/i386.c @@ -4901,17 +4901,21 @@ return_in_memory_ms_64 (const_tree type, enum machine_mode mode) return (size != 1 && size != 2 && size != 4 && size != 8); } -bool +static bool ix86_return_in_memory (const_tree type, const_tree fntype ATTRIBUTE_UNUSED) { - const enum machine_mode mode = type_natural_mode (type); - +#ifdef SUBTARGET_RETURN_IN_MEMORY + return SUBTARGET_RETURN_IN_MEMORY (type, fntype); +#else + const enum machine_mode mode = type_natural_mode (type); + if (TARGET_64BIT_MS_ABI) - return return_in_memory_ms_64 (type, mode); - else if (TARGET_64BIT) - return return_in_memory_64 (type, mode); - else - return return_in_memory_32 (type, mode); + return return_in_memory_ms_64 (type, mode); + else if (TARGET_64BIT) + return return_in_memory_64 (type, mode); + else + return return_in_memory_32 (type, mode); +#endif } /* Return false iff TYPE is returned in memory. This version is used @@ -4951,20 +4955,6 @@ ix86_sol10_return_in_memory (const_tree type, const_tree fntype ATTRIBUTE_UNUSED return size > 12; } -bool -ix86_i386elf_return_in_memory (const_tree type, const_tree fntype ATTRIBUTE_UNUSED) -{ - return (TYPE_MODE (type) == BLKmode - || (VECTOR_MODE_P (TYPE_MODE (type)) && int_size_in_bytes (type) == 8)); -} - -bool -ix86_i386interix_return_in_memory (const_tree type, const_tree fntype ATTRIBUTE_UNUSED) -{ - return (TYPE_MODE (type) == BLKmode - || (AGGREGATE_TYPE_P (type) && int_size_in_bytes(type) > 8 )); -} - /* When returning SSE vector types, we have a choice of either (1) being abi incompatible with a -march switch, or (2) generating an error. @@ -22023,6 +22013,36 @@ ix86_preferred_output_reload_class (rtx x, enum reg_class regclass) return regclass; } +static enum reg_class +ix86_secondary_reload (bool in_p, rtx x, enum reg_class class, + enum machine_mode mode, + secondary_reload_info *sri ATTRIBUTE_UNUSED) +{ + /* QImode spills from non-QI registers require + intermediate register on 32bit targets. */ + if (!in_p && mode == QImode && !TARGET_64BIT + && (class == GENERAL_REGS + || class == LEGACY_REGS + || class == INDEX_REGS)) + { + int regno; + + if (REG_P (x)) + regno = REGNO (x); + else + regno = -1; + + if (regno >= FIRST_PSEUDO_REGISTER || GET_CODE (x) == SUBREG) + regno = true_regnum (x); + + /* Return Q_REGS if the operand is in memory. */ + if (regno == -1) + return Q_REGS; + } + + return NO_REGS; +} + /* If we are copying between general and FP registers, we need a memory location. The same is true for SSE and MMX registers. @@ -23652,6 +23672,7 @@ ix86_expand_vector_init_one_nonzero (bool mmx_ok, enum machine_mode mode, break; case V4HImode: use_vector_set = TARGET_SSE || TARGET_3DNOW_A; + break; default: break; } @@ -23839,194 +23860,269 @@ ix86_expand_vector_init_one_var (bool mmx_ok, enum machine_mode mode, return true; } -/* A subroutine of ix86_expand_vector_init. Handle the most general case: - all values variable, and none identical. */ +/* A subroutine of ix86_expand_vector_init_general. Use vector + concatenate to handle the most general case: all values variable, + and none identical. */ static void -ix86_expand_vector_init_general (bool mmx_ok, enum machine_mode mode, - rtx target, rtx vals) +ix86_expand_vector_init_concat (enum machine_mode mode, + rtx target, rtx *ops, int n) { - enum machine_mode half_mode = GET_MODE_INNER (mode); - rtx op0 = NULL, op1 = NULL; - bool use_vec_concat = false; + enum machine_mode cmode, hmode = VOIDmode; + rtx first[4], second[2]; + rtvec v; + int i, j; - switch (mode) + switch (n) { - case V2SFmode: - case V2SImode: - if (!mmx_ok && !TARGET_SSE) - break; - /* FALLTHRU */ + case 2: + switch (mode) + { + case V4SImode: + cmode = V2SImode; + break; + case V4SFmode: + cmode = V2SFmode; + break; + case V2DImode: + cmode = DImode; + break; + case V2SImode: + cmode = SImode; + break; + case V2DFmode: + cmode = DFmode; + break; + case V2SFmode: + cmode = SFmode; + break; + default: + gcc_unreachable (); + } - case V2DFmode: - case V2DImode: - /* For the two element vectors, we always implement VEC_CONCAT. */ - op0 = XVECEXP (vals, 0, 0); - op1 = XVECEXP (vals, 0, 1); - use_vec_concat = true; + if (!register_operand (ops[1], cmode)) + ops[1] = force_reg (cmode, ops[1]); + if (!register_operand (ops[0], cmode)) + ops[0] = force_reg (cmode, ops[0]); + emit_insn (gen_rtx_SET (VOIDmode, target, + gen_rtx_VEC_CONCAT (mode, ops[0], + ops[1]))); break; - case V4SFmode: - half_mode = V2SFmode; - goto half; - case V4SImode: - half_mode = V2SImode; + case 4: + switch (mode) + { + case V4SImode: + cmode = V2SImode; + break; + case V4SFmode: + cmode = V2SFmode; + break; + default: + gcc_unreachable (); + } goto half; - half: - { - rtvec v; - /* For V4SF and V4SI, we implement a concat of two V2 vectors. - Recurse to load the two halves. */ +half: + /* FIXME: We process inputs backward to help RA. PR 36222. */ + i = n - 1; + j = (n >> 1) - 1; + for (; i > 0; i -= 2, j--) + { + first[j] = gen_reg_rtx (cmode); + v = gen_rtvec (2, ops[i - 1], ops[i]); + ix86_expand_vector_init (false, first[j], + gen_rtx_PARALLEL (cmode, v)); + } - op1 = gen_reg_rtx (half_mode); - v = gen_rtvec (2, XVECEXP (vals, 0, 2), XVECEXP (vals, 0, 3)); - ix86_expand_vector_init (false, op1, gen_rtx_PARALLEL (half_mode, v)); + n >>= 1; + if (n > 2) + { + gcc_assert (hmode != VOIDmode); + for (i = j = 0; i < n; i += 2, j++) + { + second[j] = gen_reg_rtx (hmode); + ix86_expand_vector_init_concat (hmode, second [j], + &first [i], 2); + } + n >>= 1; + ix86_expand_vector_init_concat (mode, target, second, n); + } + else + ix86_expand_vector_init_concat (mode, target, first, n); + break; - op0 = gen_reg_rtx (half_mode); - v = gen_rtvec (2, XVECEXP (vals, 0, 0), XVECEXP (vals, 0, 1)); - ix86_expand_vector_init (false, op0, gen_rtx_PARALLEL (half_mode, v)); + default: + gcc_unreachable (); + } +} - use_vec_concat = true; - } - break; +/* A subroutine of ix86_expand_vector_init_general. Use vector + interleave to handle the most general case: all values variable, + and none identical. */ +static void +ix86_expand_vector_init_interleave (enum machine_mode mode, + rtx target, rtx *ops, int n) +{ + enum machine_mode first_imode, second_imode, third_imode; + int i, j; + rtx op0, op1; + rtx (*gen_load_even) (rtx, rtx, rtx); + rtx (*gen_interleave_first_low) (rtx, rtx, rtx); + rtx (*gen_interleave_second_low) (rtx, rtx, rtx); + + switch (mode) + { case V8HImode: - if (TARGET_SSE2) - { - rtx ops[4]; - unsigned int i, j; + gen_load_even = gen_vec_setv8hi; + gen_interleave_first_low = gen_vec_interleave_lowv4si; + gen_interleave_second_low = gen_vec_interleave_lowv2di; + first_imode = V4SImode; + second_imode = V2DImode; + third_imode = VOIDmode; + break; + case V16QImode: + gen_load_even = gen_vec_setv16qi; + gen_interleave_first_low = gen_vec_interleave_lowv8hi; + gen_interleave_second_low = gen_vec_interleave_lowv4si; + first_imode = V8HImode; + second_imode = V4SImode; + third_imode = V2DImode; + break; + default: + gcc_unreachable (); + } + + for (i = 0; i < n; i++) + { + /* Extend the odd elment to SImode using a paradoxical SUBREG. */ + op0 = gen_reg_rtx (SImode); + emit_move_insn (op0, gen_lowpart (SImode, ops [i + i])); - for (i = 0; i < ARRAY_SIZE (ops); i++) - { - /* Extend the odd elment from HImode to SImode using - a paradoxical SUBREG. */ - op0 = gen_reg_rtx (SImode); - emit_move_insn (op0, gen_lowpart (SImode, - XVECEXP (vals, 0, - i + i))); - - /* Insert the SImode value as low element of V4SImode - vector. */ - op1 = gen_reg_rtx (V4SImode); - op0 = gen_rtx_VEC_MERGE (V4SImode, - gen_rtx_VEC_DUPLICATE (V4SImode, - op0), - CONST0_RTX (V4SImode), - const1_rtx); - emit_insn (gen_rtx_SET (VOIDmode, op1, op0)); - - /* Cast the V4SImode vector back to a V8HImode vector. */ - op0 = gen_reg_rtx (mode); - emit_move_insn (op0, gen_lowpart (mode, op1)); - - /* Load even HI elements into the second positon. */ - emit_insn (gen_vec_setv8hi (op0, XVECEXP (vals, 0, - i + i + 1), - const1_rtx)); - - /* Cast V8HImode vector to V4SImode vector. */ - ops[i] = gen_reg_rtx (V4SImode); - emit_move_insn (ops[i], gen_lowpart (V4SImode, op0)); - } + /* Insert the SImode value as low element of V4SImode vector. */ + op1 = gen_reg_rtx (V4SImode); + op0 = gen_rtx_VEC_MERGE (V4SImode, + gen_rtx_VEC_DUPLICATE (V4SImode, + op0), + CONST0_RTX (V4SImode), + const1_rtx); + emit_insn (gen_rtx_SET (VOIDmode, op1, op0)); - /* Interleave low V4SIs. */ - for (i = j = 0; i < ARRAY_SIZE (ops); i += 2, j++) - { - op0 = gen_reg_rtx (V4SImode); - emit_insn (gen_vec_interleave_lowv4si (op0, ops[i], - ops[i + 1])); - - /* Cast V4SImode vectors to V2DImode vectors. */ - op1 = gen_reg_rtx (V2DImode); - emit_move_insn (op1, gen_lowpart (V2DImode, op0)); - ops[j] = op1; - } + /* Cast the V4SImode vector back to a vector in orignal mode. */ + op0 = gen_reg_rtx (mode); + emit_move_insn (op0, gen_lowpart (mode, op1)); + + /* Load even elements into the second positon. */ + emit_insn ((*gen_load_even) (op0, ops [i + i + 1], + const1_rtx)); - /* Interleave low V2DIs. */ - op0 = gen_reg_rtx (V2DImode); - emit_insn (gen_vec_interleave_lowv2di (op0, ops[0], ops[1])); + /* Cast vector to FIRST_IMODE vector. */ + ops[i] = gen_reg_rtx (first_imode); + emit_move_insn (ops[i], gen_lowpart (first_imode, op0)); + } - /* Cast the V2DImode vector back to a V8HImode vector. */ - emit_insn (gen_rtx_SET (VOIDmode, target, - gen_lowpart (mode, op0))); - return; - } + /* Interleave low FIRST_IMODE vectors. */ + for (i = j = 0; i < n; i += 2, j++) + { + op0 = gen_reg_rtx (first_imode); + emit_insn ((*gen_interleave_first_low) (op0, ops[i], ops[i + 1])); - case V16QImode: - if (TARGET_SSE4_1) + /* Cast FIRST_IMODE vector to SECOND_IMODE vector. */ + ops[j] = gen_reg_rtx (second_imode); + emit_move_insn (ops[j], gen_lowpart (second_imode, op0)); + } + + /* Interleave low SECOND_IMODE vectors. */ + switch (second_imode) + { + case V4SImode: + for (i = j = 0; i < n / 2; i += 2, j++) { - rtx ops[8]; - unsigned int i, j; + op0 = gen_reg_rtx (second_imode); + emit_insn ((*gen_interleave_second_low) (op0, ops[i], + ops[i + 1])); - for (i = 0; i < ARRAY_SIZE (ops); i++) - { - /* Extend the odd elment from QImode to SImode using - a paradoxical SUBREG. */ - op0 = gen_reg_rtx (SImode); - emit_move_insn (op0, gen_lowpart (SImode, - XVECEXP (vals, 0, - i + i))); - - /* Insert the SImode value as low element of V4SImode - vector. */ - op1 = gen_reg_rtx (V4SImode); - op0 = gen_rtx_VEC_MERGE (V4SImode, - gen_rtx_VEC_DUPLICATE (V4SImode, - op0), - CONST0_RTX (V4SImode), - const1_rtx); - emit_insn (gen_rtx_SET (VOIDmode, op1, op0)); - - /* Cast the V4SImode vector back to a V16QImode vector. */ - op0 = gen_reg_rtx (mode); - emit_move_insn (op0, gen_lowpart (mode, op1)); - - /* Load even QI elements into the second positon. */ - emit_insn (gen_vec_setv16qi (op0, XVECEXP (vals, 0, - i + i + 1), - const1_rtx)); - - /* Cast V16QImode vector to V8HImode vector. */ - ops[i] = gen_reg_rtx (V8HImode); - emit_move_insn (ops[i], gen_lowpart (V8HImode, op0)); - } + /* Cast the SECOND_IMODE vector to the THIRD_IMODE + vector. */ + ops[j] = gen_reg_rtx (third_imode); + emit_move_insn (ops[j], gen_lowpart (third_imode, op0)); + } + second_imode = V2DImode; + gen_interleave_second_low = gen_vec_interleave_lowv2di; + /* FALLTHRU */ - /* Interleave low V8HIs. */ - for (i = j = 0; i < ARRAY_SIZE (ops); i += 2, j++) - { - op0 = gen_reg_rtx (V8HImode); - emit_insn (gen_vec_interleave_lowv8hi (op0, ops[i], - ops[i + 1])); - - /* Cast V8HImode vector to V4SImode vector. */ - op1 = gen_reg_rtx (V4SImode); - emit_move_insn (op1, gen_lowpart (V4SImode, op0)); - ops[j] = op1; - } + case V2DImode: + op0 = gen_reg_rtx (second_imode); + emit_insn ((*gen_interleave_second_low) (op0, ops[0], + ops[1])); - /* Interleave low V4SIs. */ - for (i = j = 0; i < ARRAY_SIZE (ops) / 2; i += 2, j++) - { - op0 = gen_reg_rtx (V4SImode); - emit_insn (gen_vec_interleave_lowv4si (op0, ops[i], - ops[i + 1])); - - /* Cast V4SImode vectors to V2DImode vectors. */ - op1 = gen_reg_rtx (V2DImode); - emit_move_insn (op1, gen_lowpart (V2DImode, op0)); - ops[j] = op1; - } + /* Cast the SECOND_IMODE vector back to a vector on original + mode. */ + emit_insn (gen_rtx_SET (VOIDmode, target, + gen_lowpart (mode, op0))); + break; + + default: + gcc_unreachable (); + } +} - /* Interleave low V2DIs. */ - op0 = gen_reg_rtx (V2DImode); - emit_insn (gen_vec_interleave_lowv2di (op0, ops[0], ops[1])); +/* A subroutine of ix86_expand_vector_init. Handle the most general case: + all values variable, and none identical. */ - /* Cast the V2DImode vector back to a V8HImode vector. */ - emit_insn (gen_rtx_SET (VOIDmode, target, - gen_lowpart (mode, op0))); - return; - } +static void +ix86_expand_vector_init_general (bool mmx_ok, enum machine_mode mode, + rtx target, rtx vals) +{ + rtx ops[16]; + int n, i; + + switch (mode) + { + case V2SFmode: + case V2SImode: + if (!mmx_ok && !TARGET_SSE) + break; + + n = 2; + goto vec_concat; + + case V4SFmode: + case V4SImode: + n = 4; + goto vec_concat; + + case V2DFmode: + case V2DImode: + n = 2; + goto vec_concat; + +vec_concat: + for (i = 0; i < n; i++) + ops[i] = XVECEXP (vals, 0, i); + ix86_expand_vector_init_concat (mode, target, ops, n); + return; + + case V16QImode: + if (!TARGET_SSE4_1) + break; + + n = 16; + goto vec_interleave; + + case V8HImode: + if (!TARGET_SSE2) + break; + + n = 8; + goto vec_interleave; + +vec_interleave: + for (i = 0; i < n; i++) + ops[i] = XVECEXP (vals, 0, i); + ix86_expand_vector_init_interleave (mode, target, ops, n >> 1); + return; case V4HImode: case V8QImode: @@ -24036,17 +24132,6 @@ ix86_expand_vector_init_general (bool mmx_ok, enum machine_mode mode, gcc_unreachable (); } - if (use_vec_concat) - { - if (!register_operand (op1, half_mode)) - op1 = force_reg (half_mode, op1); - if (!register_operand (op0, half_mode)) - op0 = force_reg (half_mode, op0); - - emit_insn (gen_rtx_SET (VOIDmode, target, - gen_rtx_VEC_CONCAT (mode, op0, op1))); - } - else { int i, j, n_elts, n_words, n_elt_per_word; enum machine_mode inner_mode; @@ -24094,6 +24179,7 @@ ix86_expand_vector_init_general (bool mmx_ok, enum machine_mode mode, else if (n_words == 4) { rtx tmp = gen_reg_rtx (V4SImode); + gcc_assert (word_mode == SImode); vals = gen_rtx_PARALLEL (V4SImode, gen_rtvec_v (4, words)); ix86_expand_vector_init_general (false, V4SImode, tmp, vals); emit_move_insn (target, gen_lowpart (mode, tmp)); @@ -25700,6 +25786,9 @@ x86_builtin_vectorization_cost (bool runtime_test) } /* Initialize the GCC target structure. */ +#undef TARGET_RETURN_IN_MEMORY +#define TARGET_RETURN_IN_MEMORY ix86_return_in_memory + #undef TARGET_ATTRIBUTE_TABLE #define TARGET_ATTRIBUTE_TABLE ix86_attribute_table #if TARGET_DLLIMPORT_DECL_ATTRIBUTES @@ -25878,6 +25967,9 @@ x86_builtin_vectorization_cost (bool runtime_test) #undef TARGET_FUNCTION_VALUE #define TARGET_FUNCTION_VALUE ix86_function_value +#undef TARGET_SECONDARY_RELOAD +#define TARGET_SECONDARY_RELOAD ix86_secondary_reload + #undef TARGET_VECTORIZE_BUILTIN_VECTORIZATION_COST #define TARGET_VECTORIZE_BUILTIN_VECTORIZATION_COST x86_builtin_vectorization_cost diff --git a/gcc/config/i386/i386.h b/gcc/config/i386/i386.h index 8516e53b41d..9d36a1ff49f 100644 --- a/gcc/config/i386/i386.h +++ b/gcc/config/i386/i386.h @@ -1261,25 +1261,6 @@ do { \ #define GOT_SYMBOL_NAME "_GLOBAL_OFFSET_TABLE_" -/* A C expression which can inhibit the returning of certain function - values in registers, based on the type of value. A nonzero value - says to return the function value in memory, just as large - structures are always returned. Here TYPE will be a C expression - of type `tree', representing the data type of the value. - - Note that values of mode `BLKmode' must be explicitly handled by - this macro. Also, the option `-fpcc-struct-return' takes effect - regardless of this macro. On most systems, it is possible to - leave the macro undefined; this causes a default definition to be - used, whose value is the constant 1 for `BLKmode' values, and 0 - otherwise. - - Do not use this macro to indicate that structures and unions - should always be returned in memory. You should instead use - `DEFAULT_PCC_STRUCT_RETURN' to indicate this. */ - -#define TARGET_RETURN_IN_MEMORY ix86_return_in_memory - /* This is overridden by <cygwin.h>. */ #define MS_AGGREGATE_RETURN 0 @@ -1524,15 +1505,6 @@ enum reg_class ? mode_for_size (32, GET_MODE_CLASS (MODE), 0) \ : MODE) -/* QImode spills from non-QI registers need a scratch. This does not - happen often -- the only example so far requires an uninitialized - pseudo. */ - -#define SECONDARY_OUTPUT_RELOAD_CLASS(CLASS, MODE, OUT) \ - (((CLASS) == GENERAL_REGS || (CLASS) == LEGACY_REGS \ - || (CLASS) == INDEX_REGS) && !TARGET_64BIT && (MODE) == QImode \ - ? Q_REGS : NO_REGS) - /* Return the maximum number of consecutive registers needed to represent mode MODE in a register of class CLASS. */ /* On the 80386, this is the size of MODE in words, diff --git a/gcc/config/i386/i386.md b/gcc/config/i386/i386.md index 145c373ff75..a021e7c75e7 100644 --- a/gcc/config/i386/i386.md +++ b/gcc/config/i386/i386.md @@ -1810,25 +1810,6 @@ ] (const_string "QI")))]) -(define_expand "reload_outqi" - [(parallel [(match_operand:QI 0 "" "=m") - (match_operand:QI 1 "register_operand" "r") - (match_operand:QI 2 "register_operand" "=&q")])] - "" -{ - rtx op0, op1, op2; - op0 = operands[0]; op1 = operands[1]; op2 = operands[2]; - - gcc_assert (!reg_overlap_mentioned_p (op2, op0)); - if (! q_regs_operand (op1, QImode)) - { - emit_insn (gen_movqi (op2, op1)); - op1 = op2; - } - emit_insn (gen_movqi (op0, op1)); - DONE; -}) - (define_insn "*swapqi_1" [(set (match_operand:QI 0 "register_operand" "+r") (match_operand:QI 1 "register_operand" "+r")) diff --git a/gcc/config/i386/i386elf.h b/gcc/config/i386/i386elf.h index 6659669ba8a..d2fedad1b59 100644 --- a/gcc/config/i386/i386elf.h +++ b/gcc/config/i386/i386elf.h @@ -29,8 +29,9 @@ along with GCC; see the file COPYING3. If not see /* The ELF ABI for the i386 says that records and unions are returned in memory. */ -#undef TARGET_RETURN_IN_MEMORY -#define TARGET_RETURN_IN_MEMORY ix86_i386elf_return_in_memory +#define SUBTARGET_RETURN_IN_MEMORY(TYPE, FNTYPE) \ + (TYPE_MODE (TYPE) == BLKmode \ + || (VECTOR_MODE_P (TYPE_MODE (TYPE)) && int_size_in_bytes (TYPE) == 8)) #undef CPP_SPEC #define CPP_SPEC "" diff --git a/gcc/config/i386/ptx4-i.h b/gcc/config/i386/ptx4-i.h index 08473f0c109..15959af70d3 100644 --- a/gcc/config/i386/ptx4-i.h +++ b/gcc/config/i386/ptx4-i.h @@ -27,8 +27,9 @@ along with GCC; see the file COPYING3. If not see /* The svr4 ABI for the i386 says that records and unions are returned in memory. */ -#undef TARGET_RETURN_IN_MEMORY -#define TARGET_RETURN_IN_MEMORY ix86_i386elf_return_in_memory +#define SUBTARGET_RETURN_IN_MEMORY(TYPE, FNTYPE) \ + (TYPE_MODE (TYPE) == BLKmode \ + || (VECTOR_MODE_P (TYPE_MODE (TYPE)) && int_size_in_bytes (TYPE) == 8)); #define TARGET_OS_CPP_BUILTINS() \ do \ diff --git a/gcc/config/i386/sol2-10.h b/gcc/config/i386/sol2-10.h index 88b92f6afb6..3215c5d92c3 100644 --- a/gcc/config/i386/sol2-10.h +++ b/gcc/config/i386/sol2-10.h @@ -110,5 +110,5 @@ along with GCC; see the file COPYING3. If not see #undef TARGET_ASM_NAMED_SECTION #define TARGET_ASM_NAMED_SECTION i386_solaris_elf_named_section -#undef TARGET_RETURN_IN_MEMORY -#define TARGET_RETURN_IN_MEMORY ix86_sol10_return_in_memory +#define SUBTARGET_RETURN_IN_MEMORY(TYPE, FNTYPE) \ + ix86_sol10_return_in_memory (TYPE, FNTYPE) diff --git a/gcc/config/i386/sysv4.h b/gcc/config/i386/sysv4.h index e57fd0c5b0a..267785be320 100644 --- a/gcc/config/i386/sysv4.h +++ b/gcc/config/i386/sysv4.h @@ -25,8 +25,9 @@ along with GCC; see the file COPYING3. If not see /* The svr4 ABI for the i386 says that records and unions are returned in memory. */ -#undef TARGET_RETURN_IN_MEMORY -#define TARGET_RETURN_IN_MEMORY ix86_i386elf_return_in_memory +#define SUBTARGET_RETURN_IN_MEMORY(TYPE, FNTYPE) \ + (TYPE_MODE (TYPE) == BLKmode \ + || (VECTOR_MODE_P (TYPE_MODE (TYPE)) && int_size_in_bytes (TYPE) == 8)); /* Output at beginning of assembler file. */ /* The .file command should always begin the output. */ diff --git a/gcc/config/i386/vx-common.h b/gcc/config/i386/vx-common.h index 81530bc90f6..4bf023e5e43 100644 --- a/gcc/config/i386/vx-common.h +++ b/gcc/config/i386/vx-common.h @@ -22,5 +22,5 @@ along with GCC; see the file COPYING3. If not see /* VxWorks uses the same ABI as Solaris 10. */ -#undef TARGET_RETURN_IN_MEMORY -#define TARGET_RETURN_IN_MEMORY ix86_sol10_return_in_memory +#define SUBTARGET_RETURN_IN_MEMORY(TYPE, FNTYPE) \ + ix86_sol10_return_in_memory (TYPE, FNTYPE) diff --git a/gcc/config/mips/mips-protos.h b/gcc/config/mips/mips-protos.h index fbac8fcfd07..db65aab93c9 100644 --- a/gcc/config/mips/mips-protos.h +++ b/gcc/config/mips/mips-protos.h @@ -292,6 +292,14 @@ extern bool mips_use_ins_ext_p (rtx, HOST_WIDE_INT, HOST_WIDE_INT); extern const char *mips16e_output_save_restore (rtx, HOST_WIDE_INT); extern bool mips16e_save_restore_pattern_p (rtx, HOST_WIDE_INT, struct mips16e_save_restore_info *); -extern void mips_expand_compare_and_swap_12 (rtx, rtx, rtx, rtx); +union mips_gen_fn_ptrs +{ + rtx (*fn_6) (rtx, rtx, rtx, rtx, rtx, rtx); + rtx (*fn_5) (rtx, rtx, rtx, rtx, rtx); + rtx (*fn_4) (rtx, rtx, rtx, rtx); +}; + +extern void mips_expand_atomic_qihi (union mips_gen_fn_ptrs, + rtx, rtx, rtx, rtx); #endif /* ! GCC_MIPS_PROTOS_H */ diff --git a/gcc/config/mips/mips.c b/gcc/config/mips/mips.c index 218953385b3..6cb0d293dda 100644 --- a/gcc/config/mips/mips.c +++ b/gcc/config/mips/mips.c @@ -5873,14 +5873,29 @@ mips_expand_synci_loop (rtx begin, rtx end) emit_jump_insn (gen_condjump (cmp_result, label)); } -/* Expand a QI or HI mode compare_and_swap. The operands are the same - as for the generator function. */ +/* Expand a QI or HI mode atomic memory operation. + + GENERATOR contains a pointer to the gen_* function that generates + the SI mode underlying atomic operation using masks that we + calculate. + + RESULT is the return register for the operation. Its value is NULL + if unused. + + MEM is the location of the atomic access. + + OLDVAL is the first operand for the operation. + + NEWVAL is the optional second operand for the operation. Its value + is NULL if unused. */ void -mips_expand_compare_and_swap_12 (rtx result, rtx mem, rtx oldval, rtx newval) +mips_expand_atomic_qihi (union mips_gen_fn_ptrs generator, + rtx result, rtx mem, rtx oldval, rtx newval) { rtx orig_addr, memsi_addr, memsi, shift, shiftsi, unshifted_mask; - rtx unshifted_mask_reg, mask, inverted_mask, res; + rtx unshifted_mask_reg, mask, inverted_mask, si_op; + rtx res = NULL; enum machine_mode mode; mode = GET_MODE (mem); @@ -5927,7 +5942,7 @@ mips_expand_compare_and_swap_12 (rtx result, rtx mem, rtx oldval, rtx newval) } /* Do the same for the new value. */ - if (newval != const0_rtx) + if (newval && newval != const0_rtx) { newval = convert_modes (SImode, mode, newval, true); newval = force_reg (SImode, newval); @@ -5935,14 +5950,24 @@ mips_expand_compare_and_swap_12 (rtx result, rtx mem, rtx oldval, rtx newval) } /* Do the SImode atomic access. */ - res = gen_reg_rtx (SImode); - emit_insn (gen_compare_and_swap_12 (res, memsi, mask, inverted_mask, - oldval, newval)); - - /* Shift and convert the result. */ - mips_emit_binary (AND, res, res, mask); - mips_emit_binary (LSHIFTRT, res, res, shiftsi); - mips_emit_move (result, gen_lowpart (GET_MODE (result), res)); + if (result) + res = gen_reg_rtx (SImode); + if (newval) + si_op = generator.fn_6 (res, memsi, mask, inverted_mask, oldval, newval); + else if (result) + si_op = generator.fn_5 (res, memsi, mask, inverted_mask, oldval); + else + si_op = generator.fn_4 (memsi, mask, inverted_mask, oldval); + + emit_insn (si_op); + + if (result) + { + /* Shift and convert the result. */ + mips_emit_binary (AND, res, res, mask); + mips_emit_binary (LSHIFTRT, res, res, shiftsi); + mips_emit_move (result, gen_lowpart (GET_MODE (result), res)); + } } /* Return true if it is possible to use left/right accesses for a diff --git a/gcc/config/mips/mips.h b/gcc/config/mips/mips.h index 9f59f1a2550..765552778b5 100644 --- a/gcc/config/mips/mips.h +++ b/gcc/config/mips/mips.h @@ -1,6 +1,6 @@ /* Definitions of target machine for GNU compiler. MIPS version. Copyright (C) 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998 - 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007 + 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008 Free Software Foundation, Inc. Contributed by A. Lichnewsky (lich@inria.inria.fr). Changed by Michael Meissner (meissner@osf.org). @@ -2908,41 +2908,32 @@ while (0) /* Return an asm string that atomically: - Given that %2 contains a bit mask and %3 the inverted mask and - that %4 and %5 have already been ANDed with $2. + that %4 and %5 have already been ANDed with %2. - Compares the bits in memory reference %1 selected by mask %2 to register %4 and, if they are equal, changes the selected bits in memory to %5. - Sets register %0 to the old value of memory reference %1. - */ -#define MIPS_COMPARE_AND_SWAP_12 \ - "%(%<%[%|sync\n" \ - "1:\tll\t%0,%1\n" \ - "\tand\t%@,%0,%2\n" \ - "\tbne\t%@,%z4,2f\n" \ - "\tand\t%@,%0,%3\n" \ - "\tor\t%@,%@,%5\n" \ - "\tsc\t%@,%1\n" \ - "\tbeq\t%@,%.,1b\n" \ - "\tnop\n" \ - "\tsync%-%]%>%)\n" \ - "2:\n" -/* Like MIPS_COMPARE_AND_SWAP_12, except %5 is a constant zero, - so the OR can be omitted. */ -#define MIPS_COMPARE_AND_SWAP_12_0 \ + OPS are the instructions needed to OR %5 with %@. */ +#define MIPS_COMPARE_AND_SWAP_12(OPS) \ "%(%<%[%|sync\n" \ "1:\tll\t%0,%1\n" \ "\tand\t%@,%0,%2\n" \ "\tbne\t%@,%z4,2f\n" \ "\tand\t%@,%0,%3\n" \ + OPS \ "\tsc\t%@,%1\n" \ "\tbeq\t%@,%.,1b\n" \ "\tnop\n" \ "\tsync%-%]%>%)\n" \ "2:\n" +#define MIPS_COMPARE_AND_SWAP_12_ZERO_OP "" +#define MIPS_COMPARE_AND_SWAP_12_NONZERO_OP "\tor\t%@,%@,%5\n" + + /* Return an asm string that atomically: - Sets memory reference %0 to %0 INSN %1. @@ -2960,6 +2951,97 @@ while (0) /* Return an asm string that atomically: + - Given that %1 contains a bit mask and %2 the inverted mask and + that %3 has already been ANDed with %1. + + - Sets the selected bits of memory reference %0 to %0 INSN %3. + + - Uses scratch register %4. + + NOT_OP are the optional instructions to do a bit-wise not + operation in conjunction with an AND INSN to generate a sync_nand + operation. */ +#define MIPS_SYNC_OP_12(INSN, NOT_OP) \ + "%(%<%[%|sync\n" \ + "1:\tll\t%4,%0\n" \ + "\tand\t%@,%4,%2\n" \ + NOT_OP \ + "\t" INSN "\t%4,%4,%z3\n" \ + "\tand\t%4,%4,%1\n" \ + "\tor\t%@,%@,%4\n" \ + "\tsc\t%@,%0\n" \ + "\tbeq\t%@,%.,1b\n" \ + "\tnop\n" \ + "\tsync%-%]%>%)" + +#define MIPS_SYNC_OP_12_NOT_NOP "" +#define MIPS_SYNC_OP_12_NOT_NOT "\tnor\t%4,%4,%.\n" + +/* Return an asm string that atomically: + + - Given that %2 contains a bit mask and %3 the inverted mask and + that %4 has already been ANDed with %2. + + - Sets the selected bits of memory reference %1 to %1 INSN %4. + + - Sets %0 to the original value of %1. + + - Uses scratch register %5. + + NOT_OP are the optional instructions to do a bit-wise not + operation in conjunction with an AND INSN to generate a sync_nand + operation. + + REG is used in conjunction with NOT_OP and is used to select the + register operated on by the INSN. */ +#define MIPS_SYNC_OLD_OP_12(INSN, NOT_OP, REG) \ + "%(%<%[%|sync\n" \ + "1:\tll\t%0,%1\n" \ + "\tand\t%@,%0,%3\n" \ + NOT_OP \ + "\t" INSN "\t%5," REG ",%z4\n" \ + "\tand\t%5,%5,%2\n" \ + "\tor\t%@,%@,%5\n" \ + "\tsc\t%@,%1\n" \ + "\tbeq\t%@,%.,1b\n" \ + "\tnop\n" \ + "\tsync%-%]%>%)" + +#define MIPS_SYNC_OLD_OP_12_NOT_NOP "" +#define MIPS_SYNC_OLD_OP_12_NOT_NOP_REG "%0" +#define MIPS_SYNC_OLD_OP_12_NOT_NOT "\tnor\t%5,%0,%.\n" +#define MIPS_SYNC_OLD_OP_12_NOT_NOT_REG "%5" + +/* Return an asm string that atomically: + + - Given that %2 contains a bit mask and %3 the inverted mask and + that %4 has already been ANDed with %2. + + - Sets the selected bits of memory reference %1 to %1 INSN %4. + + - Sets %0 to the new value of %1. + + NOT_OP are the optional instructions to do a bit-wise not + operation in conjunction with an AND INSN to generate a sync_nand + operation. */ +#define MIPS_SYNC_NEW_OP_12(INSN, NOT_OP) \ + "%(%<%[%|sync\n" \ + "1:\tll\t%0,%1\n" \ + "\tand\t%@,%0,%3\n" \ + NOT_OP \ + "\t" INSN "\t%0,%0,%z4\n" \ + "\tand\t%0,%0,%2\n" \ + "\tor\t%@,%@,%0\n" \ + "\tsc\t%@,%1\n" \ + "\tbeq\t%@,%.,1b\n" \ + "\tnop\n" \ + "\tsync%-%]%>%)" + +#define MIPS_SYNC_NEW_OP_12_NOT_NOP "" +#define MIPS_SYNC_NEW_OP_12_NOT_NOT "\tnor\t%0,%0,%.\n" + +/* Return an asm string that atomically: + - Sets memory reference %1 to %1 INSN %2. - Sets register %0 to the old value of memory reference %1. @@ -3065,6 +3147,33 @@ while (0) "\tnop\n" \ "\tsync%-%]%>%)" +/* Return an asm string that atomically: + + - Given that %2 contains an inclusive mask, %3 and exclusive mask + and %4 has already been ANDed with the inclusive mask. + + - Sets bits selected by the inclusive mask of memory reference %1 + to %4. + + - Sets register %0 to the old value of memory reference %1. + + OPS are the instructions needed to OR %4 with %@. + + Operand %2 is unused, but needed as to give the test_and_set_12 + insn the five operands expected by the expander. */ +#define MIPS_SYNC_EXCHANGE_12(OPS) \ + "%(%<%[%|\n" \ + "1:\tll\t%0,%1\n" \ + "\tand\t%@,%0,%3\n" \ + OPS \ + "\tsc\t%@,%1\n" \ + "\tbeq\t%@,%.,1b\n" \ + "\tnop\n" \ + "\tsync%-%]%>%)" + +#define MIPS_SYNC_EXCHANGE_12_ZERO_OP "" +#define MIPS_SYNC_EXCHANGE_12_NONZERO_OP "\tor\t%@,%@,%4\n" + #ifndef USED_FOR_TARGET extern const enum reg_class mips_regno_to_class[]; extern bool mips_hard_regno_mode_ok[][FIRST_PSEUDO_REGISTER]; diff --git a/gcc/config/mips/mips.md b/gcc/config/mips/mips.md index a423529b330..2b789eef8b6 100644 --- a/gcc/config/mips/mips.md +++ b/gcc/config/mips/mips.md @@ -1,6 +1,6 @@ ;; Mips.md Machine Description for MIPS based processors ;; Copyright (C) 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, -;; 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 +;; 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 ;; Free Software Foundation, Inc. ;; Contributed by A. Lichnewsky, lich@inria.inria.fr ;; Changes by Michael Meissner, meissner@osf.org @@ -57,10 +57,13 @@ (UNSPEC_COMPARE_AND_SWAP_12 38) (UNSPEC_SYNC_OLD_OP 39) (UNSPEC_SYNC_NEW_OP 40) - (UNSPEC_SYNC_EXCHANGE 41) - (UNSPEC_MEMORY_BARRIER 42) - (UNSPEC_SET_GOT_VERSION 43) - (UNSPEC_UPDATE_GOT_VERSION 44) + (UNSPEC_SYNC_NEW_OP_12 41) + (UNSPEC_SYNC_OLD_OP_12 42) + (UNSPEC_SYNC_EXCHANGE 43) + (UNSPEC_SYNC_EXCHANGE_12 44) + (UNSPEC_MEMORY_BARRIER 45) + (UNSPEC_SET_GOT_VERSION 46) + (UNSPEC_UPDATE_GOT_VERSION 47) (UNSPEC_ADDRESS_FIRST 100) @@ -639,7 +642,9 @@ (lshiftrt "lshr") (ior "ior") (xor "xor") - (and "and")]) + (and "and") + (plus "add") + (minus "sub")]) ;; <insn> expands to the name of the insn that implements a particular code. (define_code_attr insn [(ashift "sll") @@ -647,7 +652,9 @@ (lshiftrt "srl") (ior "or") (xor "xor") - (and "and")]) + (and "and") + (plus "addu") + (minus "subu")]) ;; <fcond> is the c.cond.fmt condition associated with a particular code. (define_code_attr fcond [(unordered "un") @@ -671,6 +678,8 @@ ;; a particular code to operate in immediate values. (define_code_attr immediate_insn [(ior "ori") (xor "xori") (and "andi")]) +;; Atomic HI and QI operations +(define_code_iterator atomic_hiqi_op [plus minus ior xor and]) ;; ......................... ;; @@ -4455,12 +4464,14 @@ (match_operand:SHORT 3 "general_operand")] "GENERATE_LL_SC" { - mips_expand_compare_and_swap_12 (operands[0], operands[1], - operands[2], operands[3]); + union mips_gen_fn_ptrs generator; + generator.fn_6 = gen_compare_and_swap_12; + mips_expand_atomic_qihi (generator, + operands[0], operands[1], operands[2], operands[3]); DONE; }) -;; Helper insn for mips_expand_compare_and_swap_12. +;; Helper insn for mips_expand_atomic_qihi. (define_insn "compare_and_swap_12" [(set (match_operand:SI 0 "register_operand" "=&d,&d") (match_operand:SI 1 "memory_operand" "+R,R")) @@ -4473,9 +4484,9 @@ "GENERATE_LL_SC" { if (which_alternative == 0) - return MIPS_COMPARE_AND_SWAP_12; + return MIPS_COMPARE_AND_SWAP_12 (MIPS_COMPARE_AND_SWAP_12_NONZERO_OP); else - return MIPS_COMPARE_AND_SWAP_12_0; + return MIPS_COMPARE_AND_SWAP_12 (MIPS_COMPARE_AND_SWAP_12_ZERO_OP); } [(set_attr "length" "40,36")]) @@ -4483,8 +4494,8 @@ [(set (match_operand:GPR 0 "memory_operand" "+R,R") (unspec_volatile:GPR [(plus:GPR (match_dup 0) - (match_operand:GPR 1 "arith_operand" "I,d"))] - UNSPEC_SYNC_OLD_OP))] + (match_operand:GPR 1 "arith_operand" "I,d"))] + UNSPEC_SYNC_OLD_OP))] "GENERATE_LL_SC" { if (which_alternative == 0) @@ -4494,6 +4505,220 @@ } [(set_attr "length" "28")]) +(define_expand "sync_<optab><mode>" + [(set (match_operand:SHORT 0 "memory_operand") + (unspec_volatile:SHORT + [(atomic_hiqi_op:SHORT (match_dup 0) + (match_operand:SHORT 1 "general_operand"))] + UNSPEC_SYNC_OLD_OP))] + "GENERATE_LL_SC" +{ + union mips_gen_fn_ptrs generator; + generator.fn_4 = gen_sync_<optab>_12; + mips_expand_atomic_qihi (generator, + NULL, operands[0], operands[1], NULL); + DONE; +}) + +;; Helper insn for sync_<optab><mode> +(define_insn "sync_<optab>_12" + [(set (match_operand:SI 0 "memory_operand" "+R") + (unspec_volatile:SI + [(match_operand:SI 1 "register_operand" "d") + (match_operand:SI 2 "register_operand" "d") + (atomic_hiqi_op:SI (match_dup 0) + (match_operand:SI 3 "register_operand" "dJ"))] + UNSPEC_SYNC_OLD_OP_12)) + (clobber (match_scratch:SI 4 "=&d"))] + "GENERATE_LL_SC" +{ + return MIPS_SYNC_OP_12 ("<insn>", MIPS_SYNC_OP_12_NOT_NOP); +} + [(set_attr "length" "40")]) + +(define_expand "sync_old_<optab><mode>" + [(parallel [ + (set (match_operand:SHORT 0 "register_operand") + (match_operand:SHORT 1 "memory_operand")) + (set (match_dup 1) + (unspec_volatile:SHORT [(atomic_hiqi_op:SHORT + (match_dup 1) + (match_operand:SHORT 2 "general_operand"))] + UNSPEC_SYNC_OLD_OP))])] + "GENERATE_LL_SC" +{ + union mips_gen_fn_ptrs generator; + generator.fn_5 = gen_sync_old_<optab>_12; + mips_expand_atomic_qihi (generator, + operands[0], operands[1], operands[2], NULL); + DONE; +}) + +;; Helper insn for sync_old_<optab><mode> +(define_insn "sync_old_<optab>_12" + [(set (match_operand:SI 0 "register_operand" "=&d") + (match_operand:SI 1 "memory_operand" "+R")) + (set (match_dup 1) + (unspec_volatile:SI + [(match_operand:SI 2 "register_operand" "d") + (match_operand:SI 3 "register_operand" "d") + (atomic_hiqi_op:SI (match_dup 0) + (match_operand:SI 4 "register_operand" "dJ"))] + UNSPEC_SYNC_OLD_OP_12)) + (clobber (match_scratch:SI 5 "=&d"))] + "GENERATE_LL_SC" +{ + return MIPS_SYNC_OLD_OP_12 ("<insn>", MIPS_SYNC_OLD_OP_12_NOT_NOP, + MIPS_SYNC_OLD_OP_12_NOT_NOP_REG); +} + [(set_attr "length" "40")]) + +(define_expand "sync_new_<optab><mode>" + [(parallel [ + (set (match_operand:SHORT 0 "register_operand") + (unspec_volatile:SHORT [(atomic_hiqi_op:SHORT + (match_operand:SHORT 1 "memory_operand") + (match_operand:SHORT 2 "general_operand"))] + UNSPEC_SYNC_NEW_OP)) + (set (match_dup 1) + (unspec_volatile:SHORT [(match_dup 1) (match_dup 2)] + UNSPEC_SYNC_NEW_OP))])] + "GENERATE_LL_SC" +{ + union mips_gen_fn_ptrs generator; + generator.fn_5 = gen_sync_new_<optab>_12; + mips_expand_atomic_qihi (generator, + operands[0], operands[1], operands[2], NULL); + DONE; +}) + +;; Helper insn for sync_new_<optab><mode> +(define_insn "sync_new_<optab>_12" + [(set (match_operand:SI 0 "register_operand" "=&d") + (unspec_volatile:SI + [(match_operand:SI 1 "memory_operand" "+R") + (match_operand:SI 2 "register_operand" "d") + (match_operand:SI 3 "register_operand" "d") + (atomic_hiqi_op:SI (match_dup 0) + (match_operand:SI 4 "register_operand" "dJ"))] + UNSPEC_SYNC_NEW_OP_12)) + (set (match_dup 1) + (unspec_volatile:SI + [(match_dup 1) + (match_dup 2) + (match_dup 3) + (match_dup 4)] UNSPEC_SYNC_NEW_OP_12))] + "GENERATE_LL_SC" +{ + return MIPS_SYNC_NEW_OP_12 ("<insn>", MIPS_SYNC_NEW_OP_12_NOT_NOP); +} + [(set_attr "length" "40")]) + +(define_expand "sync_nand<mode>" + [(set (match_operand:SHORT 0 "memory_operand") + (unspec_volatile:SHORT + [(match_dup 0) + (match_operand:SHORT 1 "general_operand")] + UNSPEC_SYNC_OLD_OP))] + "GENERATE_LL_SC" +{ + union mips_gen_fn_ptrs generator; + generator.fn_4 = gen_sync_nand_12; + mips_expand_atomic_qihi (generator, + NULL, operands[0], operands[1], NULL); + DONE; +}) + +;; Helper insn for sync_nand<mode> +(define_insn "sync_nand_12" + [(set (match_operand:SI 0 "memory_operand" "+R") + (unspec_volatile:SI + [(match_operand:SI 1 "register_operand" "d") + (match_operand:SI 2 "register_operand" "d") + (match_dup 0) + (match_operand:SI 3 "register_operand" "dJ")] + UNSPEC_SYNC_OLD_OP_12)) + (clobber (match_scratch:SI 4 "=&d"))] + "GENERATE_LL_SC" +{ + return MIPS_SYNC_OP_12 ("and", MIPS_SYNC_OP_12_NOT_NOT); +} + [(set_attr "length" "44")]) + +(define_expand "sync_old_nand<mode>" + [(parallel [ + (set (match_operand:SHORT 0 "register_operand") + (match_operand:SHORT 1 "memory_operand")) + (set (match_dup 1) + (unspec_volatile:SHORT [(match_dup 1) + (match_operand:SHORT 2 "general_operand")] + UNSPEC_SYNC_OLD_OP))])] + "GENERATE_LL_SC" +{ + union mips_gen_fn_ptrs generator; + generator.fn_5 = gen_sync_old_nand_12; + mips_expand_atomic_qihi (generator, + operands[0], operands[1], operands[2], NULL); + DONE; +}) + +;; Helper insn for sync_old_nand<mode> +(define_insn "sync_old_nand_12" + [(set (match_operand:SI 0 "register_operand" "=&d") + (match_operand:SI 1 "memory_operand" "+R")) + (set (match_dup 1) + (unspec_volatile:SI + [(match_operand:SI 2 "register_operand" "d") + (match_operand:SI 3 "register_operand" "d") + (match_operand:SI 4 "register_operand" "dJ")] + UNSPEC_SYNC_OLD_OP_12)) + (clobber (match_scratch:SI 5 "=&d"))] + "GENERATE_LL_SC" +{ + return MIPS_SYNC_OLD_OP_12 ("and", MIPS_SYNC_OLD_OP_12_NOT_NOT, + MIPS_SYNC_OLD_OP_12_NOT_NOT_REG); +} + [(set_attr "length" "44")]) + +(define_expand "sync_new_nand<mode>" + [(parallel [ + (set (match_operand:SHORT 0 "register_operand") + (unspec_volatile:SHORT [(match_operand:SHORT 1 "memory_operand") + (match_operand:SHORT 2 "general_operand")] + UNSPEC_SYNC_NEW_OP)) + (set (match_dup 1) + (unspec_volatile:SHORT [(match_dup 1) (match_dup 2)] + UNSPEC_SYNC_NEW_OP))])] + "GENERATE_LL_SC" +{ + union mips_gen_fn_ptrs generator; + generator.fn_5 = gen_sync_new_nand_12; + mips_expand_atomic_qihi (generator, + operands[0], operands[1], operands[2], NULL); + DONE; +}) + +;; Helper insn for sync_new_nand<mode> +(define_insn "sync_new_nand_12" + [(set (match_operand:SI 0 "register_operand" "=&d") + (unspec_volatile:SI + [(match_operand:SI 1 "memory_operand" "+R") + (match_operand:SI 2 "register_operand" "d") + (match_operand:SI 3 "register_operand" "d") + (match_operand:SI 4 "register_operand" "dJ")] + UNSPEC_SYNC_NEW_OP_12)) + (set (match_dup 1) + (unspec_volatile:SI + [(match_dup 1) + (match_dup 2) + (match_dup 3) + (match_dup 4)] UNSPEC_SYNC_NEW_OP_12))] + "GENERATE_LL_SC" +{ + return MIPS_SYNC_NEW_OP_12 ("and", MIPS_SYNC_NEW_OP_12_NOT_NOT); +} + [(set_attr "length" "40")]) + (define_insn "sync_sub<mode>" [(set (match_operand:GPR 0 "memory_operand" "+R") (unspec_volatile:GPR @@ -4507,7 +4732,7 @@ [(set_attr "length" "28")]) (define_insn "sync_old_add<mode>" - [(set (match_operand:GPR 0 "register_operand" "=d,&d") + [(set (match_operand:GPR 0 "register_operand" "=&d,&d") (match_operand:GPR 1 "memory_operand" "+R,R")) (set (match_dup 1) (unspec_volatile:GPR @@ -4538,7 +4763,7 @@ [(set_attr "length" "28")]) (define_insn "sync_new_add<mode>" - [(set (match_operand:GPR 0 "register_operand" "=d,&d") + [(set (match_operand:GPR 0 "register_operand" "=&d,&d") (plus:GPR (match_operand:GPR 1 "memory_operand" "+R,R") (match_operand:GPR 2 "arith_operand" "I,d"))) (set (match_dup 1) @@ -4584,7 +4809,7 @@ [(set_attr "length" "28")]) (define_insn "sync_old_<optab><mode>" - [(set (match_operand:GPR 0 "register_operand" "=d,&d") + [(set (match_operand:GPR 0 "register_operand" "=&d,&d") (match_operand:GPR 1 "memory_operand" "+R,R")) (set (match_dup 1) (unspec_volatile:GPR @@ -4601,7 +4826,7 @@ [(set_attr "length" "28")]) (define_insn "sync_new_<optab><mode>" - [(set (match_operand:GPR 0 "register_operand" "=d,&d") + [(set (match_operand:GPR 0 "register_operand" "=&d,&d") (match_operand:GPR 1 "memory_operand" "+R,R")) (set (match_dup 1) (unspec_volatile:GPR @@ -4631,7 +4856,7 @@ [(set_attr "length" "32")]) (define_insn "sync_old_nand<mode>" - [(set (match_operand:GPR 0 "register_operand" "=d,&d") + [(set (match_operand:GPR 0 "register_operand" "=&d,&d") (match_operand:GPR 1 "memory_operand" "+R,R")) (set (match_dup 1) (unspec_volatile:GPR [(match_operand:GPR 2 "uns_arith_operand" "K,d")] @@ -4646,7 +4871,7 @@ [(set_attr "length" "32")]) (define_insn "sync_new_nand<mode>" - [(set (match_operand:GPR 0 "register_operand" "=d,&d") + [(set (match_operand:GPR 0 "register_operand" "=&d,&d") (match_operand:GPR 1 "memory_operand" "+R,R")) (set (match_dup 1) (unspec_volatile:GPR [(match_operand:GPR 2 "uns_arith_operand" "K,d")] @@ -4661,7 +4886,7 @@ [(set_attr "length" "32")]) (define_insn "sync_lock_test_and_set<mode>" - [(set (match_operand:GPR 0 "register_operand" "=d,&d") + [(set (match_operand:GPR 0 "register_operand" "=&d,&d") (match_operand:GPR 1 "memory_operand" "+R,R")) (set (match_dup 1) (unspec_volatile:GPR [(match_operand:GPR 2 "arith_operand" "I,d")] @@ -4674,6 +4899,36 @@ return MIPS_SYNC_EXCHANGE ("<d>", "move"); } [(set_attr "length" "24")]) + +(define_expand "sync_lock_test_and_set<mode>" + [(match_operand:SHORT 0 "register_operand") + (match_operand:SHORT 1 "memory_operand") + (match_operand:SHORT 2 "general_operand")] + "GENERATE_LL_SC" +{ + union mips_gen_fn_ptrs generator; + generator.fn_5 = gen_test_and_set_12; + mips_expand_atomic_qihi (generator, + operands[0], operands[1], operands[2], NULL); + DONE; +}) + +(define_insn "test_and_set_12" + [(set (match_operand:SI 0 "register_operand" "=&d,&d") + (match_operand:SI 1 "memory_operand" "+R,R")) + (set (match_dup 1) + (unspec_volatile:SI [(match_operand:SI 2 "register_operand" "d,d") + (match_operand:SI 3 "register_operand" "d,d") + (match_operand:SI 4 "arith_operand" "d,J")] + UNSPEC_SYNC_EXCHANGE_12))] + "GENERATE_LL_SC" +{ + if (which_alternative == 0) + return MIPS_SYNC_EXCHANGE_12 (MIPS_SYNC_EXCHANGE_12_NONZERO_OP); + else + return MIPS_SYNC_EXCHANGE_12 (MIPS_SYNC_EXCHANGE_12_ZERO_OP); +} + [(set_attr "length" "28,24")]) ;; Block moves, see mips.c for more details. ;; Argument 0 is the destination diff --git a/gcc/config/sh/sh.c b/gcc/config/sh/sh.c index 67301c969ad..a41783de91b 100644 --- a/gcc/config/sh/sh.c +++ b/gcc/config/sh/sh.c @@ -10522,7 +10522,7 @@ sh_output_mi_thunk (FILE *file, tree thunk_fndecl ATTRIBUTE_UNUSED, if (optimize > 0) { if (! cfun->cfg) - init_flow (); + init_flow (cfun); split_all_insns_noflow (); } #endif diff --git a/gcc/cselib.c b/gcc/cselib.c index 5d490941df8..f45803e8e4d 100644 --- a/gcc/cselib.c +++ b/gcc/cselib.c @@ -1600,7 +1600,7 @@ cselib_record_sets (rtx insn) { rtx src = sets[i].src; if (cond) - src = gen_rtx_IF_THEN_ELSE (GET_MODE (src), cond, src, dest); + src = gen_rtx_IF_THEN_ELSE (GET_MODE (dest), cond, src, dest); sets[i].src_elt = cselib_lookup (src, GET_MODE (dest), 1); if (MEM_P (dest)) sets[i].dest_addr_elt = cselib_lookup (XEXP (dest, 0), Pmode, 1); diff --git a/gcc/df-problems.c b/gcc/df-problems.c index 682cca857a7..b1e60b3ab71 100644 --- a/gcc/df-problems.c +++ b/gcc/df-problems.c @@ -3767,10 +3767,10 @@ df_simulate_fixup_sets (basic_block bb, bitmap live) df_simulate_artificial_refs_at_top can be called to get a new value of the sets at the top of the block (this is rarely used). - It would be trivial to define a similar set of functions that work - in the forwards direction. The only changes would be to process - the uses before the defs and properly rename the functions. This - has so far not been necessary. + It would be not be difficult to define a similar set of functions + that work in the forwards direction. In that case the functions + would ignore the use sets and look for the REG_DEAD and REG_UNUSED + notes. ----------------------------------------------------------------------------*/ /* Apply the artificial uses and defs at the end of BB in a backwards diff --git a/gcc/doc/extend.texi b/gcc/doc/extend.texi index f3c6c574a42..36e81ffe55c 100644 --- a/gcc/doc/extend.texi +++ b/gcc/doc/extend.texi @@ -5768,6 +5768,7 @@ should be called and the @var{flag} argument passed to it. @findex __builtin_isnormal @findex __builtin_isgreater @findex __builtin_isgreaterequal +@findex __builtin_isinf_sign @findex __builtin_isless @findex __builtin_islessequal @findex __builtin_islessgreater @@ -6294,8 +6295,10 @@ the same names as the standard macros ( @code{isgreater}, @code{islessgreater}, and @code{isunordered}) , with @code{__builtin_} prefixed. We intend for a library implementor to be able to simply @code{#define} each standard macro to its built-in equivalent. -In the same fashion, GCC provides @code{isfinite} and @code{isnormal} -built-ins used with @code{__builtin_} prefixed. +In the same fashion, GCC provides @code{isfinite}, @code{isinf_sign} +and @code{isnormal} built-ins used with @code{__builtin_} prefixed. +The @code{isinf} and @code{isnan} builtins appear both with and +without the @code{__builtin_} prefix. @deftypefn {Built-in Function} int __builtin_types_compatible_p (@var{type1}, @var{type2}) @@ -6579,6 +6582,14 @@ Similar to @code{__builtin_inf}, except the return type is @code{long double}. @end deftypefn +@deftypefn {Built-in Function} int __builtin_isinf_sign (...) +Similar to @code{isinf}, except the return value will be negative for +an argument of @code{-Inf}. Note while the parameter list is an +ellipsis, this function only accepts exactly one floating point +argument. GCC treats this parameter as type-generic, which means it +does not do default promotion from float to double. +@end deftypefn + @deftypefn {Built-in Function} double __builtin_nan (const char *str) This is an implementation of the ISO C99 function @code{nan}. diff --git a/gcc/doc/install.texi2html b/gcc/doc/install.texi2html index c5452661187..f735d042524 100755 --- a/gcc/doc/install.texi2html +++ b/gcc/doc/install.texi2html @@ -32,7 +32,7 @@ fi echo "@clear DEVELOPMENT" fi echo "@set srcdir $SOURCEDIR/.." -) > $SOURCEDIR/include/gcc-vers.texi +) > $DESTDIR/gcc-vers.texi for x in index.html specific.html prerequisites.html download.html configure.html \ build.html test.html finalinstall.html binaries.html old.html \ @@ -40,7 +40,7 @@ for x in index.html specific.html prerequisites.html download.html configure.htm do define=`echo $x | sed -e 's/\.//g'` echo "define = $define" - $MAKEINFO --no-number-sections -I $SOURCEDIR -I $SOURCEDIR/include $SOURCEDIR/install.texi --html --no-split -D$define -o$DESTDIR/$x + $MAKEINFO --no-number-sections -I $SOURCEDIR -I $SOURCEDIR/include -I $DESTDIR $SOURCEDIR/install.texi --html --no-split -D$define -o$DESTDIR/$x done -rm $SOURCEDIR/include/gcc-vers.texi +rm $DESTDIR/gcc-vers.texi diff --git a/gcc/doc/rtl.texi b/gcc/doc/rtl.texi index 96de36503fa..3191fc8e6a9 100644 --- a/gcc/doc/rtl.texi +++ b/gcc/doc/rtl.texi @@ -562,7 +562,7 @@ Stored in the @code{unchanging} field and printed as @samp{/u}. @findex RTL_CONST_CALL_P @cindex @code{call_insn} and @samp{/u} @cindex @code{unchanging}, in @code{call_insn} -@item RTLCONST_OR_PURE_CALL_P (@var{x}) +@item RTL_CONST_CALL_P (@var{x}) In a @code{call_insn} indicates that the insn represents a call to a const function. Stored in the @code{unchanging} field and printed as @samp{/u}. @@ -570,7 +570,7 @@ const function. Stored in the @code{unchanging} field and printed as @findex RTL_PURE_CALL_P @cindex @code{call_insn} and @samp{/i} @cindex @code{return_val}, in @code{call_insn} -@item RTLCONST_OR_PURE_CALL_P (@var{x}) +@item RTL_PURE_CALL_P (@var{x}) In a @code{call_insn} indicates that the insn represents a call to a pure function. Stored in the @code{return_val} field and printed as @samp{/i}. diff --git a/gcc/fold-const.c b/gcc/fold-const.c index c167bc4f670..4113dc45b21 100644 --- a/gcc/fold-const.c +++ b/gcc/fold-const.c @@ -3258,6 +3258,9 @@ operand_equal_p (const_tree arg0, const_tree arg1, unsigned int flags) && operand_equal_p (TREE_OPERAND (arg0, 1), TREE_OPERAND (arg1, 0), flags)); + case COND_EXPR: + return OP_SAME (0) && OP_SAME (1) && OP_SAME (2); + default: return 0; } @@ -7864,8 +7867,7 @@ fold_unary (enum tree_code code, tree type, tree op0) /* Convert (T)(x & c) into (T)x & (T)c, if c is an integer constants (if x has signed type, the sign bit cannot be set in c). This folds extension into the BIT_AND_EXPR. */ - if (INTEGRAL_TYPE_P (type) - && TREE_CODE (type) != BOOLEAN_TYPE + if (TREE_CODE (type) == INTEGER_TYPE && TREE_CODE (op0) == BIT_AND_EXPR && TREE_CODE (TREE_OPERAND (op0, 1)) == INTEGER_CST) { diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0762a6446f3..436142879da 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,177 @@ +2008-05-19 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/36265 + * trans-expr.c (gfc_conv_string_tmp): Pick the correct type for + the temporary variable. + +2008-05-19 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * simplify.c (gfc_simplify_dble, gfc_simplify_real): Initialize + result variable to avoid warnings. + +2008-05-18 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * intrinsic.c (char_conversions, ncharconv): New static variables. + (find_char_conv): New function. + (add_functions): Add simplification functions for ADJUSTL and + ADJUSTR. Don't check the kind of their argument. Add checking for + LGE, LLE, LGT and LLT. + (add_subroutines): Fix argument type for SLEEP. Fix argument name + for SYSTEM. + (add_char_conversions): New function. + (gfc_intrinsic_init_1): Call add_char_conversions. + (gfc_intrinsic_done_1): Free char_conversions. + (check_arglist): Use kind == 0 as a signal that we don't want + the kind value to be checked. + (do_simplify): Also simplify character functions. + (gfc_convert_chartype): New function + * trans-array.c (gfc_trans_array_ctor_element): Don't force the + use of default character type. + (gfc_trans_array_constructor_value): Likewise. + (get_array_ctor_var_strlen): Use integer kind to build an integer + instead of a character kind! + (gfc_build_constant_array_constructor): Don't force the use of + default character type. + (gfc_conv_loop_setup): Likewise. + * trans-expr.c (gfc_conv_string_tmp): Don't force the use of + default character type. Allocate enough memory for wide strings. + (gfc_conv_concat_op): Make sure operand kind are the same. + (string_to_single_character): Remove gfc_ prefix. Reindent. + Don't force the use of default character type. + (gfc_conv_scalar_char_value): Likewise. + (gfc_build_compare_string): Call string_to_single_character. + (fill_with_spaces): New function + (gfc_trans_string_copy): Add kind arguments. Use them to deal + with wide character kinds. + (gfc_conv_statement_function): Whitespace fix. Call + gfc_trans_string_copy with new kind arguments. + (gfc_conv_substring_expr): Call gfc_build_wide_string_const + instead of using gfc_widechar_to_char. + (gfc_conv_string_parameter): Don't force the use of default + character type. + (gfc_trans_scalar_assign): Pass kind args to gfc_trans_string_copy. + * intrinsic.h (gfc_check_lge_lgt_lle_llt, gfc_convert_char_constant, + gfc_resolve_adjustl, gfc_resolve_adjustr): New prototypes. + * decl.c (gfc_set_constant_character_len): Don't assert the + existence of a single character kind. + * trans-array.h (gfc_trans_string_copy): New prototype. + * gfortran.h (gfc_check_character_range, gfc_convert_chartype): + New prototypes. + * error.c (print_wide_char_into_buffer): New function lifting + code from gfc_print_wide_char. Fix order to output '\x??' instead + of 'x\??'. + (gfc_print_wide_char): Call print_wide_char_into_buffer. + (show_locus): Call print_wide_char_into_buffer with buffer local + to this function. + * trans-const.c (gfc_build_wide_string_const): New function. + (gfc_conv_string_init): Deal with wide characters strings + constructors. + (gfc_conv_constant_to_tree): Call gfc_build_wide_string_const. + * trans-stmt.c (gfc_trans_label_assign): Likewise. + (gfc_trans_character_select): Deal with wide strings. + * expr.c (gfc_check_assign): Allow conversion between character + kinds on assignment. + * trans-const.h (gfc_build_wide_string_const): New prototype. + * trans-types.c (gfc_get_character_type_len_for_eltype, + gfc_get_character_type_len): Create too variants of the old + gfc_get_character_type_len, one getting kind argument and the + other one directly taking a type tree. + * trans.h (gfor_fndecl_select_string_char4, + gfor_fndecl_convert_char1_to_char4, + gfor_fndecl_convert_char4_to_char1): New prototypes. + * trans-types.h (gfc_get_character_type_len_for_eltype): New + prototype. + * resolve.c (resolve_operator): Exit early when kind mismatches + are detected, because that makes us issue an error message later. + (validate_case_label_expr): Fix wording of error message. + * iresolve.c (gfc_resolve_adjustl, gfc_resolve_adjustr): New + functions. + (gfc_resolve_pack): Call _char4 variants of library function + when dealing with wide characters. + (gfc_resolve_reshape): Likewise. + (gfc_resolve_spread): Likewise. + (gfc_resolve_transpose): Likewise. + (gfc_resolve_unpack): Likewise. + * target-memory.c (size_character): Take character kind bit size + correctly into account (not that it changes anything for now, but + it's more generic). + (gfc_encode_character): Added gfc_ prefix. Encoding each + character of a string by calling native_encode_expr for the + corresponding unsigned integer. + (gfc_target_encode_expr): Add gfc_ prefix to encode_character. + * trans-decl.c (gfc_build_intrinsic_function_decls): Build + gfor_fndecl_select_string_char4, gfor_fndecl_convert_char1_to_char4 + and gfor_fndecl_convert_char4_to_char1. + * target-memory.h (gfc_encode_character): New prototype. + * arith.c (gfc_check_character_range): New function. + (eval_intrinsic): Allow non-default character kinds. + * check.c (gfc_check_access_func): Only allow default + character kind arguments. + (gfc_check_chdir): Likewise. + (gfc_check_chdir_sub): Likewise. + (gfc_check_chmod): Likewise. + (gfc_check_chmod_sub): Likewise. + (gfc_check_lge_lgt_lle_llt): New function. + (gfc_check_link): Likewise. + (gfc_check_link_sub): Likewise. + (gfc_check_symlnk): Likewise. + (gfc_check_symlnk_sub): Likewise. + (gfc_check_rename): Likewise. + (gfc_check_rename_sub): Likewise. + (gfc_check_fgetputc_sub): Likewise. + (gfc_check_fgetput_sub): Likewise. + (gfc_check_stat): Likewise. + (gfc_check_stat_sub): Likewise. + (gfc_check_date_and_time): Likewise. + (gfc_check_ctime_sub): Likewise. + (gfc_check_fdate_sub): Likewise. + (gfc_check_gerror): Likewise. + (gfc_check_getcwd_sub): Likewise. + (gfc_check_getarg): Likewise. + (gfc_check_getlog): Likewise. + (gfc_check_hostnm): Likewise. + (gfc_check_hostnm_sub): Likewise. + (gfc_check_ttynam_sub): Likewise. + (gfc_check_perror): Likewise. + (gfc_check_unlink): Likewise. + (gfc_check_unlink_sub): Likewise. + (gfc_check_system_sub): Likewise. + * primary.c (got_delim): Perform correct character range checking + for all kinds. + * trans-intrinsic.c (gfc_conv_intrinsic_conversion): Generate + calls to library functions convert_char4_to_char1 and + convert_char1_to_char4 for character conversions. + (gfc_conv_intrinsic_char): Allow all character kings. + (gfc_conv_intrinsic_strcmp): Fix whitespace. + (gfc_conv_intrinsic_repeat): Take care of all character kinds. + * intrinsic.texi: For all GNU intrinsics accepting character + arguments, mention that they're restricted to the default kind. + * simplify.c (simplify_achar_char): New function. + (gfc_simplify_achar, gfc_simplify_char): Call simplify_achar_char. + gfc_simplify_ichar): Don't error out for wide characters. + (gfc_convert_char_constant): New function. + +2008-05-18 Steven G. Kargl <kargls@comcast.net> + + PR fortran/36251 + * symbol.c (check_conflict): Issue errors for abuse of PUBLIC, PRIVATE, + and BIND(C). + * resolve.c (gfc_verify_binding_labels): Fix NULL pointer dereference. + +2008-05-17 Tobias Burnus <burnus@net-b.de> + + * intrinsic.texi: Correct description of GET_COMMAND_ARGUMENT + and GET_ENVIRONMENT_VARIABLE; fix keyword= name for GETENV, + GETLOG, GMTIME, HOSTNM, IRAND, ITIME, KILL. + Move LOG_GAMMA after LOG10. + +2008-05-17 Tobias Burnus <burnus@net-b.de> + + * intrinsic.c (add_functions): Change FLUSH(C) to FLUSH(UNIT). + * intrinsic.texi: Change INTEGER(*) to INTEGER; fix keyword= name for + ABS, ADJUSTL, AINT, ALLOCATED, ANINT, ASSOCIATED, C_ASSOCIATED, + CEILING, DBLE, DFLOAT, DOT_PRODUCT, DREAL, FLOAT, FLOOR, GET_COMMAND. + 2008-05-16 Paul Thomas <pault@gcc.gnu.org> PR fortran/35756 diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index cbfcf291049..6e09f8a3e1e 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -280,6 +280,23 @@ gfc_arith_done_1 (void) } +/* Given a wide character value and a character kind, determine whether + the character is representable for that kind. */ +bool +gfc_check_character_range (gfc_char_t c, int kind) +{ + /* As wide characters are stored as 32-bit values, they're all + representable in UCS=4. */ + if (kind == 4) + return true; + + if (kind == 1) + return c <= 255 ? true : false; + + gcc_unreachable (); +} + + /* Given an integer and a kind, make sure that the integer lies within the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or ARITH_OVERFLOW. */ @@ -1655,6 +1672,11 @@ eval_intrinsic (gfc_intrinsic_op operator, unary = 0; temp.ts.type = BT_LOGICAL; temp.ts.kind = gfc_default_logical_kind; + + /* If kind mismatch, exit and we'll error out later. */ + if (op1->ts.kind != op2->ts.kind) + goto runtime; + break; } @@ -1696,11 +1718,12 @@ eval_intrinsic (gfc_intrinsic_op operator, /* Character binary */ case INTRINSIC_CONCAT: - if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER) + if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER + || op1->ts.kind != op2->ts.kind) goto runtime; temp.ts.type = BT_CHARACTER; - temp.ts.kind = gfc_default_character_kind; + temp.ts.kind = op1->ts.kind; unary = 0; break; diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index f0497a1c88b..87d962e50a7 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -492,10 +492,14 @@ gfc_check_access_func (gfc_expr *name, gfc_expr *mode) if (type_check (name, 0, BT_CHARACTER) == FAILURE || scalar_check (name, 0) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (mode, 1, BT_CHARACTER) == FAILURE || scalar_check (mode, 1) == FAILURE) return FAILURE; + if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } @@ -716,6 +720,8 @@ gfc_check_chdir (gfc_expr *dir) { if (type_check (dir, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } @@ -726,13 +732,14 @@ gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status) { if (type_check (dir, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; if (type_check (status, 1, BT_INTEGER) == FAILURE) return FAILURE; - if (scalar_check (status, 1) == FAILURE) return FAILURE; @@ -745,9 +752,13 @@ gfc_check_chmod (gfc_expr *name, gfc_expr *mode) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (mode, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } @@ -758,9 +769,13 @@ gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (mode, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; @@ -1497,13 +1512,34 @@ gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind) try +gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b) +{ + if (type_check (a, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + if (kind_value_check (a, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; + + if (type_check (b, 1, BT_CHARACTER) == FAILURE) + return FAILURE; + if (kind_value_check (b, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try gfc_check_link (gfc_expr *path1, gfc_expr *path2) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } @@ -1514,9 +1550,13 @@ gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path2, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; @@ -1543,9 +1583,13 @@ gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } @@ -1556,9 +1600,13 @@ gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; @@ -2166,9 +2214,13 @@ gfc_check_rename (gfc_expr *path1, gfc_expr *path2) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } @@ -2179,9 +2231,13 @@ gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; @@ -2535,6 +2591,8 @@ gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status) if (type_check (c, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; @@ -2560,6 +2618,8 @@ gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status) { if (type_check (c, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; @@ -2705,6 +2765,8 @@ gfc_check_stat (gfc_expr *name, gfc_expr *array) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (array, 1, BT_INTEGER) == FAILURE || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE) @@ -2722,6 +2784,8 @@ gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (array, 1, BT_INTEGER) == FAILURE || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE) @@ -2914,6 +2978,8 @@ gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, { if (type_check (date, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (scalar_check (date, 0) == FAILURE) return FAILURE; if (variable_check (date, 0) == FAILURE) @@ -2924,6 +2990,8 @@ gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, { if (type_check (time, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; if (scalar_check (time, 1) == FAILURE) return FAILURE; if (variable_check (time, 1) == FAILURE) @@ -2934,6 +3002,8 @@ gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, { if (type_check (zone, 2, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE) + return FAILURE; if (scalar_check (zone, 2) == FAILURE) return FAILURE; if (variable_check (zone, 2) == FAILURE) @@ -3246,12 +3316,13 @@ gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result) { if (scalar_check (time, 0) == FAILURE) return FAILURE; - if (type_check (time, 0, BT_INTEGER) == FAILURE) return FAILURE; if (type_check (result, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } @@ -3315,6 +3386,8 @@ gfc_check_fdate_sub (gfc_expr *date) { if (type_check (date, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } @@ -3325,6 +3398,8 @@ gfc_check_gerror (gfc_expr *msg) { if (type_check (msg, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } @@ -3335,6 +3410,8 @@ gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status) { if (type_check (cwd, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; @@ -3366,6 +3443,8 @@ gfc_check_getarg (gfc_expr *pos, gfc_expr *value) if (type_check (value, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } @@ -3376,6 +3455,8 @@ gfc_check_getlog (gfc_expr *msg) { if (type_check (msg, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } @@ -3431,6 +3512,8 @@ gfc_check_hostnm (gfc_expr *name) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } @@ -3441,6 +3524,8 @@ gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; @@ -3519,6 +3604,8 @@ gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name) if (type_check (name, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } @@ -3555,6 +3642,8 @@ gfc_check_perror (gfc_expr *string) { if (type_check (string, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } @@ -3600,6 +3689,8 @@ gfc_check_unlink (gfc_expr *name) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } @@ -3610,6 +3701,8 @@ gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; @@ -3686,6 +3779,8 @@ gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status) { if (type_check (cmd, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (scalar_check (status, 1) == FAILURE) return FAILURE; diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 5a1ce038f1f..79044eb1846 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1093,7 +1093,7 @@ gfc_set_constant_character_len (int len, gfc_expr *expr, bool array) int slen; gcc_assert (expr->expr_type == EXPR_CONSTANT); - gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1); + gcc_assert (expr->ts.type == BT_CHARACTER); slen = expr->value.character.length; if (len != slen) diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c index a9cbe9ef5f2..c34899f1337 100644 --- a/gcc/fortran/error.c +++ b/gcc/fortran/error.c @@ -152,14 +152,11 @@ error_integer (long int i) } -static char wide_char_print_buffer[11]; - -const char * -gfc_print_wide_char (gfc_char_t c) +static void +print_wide_char_into_buffer (gfc_char_t c, char *buf) { static const char xdigit[16] = { '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' }; - char *buf = wide_char_print_buffer; if (gfc_wide_is_printable (c)) { @@ -173,8 +170,8 @@ gfc_print_wide_char (gfc_char_t c) c = c >> 4; buf[2] = xdigit[c & 0x0F]; - buf[1] = '\\'; - buf[0] = 'x'; + buf[1] = 'x'; + buf[0] = '\\'; } else if (c < ((gfc_char_t) 1 << 16)) { @@ -187,8 +184,8 @@ gfc_print_wide_char (gfc_char_t c) c = c >> 4; buf[2] = xdigit[c & 0x0F]; - buf[1] = '\\'; - buf[0] = 'u'; + buf[1] = 'u'; + buf[0] = '\\'; } else { @@ -209,13 +206,21 @@ gfc_print_wide_char (gfc_char_t c) c = c >> 4; buf[2] = xdigit[c & 0x0F]; - buf[1] = '\\'; - buf[0] = 'U'; + buf[1] = 'U'; + buf[0] = '\\'; } +} - return buf; +static char wide_char_print_buffer[11]; + +const char * +gfc_print_wide_char (gfc_char_t c) +{ + print_wide_char_into_buffer (c, wide_char_print_buffer); + return wide_char_print_buffer; } + /* Show the file, where it was included, and the source line, give a locus. Calls error_printf() recursively, but the recursion is at most one level deep. */ @@ -317,11 +322,14 @@ show_locus (locus *loc, int c1, int c2) for (; i > 0; i--) { + static char buffer[11]; + c = *p++; if (c == '\t') c = ' '; - error_string (gfc_print_wide_char (c)); + print_wide_char_into_buffer (c, buffer); + error_string (buffer); } error_char ('\n'); diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index e6c1e4e9dbe..a8727430221 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -2847,6 +2847,16 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) return FAILURE; } + /* Assignment is the only case where character variables of different + kind values can be converted into one another. */ + if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER) + { + if (lvalue->ts.kind != rvalue->ts.kind) + gfc_convert_chartype (rvalue, &lvalue->ts); + + return SUCCESS; + } + return gfc_convert_type (rvalue, &lvalue->ts, 1); } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 5fa3bc1f2c7..e3a9446333e 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2069,6 +2069,7 @@ void gfc_arith_init_1 (void); void gfc_arith_done_1 (void); gfc_expr *gfc_enum_initializer (gfc_expr *, locus); arith gfc_check_integer_range (mpz_t p, int kind); +bool gfc_check_character_range (gfc_char_t, int); /* trans-types.c */ try gfc_validate_c_kind (gfc_typespec *); @@ -2225,6 +2226,7 @@ char gfc_type_letter (bt); gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *); try gfc_convert_type (gfc_expr *, gfc_typespec *, int); try gfc_convert_type_warn (gfc_expr *, gfc_typespec *, int, int); +try gfc_convert_chartype (gfc_expr *, gfc_typespec *); int gfc_generic_intrinsic (const char *); int gfc_specific_intrinsic (const char *); int gfc_intrinsic_name (const char *, int); diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index f6381275997..e902f693f6b 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -39,9 +39,10 @@ const char *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; locus *gfc_current_intrinsic_where; static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym; +static gfc_intrinsic_sym *char_conversions; static gfc_intrinsic_arg *next_arg; -static int nfunc, nsub, nargs, nconv; +static int nfunc, nsub, nargs, nconv, ncharconv; static enum { SZ_NOTHING = 0, SZ_SUBS, SZ_FUNCS, SZ_CONVS } @@ -148,6 +149,28 @@ find_conv (gfc_typespec *from, gfc_typespec *to) } +/* Given a pair of CHARACTER typespecs, find the gfc_intrinsic_sym node + that corresponds to the conversion. Returns NULL if the conversion + isn't found. */ + +static gfc_intrinsic_sym * +find_char_conv (gfc_typespec *from, gfc_typespec *to) +{ + gfc_intrinsic_sym *sym; + const char *target; + int i; + + target = conv_name (from, to); + sym = char_conversions; + + for (i = 0; i < ncharconv; i++, sym++) + if (target == sym->name) + return sym; + + return NULL; +} + + /* Interface to the check functions. We break apart an argument list and call the proper check function rather than forcing each function to manipulate the argument list. */ @@ -974,15 +997,15 @@ add_functions (void) make_generic ("acosh", GFC_ISYM_ACOSH, GFC_STD_F2008); - add_sym_1 ("adjustl", GFC_ISYM_ADJUSTL, CLASS_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95, - NULL, gfc_simplify_adjustl, NULL, - stg, BT_CHARACTER, dc, REQUIRED); + add_sym_1 ("adjustl", GFC_ISYM_ADJUSTL, CLASS_ELEMENTAL, ACTUAL_NO, + BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustl, + gfc_resolve_adjustl, stg, BT_CHARACTER, 0, REQUIRED); make_generic ("adjustl", GFC_ISYM_ADJUSTL, GFC_STD_F95); - add_sym_1 ("adjustr", GFC_ISYM_ADJUSTR, CLASS_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95, - NULL, gfc_simplify_adjustr, NULL, - stg, BT_CHARACTER, dc, REQUIRED); + add_sym_1 ("adjustr", GFC_ISYM_ADJUSTR, CLASS_ELEMENTAL, ACTUAL_NO, + BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustr, + gfc_resolve_adjustr, stg, BT_CHARACTER, 0, REQUIRED); make_generic ("adjustr", GFC_ISYM_ADJUSTR, GFC_STD_F95); @@ -1760,26 +1783,26 @@ add_functions (void) make_generic ("log_gamma", GFC_ISYM_LGAMMA, GFC_STD_F2008); - add_sym_2 ("lge", GFC_ISYM_LGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F77, - NULL, gfc_simplify_lge, NULL, + add_sym_2 ("lge", GFC_ISYM_LGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, + GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lge, NULL, sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); make_generic ("lge", GFC_ISYM_LGE, GFC_STD_F77); - add_sym_2 ("lgt", GFC_ISYM_LGT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F77, - NULL, gfc_simplify_lgt, NULL, + add_sym_2 ("lgt", GFC_ISYM_LGT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, + GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lgt, NULL, sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); make_generic ("lgt", GFC_ISYM_LGT, GFC_STD_F77); - add_sym_2 ("lle",GFC_ISYM_LLE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F77, - NULL, gfc_simplify_lle, NULL, + add_sym_2 ("lle",GFC_ISYM_LLE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, + GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lle, NULL, sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); make_generic ("lle", GFC_ISYM_LLE, GFC_STD_F77); - add_sym_2 ("llt", GFC_ISYM_LLT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F77, - NULL, gfc_simplify_llt, NULL, + add_sym_2 ("llt", GFC_ISYM_LLT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, + GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_llt, NULL, sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77); @@ -2578,7 +2601,7 @@ add_subroutines (void) add_sym_1s ("flush", GFC_ISYM_FLUSH, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_flush, NULL, gfc_resolve_flush, - c, BT_INTEGER, di, OPTIONAL); + ut, BT_INTEGER, di, OPTIONAL); add_sym_3s ("fputc", GFC_ISYM_FPUTC, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_fgetputc_sub, NULL, gfc_resolve_fputc_sub, @@ -2625,7 +2648,7 @@ add_subroutines (void) add_sym_1s ("sleep", GFC_ISYM_SLEEP, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub, - val, BT_CHARACTER, dc, REQUIRED); + val, BT_INTEGER, di, REQUIRED); add_sym_3s ("fstat", GFC_ISYM_FSTAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub, @@ -2654,7 +2677,7 @@ add_subroutines (void) add_sym_2s ("system", GFC_ISYM_SYSTEM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, NULL, NULL, gfc_resolve_system_sub, - c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + com, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); add_sym_3s ("system_clock", GFC_ISYM_SYSTEM_CLOCK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95, gfc_check_system_clock, NULL, gfc_resolve_system_clock, @@ -2817,6 +2840,52 @@ add_conversions (void) } +static void +add_char_conversions (void) +{ + int n, i, j; + + /* Count possible conversions. */ + for (i = 0; gfc_character_kinds[i].kind != 0; i++) + for (j = 0; gfc_character_kinds[j].kind != 0; j++) + if (i != j) + ncharconv++; + + /* Allocate memory. */ + char_conversions = gfc_getmem (sizeof (gfc_intrinsic_sym) * ncharconv); + + /* Add the conversions themselves. */ + n = 0; + for (i = 0; gfc_character_kinds[i].kind != 0; i++) + for (j = 0; gfc_character_kinds[j].kind != 0; j++) + { + gfc_typespec from, to; + + if (i == j) + continue; + + gfc_clear_ts (&from); + from.type = BT_CHARACTER; + from.kind = gfc_character_kinds[i].kind; + + gfc_clear_ts (&to); + to.type = BT_CHARACTER; + to.kind = gfc_character_kinds[j].kind; + + char_conversions[n].name = conv_name (&from, &to); + char_conversions[n].lib_name = char_conversions[n].name; + char_conversions[n].simplify.cc = gfc_convert_char_constant; + char_conversions[n].standard = GFC_STD_F2003; + char_conversions[n].elemental = 1; + char_conversions[n].conversion = 0; + char_conversions[n].ts = to; + char_conversions[n].id = GFC_ISYM_CONVERSION; + + n++; + } +} + + /* Initialize the table of intrinsics. */ void gfc_intrinsic_init_1 (void) @@ -2852,6 +2921,9 @@ gfc_intrinsic_init_1 (void) add_subroutines (); add_conversions (); + /* Character conversion intrinsics need to be treated separately. */ + add_char_conversions (); + /* Set the pure flag. All intrinsic functions are pure, and intrinsic subroutines are pure if they are elemental. */ @@ -2868,6 +2940,7 @@ gfc_intrinsic_done_1 (void) { gfc_free (functions); gfc_free (conversion); + gfc_free (char_conversions); gfc_free_namespace (gfc_intrinsic_namespace); } @@ -3052,10 +3125,18 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym, i = 0; for (; formal; formal = formal->next, actual = actual->next, i++) { + gfc_typespec ts; + if (actual->expr == NULL) continue; - if (!gfc_compare_types (&formal->ts, &actual->expr->ts)) + ts = formal->ts; + + /* A kind of 0 means we don't check for kind. */ + if (ts.kind == 0) + ts.kind = actual->expr->ts.kind; + + if (!gfc_compare_types (&ts, &actual->expr->ts)) { if (error_flag) gfc_error ("Type of argument '%s' in call to '%s' at %L should " @@ -3199,9 +3280,10 @@ do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e) a1 = arg->expr; arg = arg->next; - if (specific->simplify.cc == gfc_convert_constant) + if (specific->simplify.cc == gfc_convert_constant + || specific->simplify.cc == gfc_convert_char_constant) { - result = gfc_convert_constant (a1, specific->ts.type, specific->ts.kind); + result = specific->simplify.cc (a1, specific->ts.type, specific->ts.kind); goto finish; } @@ -3687,3 +3769,60 @@ bad: &expr->where); /* Not reached */ } + + +try +gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts) +{ + gfc_intrinsic_sym *sym; + gfc_typespec from_ts; + locus old_where; + gfc_expr *new; + int rank; + mpz_t *shape; + + gcc_assert (expr->ts.type == BT_CHARACTER && ts->type == BT_CHARACTER); + from_ts = expr->ts; /* expr->ts gets clobbered */ + + sym = find_char_conv (&expr->ts, ts); + gcc_assert (sym); + + /* Insert a pre-resolved function call to the right function. */ + old_where = expr->where; + rank = expr->rank; + shape = expr->shape; + + new = gfc_get_expr (); + *new = *expr; + + new = gfc_build_conversion (new); + new->value.function.name = sym->lib_name; + new->value.function.isym = sym; + new->where = old_where; + new->rank = rank; + new->shape = gfc_copy_shape (shape, rank); + + gfc_get_ha_sym_tree (sym->name, &new->symtree); + new->symtree->n.sym->ts = *ts; + new->symtree->n.sym->attr.flavor = FL_PROCEDURE; + new->symtree->n.sym->attr.function = 1; + new->symtree->n.sym->attr.elemental = 1; + new->symtree->n.sym->attr.pure = 1; + new->symtree->n.sym->attr.referenced = 1; + gfc_intrinsic_symbol(new->symtree->n.sym); + gfc_commit_symbol (new->symtree->n.sym); + + *expr = *new; + + gfc_free (new); + expr->ts = *ts; + + if (gfc_is_constant_expr (expr->value.function.actual->expr) + && do_simplify (sym, expr) == FAILURE) + { + /* Error already generated in do_simplify() */ + return FAILURE; + } + + return SUCCESS; +} diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index ac996b62a57..e280c50d78f 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -91,6 +91,7 @@ try gfc_check_kind (gfc_expr *); try gfc_check_lbound (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_len_lentrim (gfc_expr *, gfc_expr *); try gfc_check_link (gfc_expr *, gfc_expr *); +try gfc_check_lge_lgt_lle_llt (gfc_expr *, gfc_expr *); try gfc_check_loc (gfc_expr *); try gfc_check_logical (gfc_expr *, gfc_expr *); try gfc_check_min_max (gfc_actual_arglist *); @@ -317,11 +318,14 @@ gfc_expr *gfc_simplify_xor (gfc_expr *, gfc_expr *); /* Constant conversion simplification. */ gfc_expr *gfc_convert_constant (gfc_expr *, bt, int); +gfc_expr *gfc_convert_char_constant (gfc_expr *, bt, int); /* Resolution functions. */ void gfc_resolve_abs (gfc_expr *, gfc_expr *); void gfc_resolve_access (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_adjustl (gfc_expr *, gfc_expr *); +void gfc_resolve_adjustr (gfc_expr *, gfc_expr *); void gfc_resolve_achar (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_acos (gfc_expr *, gfc_expr *); void gfc_resolve_acosh (gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 571f10e893f..6852d64387e 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -358,7 +358,7 @@ end program test_abort @table @asis @item @emph{Description}: -@code{ABS(X)} computes the absolute value of @code{X}. +@code{ABS(A)} computes the absolute value of @code{A}. @item @emph{Standard}: Fortran 77 and later, has overloads that are GNU extensions @@ -367,18 +367,18 @@ Fortran 77 and later, has overloads that are GNU extensions Elemental function @item @emph{Syntax}: -@code{RESULT = ABS(X)} +@code{RESULT = ABS(A)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type of the argument shall be an @code{INTEGER(*)}, -@code{REAL(*)}, or @code{COMPLEX(*)}. +@item @var{A} @tab The type of the argument shall be an @code{INTEGER}, +@code{REAL}, or @code{COMPLEX}. @end multitable @item @emph{Return value}: The return value is of the same type and -kind as the argument except the return value is @code{REAL(*)} for a -@code{COMPLEX(*)} argument. +kind as the argument except the return value is @code{REAL} for a +@code{COMPLEX} argument. @item @emph{Example}: @smallexample @@ -395,11 +395,11 @@ end program test_abs @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{CABS(Z)} @tab @code{COMPLEX(4) Z} @tab @code{REAL(4)} @tab Fortran 77 and later -@item @code{DABS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later -@item @code{IABS(I)} @tab @code{INTEGER(4) I} @tab @code{INTEGER(4)} @tab Fortran 77 and later -@item @code{ZABS(Z)} @tab @code{COMPLEX(8) Z} @tab @code{COMPLEX(8)} @tab GNU extension -@item @code{CDABS(Z)} @tab @code{COMPLEX(8) Z} @tab @code{COMPLEX(8)} @tab GNU extension +@item @code{CABS(A)} @tab @code{COMPLEX(4) Z} @tab @code{REAL(4)} @tab Fortran 77 and later +@item @code{DABS(A)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later +@item @code{IABS(A)} @tab @code{INTEGER(4) I} @tab @code{INTEGER(4)} @tab Fortran 77 and later +@item @code{ZABS(A)} @tab @code{COMPLEX(8) Z} @tab @code{COMPLEX(8)} @tab GNU extension +@item @code{CDABS(A)} @tab @code{COMPLEX(8) Z} @tab @code{COMPLEX(8)} @tab GNU extension @end multitable @end table @@ -428,13 +428,14 @@ Inquiry function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{NAME} @tab Scalar @code{CHARACTER} with the file name. -Tailing blank are ignored unless the character @code{achar(0)} is -present, then all characters up to and excluding @code{achar(0)} are +@item @var{NAME} @tab Scalar @code{CHARACTER} of default kind with the +file name. Tailing blank are ignored unless the character @code{achar(0)} +is present, then all characters up to and excluding @code{achar(0)} are used as file name. -@item @var{MODE} @tab Scalar @code{CHARACTER} with the file access mode, -may be any concatenation of @code{"r"} (readable), @code{"w"} (writable) -and @code{"x"} (executable), or @code{" "} to check for existence. +@item @var{MODE} @tab Scalar @code{CHARACTER} of default kind with the +file access mode, may be any concatenation of @code{"r"} (readable), +@code{"w"} (writable) and @code{"x"} (executable), or @code{" "} to check +for existence. @end multitable @item @emph{Return value}: @@ -485,15 +486,16 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be @code{INTEGER(*)}. +@item @var{I} @tab The type shall be @code{INTEGER}. @item @var{KIND} @tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of the result. @end multitable @item @emph{Return value}: -The return value is of type @code{CHARACTER} with a length of one. The -kind type parameter is the same as @code{KIND('A')}. +The return value is of type @code{CHARACTER} with a length of one. +If the @var{KIND} argument is present, the return value is of the +specified kind and of the default kind otherwise. @item @emph{Example}: @smallexample @@ -536,14 +538,14 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)} with a magnitude that is +@item @var{X} @tab The type shall be @code{REAL} with a magnitude that is less than one. @end multitable @item @emph{Return value}: -The return value is of type @code{REAL(*)} and it lies in the -range @math{ 0 \leq \acos(x) \leq \pi}. The kind type parameter -is the same as @var{X}. +The return value is of type @code{REAL} and it lies in the +range @math{ 0 \leq \acos(x) \leq \pi}. The return value if of the same +kind as @var{X}. @item @emph{Example}: @smallexample @@ -625,7 +627,7 @@ Inverse function: @ref{COSH} @table @asis @item @emph{Description}: -@code{ADJUSTL(STR)} will left adjust a string by removing leading spaces. +@code{ADJUSTL(STRING)} will left adjust a string by removing leading spaces. Spaces are inserted at the end of the string as needed. @item @emph{Standard}: @@ -635,17 +637,17 @@ Fortran 95 and later Elemental function @item @emph{Syntax}: -@code{RESULT = ADJUSTL(STR)} +@code{RESULT = ADJUSTL(STRING)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{STR} @tab The type shall be @code{CHARACTER}. +@item @var{STRING} @tab The type shall be @code{CHARACTER}. @end multitable @item @emph{Return value}: -The return value is of type @code{CHARACTER} where leading spaces -are removed and the same number of spaces are inserted on the end -of @var{STR}. +The return value is of type @code{CHARACTER} and of the same kind as +@var{STRING} where leading spaces are removed and the same number of +spaces are inserted on the end of @var{STRING}. @item @emph{Example}: @smallexample @@ -670,7 +672,7 @@ end program test_adjustl @table @asis @item @emph{Description}: -@code{ADJUSTR(STR)} will right adjust a string by removing trailing spaces. +@code{ADJUSTR(STRING)} will right adjust a string by removing trailing spaces. Spaces are inserted at the start of the string as needed. @item @emph{Standard}: @@ -680,7 +682,7 @@ Fortran 95 and later Elemental function @item @emph{Syntax}: -@code{RESULT = ADJUSTR(STR)} +@code{RESULT = ADJUSTR(STRING)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -688,9 +690,9 @@ Elemental function @end multitable @item @emph{Return value}: -The return value is of type @code{CHARACTER} where trailing spaces -are removed and the same number of spaces are inserted at the start -of @var{STR}. +The return value is of type @code{CHARACTER} and of the same kind as +@var{STRING} where trailing spaces are removed and the same number of +spaces are inserted at the start of @var{STRING}. @item @emph{Example}: @smallexample @@ -733,11 +735,11 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{Z} @tab The type of the argument shall be @code{COMPLEX(*)}. +@item @var{Z} @tab The type of the argument shall be @code{COMPLEX}. @end multitable @item @emph{Return value}: -The return value is of type real with the +The return value is of type @code{REAL} with the kind type parameter of the argument. @item @emph{Example}: @@ -755,8 +757,8 @@ end program test_aimag @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard @item @code{DIMAG(Z)} @tab @code{COMPLEX(8) Z} @tab @code{REAL(8)} @tab GNU extension -@item @code{IMAG(Z)} @tab @code{COMPLEX(*) Z} @tab @code{REAL(*)} @tab GNU extension -@item @code{IMAGPART(Z)} @tab @code{COMPLEX(*) Z} @tab @code{REAL(*)} @tab GNU extension +@item @code{IMAG(Z)} @tab @code{COMPLEX Z} @tab @code{REAL} @tab GNU extension +@item @code{IMAGPART(Z)} @tab @code{COMPLEX Z} @tab @code{REAL} @tab GNU extension @end multitable @end table @@ -771,7 +773,7 @@ end program test_aimag @table @asis @item @emph{Description}: -@code{AINT(X [, KIND])} truncates its argument to a whole number. +@code{AINT(A [, KIND])} truncates its argument to a whole number. @item @emph{Standard}: Fortran 77 and later @@ -780,22 +782,22 @@ Fortran 77 and later Elemental function @item @emph{Syntax}: -@code{RESULT = AINT(X [, KIND])} +@code{RESULT = AINT(A [, KIND])} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type of the argument shall be @code{REAL(*)}. -@item @var{KIND} @tab (Optional) An @code{INTEGER(*)} initialization +@item @var{A} @tab The type of the argument shall be @code{REAL}. +@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of the result. @end multitable @item @emph{Return value}: -The return value is of type real with the kind type parameter of the +The return value is of type @code{REAL} with the kind type parameter of the argument if the optional @var{KIND} is absent; otherwise, the kind type parameter will be given by @var{KIND}. If the magnitude of -@var{X} is less than one, then @code{AINT(X)} returns zero. If the -magnitude is equal to or greater than one, then it returns the largest +@var{X} is less than one, @code{AINT(X)} returns zero. If the +magnitude is equal to or greater than one then it returns the largest whole number that does not exceed its magnitude. The sign is the same as the sign of @var{X}. @@ -893,14 +895,14 @@ Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{MASK} @tab The type of the argument shall be @code{LOGICAL(*)} and +@item @var{MASK} @tab The type of the argument shall be @code{LOGICAL} and it shall not be scalar. @item @var{DIM} @tab (Optional) @var{DIM} shall be a scalar integer with a value that lies between one and the rank of @var{MASK}. @end multitable @item @emph{Return value}: -@code{ALL(MASK)} returns a scalar value of type @code{LOGICAL(*)} where +@code{ALL(MASK)} returns a scalar value of type @code{LOGICAL} where the kind type parameter is the same as the kind type parameter of @var{MASK}. If @var{DIM} is present, then @code{ALL(MASK, DIM)} returns an array with the rank of @var{MASK} minus 1. The shape is determined from @@ -945,7 +947,7 @@ end program test_all @table @asis @item @emph{Description}: -@code{ALLOCATED(X)} checks the status of whether @var{X} is allocated. +@code{ALLOCATED(ARRAY)} checks the status of whether @var{X} is allocated. @item @emph{Standard}: Fortran 95 and later @@ -954,16 +956,16 @@ Fortran 95 and later Inquiry function @item @emph{Syntax}: -@code{RESULT = ALLOCATED(X)} +@code{RESULT = ALLOCATED(ARRAY)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The argument shall be an @code{ALLOCATABLE} array. +@item @var{ARRAY} @tab The argument shall be an @code{ALLOCATABLE} array. @end multitable @item @emph{Return value}: The return value is a scalar @code{LOGICAL} with the default logical -kind type parameter. If @var{X} is allocated, @code{ALLOCATED(X)} +kind type parameter. If @var{ARRAY} is allocated, @code{ALLOCATED(ARRAY)} is @code{.TRUE.}; otherwise, it returns @code{.FALSE.} @item @emph{Example}: @@ -1003,13 +1005,13 @@ Function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be either a scalar @code{INTEGER(*)} +@item @var{I} @tab The type shall be either a scalar @code{INTEGER} type or a scalar @code{LOGICAL} type. @item @var{J} @tab The type shall be the same as the type of @var{I}. @end multitable @item @emph{Return value}: -The return type is either a scalar @code{INTEGER(*)} or a scalar +The return type is either a scalar @code{INTEGER} or a scalar @code{LOGICAL}. If the kind type parameters differ, then the smaller kind type is implicitly converted to larger kind, and the return has the larger kind. @@ -1041,7 +1043,7 @@ Fortran 95 elemental function: @ref{IAND} @table @asis @item @emph{Description}: -@code{ANINT(X [, KIND])} rounds its argument to the nearest whole number. +@code{ANINT(A [, KIND])} rounds its argument to the nearest whole number. @item @emph{Standard}: Fortran 77 and later @@ -1050,12 +1052,12 @@ Fortran 77 and later Elemental function @item @emph{Syntax}: -@code{RESULT = ANINT(X [, KIND])} +@code{RESULT = ANINT(A [, KIND])} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type of the argument shall be @code{REAL(*)}. -@item @var{KIND} @tab (Optional) An @code{INTEGER(*)} initialization +@item @var{A} @tab The type of the argument shall be @code{REAL}. +@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of the result. @end multitable @@ -1063,9 +1065,9 @@ Elemental function @item @emph{Return value}: The return value is of type real with the kind type parameter of the argument if the optional @var{KIND} is absent; otherwise, the kind -type parameter will be given by @var{KIND}. If @var{X} is greater than -zero, then @code{ANINT(X)} returns @code{AINT(X+0.5)}. If @var{X} is -less than or equal to zero, then it returns @code{AINT(X-0.5)}. +type parameter will be given by @var{KIND}. If @var{A} is greater than +zero, @code{ANINT(A)} returns @code{AINT(X+0.5)}. If @var{A} is +less than or equal to zero then it returns @code{AINT(X-0.5)}. @item @emph{Example}: @smallexample @@ -1082,7 +1084,7 @@ end program test_anint @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{DNINT(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later +@item @code{DNINT(A)} @tab @code{REAL(8) A} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @end table @@ -1110,14 +1112,14 @@ Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{MASK} @tab The type of the argument shall be @code{LOGICAL(*)} and +@item @var{MASK} @tab The type of the argument shall be @code{LOGICAL} and it shall not be scalar. @item @var{DIM} @tab (Optional) @var{DIM} shall be a scalar integer with a value that lies between one and the rank of @var{MASK}. @end multitable @item @emph{Return value}: -@code{ANY(MASK)} returns a scalar value of type @code{LOGICAL(*)} where +@code{ANY(MASK)} returns a scalar value of type @code{LOGICAL} where the kind type parameter is the same as the kind type parameter of @var{MASK}. If @var{DIM} is present, then @code{ANY(MASK, DIM)} returns an array with the rank of @var{MASK} minus 1. The shape is determined from @@ -1177,12 +1179,12 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)}, and a magnitude that is +@item @var{X} @tab The type shall be @code{REAL}, and a magnitude that is less than one. @end multitable @item @emph{Return value}: -The return value is of type @code{REAL(*)} and it lies in the +The return value is of type @code{REAL} and it lies in the range @math{-\pi / 2 \leq \asin (x) \leq \pi / 2}. The kind type parameter is the same as @var{X}. @@ -1265,8 +1267,8 @@ Inverse function: @ref{SINH} @table @asis @item @emph{Description}: -@code{ASSOCIATED(PTR [, TGT])} determines the status of the pointer @var{PTR} -or if @var{PTR} is associated with the target @var{TGT}. +@code{ASSOCIATED(POINTER [, TARGET])} determines the status of the pointer +@var{POINTER} or if @var{POINTER} is associated with the target @var{TARGET}. @item @emph{Standard}: Fortran 95 and later @@ -1275,44 +1277,45 @@ Fortran 95 and later Inquiry function @item @emph{Syntax}: -@code{RESULT = ASSOCIATED(PTR [, TGT])} +@code{RESULT = ASSOCIATED(POINTER [, TARGET])} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{PTR} @tab @var{PTR} shall have the @code{POINTER} attribute and -it can be of any type. -@item @var{TGT} @tab (Optional) @var{TGT} shall be a @code{POINTER} or -a @code{TARGET}. It must have the same type, kind type parameter, and -array rank as @var{PTR}. +@item @var{POINTER} @tab @var{POINTER} shall have the @code{POINTER} attribute +and it can be of any type. +@item @var{TARGET} @tab (Optional) @var{TARGET} shall be a pointer or +a target. It must have the same type, kind type parameter, and +array rank as @var{POINTER}. @end multitable -The status of neither @var{PTR} nor @var{TGT} can be undefined. +The association status of neither @var{POINTER} nor @var{TARGET} shall be +undefined. @item @emph{Return value}: -@code{ASSOCIATED(PTR)} returns a scalar value of type @code{LOGICAL(4)}. +@code{ASSOCIATED(POINTER)} returns a scalar value of type @code{LOGICAL(4)}. There are several cases: @table @asis -@item (A) If the optional @var{TGT} is not present, then @code{ASSOCIATED(PTR)} -is true if @var{PTR} is associated with a target; otherwise, it returns false. -@item (B) If @var{TGT} is present and a scalar target, the result is true if -@var{TGT} -is not a 0 sized storage sequence and the target associated with @var{PTR} -occupies the same storage units. If @var{PTR} is disassociated, then the -result is false. -@item (C) If @var{TGT} is present and an array target, the result is true if -@var{TGT} and @var{PTR} have the same shape, are not 0 sized arrays, are -arrays whose elements are not 0 sized storage sequences, and @var{TGT} and -@var{PTR} occupy the same storage units in array element order. -As in case(B), the result is false, if @var{PTR} is disassociated. -@item (D) If @var{TGT} is present and an scalar pointer, the result is true if -target associated with @var{PTR} and the target associated with @var{TGT} -are not 0 sized storage sequences and occupy the same storage units. -The result is false, if either @var{TGT} or @var{PTR} is disassociated. -@item (E) If @var{TGT} is present and an array pointer, the result is true if -target associated with @var{PTR} and the target associated with @var{TGT} -have the same shape, are not 0 sized arrays, are arrays whose elements are -not 0 sized storage sequences, and @var{TGT} and @var{PTR} occupy the same -storage units in array element order. -The result is false, if either @var{TGT} or @var{PTR} is disassociated. +@item (A) When the optional @var{TARGET} is not present then +@code{ASSOCIATED(POINTER)} is true if @var{POINTER} is associated with a target; otherwise, it returns false. +@item (B) If @var{TARGET} is present and a scalar target, the result is true if +@var{TARGET} is not a zero-sized storage sequence and the target associated with @var{POINTER} occupies the same storage units. If @var{POINTER} is +disassociated, the result is false. +@item (C) If @var{TARGET} is present and an array target, the result is true if +@var{TARGET} and @var{POINTER} have the same shape, are not zero-sized arrays, +are arrays whose elements are not zero-sized storage sequences, and +@var{TARGET} and @var{POINTER} occupy the same storage units in array element +order. +As in case(B), the result is false, if @var{POINTER} is disassociated. +@item (D) If @var{TARGET} is present and an scalar pointer, the result is true +if @var{TARGET} is associated with @var{POINTER}, the target associated with +@var{TARGET} are not zero-sized storage sequences and occupy the same storage +units. +The result is false, if either @var{TARGET} or @var{POINTER} is disassociated. +@item (E) If @var{TARGET} is present and an array pointer, the result is true if +target associated with @var{POINTER} and the target associated with @var{TARGET} +have the same shape, are not zero-sized arrays, are arrays whose elements are +not zero-sized storage sequences, and @var{TARGET} and @var{POINTER} occupy +the same storage units in array element order. +The result is false, if either @var{TARGET} or @var{POINTER} is disassociated. @end table @item @emph{Example}: @@ -1355,11 +1358,11 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)}. +@item @var{X} @tab The type shall be @code{REAL}. @end multitable @item @emph{Return value}: -The return value is of type @code{REAL(*)} and it lies in the +The return value is of type @code{REAL} and it lies in the range @math{ - \pi / 2 \leq \atan (x) \leq \pi / 2}. @item @emph{Example}: @@ -1392,7 +1395,7 @@ Inverse function: @ref{TAN} @table @asis @item @emph{Description}: -@code{ATAN2(Y,X)} computes the arctangent of the complex number +@code{ATAN2(Y, X)} computes the arctangent of the complex number @math{X + i Y}. @item @emph{Standard}: @@ -1402,11 +1405,11 @@ Fortran 77 and later Elemental function @item @emph{Syntax}: -@code{RESULT = ATAN2(Y,X)} +@code{RESULT = ATAN2(Y, X)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{Y} @tab The type shall be @code{REAL(*)}. +@item @var{Y} @tab The type shall be @code{REAL}. @item @var{X} @tab The type and kind type parameter shall be the same as @var{Y}. If @var{Y} is zero, then @var{X} must be nonzero. @end multitable @@ -1512,12 +1515,13 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)}, and it shall be scalar. +@item @var{X} @tab The type shall be @code{REAL}, and it shall be scalar. @end multitable @item @emph{Return value}: -The return value is of type @code{REAL(*)} and it lies in the -range @math{ - 0.4027... \leq Bessel (0,x) \leq 1}. +The return value is of type @code{REAL} and lies in the +range @math{ - 0.4027... \leq Bessel (0,x) \leq 1}. It has the same +kind as @var{X}. @item @emph{Example}: @smallexample @@ -1560,12 +1564,13 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)}, and it shall be scalar. +@item @var{X} @tab The type shall be @code{REAL}, and it shall be scalar. @end multitable @item @emph{Return value}: -The return value is of type @code{REAL(*)} and it lies in the -range @math{ - 0.5818... \leq Bessel (0,x) \leq 0.5818 }. +The return value is of type @code{REAL} and it lies in the +range @math{ - 0.5818... \leq Bessel (0,x) \leq 0.5818 }. It has the same +kind as @var{X}. @item @emph{Example}: @smallexample @@ -1610,12 +1615,13 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{N} @tab Shall be a scalar or an array of type @code{INTEGER(*)}. -@item @var{X} @tab Shall be a scalar or an array of type @code{REAL(*)}. +@item @var{N} @tab Shall be a scalar or an array of type @code{INTEGER}. +@item @var{X} @tab Shall be a scalar or an array of type @code{REAL}. @end multitable @item @emph{Return value}: -The return value is a scalar of type @code{REAL(*)}. +The return value is a scalar of type @code{REAL}. It has the same +kind as @var{X}. @item @emph{Example}: @smallexample @@ -1628,7 +1634,7 @@ end program test_besjn @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{DBESJN(X)} @tab @code{INTEGER(*) N} @tab @code{REAL(8)} @tab GNU extension +@item @code{DBESJN(X)} @tab @code{INTEGER N} @tab @code{REAL(8)} @tab GNU extension @item @tab @code{REAL(8) X} @tab @tab @end multitable @end table @@ -1659,11 +1665,12 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)}, and it shall be scalar. +@item @var{X} @tab The type shall be @code{REAL}, and it shall be scalar. @end multitable @item @emph{Return value}: -The return value is a scalar of type @code{REAL(*)}. +The return value is a scalar of type @code{REAL}. It has the same +kind as @var{X}. @item @emph{Example}: @smallexample @@ -1706,11 +1713,12 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)}, and it shall be scalar. +@item @var{X} @tab The type shall be @code{REAL}, and it shall be scalar. @end multitable @item @emph{Return value}: -The return value is a scalar of type @code{REAL(*)}. +The return value is a scalar of type @code{REAL}. It has the same +kind as @var{X}. @item @emph{Example}: @smallexample @@ -1755,12 +1763,13 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{N} @tab Shall be a scalar or an array of type @code{INTEGER(*)}. -@item @var{X} @tab Shall be a scalar or an array of type @code{REAL(*)}. +@item @var{N} @tab Shall be a scalar or an array of type @code{INTEGER}. +@item @var{X} @tab Shall be a scalar or an array of type @code{REAL}. @end multitable @item @emph{Return value}: -The return value is a scalar of type @code{REAL(*)}. +The return value is a scalar of type @code{REAL}. It has the same +kind as @var{X}. @item @emph{Example}: @smallexample @@ -1773,7 +1782,7 @@ end program test_besyn @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{DBESYN(N,X)} @tab @code{INTEGER(*) N} @tab @code{REAL(8)} @tab GNU extension +@item @code{DBESYN(N,X)} @tab @code{INTEGER N} @tab @code{REAL(8)} @tab GNU extension @item @tab @code{REAL(8) X} @tab @tab @end multitable @end table @@ -1802,11 +1811,11 @@ Inquiry function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be @code{INTEGER(*)}. +@item @var{I} @tab The type shall be @code{INTEGER}. @end multitable @item @emph{Return value}: -The return value is of type @code{INTEGER(*)} +The return value is of type @code{INTEGER} @item @emph{Example}: @smallexample @@ -1842,8 +1851,8 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be @code{INTEGER(*)}. -@item @var{POS} @tab The type shall be @code{INTEGER(*)}. +@item @var{I} @tab The type shall be @code{INTEGER}. +@item @var{POS} @tab The type shall be @code{INTEGER}. @end multitable @item @emph{Return value}: @@ -1872,8 +1881,8 @@ end program test_btest @table @asis @item @emph{Description}: -@code{C_ASSOCIATED(c_prt1[, c_ptr2])} determines the status of the C pointer @var{c_ptr1} -or if @var{c_ptr1} is associated with the target @var{c_ptr2}. +@code{C_ASSOCIATED(c_prt_1[, c_ptr_2])} determines the status of the C pointer +@var{c_ptr_1} or if @var{c_ptr_1} is associated with the target @var{c_ptr_2}. @item @emph{Standard}: Fortran 2003 and later @@ -1882,17 +1891,17 @@ Fortran 2003 and later Inquiry function @item @emph{Syntax}: -@code{RESULT = C_ASSOCIATED(c_prt1[, c_ptr2])} +@code{RESULT = C_ASSOCIATED(c_prt_1[, c_ptr_2])} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{c_ptr1} @tab Scalar of the type @code{C_PTR} or @code{C_FUNPTR}. -@item @var{c_ptr2} @tab (Optional) Scalar of the same type as @var{c_ptr1}. +@item @var{c_ptr_1} @tab Scalar of the type @code{C_PTR} or @code{C_FUNPTR}. +@item @var{c_ptr_2} @tab (Optional) Scalar of the same type as @var{c_ptr_1}. @end multitable @item @emph{Return value}: The return value is of type @code{LOGICAL}; it is @code{.false.} if either -@var{c_ptr1} is a C NULL pointer or if @var{c_ptr1} and @var{c_ptr2} +@var{c_ptr_1} is a C NULL pointer or if @var{c_ptr1} and @var{c_ptr_2} point to different addresses. @item @emph{Example}: @@ -1976,8 +1985,8 @@ end program main @table @asis @item @emph{Description}: -@code{C_F_PROCPOINTER(cptr, fptr)} Assign the target of the C function pointer -@var{cptr} to the Fortran procedure pointer @var{fptr}. +@code{C_F_PROCPOINTER(CPTR, FPTR)} Assign the target of the C function pointer +@var{CPTR} to the Fortran procedure pointer @var{FPTR}. Note: Due to the currently lacking support of procedure pointers in GNU Fortran this function is not fully operable. @@ -1993,9 +2002,9 @@ Subroutine @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{cptr} @tab scalar of the type @code{C_FUNPTR}. It is +@item @var{CPTR} @tab scalar of the type @code{C_FUNPTR}. It is @code{INTENT(IN)}. -@item @var{fptr} @tab procedure pointer interoperable with @var{cptr}. It is +@item @var{FPTR} @tab procedure pointer interoperable with @var{cptr}. It is @code{INTENT(OUT)}. @end multitable @@ -2036,8 +2045,8 @@ end program main @table @asis @item @emph{Description}: -@code{C_F_POINTER(cptr, fptr[, shape])} Assign the target the C pointer -@var{cptr} to the Fortran pointer @var{fptr} and specify its +@code{C_F_POINTER(CPTR, FPTR[, SHAPE])} Assign the target the C pointer +@var{CPTR} to the Fortran pointer @var{FPTR} and specify its shape. @item @emph{Standard}: @@ -2047,15 +2056,15 @@ Fortran 2003 and later Subroutine @item @emph{Syntax}: -@code{CALL C_F_POINTER(cptr, fptr[, shape])} +@code{CALL C_F_POINTER(CPTR, FPTR[, SHAPE])} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{cptr} @tab scalar of the type @code{C_PTR}. It is +@item @var{CPTR} @tab scalar of the type @code{C_PTR}. It is @code{INTENT(IN)}. -@item @var{fptr} @tab pointer interoperable with @var{cptr}. It is +@item @var{FPTR} @tab pointer interoperable with @var{cptr}. It is @code{INTENT(OUT)}. -@item @var{shape} @tab (Optional) Rank-one array of type @code{INTEGER} +@item @var{SHAPE} @tab (Optional) Rank-one array of type @code{INTEGER} with @code{INTENT(IN)}. It shall be present if and only if @var{fptr} is an array. The size must be equal to the rank of @var{fptr}. @@ -2091,7 +2100,7 @@ end program main @table @asis @item @emph{Description}: -@code{C_LOC(x)} determines the C address of the argument. +@code{C_LOC(X)} determines the C address of the argument. @item @emph{Standard}: Fortran 2003 and later @@ -2100,11 +2109,11 @@ Fortran 2003 and later Inquiry function @item @emph{Syntax}: -@code{RESULT = C_LOC(x)} +@code{RESULT = C_LOC(X)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{x} @tab Associated scalar pointer or interoperable scalar +@item @var{X} @tab Associated scalar pointer or interoperable scalar or allocated allocatable variable with @code{TARGET} attribute. @end multitable @@ -2138,7 +2147,7 @@ end subroutine association_test @table @asis @item @emph{Description}: -@code{CEILING(X)} returns the least integer greater than or equal to @var{X}. +@code{CEILING(A)} returns the least integer greater than or equal to @var{A}. @item @emph{Standard}: Fortran 95 and later @@ -2147,18 +2156,19 @@ Fortran 95 and later Elemental function @item @emph{Syntax}: -@code{RESULT = CEILING(X [, KIND])} +@code{RESULT = CEILING(A [, KIND])} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)}. -@item @var{KIND} @tab (Optional) An @code{INTEGER(*)} initialization +@item @var{A} @tab The type shall be @code{REAL}. +@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of the result. @end multitable @item @emph{Return value}: -The return value is of type @code{INTEGER(KIND)} +The return value is of type @code{INTEGER(KIND)} if @var{KIND} is present +and a default-kind @code{INTEGER} otherwise. @item @emph{Example}: @smallexample @@ -2197,8 +2207,8 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be @code{INTEGER(*)}. -@item @var{KIND} @tab (Optional) An @code{INTEGER(*)} initialization +@item @var{I} @tab The type shall be @code{INTEGER}. +@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of the result. @end multitable @@ -2253,8 +2263,9 @@ Subroutine, function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{NAME} @tab The type shall be @code{CHARACTER(*)} and shall - specify a valid path within the file system. +@item @var{NAME} @tab The type shall be @code{CHARACTER} of default + kind and shall specify a valid path within the + file system. @item @var{STATUS} @tab (Optional) @code{INTEGER} status flag of the default kind. Returns 0 on success, and a system specific and nonzero error code otherwise. @@ -2305,14 +2316,15 @@ Subroutine, function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{NAME} @tab Scalar @code{CHARACTER} with the file name. -Trailing blanks are ignored unless the character @code{achar(0)} is -present, then all characters up to and excluding @code{achar(0)} are -used as the file name. -@item @var{MODE} @tab Scalar @code{CHARACTER} giving the file permission. -@var{MODE} uses the same syntax as the @var{MODE} argument of -@code{/bin/chmod}. +@item @var{NAME} @tab Scalar @code{CHARACTER} of default kind with the +file name. Trailing blanks are ignored unless the character +@code{achar(0)} is present, then all characters up to and excluding +@code{achar(0)} are used as the file name. + +@item @var{MODE} @tab Scalar @code{CHARACTER} of default kind giving the +file permission. @var{MODE} uses the same syntax as the @var{MODE} +argument of @code{/bin/chmod}. @item @var{STATUS} @tab (optional) scalar @code{INTEGER}, which is @code{0} on success and nonzero otherwise. @@ -2370,12 +2382,12 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type may be @code{INTEGER(*)}, @code{REAL(*)}, - or @code{COMPLEX(*)}. +@item @var{X} @tab The type may be @code{INTEGER}, @code{REAL}, + or @code{COMPLEX}. @item @var{Y} @tab (Optional; only allowed if @var{X} is not - @code{COMPLEX(*)}.) May be @code{INTEGER(*)} - or @code{REAL(*)}. -@item @var{KIND} @tab (Optional) An @code{INTEGER(*)} initialization + @code{COMPLEX}.) May be @code{INTEGER} + or @code{REAL}. +@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of the result. @end multitable @@ -2470,8 +2482,8 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type may be @code{INTEGER(*)} or @code{REAL(*)}. -@item @var{Y} @tab The type may be @code{INTEGER(*)} or @code{REAL(*)}. +@item @var{X} @tab The type may be @code{INTEGER} or @code{REAL}. +@item @var{Y} @tab The type may be @code{INTEGER} or @code{REAL}. @end multitable @item @emph{Return value}: @@ -2520,11 +2532,11 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{Z} @tab The type shall be @code{COMPLEX(*)}. +@item @var{Z} @tab The type shall be @code{COMPLEX}. @end multitable @item @emph{Return value}: -The return value is of type @code{COMPLEX(*)}. +The return value is of type @code{COMPLEX}. @item @emph{Example}: @smallexample @@ -2572,12 +2584,12 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)} or -@code{COMPLEX(*)}. +@item @var{X} @tab The type shall be @code{REAL} or +@code{COMPLEX}. @end multitable @item @emph{Return value}: -The return value is of type @code{REAL(*)} and it lies in the +The return value is of type @code{REAL} and it lies in the range @math{ -1 \leq \cos (x) \leq 1}. The kind type parameter is the same as @var{X}. @@ -2628,12 +2640,13 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)}. +@item @var{X} @tab The type shall be @code{REAL}. @end multitable @item @emph{Return value}: -The return value is of type @code{REAL(*)} and it is positive -(@math{ \cosh (x) \geq 0 }. +The return value is of type @code{REAL} and it is positive +(@math{ \cosh (x) \geq 0 }. The return value is of the same +kind as @var{X}. @item @emph{Example}: @smallexample @@ -2730,7 +2743,7 @@ end program test_count @table @asis @item @emph{Description}: -Returns a @code{REAL(*)} value representing the elapsed CPU time in +Returns a @code{REAL} value representing the elapsed CPU time in seconds. This is useful for testing segments of code to determine execution time. @@ -2755,7 +2768,7 @@ Subroutine @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{TIME} @tab The type shall be @code{REAL(*)} with @code{INTENT(OUT)}. +@item @var{TIME} @tab The type shall be @code{REAL} with @code{INTENT(OUT)}. @end multitable @item @emph{Return value}: @@ -2863,7 +2876,8 @@ Subroutine, function @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{TIME} @tab The type shall be of type @code{INTEGER(KIND=8)}. -@item @var{RESULT} @tab The type shall be of type @code{CHARACTER}. +@item @var{RESULT} @tab The type shall be of type @code{CHARACTER} and + of default kind. @end multitable @item @emph{Return value}: @@ -2930,9 +2944,12 @@ Subroutine @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{DATE} @tab (Optional) The type shall be @code{CHARACTER(8)} or larger. -@item @var{TIME} @tab (Optional) The type shall be @code{CHARACTER(10)} or larger. -@item @var{ZONE} @tab (Optional) The type shall be @code{CHARACTER(5)} or larger. +@item @var{DATE} @tab (Optional) The type shall be @code{CHARACTER(LEN=8)} + or larger, and of default kind. +@item @var{TIME} @tab (Optional) The type shall be @code{CHARACTER(LEN=10)} + or larger, and of default kind. +@item @var{ZONE} @tab (Optional) The type shall be @code{CHARACTER(LEN=5)} + or larger, and of default kind. @item @var{VALUES}@tab (Optional) The type shall be @code{INTEGER(8)}. @end multitable @@ -2969,7 +2986,7 @@ end program test_time_and_date @table @asis @item @emph{Description}: -@code{DBLE(X)} Converts @var{X} to double precision real type. +@code{DBLE(A)} Converts @var{A} to double precision real type. @item @emph{Standard}: Fortran 77 and later @@ -2978,12 +2995,12 @@ Fortran 77 and later Elemental function @item @emph{Syntax}: -@code{RESULT = DBLE(X)} +@code{RESULT = DBLE(A)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{INTEGER(*)}, @code{REAL(*)}, - or @code{COMPLEX(*)}. +@item @var{A} @tab The type shall be @code{INTEGER}, @code{REAL}, + or @code{COMPLEX}. @end multitable @item @emph{Return value}: @@ -3029,10 +3046,10 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type may be @code{INTEGER(*)}, @code{REAL(*)}, - or @code{COMPLEX(*)}. -@item @var{Y} @tab (Optional if @var{X} is not @code{COMPLEX(*)}.) May be - @code{INTEGER(*)} or @code{REAL(*)}. +@item @var{X} @tab The type may be @code{INTEGER}, @code{REAL}, + or @code{COMPLEX}. +@item @var{Y} @tab (Optional if @var{X} is not @code{COMPLEX}.) May be + @code{INTEGER} or @code{REAL}. @end multitable @item @emph{Return value}: @@ -3062,7 +3079,7 @@ end program test_dcmplx @table @asis @item @emph{Description}: -@code{DFLOAT(X)} Converts @var{X} to double precision real type. +@code{DFLOAT(A)} Converts @var{A} to double precision real type. @item @emph{Standard}: GNU extension @@ -3071,11 +3088,11 @@ GNU extension Elemental function @item @emph{Syntax}: -@code{RESULT = DFLOAT(X)} +@code{RESULT = DFLOAT(A)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{INTEGER(*)}. +@item @var{A} @tab The type shall be @code{INTEGER}. @end multitable @item @emph{Return value}: @@ -3117,7 +3134,7 @@ Inquiry function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type may be @code{INTEGER(*)} or @code{REAL(*)}. +@item @var{X} @tab The type may be @code{INTEGER} or @code{REAL}. @end multitable @item @emph{Return value}: @@ -3161,12 +3178,12 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{INTEGER(*)} or @code{REAL(*)} +@item @var{X} @tab The type shall be @code{INTEGER} or @code{REAL} @item @var{Y} @tab The type shall be the same type and kind as @var{X}. @end multitable @item @emph{Return value}: -The return value is of type @code{INTEGER(*)} or @code{REAL(*)}. +The return value is of type @code{INTEGER} or @code{REAL}. @item @emph{Example}: @smallexample @@ -3199,12 +3216,13 @@ end program test_dim @table @asis @item @emph{Description}: -@code{DOT_PRODUCT(X,Y)} computes the dot product multiplication of two vectors -@var{X} and @var{Y}. The two vectors may be either numeric or logical -and must be arrays of rank one and of equal size. If the vectors are -@code{INTEGER(*)} or @code{REAL(*)}, the result is @code{SUM(X*Y)}. If the -vectors are @code{COMPLEX(*)}, the result is @code{SUM(CONJG(X)*Y)}. If the -vectors are @code{LOGICAL}, the result is @code{ANY(X.AND.Y)}. +@code{DOT_PRODUCT(VECTOR_A, VECTOR_B)} computes the dot product multiplication +of two vectors @var{VECTOR_A} and @var{VECTOR_B}. The two vectors may be +either numeric or logical and must be arrays of rank one and of equal size. If +the vectors are @code{INTEGER} or @code{REAL}, the result is +@code{SUM(VECTOR_A*VECTOR_B)}. If the vectors are @code{COMPLEX}, the result +is @code{SUM(CONJG(VECTOR_A)*VECTOR_B)}. If the vectors are @code{LOGICAL}, +the result is @code{ANY(VECTOR_A .AND. VECTOR_B)}. @item @emph{Standard}: Fortran 95 and later @@ -3213,17 +3231,17 @@ Fortran 95 and later Transformational function @item @emph{Syntax}: -@code{RESULT = DOT_PRODUCT(X, Y)} +@code{RESULT = DOT_PRODUCT(VECTOR_A, VECTOR_B)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be numeric or @code{LOGICAL}, rank 1. -@item @var{Y} @tab The type shall be numeric or @code{LOGICAL}, rank 1. +@item @var{VECTOR_A} @tab The type shall be numeric or @code{LOGICAL}, rank 1. +@item @var{VECTOR_B} @tab The type shall be numeric if @var{VECTOR_A} is of numeric type or @code{LOGICAL} if @var{VECTOR_A} is of type @code{LOGICAL}. @var{VECTOR_B} shall be a rank-one array. @end multitable @item @emph{Return value}: If the arguments are numeric, the return value is a scaler of numeric type, -@code{INTEGER(*)}, @code{REAL(*)}, or @code{COMPLEX(*)}. If the arguments are +@code{INTEGER}, @code{REAL}, or @code{COMPLEX}. If the arguments are @code{LOGICAL}, the return value is @code{.TRUE.} or @code{.FALSE.}. @item @emph{Example}: @@ -3300,11 +3318,11 @@ GNU extension Elemental function @item @emph{Syntax}: -@code{RESULT = DREAL(Z)} +@code{RESULT = DREAL(A)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{Z} @tab The type shall be @code{COMPLEX(8)}. +@item @var{A} @tab The type shall be @code{COMPLEX(8)}. @end multitable @item @emph{Return value}: @@ -3421,7 +3439,7 @@ end program test_dtime @table @asis @item @emph{Description}: -@code{EOSHIFT(ARRAY, SHIFT[,BOUNDARY, DIM])} performs an end-off shift on +@code{EOSHIFT(ARRAY, SHIFT[, BOUNDARY, DIM])} performs an end-off shift on elements of @var{ARRAY} along the dimension of @var{DIM}. If @var{DIM} is omitted it is taken to be @code{1}. @var{DIM} is a scaler of type @code{INTEGER} in the range of @math{1 /leq DIM /leq n)} where @math{n} is the @@ -3499,7 +3517,7 @@ Inquiry function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)}. +@item @var{X} @tab The type shall be @code{REAL}. @end multitable @item @emph{Return value}: @@ -3790,8 +3808,8 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)} or -@code{COMPLEX(*)}. +@item @var{X} @tab The type shall be @code{REAL} or +@code{COMPLEX}. @end multitable @item @emph{Return value}: @@ -3839,7 +3857,7 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)}. +@item @var{X} @tab The type shall be @code{REAL}. @end multitable @item @emph{Return value}: @@ -3876,7 +3894,8 @@ TIME())}. This intrinsic is provided in both subroutine and function forms; however, only one form can be used in any given program unit. -@var{DATE} is an @code{INTENT(OUT)} @code{CHARACTER} variable. +@var{DATE} is an @code{INTENT(OUT)} @code{CHARACTER} variable of the +default kind. @item @emph{Standard}: GNU extension @@ -3892,7 +3911,8 @@ Subroutine, function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{DATE}@tab The type shall be of type @code{CHARACTER}. +@item @var{DATE}@tab The type shall be of type @code{CHARACTER} of the +default kind @end multitable @item @emph{Return value}: @@ -3923,7 +3943,7 @@ end program test_fdate @table @asis @item @emph{Description}: -@code{FLOAT(I)} converts the integer @var{I} to a default real value. +@code{FLOAT(A)} converts the integer @var{A} to a default real value. @item @emph{Standard}: Fortran 77 and later @@ -3932,11 +3952,11 @@ Fortran 77 and later Elemental function @item @emph{Syntax}: -@code{RESULT = FLOAT(I)} +@code{RESULT = FLOAT(A)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be @code{INTEGER(*)}. +@item @var{A} @tab The type shall be @code{INTEGER}. @end multitable @item @emph{Return value}: @@ -3988,7 +4008,8 @@ Subroutine, function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{C} @tab The type shall be @code{CHARACTER}. +@item @var{C} @tab The type shall be @code{CHARACTER} and of default + kind. @item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}. Returns 0 on success, -1 on end-of-file, and a system specific positive error code otherwise. @@ -4050,9 +4071,11 @@ Subroutine, function @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{UNIT} @tab The type shall be @code{INTEGER}. -@item @var{C} @tab The type shall be @code{CHARACTER}. -@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}. Returns 0 on success, - -1 on end-of-file and a system specific positive error code otherwise. +@item @var{C} @tab The type shall be @code{CHARACTER} and of default + kind. +@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}. + Returns 0 on success, -1 on end-of-file and a + system specific positive error code otherwise. @end multitable @item @emph{Example}: @@ -4085,7 +4108,7 @@ END PROGRAM @table @asis @item @emph{Description}: -@code{FLOOR(X)} returns the greatest integer less than or equal to @var{X}. +@code{FLOOR(A)} returns the greatest integer less than or equal to @var{X}. @item @emph{Standard}: Fortran 95 and later @@ -4094,18 +4117,19 @@ Fortran 95 and later Elemental function @item @emph{Syntax}: -@code{RESULT = FLOOR(X [, KIND])} +@code{RESULT = FLOOR(A [, KIND])} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)}. -@item @var{KIND} @tab (Optional) An @code{INTEGER(*)} initialization +@item @var{A} @tab The type shall be @code{REAL}. +@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of the result. @end multitable @item @emph{Return value}: -The return value is of type @code{INTEGER(KIND)} +The return value is of type @code{INTEGER(KIND)} if @var{KIND} is present +and of default-kind @code{INTEGER} otherwise. @item @emph{Example}: @smallexample @@ -4229,9 +4253,11 @@ Subroutine, function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{C} @tab The type shall be @code{CHARACTER}. -@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}. Returns 0 on success, - -1 on end-of-file and a system specific positive error code otherwise. +@item @var{C} @tab The type shall be @code{CHARACTER} and of default + kind. +@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}. + Returns 0 on success, -1 on end-of-file and a + system specific positive error code otherwise. @end multitable @item @emph{Example}: @@ -4284,9 +4310,11 @@ Subroutine, function @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{UNIT} @tab The type shall be @code{INTEGER}. -@item @var{C} @tab The type shall be @code{CHARACTER}. -@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}. Returns 0 on success, - -1 on end-of-file and a system specific positive error code otherwise. +@item @var{C} @tab The type shall be @code{CHARACTER} and of default + kind. +@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}. + Returns 0 on success, -1 on end-of-file and a + system specific positive error code otherwise. @end multitable @item @emph{Example}: @@ -4644,7 +4672,7 @@ Subroutine @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{RESULT} @tab Shall of type @code{CHARACTER(*)}. +@item @var{RESULT} @tab Shall of type @code{CHARACTER} and of default @end multitable @item @emph{Example}: @@ -4670,7 +4698,7 @@ END PROGRAM @table @asis @item @emph{Description}: -Retrieve the @var{N}th argument that was passed on the +Retrieve the @var{POS}-th argument that was passed on the command line when the containing program was invoked. This intrinsic routine is provided for backwards compatibility with @@ -4691,7 +4719,9 @@ Subroutine @multitable @columnfractions .15 .70 @item @var{POS} @tab Shall be of type @code{INTEGER} and not wider than the default integer kind; @math{@var{POS} \geq 0} -@item @var{VALUE} @tab Shall be of type @code{CHARACTER(*)}. +@item @var{VALUE} @tab Shall be of type @code{CHARACTER} and of default +kind. +@item @var{VALUE} @tab Shall be of type @code{CHARACTER}. @end multitable @item @emph{Return value}: @@ -4741,16 +4771,18 @@ Fortran 2003 and later Subroutine @item @emph{Syntax}: -@code{CALL GET_COMMAND(CMD)} +@code{CALL GET_COMMAND(COMMAND)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{CMD} @tab Shall be of type @code{CHARACTER(*)}. +@item @var{COMMAND} @tab Shall be of type @code{CHARACTER} and of default +kind. @end multitable @item @emph{Return value}: -Stores the entire command line that was used to invoke the program in @var{ARG}. -If @var{ARG} is not large enough, the command will be truncated. +Stores the entire command line that was used to invoke the program in +@var{COMMAND}. If @var{COMMAND} is not large enough, the command will be +truncated. @item @emph{Example}: @smallexample @@ -4775,7 +4807,7 @@ END PROGRAM @table @asis @item @emph{Description}: -Retrieve the @var{N}th argument that was passed on the +Retrieve the @var{NUMBER}-th argument that was passed on the command line when the containing program was invoked. @item @emph{Standard}: @@ -4785,21 +4817,28 @@ Fortran 2003 and later Subroutine @item @emph{Syntax}: -@code{CALL GET_COMMAND_ARGUMENT(N, ARG)} +@code{CALL GET_COMMAND_ARGUMENT(NUMBER [, VALUE, LENGTH, STATUS])} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{N} @tab Shall be of type @code{INTEGER(4)}, @math{@var{N} \geq 0} -@item @var{ARG} @tab Shall be of type @code{CHARACTER(*)}. +@item @var{NUMBER} @tab Shall be a scalar of type @code{INTEGER(4)}, + @math{@var{NUMBER} \geq 0} +@item @var{VALUE} @tab Shall be a scalar of type @code{CHARACTER} + and of default kind. +@item @var{LENGTH} @tab (Option) Shall be a scalar of type @code{INTEGER(4)}. +@item @var{STATUS} @tab (Option) Shall be a scalar of type @code{INTEGER(4)}. @end multitable @item @emph{Return value}: -After @code{GET_COMMAND_ARGUMENT} returns, the @var{ARG} argument holds the -@var{N}th command line argument. If @var{ARG} can not hold the argument, it is -truncated to fit the length of @var{ARG}. If there are less than @var{N} -arguments specified at the command line, @var{ARG} will be filled with blanks. -If @math{@var{N} = 0}, @var{ARG} is set to the name of the program (on systems -that support this feature). +After @code{GET_COMMAND_ARGUMENT} returns, the @var{VALUE} argument holds the +@var{NUMBER}-th command line argument. If @var{VALUE} can not hold the argument, it is +truncated to fit the length of @var{VALUE}. If there are less than @var{NUMBER} +arguments specified at the command line, @var{VALUE} will be filled with blanks. +If @math{@var{NUMBER} = 0}, @var{VALUE} is set to the name of the program (on systems +that support this feature). The @var{LENGTH} argument contains the length of the +@var{NUMBER}-th command line argument. If the argument retrival fails, @var{STATUS} +is a positiv number; if @var{VALUE} contains a truncated command line argument, +@var{STATUS} is -1; and otherwise the @var{STATUS} is zero. @item @emph{Example}: @smallexample @@ -4843,11 +4882,11 @@ GNU extension Subroutine, function @item @emph{Syntax}: -@code{CALL GETCWD(CWD [, STATUS])} +@code{CALL GETCWD(C [, STATUS])} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{CWD} @tab The type shall be @code{CHARACTER(*)}. +@item @var{C} @tab The type shall be @code{CHARACTER} and of default kind. @item @var{STATUS} @tab (Optional) status flag. Returns 0 on success, a system specific and nonzero error code otherwise. @end multitable @@ -4874,7 +4913,7 @@ END PROGRAM @table @asis @item @emph{Description}: -Get the @var{VALUE} of the environmental variable @var{ENVVAR}. +Get the @var{VALUE} of the environmental variable @var{NAME}. This intrinsic routine is provided for backwards compatibility with GNU Fortran 77. In new code, programmers should consider the use of @@ -4888,17 +4927,17 @@ GNU extension Subroutine @item @emph{Syntax}: -@code{CALL GETENV(ENVVAR, VALUE)} +@code{CALL GETENV(NAME, VALUE)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{ENVVAR} @tab Shall be of type @code{CHARACTER(*)}. -@item @var{VALUE} @tab Shall be of type @code{CHARACTER(*)}. +@item @var{NAME} @tab Shall be of type @code{CHARACTER} and of default kind. +@item @var{VALUE} @tab Shall be of type @code{CHARACTER} and of default kind. @end multitable @item @emph{Return value}: -Stores the value of @var{ENVVAR} in @var{VALUE}. If @var{VALUE} is -not large enough to hold the data, it is truncated. If @var{ENVVAR} +Stores the value of @var{NAME} in @var{VALUE}. If @var{VALUE} is +not large enough to hold the data, it is truncated. If @var{NAME} is not set, @var{VALUE} will be filled with blanks. @item @emph{Example}: @@ -4923,7 +4962,7 @@ END PROGRAM @table @asis @item @emph{Description}: -Get the @var{VALUE} of the environmental variable @var{ENVVAR}. +Get the @var{VALUE} of the environmental variable @var{NAME}. @item @emph{Standard}: Fortran 2003 and later @@ -4932,18 +4971,29 @@ Fortran 2003 and later Subroutine @item @emph{Syntax}: -@code{CALL GET_ENVIRONMENT_VARIABLE(ENVVAR, VALUE)} +@code{CALL GET_ENVIRONMENT_VARIABLE(NAME[, VALUE, LENGTH, STATUS, TRIM_NAME)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{ENVVAR} @tab Shall be of type @code{CHARACTER(*)}. -@item @var{VALUE} @tab Shall be of type @code{CHARACTER(*)}. +@item @var{NAME} @tab Shall be a scalar of type @code{CHARACTER(1)}. +@item @var{VALUE} @tab Shall be a scalar of type @code{CHARACTER(1)}. +@item @var{LENGTH} @tab Shall be a scalar of type @code{INTEGER(4)}. +@item @var{STATUS} @tab Shall be a scalar of type @code{INTEGER(4)}. +@item @var{TRIM_NAME} @tab Shall be a scalar of type @code{LOGICAL(4)}. @end multitable @item @emph{Return value}: -Stores the value of @var{ENVVAR} in @var{VALUE}. If @var{VALUE} is -not large enough to hold the data, it is truncated. If @var{ENVVAR} -is not set, @var{VALUE} will be filled with blanks. +Stores the value of @var{NAME} in @var{VALUE}. If @var{VALUE} is +not large enough to hold the data, it is truncated. If @var{NAME} +is not set, @var{VALUE} will be filled with blanks. Argument @var{LENGTH} +contains the length needed for storing the environment variable @var{NAME} +or zero if it is not present. @var{STATUS} is -1 if @var{VALUE} is present +but too short for the environment variable; it is 1 if the environment +variable does not exist and 2 if the processor does not support environment +variables; in all other cases @var{STATUS} is zero. If @var{TRIM_NAME} is +present with the value @code{.FALSE.}, the trailing blanks in @var{NAME} +are significant; otherwise they are not part of the environment variable +name. @item @emph{Example}: @smallexample @@ -5006,11 +5056,11 @@ GNU extension Subroutine @item @emph{Syntax}: -@code{CALL GETLOG(LOGIN)} +@code{CALL GETLOG(C)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{LOGIN} @tab Shall be of type @code{CHARACTER(*)}. +@item @var{C} @tab Shall be of type @code{CHARACTER} and of default kind. @end multitable @item @emph{Return value}: @@ -5113,8 +5163,8 @@ See @code{GETPID} for an example. @table @asis @item @emph{Description}: -Given a system time value @var{STIME} (as provided by the @code{TIME8()} -intrinsic), fills @var{TARRAY} with values extracted from it appropriate +Given a system time value @var{TIME} (as provided by the @code{TIME8()} +intrinsic), fills @var{VALUES} with values extracted from it appropriate to the UTC time zone (Universal Coordinated Time, also known in some countries as GMT, Greenwich Mean Time), using @code{gmtime(3)}. @@ -5125,19 +5175,19 @@ GNU extension Subroutine @item @emph{Syntax}: -@code{CALL GMTIME(STIME, TARRAY)} +@code{CALL GMTIME(TIME, VALUES)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{STIME} @tab An @code{INTEGER(*)} scalar expression +@item @var{TIME} @tab An @code{INTEGER} scalar expression corresponding to a system time, with @code{INTENT(IN)}. -@item @var{TARRAY} @tab A default @code{INTEGER} array with 9 elements, +@item @var{VALUES} @tab A default @code{INTEGER} array with 9 elements, with @code{INTENT(OUT)}. @end multitable @item @emph{Return value}: -The elements of @var{TARRAY} are assigned as follows: +The elements of @var{VALUES} are assigned as follows: @enumerate @item Seconds after the minute, range 0--59 or 0--61 to allow for leap seconds @@ -5180,13 +5230,13 @@ Subroutine, function @item @emph{Syntax}: @multitable @columnfractions .80 -@item @code{CALL HOSTNM(NAME[, STATUS])} +@item @code{CALL HOSTNM(C [, STATUS])} @item @code{STATUS = HOSTNM(NAME)} @end multitable @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{NAME} @tab Shall of type @code{CHARACTER(*)}. +@item @var{C} @tab Shall of type @code{CHARACTER} and of default kind. @item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}. Returns 0 on success, or a system specific error code otherwise. @@ -5256,7 +5306,7 @@ Fortran 2008 and later Elemental function @item @emph{Syntax}: -@code{RESULT = HYPOT(X,Y)} +@code{RESULT = HYPOT(X, Y)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -5352,14 +5402,14 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be @code{INTEGER(*)}. -@item @var{J} @tab The type shall be @code{INTEGER(*)}, of the same +@item @var{I} @tab The type shall be @code{INTEGER}. +@item @var{J} @tab The type shall be @code{INTEGER}, of the same kind as @var{I}. (As a GNU extension, different kinds are also permitted.) @end multitable @item @emph{Return value}: -The return type is @code{INTEGER(*)}, of the same kind as the +The return type is @code{INTEGER}, of the same kind as the arguments. (If the argument kinds differ, it is of the same kind as the larger argument.) @@ -5445,12 +5495,12 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be @code{INTEGER(*)}. -@item @var{POS} @tab The type shall be @code{INTEGER(*)}. +@item @var{I} @tab The type shall be @code{INTEGER}. +@item @var{POS} @tab The type shall be @code{INTEGER}. @end multitable @item @emph{Return value}: -The return value is of type @code{INTEGER(*)} and of the same kind as +The return value is of type @code{INTEGER} and of the same kind as @var{I}. @item @emph{See also}: @@ -5485,13 +5535,13 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be @code{INTEGER(*)}. -@item @var{POS} @tab The type shall be @code{INTEGER(*)}. -@item @var{LEN} @tab The type shall be @code{INTEGER(*)}. +@item @var{I} @tab The type shall be @code{INTEGER}. +@item @var{POS} @tab The type shall be @code{INTEGER}. +@item @var{LEN} @tab The type shall be @code{INTEGER}. @end multitable @item @emph{Return value}: -The return value is of type @code{INTEGER(*)} and of the same kind as +The return value is of type @code{INTEGER} and of the same kind as @var{I}. @item @emph{See also}: @@ -5521,12 +5571,12 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be @code{INTEGER(*)}. -@item @var{POS} @tab The type shall be @code{INTEGER(*)}. +@item @var{I} @tab The type shall be @code{INTEGER}. +@item @var{POS} @tab The type shall be @code{INTEGER}. @end multitable @item @emph{Return value}: -The return value is of type @code{INTEGER(*)} and of the same kind as +The return value is of type @code{INTEGER} and of the same kind as @var{I}. @item @emph{See also}: @@ -5627,11 +5677,11 @@ GNU extension Subroutine @item @emph{Syntax}: -@code{CALL IDATE(TARRAY)} +@code{CALL IDATE(VALUES)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{TARRAY} @tab The type shall be @code{INTEGER, DIMENSION(3)} and +@item @var{VALUES} @tab The type shall be @code{INTEGER, DIMENSION(3)} and the kind shall be the default integer kind. @end multitable @@ -5674,14 +5724,14 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be @code{INTEGER(*)}. -@item @var{J} @tab The type shall be @code{INTEGER(*)}, of the same +@item @var{I} @tab The type shall be @code{INTEGER}. +@item @var{J} @tab The type shall be @code{INTEGER}, of the same kind as @var{I}. (As a GNU extension, different kinds are also permitted.) @end multitable @item @emph{Return value}: -The return type is @code{INTEGER(*)}, of the same kind as the +The return type is @code{INTEGER}, of the same kind as the arguments. (If the argument kinds differ, it is of the same kind as the larger argument.) @@ -5748,11 +5798,11 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{STRING} @tab Shall be a scalar @code{CHARACTER(*)}, with +@item @var{STRING} @tab Shall be a scalar @code{CHARACTER}, with @code{INTENT(IN)} -@item @var{SUBSTRING} @tab Shall be a scalar @code{CHARACTER(*)}, with +@item @var{SUBSTRING} @tab Shall be a scalar @code{CHARACTER}, with @code{INTENT(IN)} -@item @var{BACK} @tab (Optional) Shall be a scalar @code{LOGICAL(*)}, with +@item @var{BACK} @tab (Optional) Shall be a scalar @code{LOGICAL}, with @code{INTENT(IN)} @item @var{KIND} @tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of @@ -5791,26 +5841,26 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{A} @tab Shall be of type @code{INTEGER(*)}, - @code{REAL(*)}, or @code{COMPLEX(*)}. -@item @var{KIND} @tab (Optional) An @code{INTEGER(*)} initialization +@item @var{A} @tab Shall be of type @code{INTEGER}, + @code{REAL}, or @code{COMPLEX}. +@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of the result. @end multitable @item @emph{Return value}: -These functions return a @code{INTEGER(*)} variable or array under +These functions return a @code{INTEGER} variable or array under the following rules: @table @asis @item (A) -If @var{A} is of type @code{INTEGER(*)}, @code{INT(A) = A} +If @var{A} is of type @code{INTEGER}, @code{INT(A) = A} @item (B) -If @var{A} is of type @code{REAL(*)} and @math{|A| < 1}, @code{INT(A)} equals @code{0}. +If @var{A} is of type @code{REAL} and @math{|A| < 1}, @code{INT(A)} equals @code{0}. If @math{|A| \geq 1}, then @code{INT(A)} equals the largest integer that does not exceed the range of @var{A} and whose sign is the same as the sign of @var{A}. @item (C) -If @var{A} is of type @code{COMPLEX(*)}, rule B is applied to the real part of @var{A}. +If @var{A} is of type @code{COMPLEX}, rule B is applied to the real part of @var{A}. @end table @item @emph{Example}: @@ -5859,8 +5909,8 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{A} @tab Shall be of type @code{INTEGER(*)}, - @code{REAL(*)}, or @code{COMPLEX(*)}. +@item @var{A} @tab Shall be of type @code{INTEGER}, + @code{REAL}, or @code{COMPLEX}. @end multitable @item @emph{Return value}: @@ -5894,8 +5944,8 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{A} @tab Shall be of type @code{INTEGER(*)}, - @code{REAL(*)}, or @code{COMPLEX(*)}. +@item @var{A} @tab Shall be of type @code{INTEGER}, + @code{REAL}, or @code{COMPLEX}. @end multitable @item @emph{Return value}: @@ -5929,14 +5979,14 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be @code{INTEGER(*)}. -@item @var{J} @tab The type shall be @code{INTEGER(*)}, of the same +@item @var{I} @tab The type shall be @code{INTEGER}. +@item @var{J} @tab The type shall be @code{INTEGER}, of the same kind as @var{I}. (As a GNU extension, different kinds are also permitted.) @end multitable @item @emph{Return value}: -The return type is @code{INTEGER(*)}, of the same kind as the +The return type is @code{INTEGER}, of the same kind as the arguments. (If the argument kinds differ, it is of the same kind as the larger argument.) @@ -5972,11 +6022,11 @@ GNU extension Function @item @emph{Syntax}: -@code{RESULT = IRAND(FLAG)} +@code{RESULT = IRAND(I)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{FLAG} @tab Shall be a scalar @code{INTEGER} of kind 4. +@item @var{I} @tab Shall be a scalar @code{INTEGER} of kind 4. @end multitable @item @emph{Return value}: @@ -6107,7 +6157,7 @@ Function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{UNIT} @tab Shall be a scalar @code{INTEGER(*)}. +@item @var{UNIT} @tab Shall be a scalar @code{INTEGER}. @end multitable @item @emph{Return value}: @@ -6155,12 +6205,12 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be @code{INTEGER(*)}. -@item @var{SHIFT} @tab The type shall be @code{INTEGER(*)}. +@item @var{I} @tab The type shall be @code{INTEGER}. +@item @var{SHIFT} @tab The type shall be @code{INTEGER}. @end multitable @item @emph{Return value}: -The return value is of type @code{INTEGER(*)} and of the same kind as +The return value is of type @code{INTEGER} and of the same kind as @var{I}. @item @emph{See also}: @@ -6196,15 +6246,15 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be @code{INTEGER(*)}. -@item @var{SHIFT} @tab The type shall be @code{INTEGER(*)}. -@item @var{SIZE} @tab (Optional) The type shall be @code{INTEGER(*)}; +@item @var{I} @tab The type shall be @code{INTEGER}. +@item @var{SHIFT} @tab The type shall be @code{INTEGER}. +@item @var{SIZE} @tab (Optional) The type shall be @code{INTEGER}; the value must be greater than zero and less than or equal to @code{BIT_SIZE(I)}. @end multitable @item @emph{Return value}: -The return value is of type @code{INTEGER(*)} and of the same kind as +The return value is of type @code{INTEGER} and of the same kind as @var{I}. @item @emph{See also}: @@ -6263,9 +6313,9 @@ end program test_nan @table @asis @item @emph{Description}: -@code{IDATE(TARRAY)} Fills @var{TARRAY} with the numerical values at the +@code{IDATE(VALUES)} Fills @var{VALUES} with the numerical values at the current local time. The hour (in the range 1-24), minute (in the range 1-60), -and seconds (in the range 1-60) appear in elements 1, 2, and 3 of @var{TARRAY}, +and seconds (in the range 1-60) appear in elements 1, 2, and 3 of @var{VALUES}, respectively. @item @emph{Standard}: @@ -6275,11 +6325,11 @@ GNU extension Subroutine @item @emph{Syntax}: -@code{CALL ITIME(TARRAY)} +@code{CALL ITIME(VALUES)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{TARRAY} @tab The type shall be @code{INTEGER, DIMENSION(3)} +@item @var{VALUES} @tab The type shall be @code{INTEGER, DIMENSION(3)} and the kind shall be the default integer kind. @end multitable @@ -6318,13 +6368,13 @@ only one form can be used in any given program unit. Subroutine, function @item @emph{Syntax}: -@code{CALL KILL(PID, SIGNAL [, STATUS])} +@code{CALL KILL(C, VALUE [, STATUS])} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{PID} @tab Shall be a scalar @code{INTEGER}, with +@item @var{C} @tab Shall be a scalar @code{INTEGER}, with @code{INTENT(IN)} -@item @var{SIGNAL} @tab Shall be a scalar @code{INTEGER}, with +@item @var{VALUE} @tab Shall be a scalar @code{INTEGER}, with @code{INTENT(IN)} @item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)} or @code{INTEGER(8)}. Returns 0 on success, or a @@ -6401,7 +6451,7 @@ Inquiry function @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{ARRAY} @tab Shall be an array, of any type. -@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER(*)}. +@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER}. @item @var{KIND} @tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of the result. @@ -6447,7 +6497,7 @@ Inquiry function @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{STRING} @tab Shall be a scalar or array of type -@code{CHARACTER(*)}, with @code{INTENT(IN)} +@code{CHARACTER}, with @code{INTENT(IN)} @item @var{KIND} @tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of the result. @@ -6483,7 +6533,7 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{STRING} @tab Shall be a scalar of type @code{CHARACTER(*)}, +@item @var{STRING} @tab Shall be a scalar of type @code{CHARACTER}, with @code{INTENT(IN)} @item @var{KIND} @tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of @@ -6500,60 +6550,6 @@ The return value is of type @code{INTEGER} and of kind @var{KIND}. If -@node LOG_GAMMA -@section @code{LOG_GAMMA} --- Logarithm of the Gamma function -@fnindex LOG_GAMMA -@fnindex LGAMMA -@fnindex ALGAMA -@fnindex DLGAMA -@cindex Gamma function, logarithm of - -@table @asis -@item @emph{Description}: -@code{LOG_GAMMA(X)} computes the natural logarithm of the absolute value -of the Gamma (@math{\Gamma}) function. - -@item @emph{Standard}: -Fortran 2008 and later - -@item @emph{Class}: -Elemental function - -@item @emph{Syntax}: -@code{X = LOG_GAMMA(X)} - -@item @emph{Arguments}: -@multitable @columnfractions .15 .70 -@item @var{X} @tab Shall be of type @code{REAL} and neither zero -nor a negative integer. -@end multitable - -@item @emph{Return value}: -The return value is of type @code{REAL} of the same kind as @var{X}. - -@item @emph{Example}: -@smallexample -program test_log_gamma - real :: x = 1.0 - x = lgamma(x) ! returns 0.0 -end program test_log_gamma -@end smallexample - -@item @emph{Specific names}: -@multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard -@item @code{LGAMMA(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab GNU Extension -@item @code{ALGAMA(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab GNU Extension -@item @code{DLGAMA(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU Extension -@end multitable - -@item @emph{See also}: -Gamma function: @ref{GAMMA} - -@end table - - - @node LGE @section @code{LGE} --- Lexical greater than or equal @fnindex LGE @@ -6803,7 +6799,7 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{STRING} @tab Shall be a scalar of type @code{CHARACTER(*)}, +@item @var{STRING} @tab Shall be a scalar of type @code{CHARACTER}, with @code{INTENT(IN)} @end multitable @@ -6883,12 +6879,12 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)} or -@code{COMPLEX(*)}. +@item @var{X} @tab The type shall be @code{REAL} or +@code{COMPLEX}. @end multitable @item @emph{Return value}: -The return value is of type @code{REAL(*)} or @code{COMPLEX(*)}. +The return value is of type @code{REAL} or @code{COMPLEX}. The kind type parameter is the same as @var{X}. @item @emph{Example}: @@ -6937,11 +6933,11 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)}. +@item @var{X} @tab The type shall be @code{REAL}. @end multitable @item @emph{Return value}: -The return value is of type @code{REAL(*)} or @code{COMPLEX(*)}. +The return value is of type @code{REAL} or @code{COMPLEX}. The kind type parameter is the same as @var{X}. @item @emph{Example}: @@ -6962,6 +6958,60 @@ end program test_log10 +@node LOG_GAMMA +@section @code{LOG_GAMMA} --- Logarithm of the Gamma function +@fnindex LOG_GAMMA +@fnindex LGAMMA +@fnindex ALGAMA +@fnindex DLGAMA +@cindex Gamma function, logarithm of + +@table @asis +@item @emph{Description}: +@code{LOG_GAMMA(X)} computes the natural logarithm of the absolute value +of the Gamma (@math{\Gamma}) function. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{X = LOG_GAMMA(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{X} @tab Shall be of type @code{REAL} and neither zero +nor a negative integer. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL} of the same kind as @var{X}. + +@item @emph{Example}: +@smallexample +program test_log_gamma + real :: x = 1.0 + x = lgamma(x) ! returns 0.0 +end program test_log_gamma +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .20 .20 .20 .25 +@item Name @tab Argument @tab Return type @tab Standard +@item @code{LGAMMA(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab GNU Extension +@item @code{ALGAMA(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab GNU Extension +@item @code{DLGAMA(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU Extension +@end multitable + +@item @emph{See also}: +Gamma function: @ref{GAMMA} + +@end table + + + @node LOGICAL @section @code{LOGICAL} --- Convert to logical type @fnindex LOGICAL @@ -6982,8 +7032,8 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{L} @tab The type shall be @code{LOGICAL(*)}. -@item @var{KIND} @tab (Optional) An @code{INTEGER(*)} initialization +@item @var{L} @tab The type shall be @code{LOGICAL}. +@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of the result. @end multitable @@ -7022,8 +7072,8 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{A} @tab Shall be of type @code{INTEGER(*)}, - @code{REAL(*)}, or @code{COMPLEX(*)}. +@item @var{A} @tab Shall be of type @code{INTEGER}, + @code{REAL}, or @code{COMPLEX}. @end multitable @item @emph{Return value}: @@ -7062,12 +7112,12 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be @code{INTEGER(*)}. -@item @var{SHIFT} @tab The type shall be @code{INTEGER(*)}. +@item @var{I} @tab The type shall be @code{INTEGER}. +@item @var{SHIFT} @tab The type shall be @code{INTEGER}. @end multitable @item @emph{Return value}: -The return value is of type @code{INTEGER(*)} and of the same kind as +The return value is of type @code{INTEGER} and of the same kind as @var{I}. @item @emph{See also}: @@ -7103,10 +7153,11 @@ Subroutine, function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{FILE} @tab The type shall be @code{CHARACTER(*)}, a valid path within the file system. +@item @var{FILE} @tab The type shall be @code{CHARACTER} of the default +kind, a valid path within the file system. @item @var{BUFF} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}. -@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. Returns 0 - on success and a system specific error code otherwise. +@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. +Returns 0 on success and a system specific error code otherwise. @end multitable @item @emph{Example}: @@ -7140,7 +7191,7 @@ Subroutine @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{STIME} @tab An @code{INTEGER(*)} scalar expression +@item @var{STIME} @tab An @code{INTEGER} scalar expression corresponding to a system time, with @code{INTENT(IN)}. @item @var{TARRAY} @tab A default @code{INTEGER} array with 9 elements, @@ -7196,7 +7247,7 @@ Function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{SIZE} @tab The type shall be @code{INTEGER(*)}. +@item @var{SIZE} @tab The type shall be @code{INTEGER}. @end multitable @item @emph{Return value}: @@ -7258,14 +7309,14 @@ Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{MATRIX_A} @tab An array of @code{INTEGER(*)}, - @code{REAL(*)}, @code{COMPLEX(*)}, or - @code{LOGICAL(*)} type, with a rank of +@item @var{MATRIX_A} @tab An array of @code{INTEGER}, + @code{REAL}, @code{COMPLEX}, or + @code{LOGICAL} type, with a rank of one or two. -@item @var{MATRIX_B} @tab An array of @code{INTEGER(*)}, - @code{REAL(*)}, or @code{COMPLEX(*)} type if +@item @var{MATRIX_B} @tab An array of @code{INTEGER}, + @code{REAL}, or @code{COMPLEX} type if @var{MATRIX_A} is of a numeric type; - otherwise, an array of @code{LOGICAL(*)} + otherwise, an array of @code{LOGICAL} type. The rank shall be one or two, and the first (or only) dimension of @var{MATRIX_B} shall be equal to the last (or only) @@ -7307,8 +7358,8 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{A1} @tab The type shall be @code{INTEGER(*)} or - @code{REAL(*)}. +@item @var{A1} @tab The type shall be @code{INTEGER} or + @code{REAL}. @item @var{A2}, @var{A3}, ... @tab An expression of the same type and kind as @var{A1}. (As a GNU extension, arguments of different kinds are @@ -7324,7 +7375,7 @@ and has the same type and kind as the first argument. @item Name @tab Argument @tab Return type @tab Standard @item @code{MAX0(I)} @tab @code{INTEGER(4) I} @tab @code{INTEGER(4)} @tab Fortran 77 and later @item @code{AMAX0(I)} @tab @code{INTEGER(4) I} @tab @code{REAL(MAX(X))} @tab Fortran 77 and later -@item @code{MAX1(X)} @tab @code{REAL(*) X} @tab @code{INT(MAX(X))} @tab Fortran 77 and later +@item @code{MAX1(X)} @tab @code{REAL X} @tab @code{INT(MAX(X))} @tab Fortran 77 and later @item @code{AMAX1(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DMAX1(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @@ -7411,13 +7462,13 @@ Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER(*)}, - @code{REAL(*)}, or @code{CHARACTER(*)}. +@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER}, + @code{REAL}, or @code{CHARACTER}. @item @var{DIM} @tab (Optional) Shall be a scalar of type - @code{INTEGER(*)}, with a value between one + @code{INTEGER}, with a value between one and the rank of @var{ARRAY}, inclusive. It may not be an optional dummy argument. -@item @var{MASK} @tab Shall be an array of type @code{LOGICAL(*)}, +@item @var{MASK} @tab Shall be an array of type @code{LOGICAL}, and conformable with @var{ARRAY}. @end multitable @@ -7468,13 +7519,13 @@ Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER(*)}, - @code{REAL(*)}, or @code{CHARACTER(*)}. +@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER}, + @code{REAL}, or @code{CHARACTER}. @item @var{DIM} @tab (Optional) Shall be a scalar of type - @code{INTEGER(*)}, with a value between one + @code{INTEGER}, with a value between one and the rank of @var{ARRAY}, inclusive. It may not be an optional dummy argument. -@item @var{MASK} @tab Shall be an array of type @code{LOGICAL(*)}, +@item @var{MASK} @tab Shall be an array of type @code{LOGICAL}, and conformable with @var{ARRAY}. @end multitable @@ -7595,7 +7646,7 @@ Elemental function @item @var{TSOURCE} @tab May be of any type. @item @var{FSOURCE} @tab Shall be of the same type and type parameters as @var{TSOURCE}. -@item @var{MASK} @tab Shall be of type @code{LOGICAL(*)}. +@item @var{MASK} @tab Shall be of type @code{LOGICAL}. @end multitable @item @emph{Return value}: @@ -7630,8 +7681,8 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{A1} @tab The type shall be @code{INTEGER(*)} or - @code{REAL(*)}. +@item @var{A1} @tab The type shall be @code{INTEGER} or + @code{REAL}. @item @var{A2}, @var{A3}, ... @tab An expression of the same type and kind as @var{A1}. (As a GNU extension, arguments of different kinds are @@ -7647,7 +7698,7 @@ and has the same type and kind as the first argument. @item Name @tab Argument @tab Return type @tab Standard @item @code{MIN0(I)} @tab @code{INTEGER(4) I} @tab @code{INTEGER(4)} @tab Fortran 77 and later @item @code{AMIN0(I)} @tab @code{INTEGER(4) I} @tab @code{REAL(MIN(X))} @tab Fortran 77 and later -@item @code{MIN1(X)} @tab @code{REAL(*) X} @tab @code{INT(MIN(X))} @tab Fortran 77 and later +@item @code{MIN1(X)} @tab @code{REAL X} @tab @code{INT(MIN(X))} @tab Fortran 77 and later @item @code{AMIN1(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DMIN1(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @@ -7725,13 +7776,13 @@ Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER(*)}, - @code{REAL(*)}, or @code{CHARACTER(*)}. +@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER}, + @code{REAL}, or @code{CHARACTER}. @item @var{DIM} @tab (Optional) Shall be a scalar of type - @code{INTEGER(*)}, with a value between one + @code{INTEGER}, with a value between one and the rank of @var{ARRAY}, inclusive. It may not be an optional dummy argument. -@item @var{MASK} @tab Shall be an array of type @code{LOGICAL(*)}, +@item @var{MASK} @tab Shall be an array of type @code{LOGICAL}, and conformable with @var{ARRAY}. @end multitable @@ -7782,13 +7833,13 @@ Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER(*)}, - @code{REAL(*)}, or @code{CHARACTER(*)}. +@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER}, + @code{REAL}, or @code{CHARACTER}. @item @var{DIM} @tab (Optional) Shall be a scalar of type - @code{INTEGER(*)}, with a value between one + @code{INTEGER}, with a value between one and the rank of @var{ARRAY}, inclusive. It may not be an optional dummy argument. -@item @var{MASK} @tab Shall be an array of type @code{LOGICAL(*)}, +@item @var{MASK} @tab Shall be an array of type @code{LOGICAL}, and conformable with @var{ARRAY}. @end multitable @@ -7996,12 +8047,12 @@ Elemental subroutine @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{FROM} @tab The type shall be @code{INTEGER(*)}. -@item @var{FROMPOS} @tab The type shall be @code{INTEGER(*)}. -@item @var{LEN} @tab The type shall be @code{INTEGER(*)}. -@item @var{TO} @tab The type shall be @code{INTEGER(*)}, of the +@item @var{FROM} @tab The type shall be @code{INTEGER}. +@item @var{FROMPOS} @tab The type shall be @code{INTEGER}. +@item @var{LEN} @tab The type shall be @code{INTEGER}. +@item @var{TO} @tab The type shall be @code{INTEGER}, of the same kind as @var{FROM}. -@item @var{TOPOS} @tab The type shall be @code{INTEGER(*)}. +@item @var{TOPOS} @tab The type shall be @code{INTEGER}. @end multitable @item @emph{See also}: @@ -8175,11 +8226,11 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be @code{INTEGER(*)}. +@item @var{I} @tab The type shall be @code{INTEGER}. @end multitable @item @emph{Return value}: -The return type is @code{INTEGER(*)}, of the same kind as the +The return type is @code{INTEGER}, of the same kind as the argument. @item @emph{See also}: @@ -8259,13 +8310,13 @@ Function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be either a scalar @code{INTEGER(*)} +@item @var{X} @tab The type shall be either a scalar @code{INTEGER} type or a scalar @code{LOGICAL} type. @item @var{Y} @tab The type shall be the same as the type of @var{X}. @end multitable @item @emph{Return value}: -The return type is either a scalar @code{INTEGER(*)} or a scalar +The return type is either a scalar @code{INTEGER} or a scalar @code{LOGICAL}. If the kind type parameters differ, then the smaller kind type is implicitly converted to larger kind, and the return has the larger kind. @@ -8378,7 +8429,8 @@ Subroutine @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{STRING} @tab A scalar of default @code{CHARACTER} type. +@item @var{STRING} @tab A scalar of type @code{CHARACTER} and of the +default kind. @end multitable @item @emph{See also}: @@ -8497,8 +8549,8 @@ Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER(*)}, -@code{REAL(*)} or @code{COMPLEX(*)}. +@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER}, +@code{REAL} or @code{COMPLEX}. @item @var{DIM} @tab (Optional) shall be a scalar of type @code{INTEGER} with a value in the range from 1 to n, where n equals the rank of @var{ARRAY}. @@ -8685,7 +8737,7 @@ Subroutine @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{HARVEST} @tab Shall be a scalar or an array of type @code{REAL(*)}. +@item @var{HARVEST} @tab Shall be a scalar or an array of type @code{REAL}. @end multitable @item @emph{Example}: @@ -8827,15 +8879,15 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab Shall be @code{INTEGER(*)}, @code{REAL(*)}, or - @code{COMPLEX(*)}. -@item @var{KIND} @tab (Optional) An @code{INTEGER(*)} initialization +@item @var{X} @tab Shall be @code{INTEGER}, @code{REAL}, or + @code{COMPLEX}. +@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of the result. @end multitable @item @emph{Return value}: -These functions return a @code{REAL(*)} variable or array under +These functions return a @code{REAL} variable or array under the following rules: @table @asis @@ -8930,8 +8982,8 @@ Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{STRING} @tab Shall be scalar and of type @code{CHARACTER(*)}. -@item @var{NCOPIES} @tab Shall be scalar and of type @code{INTEGER(*)}. +@item @var{STRING} @tab Shall be scalar and of type @code{CHARACTER}. +@item @var{NCOPIES} @tab Shall be scalar and of type @code{INTEGER}. @end multitable @item @emph{Return value}: @@ -9066,12 +9118,12 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be @code{INTEGER(*)}. -@item @var{SHIFT} @tab The type shall be @code{INTEGER(*)}. +@item @var{I} @tab The type shall be @code{INTEGER}. +@item @var{SHIFT} @tab The type shall be @code{INTEGER}. @end multitable @item @emph{Return value}: -The return value is of type @code{INTEGER(*)} and of the same kind as +The return value is of type @code{INTEGER} and of the same kind as @var{I}. @item @emph{See also}: @@ -9150,8 +9202,8 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{STRING} @tab Shall be of type @code{CHARACTER(*)}. -@item @var{SET} @tab Shall be of type @code{CHARACTER(*)}. +@item @var{STRING} @tab Shall be of type @code{CHARACTER}. +@item @var{SET} @tab Shall be of type @code{CHARACTER}. @item @var{BACK} @tab (Optional) shall be of type @code{LOGICAL}. @item @var{KIND} @tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of @@ -9647,8 +9699,8 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)} or -@code{COMPLEX(*)}. +@item @var{X} @tab The type shall be @code{REAL} or +@code{COMPLEX}. @end multitable @item @emph{Return value}: @@ -9700,11 +9752,11 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)}. +@item @var{X} @tab The type shall be @code{REAL}. @end multitable @item @emph{Return value}: -The return value is of type @code{REAL(*)}. +The return value is of type @code{REAL}. @item @emph{Example}: @smallexample @@ -9909,7 +9961,7 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab Shall be of type @code{REAL(*)}. +@item @var{X} @tab Shall be of type @code{REAL}. @end multitable @item @emph{Return value}: @@ -10006,12 +10058,12 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)} or -@code{COMPLEX(*)}. +@item @var{X} @tab The type shall be @code{REAL} or +@code{COMPLEX}. @end multitable @item @emph{Return value}: -The return value is of type @code{REAL(*)} or @code{COMPLEX(*)}. +The return value is of type @code{REAL} or @code{COMPLEX}. The kind type parameter is the same as @var{X}. @item @emph{Example}: @@ -10129,7 +10181,8 @@ Subroutine, function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{FILE} @tab The type shall be @code{CHARACTER(*)}, a valid path within the file system. +@item @var{FILE} @tab The type shall be @code{CHARACTER}, of the +default kind and a valid path within the file system. @item @var{BUFF} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}. @item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. Returns 0 on success and a system specific error code otherwise. @@ -10192,8 +10245,8 @@ Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER(*)}, -@code{REAL(*)} or @code{COMPLEX(*)}. +@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER}, +@code{REAL} or @code{COMPLEX}. @item @var{DIM} @tab (Optional) shall be a scalar of type @code{INTEGER} with a value in the range from 1 to n, where n equals the rank of @var{ARRAY}. @@ -10382,11 +10435,11 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)}. +@item @var{X} @tab The type shall be @code{REAL}. @end multitable @item @emph{Return value}: -The return value is of type @code{REAL(*)}. The kind type parameter is +The return value is of type @code{REAL}. The kind type parameter is the same as @var{X}. @item @emph{Example}: @@ -10432,11 +10485,11 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL(*)}. +@item @var{X} @tab The type shall be @code{REAL}. @end multitable @item @emph{Return value}: -The return value is of type @code{REAL(*)} and lies in the range +The return value is of type @code{REAL} and lies in the range @math{ - 1 \leq tanh(x) \leq 1 }. @item @emph{Example}: @@ -10689,11 +10742,11 @@ Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{STRING} @tab Shall be a scalar of type @code{CHARACTER(*)}. +@item @var{STRING} @tab Shall be a scalar of type @code{CHARACTER}. @end multitable @item @emph{Return value}: -A scalar of type @code{CHARACTER(*)} which length is that of @var{STRING} +A scalar of type @code{CHARACTER} which length is that of @var{STRING} less the number of trailing blanks. @item @emph{Example}: @@ -10737,8 +10790,8 @@ Subroutine, function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{UNIT} @tab Shall be a scalar @code{INTEGER(*)}. -@item @var{NAME} @tab Shall be of type @code{CHARACTER(*)}. +@item @var{UNIT} @tab Shall be a scalar @code{INTEGER}. +@item @var{NAME} @tab Shall be of type @code{CHARACTER}. @end multitable @item @emph{Example}: @@ -10778,7 +10831,7 @@ Inquiry function @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{ARRAY} @tab Shall be an array, of any type. -@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER(*)}. +@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER}. @item @var{KIND}@tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of the result. @@ -10822,9 +10875,9 @@ Subroutine @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{MASK} @tab Shall be a scalar of type @code{INTEGER(*)}. +@item @var{MASK} @tab Shall be a scalar of type @code{INTEGER}. @item @var{MASK} @tab (Optional) Shall be a scalar of type - @code{INTEGER(*)}. + @code{INTEGER}. @end multitable @end table @@ -10948,8 +11001,8 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{STRING} @tab Shall be of type @code{CHARACTER(*)}. -@item @var{SET} @tab Shall be of type @code{CHARACTER(*)}. +@item @var{STRING} @tab Shall be of type @code{CHARACTER}. +@item @var{SET} @tab Shall be of type @code{CHARACTER}. @item @var{BACK} @tab (Optional) shall be of type @code{LOGICAL}. @item @var{KIND} @tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of @@ -11002,13 +11055,13 @@ Function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be either a scalar @code{INTEGER(*)} +@item @var{X} @tab The type shall be either a scalar @code{INTEGER} type or a scalar @code{LOGICAL} type. @item @var{Y} @tab The type shall be the same as the type of @var{I}. @end multitable @item @emph{Return value}: -The return type is either a scalar @code{INTEGER(*)} or a scalar +The return type is either a scalar @code{INTEGER} or a scalar @code{LOGICAL}. If the kind type parameters differ, then the smaller kind type is implicitly converted to larger kind, and the return has the larger kind. diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 2a3c6bd7283..4b7e17d70f3 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -143,6 +143,24 @@ gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED, } +void +gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string) +{ + f->ts.type = BT_CHARACTER; + f->ts.kind = string->ts.kind; + f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind); +} + + +void +gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string) +{ + f->ts.type = BT_CHARACTER; + f->ts.kind = string->ts.kind; + f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind); +} + + static void gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind, const char *name) @@ -1690,11 +1708,27 @@ gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask, resolve_mask_arg (mask); if (mask->rank != 0) - f->value.function.name = (array->ts.type == BT_CHARACTER - ? PREFIX ("pack_char") : PREFIX ("pack")); + { + if (array->ts.type == BT_CHARACTER) + f->value.function.name + = array->ts.kind == 1 ? PREFIX ("pack_char") + : gfc_get_string + (PREFIX ("pack_char%d"), + array->ts.kind); + else + f->value.function.name = PREFIX ("pack"); + } else - f->value.function.name = (array->ts.type == BT_CHARACTER - ? PREFIX ("pack_s_char") : PREFIX ("pack_s")); + { + if (array->ts.type == BT_CHARACTER) + f->value.function.name + = array->ts.kind == 1 ? PREFIX ("pack_s_char") + : gfc_get_string + (PREFIX ("pack_s_char%d"), + array->ts.kind); + else + f->value.function.name = PREFIX ("pack_s"); + } } @@ -1801,6 +1835,7 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape, case BT_REAL: case BT_INTEGER: case BT_LOGICAL: + case BT_CHARACTER: kind = source->ts.kind; break; @@ -1820,15 +1855,17 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape, = gfc_get_string (PREFIX ("reshape_%c%d"), gfc_type_letter (source->ts.type), source->ts.kind); + else if (source->ts.type == BT_CHARACTER) + f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"), + kind); else f->value.function.name = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind); - break; default: f->value.function.name = (source->ts.type == BT_CHARACTER - ? PREFIX ("reshape_char") : PREFIX ("reshape")); + ? PREFIX ("reshape_char") : PREFIX ("reshape")); break; } @@ -2000,13 +2037,27 @@ gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim, f->ts = source->ts; f->rank = source->rank + 1; if (source->rank == 0) - f->value.function.name = (source->ts.type == BT_CHARACTER - ? PREFIX ("spread_char_scalar") - : PREFIX ("spread_scalar")); + { + if (source->ts.type == BT_CHARACTER) + f->value.function.name + = source->ts.kind == 1 ? PREFIX ("spread_char_scalar") + : gfc_get_string + (PREFIX ("spread_char%d_scalar"), + source->ts.kind); + else + f->value.function.name = PREFIX ("spread_scalar"); + } else - f->value.function.name = (source->ts.type == BT_CHARACTER - ? PREFIX ("spread_char") - : PREFIX ("spread")); + { + if (source->ts.type == BT_CHARACTER) + f->value.function.name + = source->ts.kind == 1 ? PREFIX ("spread_char") + : gfc_get_string + (PREFIX ("spread_char%d"), + source->ts.kind); + else + f->value.function.name = PREFIX ("spread"); + } if (dim && gfc_is_constant_expr (dim) && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0]) @@ -2313,7 +2364,10 @@ gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix) break; default: - f->value.function.name = PREFIX ("transpose"); + if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4) + f->value.function.name = PREFIX ("transpose_char4"); + else + f->value.function.name = PREFIX ("transpose"); break; } break; @@ -2413,9 +2467,19 @@ gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask, f->rank = mask->rank; resolve_mask_arg (mask); - f->value.function.name - = gfc_get_string (PREFIX ("unpack%d%s"), field->rank > 0 ? 1 : 0, - vector->ts.type == BT_CHARACTER ? "_char" : ""); + if (vector->ts.type == BT_CHARACTER) + { + if (vector->ts.kind == 1) + f->value.function.name + = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0); + else + f->value.function.name + = gfc_get_string (PREFIX ("unpack%d_char%d"), + field->rank > 0 ? 1 : 0, vector->ts.kind); + } + else + f->value.function.name + = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0); } diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index be5fca094b6..a9b47d8bced 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -992,10 +992,10 @@ got_delim: { c = next_string_char (delimiter, &ret); - if (!gfc_wide_fits_in_byte (c)) + if (!gfc_check_character_range (c, kind)) { - gfc_error ("Unimplemented feature at %C: gfortran currently only " - "supports character strings with one-byte characters"); + gfc_error ("Character '%s' in string at %C is not representable " + "in character kind %d", gfc_print_wide_char (c), kind); return MATCH_ERROR; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index bf886240061..c3354a97d37 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2965,7 +2965,8 @@ resolve_operator (gfc_expr *e) goto bad_op; case INTRINSIC_CONCAT: - if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER) + if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER + && op1->ts.kind == op2->ts.kind) { e->ts.type = BT_CHARACTER; e->ts.kind = op1->ts.kind; @@ -3030,7 +3031,8 @@ resolve_operator (gfc_expr *e) case INTRINSIC_EQ_OS: case INTRINSIC_NE: case INTRINSIC_NE_OS: - if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER) + if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER + && op1->ts.kind == op2->ts.kind) { e->ts.type = BT_LOGICAL; e->ts.kind = gfc_default_logical_kind; @@ -5124,8 +5126,8 @@ validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr) if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind) { - gfc_error("Expression in CASE statement at %L must be kind %d", - &e->where, case_expr->ts.kind); + gfc_error ("Expression in CASE statement at %L must be of kind %d", + &e->where, case_expr->ts.kind); return FAILURE; } @@ -6612,10 +6614,10 @@ gfc_verify_binding_labels (gfc_symbol *sym) has_error = 1; } else if (sym->attr.contained == 0 - && (sym->attr.if_source == IFSRC_UNKNOWN)) - if ((sym->attr.use_assoc - && (strcmp (bind_c_sym->mod_name, sym->module) != 0)) - || sym->attr.use_assoc == 0) + && sym->attr.if_source == IFSRC_UNKNOWN) + if ((sym->attr.use_assoc && bind_c_sym->mod_name + && strcmp (bind_c_sym->mod_name, sym->module) != 0) + || sym->attr.use_assoc == 0) { gfc_error ("Binding label '%s' at %L collides with global " "entity '%s' at %L", sym->binding_label, diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 4159374f06e..8c1c6b349e7 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -256,43 +256,73 @@ gfc_simplify_abs (gfc_expr *e) return result; } -/* We use the processor's collating sequence, because all - systems that gfortran currently works on are ASCII. */ -gfc_expr * -gfc_simplify_achar (gfc_expr *e, gfc_expr *k) +static gfc_expr * +simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii) { gfc_expr *result; - int c, kind; - const char *ch; + int kind; + bool too_large = false; if (e->expr_type != EXPR_CONSTANT) return NULL; - kind = get_kind (BT_CHARACTER, k, "ACHAR", gfc_default_character_kind); + kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind); if (kind == -1) return &gfc_bad_expr; - ch = gfc_extract_int (e, &c); + if (mpz_cmp_si (e->value.integer, 0) < 0) + { + gfc_error ("Argument of %s function at %L is negative", name, + &e->where); + return &gfc_bad_expr; + } + + if (ascii && gfc_option.warn_surprising + && mpz_cmp_si (e->value.integer, 127) > 0) + gfc_warning ("Argument of %s function at %L outside of range [0,127]", + name, &e->where); - if (ch != NULL) - gfc_internal_error ("gfc_simplify_achar: %s", ch); + if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0) + too_large = true; + else if (kind == 4) + { + mpz_t t; + mpz_init_set_ui (t, 2); + mpz_pow_ui (t, t, 32); + mpz_sub_ui (t, t, 1); + if (mpz_cmp (e->value.integer, t) > 0) + too_large = true; + mpz_clear (t); + } - if (gfc_option.warn_surprising && (c < 0 || c > 127)) - gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]", - &e->where); + if (too_large) + { + gfc_error ("Argument of %s function at %L is too large for the " + "collating sequence of kind %d", name, &e->where, kind); + return &gfc_bad_expr; + } result = gfc_constant_result (BT_CHARACTER, kind, &e->where); - result->value.character.string = gfc_get_wide_string (2); - result->value.character.length = 1; - result->value.character.string[0] = c; + result->value.character.string[0] = mpz_get_ui (e->value.integer); result->value.character.string[1] = '\0'; /* For debugger */ return result; } + +/* We use the processor's collating sequence, because all + systems that gfortran currently works on are ASCII. */ + +gfc_expr * +gfc_simplify_achar (gfc_expr *e, gfc_expr *k) +{ + return simplify_achar_char (e, k, "ACHAR", true); +} + + gfc_expr * gfc_simplify_acos (gfc_expr *x) { @@ -821,35 +851,7 @@ gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k) gfc_expr * gfc_simplify_char (gfc_expr *e, gfc_expr *k) { - gfc_expr *result; - int c, kind; - const char *ch; - - kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind); - if (kind == -1) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - ch = gfc_extract_int (e, &c); - - if (ch != NULL) - gfc_internal_error ("gfc_simplify_char: %s", ch); - - if (c < 0 || c > UCHAR_MAX) - gfc_error ("Argument of CHAR function at %L outside of range [0,255]", - &e->where); - - result = gfc_constant_result (BT_CHARACTER, kind, &e->where); - - result->value.character.length = 1; - result->value.character.string = gfc_get_wide_string (2); - - result->value.character.string[0] = c; - result->value.character.string[1] = '\0'; /* For debugger */ - - return result; + return simplify_achar_char (e, k, "CHAR", false); } @@ -1092,7 +1094,7 @@ gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) gfc_expr * gfc_simplify_dble (gfc_expr *e) { - gfc_expr *result; + gfc_expr *result = NULL; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -1698,8 +1700,6 @@ gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind) } index = e->value.character.string[0]; - if (index > UCHAR_MAX) - gfc_internal_error("Argument of ICHAR at %L out of range", &e->where); if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL) return &gfc_bad_expr; @@ -3186,7 +3186,7 @@ gfc_simplify_range (gfc_expr *e) gfc_expr * gfc_simplify_real (gfc_expr *e, gfc_expr *k) { - gfc_expr *result; + gfc_expr *result = NULL; int kind; if (e->ts.type == BT_COMPLEX) @@ -4799,3 +4799,38 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind) return result; } + + +/* Function for converting character constants. */ +gfc_expr * +gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind) +{ + gfc_expr *result; + int i; + + if (!gfc_is_constant_expr (e)) + return NULL; + + result = gfc_constant_result (BT_CHARACTER, kind, &e->where); + if (result == NULL) + return &gfc_bad_expr; + + result->value.character.length = e->value.character.length; + result->value.character.string + = gfc_get_wide_string (e->value.character.length + 1); + memcpy (result->value.character.string, e->value.character.string, + (e->value.character.length + 1) * sizeof (gfc_char_t)); + + /* Check we only have values representable in the destination kind. */ + for (i = 0; i < result->value.character.length; i++) + if (!gfc_check_character_range (result->value.character.string[i], kind)) + { + gfc_error ("Character '%s' in string at %L cannot be converted into " + "character kind %d", + gfc_print_wide_char (result->value.character.string[i]), + &e->where, kind); + return &gfc_bad_expr; + } + + return result; +} diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 7f79ee38d6a..431b6513ce0 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -595,6 +595,21 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (function); conf2 (subroutine); conf2 (threadprivate); + + if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE) + { + a2 = attr->access == ACCESS_PUBLIC ? public : private; + gfc_error ("%s attribute applied to %s %s at %L", a2, a1, + name, where); + return FAILURE; + } + + if (attr->is_bind_c) + { + gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where); + return FAILURE; + } + break; case FL_VARIABLE: @@ -3625,7 +3640,8 @@ add_proc_interface (gfc_symbol *sym, ifsrc source, declaration statement (see match_proc_decl()) to create the formal args based on the args of a given named interface. */ -void copy_formal_args (gfc_symbol *dest, gfc_symbol *src) +void +copy_formal_args (gfc_symbol *dest, gfc_symbol *src) { gfc_formal_arglist *head = NULL; gfc_formal_arglist *tail = NULL; diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c index 389e2a53917..e1f9b7c33a4 100644 --- a/gcc/fortran/target-memory.c +++ b/gcc/fortran/target-memory.c @@ -75,7 +75,8 @@ size_logical (int kind) static size_t size_character (int length, int kind) { - return length * kind; + int i = gfc_validate_kind (BT_CHARACTER, kind, false); + return length * gfc_character_kinds[i].bit_size / 8; } @@ -182,20 +183,19 @@ encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size } -static int -encode_character (int kind, int length, gfc_char_t *string, - unsigned char *buffer, size_t buffer_size) +int +gfc_encode_character (int kind, int length, const gfc_char_t *string, + unsigned char *buffer, size_t buffer_size) { - char *s; + size_t elsize = size_character (1, kind); + tree type = gfc_get_char_type (kind); + int i; gcc_assert (buffer_size >= size_character (length, kind)); - /* FIXME -- when we support wide character types, we'll need to go - via integers for them. For now, we keep the simple memcpy(). */ - gcc_assert (kind == gfc_default_character_kind); - s = gfc_widechar_to_char (string, length); - memcpy (buffer, s, length); - gfc_free (s); + for (i = 0; i < length; i++) + native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize], + elsize); return length; } @@ -268,10 +268,10 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer, buffer_size); case BT_CHARACTER: if (source->expr_type == EXPR_CONSTANT || source->ref == NULL) - return encode_character (source->ts.kind, - source->value.character.length, - source->value.character.string, buffer, - buffer_size); + return gfc_encode_character (source->ts.kind, + source->value.character.length, + source->value.character.string, + buffer, buffer_size); else { int start, end; @@ -279,10 +279,9 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer, gcc_assert (source->expr_type == EXPR_SUBSTRING); gfc_extract_int (source->ref->u.ss.start, &start); gfc_extract_int (source->ref->u.ss.end, &end); - return encode_character (source->ts.kind, - MAX(end - start + 1, 0), - &source->value.character.string[start-1], - buffer, buffer_size); + return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0), + &source->value.character.string[start-1], + buffer, buffer_size); } case BT_DERIVED: diff --git a/gcc/fortran/target-memory.h b/gcc/fortran/target-memory.h index 04b9c780085..bc3a1e8c044 100644 --- a/gcc/fortran/target-memory.h +++ b/gcc/fortran/target-memory.h @@ -31,6 +31,8 @@ bool gfc_convert_boz (gfc_expr *, gfc_typespec *); size_t gfc_target_expr_size (gfc_expr *); /* Write a constant expression in binary form to a target buffer. */ +int gfc_encode_character (int, int, const gfc_char_t *, unsigned char *, + size_t); int gfc_target_encode_expr (gfc_expr *, unsigned char *, size_t); /* Read a target buffer into a constant expression. */ diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 784f1bc40d0..a691ad5ffef 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -992,12 +992,11 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, else { /* The temporary is an array of string values. */ - tmp = gfc_build_addr_expr (pchar_type_node, tmp); + tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp); /* We know the temporary and the value will be the same length, so can use memcpy. */ - gfc_trans_string_copy (&se->pre, esize, tmp, - se->string_length, - se->expr); + gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind, + se->string_length, se->expr, expr->ts.kind); } if (flag_bounds_check && !typespec_chararray_ctor) { @@ -1185,15 +1184,15 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, { gfc_init_se (&se, NULL); gfc_conv_constant (&se, p->expr); + + /* For constant character array constructors we build + an array of pointers. */ if (p->expr->ts.type == BT_CHARACTER && POINTER_TYPE_P (type)) - { - /* For constant character array constructors we build - an array of pointers. */ - se.expr = gfc_build_addr_expr (pchar_type_node, - se.expr); - } - + se.expr = gfc_build_addr_expr + (gfc_get_pchar_type (p->expr->ts.kind), + se.expr); + list = tree_cons (NULL_TREE, se.expr, list); c = p; p = p->next; @@ -1394,8 +1393,7 @@ get_array_ctor_var_strlen (gfc_expr * expr, tree * len) mpz_init_set_ui (char_len, 1); mpz_add (char_len, char_len, ref->u.ss.end->value.integer); mpz_sub (char_len, char_len, ref->u.ss.start->value.integer); - *len = gfc_conv_mpz_to_tree (char_len, - gfc_default_character_kind); + *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind); *len = convert (gfc_charlen_type_node, *len); mpz_clear (char_len); return; @@ -1546,9 +1544,9 @@ gfc_build_constant_array_constructor (gfc_expr * expr, tree type) { gfc_init_se (&se, NULL); gfc_conv_constant (&se, c->expr); - if (c->expr->ts.type == BT_CHARACTER - && POINTER_TYPE_P (type)) - se.expr = gfc_build_addr_expr (pchar_type_node, se.expr); + if (c->expr->ts.type == BT_CHARACTER && POINTER_TYPE_P (type)) + se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind), + se.expr); list = tree_cons (NULL_TREE, se.expr, list); c = c->next; nelem++; @@ -3488,8 +3486,9 @@ gfc_conv_loop_setup (gfc_loopinfo * loop) /* Make absolutely sure that this is a complete type. */ if (loop->temp_ss->string_length) loop->temp_ss->data.temp.type - = gfc_get_character_type_len (gfc_default_character_kind, - loop->temp_ss->string_length); + = gfc_get_character_type_len_for_eltype + (TREE_TYPE (loop->temp_ss->data.temp.type), + loop->temp_ss->string_length); tmp = loop->temp_ss->data.temp.type; len = loop->temp_ss->string_length; diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 511f04bcbbb..2b644c7880b 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -139,4 +139,4 @@ unsigned HOST_WIDE_INT gfc_constant_array_constructor_p (gfc_constructor *); tree gfc_build_constant_array_constructor (gfc_expr *, tree); /* Copy a string from src to dest. */ -void gfc_trans_string_copy (stmtblock_t *, tree, tree, tree, tree); +void gfc_trans_string_copy (stmtblock_t *, tree, tree, int, tree, tree, int); diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c index 6c9032f972a..e4da3f08647 100644 --- a/gcc/fortran/trans-const.c +++ b/gcc/fortran/trans-const.c @@ -33,6 +33,7 @@ along with GCC; see the file COPYING3. If not see #include "trans.h" #include "trans-const.h" #include "trans-types.h" +#include "target-memory.h" tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1]; @@ -66,6 +67,8 @@ gfc_build_const (tree type, tree intval) return val; } +/* Build a string constant with C char type. */ + tree gfc_build_string_const (int length, const char *s) { @@ -81,6 +84,36 @@ gfc_build_string_const (int length, const char *s) return str; } + +/* Build a string constant with a type given by its kind; take care of + non-default character kinds. */ + +tree +gfc_build_wide_string_const (int kind, int length, const gfc_char_t *string) +{ + int i; + tree str, len; + size_t size; + char *s; + + i = gfc_validate_kind (BT_CHARACTER, kind, false); + size = length * gfc_character_kinds[i].bit_size / 8; + + s = gfc_getmem (size); + gfc_encode_character (kind, length, string, (unsigned char *) s, size); + + str = build_string (size, s); + gfc_free (s); + + len = build_int_cst (NULL_TREE, length); + TREE_TYPE (str) = + build_array_type (gfc_get_char_type (kind), + build_range_type (gfc_charlen_type_node, + integer_one_node, len)); + return str; +} + + /* Build a Fortran character constant from a zero-terminated string. There a two version of this function, one that translates the string and one that doesn't. */ @@ -106,13 +139,13 @@ tree gfc_conv_string_init (tree length, gfc_expr * expr) { gfc_char_t *s; - char *c; HOST_WIDE_INT len; int slen; tree str; + bool free_s = false; gcc_assert (expr->expr_type == EXPR_CONSTANT); - gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1); + gcc_assert (expr->ts.type == BT_CHARACTER); gcc_assert (INTEGER_CST_P (length)); gcc_assert (TREE_INT_CST_HIGH (length) == 0); @@ -124,18 +157,15 @@ gfc_conv_string_init (tree length, gfc_expr * expr) s = gfc_get_wide_string (len); memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t)); gfc_wide_memset (&s[slen], ' ', len - slen); - - /* FIXME -- currently ignore wide character strings; see assert - above. */ - c = gfc_widechar_to_char (s, len); - gfc_free (s); + free_s = true; } else - c = gfc_widechar_to_char (expr->value.character.string, - expr->value.character.length); + s = expr->value.character.string; - str = gfc_build_string_const (len, c); - gfc_free (c); + str = gfc_build_wide_string_const (expr->ts.kind, len, s); + + if (free_s) + gfc_free (s); return str; } @@ -223,7 +253,6 @@ tree gfc_conv_constant_to_tree (gfc_expr * expr) { tree res; - char *s; gcc_assert (expr->expr_type == EXPR_CONSTANT); @@ -278,11 +307,9 @@ gfc_conv_constant_to_tree (gfc_expr * expr) } case BT_CHARACTER: - gcc_assert (expr->ts.kind == 1); - s = gfc_widechar_to_char (expr->value.character.string, - expr->value.character.length); - res = gfc_build_string_const (expr->value.character.length, s); - gfc_free (s); + res = gfc_build_wide_string_const (expr->ts.kind, + expr->value.character.length, + expr->value.character.string); return res; case BT_HOLLERITH: diff --git a/gcc/fortran/trans-const.h b/gcc/fortran/trans-const.h index 808a1a5d6af..2cba791c9c9 100644 --- a/gcc/fortran/trans-const.h +++ b/gcc/fortran/trans-const.h @@ -37,6 +37,7 @@ tree gfc_conv_constant_to_tree (gfc_expr *); void gfc_conv_constant (gfc_se *, gfc_expr *); tree gfc_build_string_const (int, const char *); +tree gfc_build_wide_string_const (int, int, const gfc_char_t *); tree gfc_build_cstring_const (const char *); tree gfc_build_localized_cstring_const (const char *); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 49eb2aa8b41..57914ae7a42 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -77,7 +77,6 @@ tree gfor_fndecl_pause_numeric; tree gfor_fndecl_pause_string; tree gfor_fndecl_stop_numeric; tree gfor_fndecl_stop_string; -tree gfor_fndecl_select_string; tree gfor_fndecl_runtime_error; tree gfor_fndecl_runtime_error_at; tree gfor_fndecl_os_error; @@ -116,6 +115,7 @@ tree gfor_fndecl_string_trim; tree gfor_fndecl_string_minmax; tree gfor_fndecl_adjustl; tree gfor_fndecl_adjustr; +tree gfor_fndecl_select_string; tree gfor_fndecl_compare_string_char4; tree gfor_fndecl_concat_string_char4; tree gfor_fndecl_string_len_trim_char4; @@ -126,6 +126,12 @@ tree gfor_fndecl_string_trim_char4; tree gfor_fndecl_string_minmax_char4; tree gfor_fndecl_adjustl_char4; tree gfor_fndecl_adjustr_char4; +tree gfor_fndecl_select_string_char4; + + +/* Conversion between character kinds. */ +tree gfor_fndecl_convert_char1_to_char4; +tree gfor_fndecl_convert_char4_to_char1; /* Other misc. runtime library functions. */ @@ -2084,6 +2090,12 @@ gfc_build_intrinsic_function_decls (void) void_type_node, 3, pchar1_type_node, gfc_charlen_type_node, pchar1_type_node); + gfor_fndecl_select_string = + gfc_build_library_function_decl (get_identifier (PREFIX("select_string")), + integer_type_node, 4, pvoid_type_node, + integer_type_node, pchar1_type_node, + gfc_charlen_type_node); + gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl (get_identifier (PREFIX("compare_string_char4")), @@ -2155,6 +2167,30 @@ gfc_build_intrinsic_function_decls (void) void_type_node, 3, pchar4_type_node, gfc_charlen_type_node, pchar4_type_node); + gfor_fndecl_select_string_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("select_string_char4")), + integer_type_node, 4, pvoid_type_node, + integer_type_node, pvoid_type_node, + gfc_charlen_type_node); + + + /* Conversion between character kinds. */ + + gfor_fndecl_convert_char1_to_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("convert_char1_to_char4")), + void_type_node, 3, + build_pointer_type (pchar4_type_node), + gfc_charlen_type_node, pchar1_type_node); + + gfor_fndecl_convert_char4_to_char1 = + gfc_build_library_function_decl (get_identifier + (PREFIX("convert_char4_to_char1")), + void_type_node, 3, + build_pointer_type (pchar1_type_node), + gfc_charlen_type_node, pchar4_type_node); + /* Misc. functions. */ gfor_fndecl_ttynam = @@ -2362,12 +2398,6 @@ gfc_build_builtin_function_decls (void) void_type_node, 2, pchar_type_node, gfc_int4_type_node); - gfor_fndecl_select_string = - gfc_build_library_function_decl (get_identifier (PREFIX("select_string")), - integer_type_node, 4, pvoid_type_node, - integer_type_node, pchar_type_node, - integer_type_node); - gfor_fndecl_runtime_error = gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")), void_type_node, -1, pchar_type_node); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 563e840c64a..6deaad65f04 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -977,7 +977,12 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len, build_int_cst (gfc_charlen_type_node, 1)); tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp); - tmp = build_array_type (gfc_character1_type_node, tmp); + + if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE) + tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp); + else + tmp = build_array_type (TREE_TYPE (type), tmp); + var = gfc_create_var (tmp, "str"); var = gfc_build_addr_expr (type, var); } @@ -985,7 +990,10 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) { /* Allocate a temporary to hold the result. */ var = gfc_create_var (type, "pstr"); - tmp = gfc_call_malloc (&se->pre, type, len); + tmp = gfc_call_malloc (&se->pre, type, + fold_build2 (MULT_EXPR, TREE_TYPE (len), len, + fold_convert (TREE_TYPE (len), + TYPE_SIZE (type)))); gfc_add_modify_expr (&se->pre, var, tmp); /* Free the temporary afterwards. */ @@ -1008,6 +1016,7 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER && expr->value.op.op2->ts.type == BT_CHARACTER); + gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind); gfc_init_se (&lse, se); gfc_conv_expr (&lse, expr->value.op.op1); @@ -1238,14 +1247,14 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) /* If a string's length is one, we convert it to a single character. */ static tree -gfc_to_single_character (tree len, tree str) +string_to_single_character (tree len, tree str, int kind) { gcc_assert (POINTER_TYPE_P (TREE_TYPE (str))); if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1 - && TREE_INT_CST_HIGH (len) == 0) + && TREE_INT_CST_HIGH (len) == 0) { - str = fold_convert (pchar_type_node, str); + str = fold_convert (gfc_get_pchar_type (kind), str); return build_fold_indirect_ref (str); } @@ -1293,18 +1302,21 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) { if ((*expr)->ref == NULL) { - se->expr = gfc_to_single_character + se->expr = string_to_single_character (build_int_cst (integer_type_node, 1), - gfc_build_addr_expr (pchar_type_node, + gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), gfc_get_symbol_decl - ((*expr)->symtree->n.sym))); + ((*expr)->symtree->n.sym)), + (*expr)->ts.kind); } else { gfc_conv_variable (se, *expr); - se->expr = gfc_to_single_character + se->expr = string_to_single_character (build_int_cst (integer_type_node, 1), - gfc_build_addr_expr (pchar_type_node, se->expr)); + gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), + se->expr), + (*expr)->ts.kind); } } } @@ -1324,8 +1336,8 @@ gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind) gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1))); gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2))); - sc1 = gfc_to_single_character (len1, str1); - sc2 = gfc_to_single_character (len2, str2); + sc1 = string_to_single_character (len1, str1, kind); + sc2 = string_to_single_character (len2, str2, kind); if (sc1 != NULL_TREE && sc2 != NULL_TREE) { @@ -2827,11 +2839,77 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, } +/* Fill a character string with spaces. */ + +static tree +fill_with_spaces (tree start, tree type, tree size) +{ + stmtblock_t block, loop; + tree i, el, exit_label, cond, tmp; + + /* For a simple char type, we can call memset(). */ + if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0) + return build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, start, + build_int_cst (gfc_get_int_type (gfc_c_int_kind), + lang_hooks.to_target_charset (' ')), + size); + + /* Otherwise, we use a loop: + for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type)) + *el = (type) ' '; + */ + + /* Initialize variables. */ + gfc_init_block (&block); + i = gfc_create_var (sizetype, "i"); + gfc_add_modify_expr (&block, i, fold_convert (sizetype, size)); + el = gfc_create_var (build_pointer_type (type), "el"); + gfc_add_modify_expr (&block, el, fold_convert (TREE_TYPE (el), start)); + exit_label = gfc_build_label_decl (NULL_TREE); + TREE_USED (exit_label) = 1; + + + /* Loop body. */ + gfc_init_block (&loop); + + /* Exit condition. */ + cond = fold_build2 (LE_EXPR, boolean_type_node, i, + fold_convert (sizetype, integer_zero_node)); + tmp = build1_v (GOTO_EXPR, exit_label); + tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ()); + gfc_add_expr_to_block (&loop, tmp); + + /* Assignment. */ + gfc_add_modify_expr (&loop, fold_build1 (INDIRECT_REF, type, el), + build_int_cst (type, + lang_hooks.to_target_charset (' '))); + + /* Increment loop variables. */ + gfc_add_modify_expr (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i, + TYPE_SIZE_UNIT (type))); + gfc_add_modify_expr (&loop, el, fold_build2 (POINTER_PLUS_EXPR, + TREE_TYPE (el), el, + TYPE_SIZE_UNIT (type))); + + /* Making the loop... actually loop! */ + tmp = gfc_finish_block (&loop); + tmp = build1_v (LOOP_EXPR, tmp); + gfc_add_expr_to_block (&block, tmp); + + /* The exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&block, tmp); + + + return gfc_finish_block (&block); +} + + /* Generate code to copy a string. */ void gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, - tree slength, tree src) + int dkind, tree slength, tree src, int skind) { tree tmp, dlen, slen; tree dsc; @@ -2841,12 +2919,15 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, tree tmp2; tree tmp3; tree tmp4; + tree chartype; stmtblock_t tempblock; + gcc_assert (dkind == skind); + if (slength != NULL_TREE) { slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block)); - ssc = gfc_to_single_character (slen, src); + ssc = string_to_single_character (slen, src, skind); } else { @@ -2857,7 +2938,7 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, if (dlength != NULL_TREE) { dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block)); - dsc = gfc_to_single_character (slen, dest); + dsc = string_to_single_character (slen, dest, dkind); } else { @@ -2866,14 +2947,14 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, } if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src))) - ssc = gfc_to_single_character (slen, src); + ssc = string_to_single_character (slen, src, skind); if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest))) - dsc = gfc_to_single_character (dlen, dest); + dsc = string_to_single_character (dlen, dest, dkind); /* Assign directly if the types are compatible. */ if (dsc != NULL_TREE && ssc != NULL_TREE - && TREE_TYPE (dsc) == TREE_TYPE (ssc)) + && TREE_TYPE (dsc) == TREE_TYPE (ssc)) { gfc_add_modify_expr (block, dsc, ssc); return; @@ -2906,6 +2987,14 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, We're now doing it here for better optimization, but the logic is the same. */ + /* For non-default character kinds, we have to multiply the string + length by the base type size. */ + chartype = gfc_get_char_type (dkind); + slen = fold_build2 (MULT_EXPR, size_type_node, slen, + TYPE_SIZE_UNIT (chartype)); + dlen = fold_build2 (MULT_EXPR, size_type_node, dlen, + TYPE_SIZE_UNIT (chartype)); + if (dlength) dest = fold_convert (pvoid_type_node, dest); else @@ -2927,12 +3016,9 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest, fold_convert (sizetype, slen)); - tmp4 = build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, - tmp4, - build_int_cst (gfc_get_int_type (gfc_c_int_kind), - lang_hooks.to_target_charset (' ')), - fold_build2 (MINUS_EXPR, TREE_TYPE(dlen), - dlen, slen)); + tmp4 = fill_with_spaces (tmp4, chartype, + fold_build2 (MINUS_EXPR, TREE_TYPE(dlen), + dlen, slen)); gfc_init_block (&tempblock); gfc_add_expr_to_block (&tempblock, tmp3); @@ -2994,7 +3080,7 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) tree arglen; gcc_assert (fsym->ts.cl && fsym->ts.cl->length - && fsym->ts.cl->length->expr_type == EXPR_CONSTANT); + && fsym->ts.cl->length->expr_type == EXPR_CONSTANT); arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); tmp = gfc_build_addr_expr (build_pointer_type (type), @@ -3005,8 +3091,8 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) gfc_add_block_to_block (&se->pre, &lse.pre); gfc_add_block_to_block (&se->pre, &rse.pre); - gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length, - rse.expr); + gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind, + rse.string_length, rse.expr, fsym->ts.kind); gfc_add_block_to_block (&se->pre, &lse.post); gfc_add_block_to_block (&se->pre, &rse.post); } @@ -3042,7 +3128,8 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) tmp = gfc_create_var (type, sym->name); tmp = gfc_build_addr_expr (build_pointer_type (type), tmp); gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp, - se->string_length, se->expr); + sym->ts.kind, se->string_length, se->expr, + sym->ts.kind); se->expr = tmp; } se->string_length = sym->ts.cl->backend_decl; @@ -3501,17 +3588,14 @@ static void gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr) { gfc_ref *ref; - char *s; ref = expr->ref; gcc_assert (ref == NULL || ref->type == REF_SUBSTRING); - gcc_assert (expr->ts.kind == gfc_default_character_kind); - s = gfc_widechar_to_char (expr->value.character.string, - expr->value.character.length); - se->expr = gfc_build_string_const (expr->value.character.length, s); - gfc_free (s); + se->expr = gfc_build_wide_string_const (expr->ts.kind, + expr->value.character.length, + expr->value.character.string); se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr))); TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1; @@ -3824,15 +3908,18 @@ gfc_conv_string_parameter (gfc_se * se) if (TREE_CODE (se->expr) == STRING_CST) { - se->expr = gfc_build_addr_expr (pchar_type_node, se->expr); + type = TREE_TYPE (TREE_TYPE (se->expr)); + se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr); return; } - type = TREE_TYPE (se->expr); - if (TYPE_STRING_FLAG (type)) + if (TYPE_STRING_FLAG (TREE_TYPE (se->expr))) { if (TREE_CODE (se->expr) != INDIRECT_REF) - se->expr = gfc_build_addr_expr (pchar_type_node, se->expr); + { + type = TREE_TYPE (se->expr); + se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr); + } else { type = gfc_get_character_type_len (gfc_default_character_kind, @@ -3881,7 +3968,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, rlen = rse->string_length; } - gfc_trans_string_copy (&block, llen, lse->expr, rlen, rse->expr); + gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen, + rse->expr, ts.kind); } else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp) { diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 03ddefd5e66..990a12789fe 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -250,6 +250,41 @@ gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr) gcc_assert (expr->value.function.actual->expr); gfc_conv_intrinsic_function_args (se, expr, args, nargs); + /* Conversion between character kinds involves a call to a library + function. */ + if (expr->ts.type == BT_CHARACTER) + { + tree fndecl, var, addr, tmp; + + if (expr->ts.kind == 1 + && expr->value.function.actual->expr->ts.kind == 4) + fndecl = gfor_fndecl_convert_char4_to_char1; + else if (expr->ts.kind == 4 + && expr->value.function.actual->expr->ts.kind == 1) + fndecl = gfor_fndecl_convert_char1_to_char4; + else + gcc_unreachable (); + + /* Create the variable storing the converted value. */ + type = gfc_get_pchar_type (expr->ts.kind); + var = gfc_create_var (type, "str"); + addr = gfc_build_addr_expr (build_pointer_type (type), var); + + /* Call the library function that will perform the conversion. */ + gcc_assert (nargs >= 2); + tmp = build_call_expr (fndecl, 3, addr, args[0], args[1]); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Free the temporary afterwards. */ + tmp = gfc_call_free (var); + gfc_add_expr_to_block (&se->post, tmp); + + se->expr = var; + se->string_length = args[0]; + + return; + } + /* Conversion from complex to non-complex involves taking the real component of the value. */ if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE @@ -1273,16 +1308,13 @@ gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr) tree type; unsigned int num_args; - /* We must allow for the KIND argument, even though.... */ num_args = gfc_intrinsic_argument_list_length (expr); gfc_conv_intrinsic_function_args (se, expr, arg, num_args); - /* .... we currently don't support character types != 1. */ - gcc_assert (expr->ts.kind == 1); - type = gfc_character1_type_node; + type = gfc_get_char_type (expr->ts.kind); var = gfc_create_var (type, "char"); - arg[0] = convert (type, arg[0]); + arg[0] = fold_build1 (NOP_EXPR, type, arg[0]); gfc_add_modify_expr (&se->pre, var, arg[0]); se->expr = gfc_build_addr_expr (build_pointer_type (type), var); se->string_length = integer_one_node; @@ -3290,7 +3322,7 @@ gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op) se->expr = gfc_build_compare_string (args[0], args[1], args[2], args[3], - expr->value.function.actual->expr->ts.kind); + expr->value.function.actual->expr->ts.kind); se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr, build_int_cst (TREE_TYPE (se->expr), 0)); } @@ -3892,9 +3924,14 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) { tree args[3], ncopies, dest, dlen, src, slen, ncopies_type; tree type, cond, tmp, count, exit_label, n, max, largest; + tree size; stmtblock_t block, body; int i; + /* We store in charsize the size of an character. */ + i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false); + size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8); + /* Get the arguments. */ gfc_conv_intrinsic_function_args (se, expr, args, 3); slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre)); @@ -3939,7 +3976,6 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) cond); gfc_trans_runtime_check (cond, &se->pre, &expr->where, "Argument NCOPIES of REPEAT intrinsic is too large"); - /* Compute the destination length. */ dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node, @@ -3950,7 +3986,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) /* Generate the code to do the repeat operation: for (i = 0; i < ncopies; i++) - memmove (dest + (i * slen), src, slen); */ + memmove (dest + (i * slen * size), src, slen*size); */ gfc_start_block (&block); count = gfc_create_var (ncopies_type, "count"); gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0)); @@ -3967,15 +4003,18 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) build_empty_stmt ()); gfc_add_expr_to_block (&body, tmp); - /* Call memmove (dest + (i*slen), src, slen). */ + /* Call memmove (dest + (i*slen*size), src, slen*size). */ tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node, fold_convert (gfc_charlen_type_node, slen), fold_convert (gfc_charlen_type_node, count)); - tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, - fold_convert (pchar_type_node, dest), + tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node, + tmp, fold_convert (gfc_charlen_type_node, size)); + tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node, + fold_convert (pvoid_type_node, dest), fold_convert (sizetype, tmp)); - tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3, - tmp, src, slen); + tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src, + fold_build2 (MULT_EXPR, size_type_node, slen, + fold_convert (size_type_node, size))); gfc_add_expr_to_block (&body, tmp); /* Increment count. */ diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 64829e370c1..6afac5d3734 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -99,7 +99,6 @@ gfc_trans_label_assign (gfc_code * code) tree len; tree addr; tree len_tree; - char *label_str; int label_len; /* Start a new block. */ @@ -119,14 +118,13 @@ gfc_trans_label_assign (gfc_code * code) } else { - label_len = code->label->format->value.character.length; - label_str - = gfc_widechar_to_char (code->label->format->value.character.string, - label_len); + gfc_expr *format = code->label->format; + + label_len = format->value.character.length; len_tree = build_int_cst (NULL_TREE, label_len); - label_tree = gfc_build_string_const (label_len + 1, label_str); + label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1, + format->value.character.string); label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); - gfc_free (label_str); } gfc_add_modify_expr (&se.pre, len, len_tree); @@ -1321,41 +1319,56 @@ gfc_trans_logical_select (gfc_code * code) static tree gfc_trans_character_select (gfc_code *code) { - tree init, node, end_label, tmp, type, case_num, label; + tree init, node, end_label, tmp, type, case_num, label, fndecl; stmtblock_t block, body; gfc_case *cp, *d; gfc_code *c; gfc_se se; - int n; + int n, k; + + /* The jump table types are stored in static variables to avoid + constructing them from scratch every single time. */ + static tree select_struct[2]; + static tree ss_string1[2], ss_string1_len[2]; + static tree ss_string2[2], ss_string2_len[2]; + static tree ss_target[2]; - static tree select_struct; - static tree ss_string1, ss_string1_len; - static tree ss_string2, ss_string2_len; - static tree ss_target; + tree pchartype = gfc_get_pchar_type (code->expr->ts.kind); + + if (code->expr->ts.kind == 1) + k = 0; + else if (code->expr->ts.kind == 4) + k = 1; + else + gcc_unreachable (); - if (select_struct == NULL) + if (select_struct[k] == NULL) { - tree gfc_int4_type_node = gfc_get_int_type (4); + select_struct[k] = make_node (RECORD_TYPE); - select_struct = make_node (RECORD_TYPE); - TYPE_NAME (select_struct) = get_identifier ("_jump_struct"); + if (code->expr->ts.kind == 1) + TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1"); + else if (code->expr->ts.kind == 4) + TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4"); + else + gcc_unreachable (); #undef ADD_FIELD -#define ADD_FIELD(NAME, TYPE) \ - ss_##NAME = gfc_add_field_to_struct \ - (&(TYPE_FIELDS (select_struct)), select_struct, \ +#define ADD_FIELD(NAME, TYPE) \ + ss_##NAME[k] = gfc_add_field_to_struct \ + (&(TYPE_FIELDS (select_struct[k])), select_struct[k], \ get_identifier (stringize(NAME)), TYPE) - ADD_FIELD (string1, pchar_type_node); - ADD_FIELD (string1_len, gfc_int4_type_node); + ADD_FIELD (string1, pchartype); + ADD_FIELD (string1_len, gfc_charlen_type_node); - ADD_FIELD (string2, pchar_type_node); - ADD_FIELD (string2_len, gfc_int4_type_node); + ADD_FIELD (string2, pchartype); + ADD_FIELD (string2_len, gfc_charlen_type_node); ADD_FIELD (target, integer_type_node); #undef ADD_FIELD - gfc_finish_type (select_struct); + gfc_finish_type (select_struct[k]); } cp = code->block->ext.case_list; @@ -1401,40 +1414,40 @@ gfc_trans_character_select (gfc_code *code) if (d->low == NULL) { - node = tree_cons (ss_string1, null_pointer_node, node); - node = tree_cons (ss_string1_len, integer_zero_node, node); + node = tree_cons (ss_string1[k], null_pointer_node, node); + node = tree_cons (ss_string1_len[k], integer_zero_node, node); } else { gfc_conv_expr_reference (&se, d->low); - node = tree_cons (ss_string1, se.expr, node); - node = tree_cons (ss_string1_len, se.string_length, node); + node = tree_cons (ss_string1[k], se.expr, node); + node = tree_cons (ss_string1_len[k], se.string_length, node); } if (d->high == NULL) { - node = tree_cons (ss_string2, null_pointer_node, node); - node = tree_cons (ss_string2_len, integer_zero_node, node); + node = tree_cons (ss_string2[k], null_pointer_node, node); + node = tree_cons (ss_string2_len[k], integer_zero_node, node); } else { gfc_init_se (&se, NULL); gfc_conv_expr_reference (&se, d->high); - node = tree_cons (ss_string2, se.expr, node); - node = tree_cons (ss_string2_len, se.string_length, node); + node = tree_cons (ss_string2[k], se.expr, node); + node = tree_cons (ss_string2_len[k], se.string_length, node); } - node = tree_cons (ss_target, build_int_cst (integer_type_node, d->n), + node = tree_cons (ss_target[k], build_int_cst (integer_type_node, d->n), node); - tmp = build_constructor_from_list (select_struct, nreverse (node)); + tmp = build_constructor_from_list (select_struct[k], nreverse (node)); init = tree_cons (NULL_TREE, tmp, init); } - type = build_array_type (select_struct, build_index_type - (build_int_cst (NULL_TREE, n - 1))); + type = build_array_type (select_struct[k], + build_index_type (build_int_cst (NULL_TREE, n-1))); init = build_constructor_from_list (type, nreverse(init)); TREE_CONSTANT (init) = 1; @@ -1455,9 +1468,15 @@ gfc_trans_character_select (gfc_code *code) gfc_add_block_to_block (&block, &se.pre); - tmp = build_call_expr (gfor_fndecl_select_string, 4, init, - build_int_cst (NULL_TREE, n), se.expr, - se.string_length); + if (code->expr->ts.kind == 1) + fndecl = gfor_fndecl_select_string; + else if (code->expr->ts.kind == 4) + fndecl = gfor_fndecl_select_string_char4; + else + gcc_unreachable (); + + tmp = build_call_expr (fndecl, 4, init, build_int_cst (NULL_TREE, n), + se.expr, se.string_length); case_num = gfc_create_var (integer_type_node, "case_num"); gfc_add_modify_expr (&block, case_num, tmp); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 1c15d644ab4..fa1bf248aec 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -874,19 +874,24 @@ gfc_get_pchar_type (int kind) /* Create a character type with the given kind and length. */ tree -gfc_get_character_type_len (int kind, tree len) +gfc_get_character_type_len_for_eltype (tree eltype, tree len) { tree bounds, type; - gfc_validate_kind (BT_CHARACTER, kind, false); - bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len); - type = build_array_type (gfc_get_char_type (kind), bounds); + type = build_array_type (eltype, bounds); TYPE_STRING_FLAG (type) = 1; return type; } +tree +gfc_get_character_type_len (int kind, tree len) +{ + gfc_validate_kind (BT_CHARACTER, kind, false); + return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len); +} + /* Get a type node for a character kind. */ diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 0da736d6d5c..7074913d4ef 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -59,6 +59,7 @@ tree gfc_get_char_type (int); tree gfc_get_pchar_type (int); tree gfc_get_character_type (int, gfc_charlen *); tree gfc_get_character_type_len (int, tree); +tree gfc_get_character_type_len_for_eltype (tree, tree); tree gfc_sym_type (gfc_symbol *); tree gfc_typenode_for_spec (gfc_typespec *); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index ffd1b84c875..d0ce2354120 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -504,7 +504,6 @@ extern GTY(()) tree gfor_fndecl_pause_numeric; extern GTY(()) tree gfor_fndecl_pause_string; extern GTY(()) tree gfor_fndecl_stop_numeric; extern GTY(()) tree gfor_fndecl_stop_string; -extern GTY(()) tree gfor_fndecl_select_string; extern GTY(()) tree gfor_fndecl_runtime_error; extern GTY(()) tree gfor_fndecl_runtime_error_at; extern GTY(()) tree gfor_fndecl_os_error; @@ -551,6 +550,7 @@ extern GTY(()) tree gfor_fndecl_string_trim; extern GTY(()) tree gfor_fndecl_string_minmax; extern GTY(()) tree gfor_fndecl_adjustl; extern GTY(()) tree gfor_fndecl_adjustr; +extern GTY(()) tree gfor_fndecl_select_string; extern GTY(()) tree gfor_fndecl_compare_string_char4; extern GTY(()) tree gfor_fndecl_concat_string_char4; extern GTY(()) tree gfor_fndecl_string_len_trim_char4; @@ -561,6 +561,11 @@ extern GTY(()) tree gfor_fndecl_string_trim_char4; extern GTY(()) tree gfor_fndecl_string_minmax_char4; extern GTY(()) tree gfor_fndecl_adjustl_char4; extern GTY(()) tree gfor_fndecl_adjustr_char4; +extern GTY(()) tree gfor_fndecl_select_string_char4; + +/* Conversion between character kinds. */ +extern GTY(()) tree gfor_fndecl_convert_char1_to_char4; +extern GTY(()) tree gfor_fndecl_convert_char4_to_char1; /* Other misc. runtime library functions. */ extern GTY(()) tree gfor_fndecl_size0; diff --git a/gcc/lambda-code.c b/gcc/lambda-code.c index dc656d3ef4e..707591154e1 100644 --- a/gcc/lambda-code.c +++ b/gcc/lambda-code.c @@ -42,6 +42,7 @@ #include "vec.h" #include "lambda.h" #include "vecprim.h" +#include "pointer-set.h" /* This loop nest code generation is based on non-singular matrix math. @@ -2641,3 +2642,198 @@ lambda_transform_legal_p (lambda_trans_matrix trans, } return true; } + + +/* Collects parameters from affine function ACCESS_FUNCTION, and push + them in PARAMETERS. */ + +static void +lambda_collect_parameters_from_af (tree access_function, + struct pointer_set_t *param_set, + VEC (tree, heap) **parameters) +{ + if (access_function == NULL) + return; + + if (TREE_CODE (access_function) == SSA_NAME + && pointer_set_contains (param_set, access_function) == 0) + { + pointer_set_insert (param_set, access_function); + VEC_safe_push (tree, heap, *parameters, access_function); + } + else + { + int i, num_operands = tree_operand_length (access_function); + + for (i = 0; i < num_operands; i++) + lambda_collect_parameters_from_af (TREE_OPERAND (access_function, i), + param_set, parameters); + } +} + +/* Collects parameters from DATAREFS, and push them in PARAMETERS. */ + +void +lambda_collect_parameters (VEC (data_reference_p, heap) *datarefs, + VEC (tree, heap) **parameters) +{ + unsigned i, j; + struct pointer_set_t *parameter_set = pointer_set_create (); + data_reference_p data_reference; + + for (i = 0; VEC_iterate (data_reference_p, datarefs, i, data_reference); i++) + for (j = 0; j < DR_NUM_DIMENSIONS (data_reference); j++) + lambda_collect_parameters_from_af (DR_ACCESS_FN (data_reference, j), + parameter_set, parameters); +} + +/* Translates BASE_EXPR to vector CY. AM is needed for inferring + indexing positions in the data access vector. CST is the analyzed + integer constant. */ + +static bool +av_for_af_base (tree base_expr, lambda_vector cy, struct access_matrix *am, + int cst) +{ + bool result = true; + + switch (TREE_CODE (base_expr)) + { + case INTEGER_CST: + /* Constant part. */ + cy[AM_CONST_COLUMN_INDEX (am)] += int_cst_value (base_expr) * cst; + return true; + + case SSA_NAME: + { + int param_index = + access_matrix_get_index_for_parameter (base_expr, am); + + if (param_index >= 0) + { + cy[param_index] = cst + cy[param_index]; + return true; + } + + return false; + } + + case PLUS_EXPR: + return av_for_af_base (TREE_OPERAND (base_expr, 0), cy, am, cst) + && av_for_af_base (TREE_OPERAND (base_expr, 1), cy, am, cst); + + case MINUS_EXPR: + return av_for_af_base (TREE_OPERAND (base_expr, 0), cy, am, cst) + && av_for_af_base (TREE_OPERAND (base_expr, 1), cy, am, -1 * cst); + + case MULT_EXPR: + if (TREE_CODE (TREE_OPERAND (base_expr, 0)) == INTEGER_CST) + result = av_for_af_base (TREE_OPERAND (base_expr, 1), + cy, am, cst * + int_cst_value (TREE_OPERAND (base_expr, 0))); + else if (TREE_CODE (TREE_OPERAND (base_expr, 1)) == INTEGER_CST) + result = av_for_af_base (TREE_OPERAND (base_expr, 0), + cy, am, cst * + int_cst_value (TREE_OPERAND (base_expr, 1))); + else + result = false; + + return result; + + case NEGATE_EXPR: + return av_for_af_base (TREE_OPERAND (base_expr, 0), cy, am, -1 * cst); + + default: + return false; + } + + return result; +} + +/* Translates ACCESS_FUN to vector CY. AM is needed for inferring + indexing positions in the data access vector. */ + +static bool +av_for_af (tree access_fun, lambda_vector cy, struct access_matrix *am) +{ + switch (TREE_CODE (access_fun)) + { + case POLYNOMIAL_CHREC: + { + tree left = CHREC_LEFT (access_fun); + tree right = CHREC_RIGHT (access_fun); + unsigned var; + + if (TREE_CODE (right) != INTEGER_CST) + return false; + + var = am_vector_index_for_loop (am, CHREC_VARIABLE (access_fun)); + cy[var] = int_cst_value (right); + + if (TREE_CODE (left) == POLYNOMIAL_CHREC) + return av_for_af (left, cy, am); + else + return av_for_af_base (left, cy, am, 1); + } + + case INTEGER_CST: + /* Constant part. */ + return av_for_af_base (access_fun, cy, am, 1); + + default: + return false; + } +} + +/* Initializes the access matrix for DATA_REFERENCE. */ + +static bool +build_access_matrix (data_reference_p data_reference, + VEC (tree, heap) *parameters, int loop_nest_num) +{ + struct access_matrix *am = GGC_NEW (struct access_matrix); + unsigned i, ndim = DR_NUM_DIMENSIONS (data_reference); + struct loop *loop = bb_for_stmt (DR_STMT (data_reference))->loop_father; + unsigned nb_induction_vars = loop_depth (loop) - loop_nest_num + 1; + unsigned lambda_nb_columns; + lambda_vector_vec_p matrix; + + AM_LOOP_NEST_NUM (am) = loop_nest_num; + AM_NB_INDUCTION_VARS (am) = nb_induction_vars; + AM_PARAMETERS (am) = parameters; + + lambda_nb_columns = AM_NB_COLUMNS (am); + matrix = VEC_alloc (lambda_vector, heap, lambda_nb_columns); + AM_MATRIX (am) = matrix; + + for (i = 0; i < ndim; i++) + { + lambda_vector access_vector = lambda_vector_new (lambda_nb_columns); + tree access_function = DR_ACCESS_FN (data_reference, i); + + if (!av_for_af (access_function, access_vector, am)) + return false; + + VEC_safe_push (lambda_vector, heap, matrix, access_vector); + } + + DR_ACCESS_MATRIX (data_reference) = am; + return true; +} + +/* Returns false when one of the access matrices cannot be built. */ + +bool +lambda_compute_access_matrices (VEC (data_reference_p, heap) *datarefs, + VEC (tree, heap) *parameters, + int loop_nest_num) +{ + data_reference_p dataref; + unsigned ix; + + for (ix = 0; VEC_iterate (data_reference_p, datarefs, ix, dataref); ix++) + if (!build_access_matrix (dataref, parameters, loop_nest_num)) + return false; + + return true; +} diff --git a/gcc/lambda.h b/gcc/lambda.h index 641b3bcaa05..40e8502973c 100644 --- a/gcc/lambda.h +++ b/gcc/lambda.h @@ -28,10 +28,13 @@ along with GCC; see the file COPYING3. If not see and scalar multiplication. In this vector space, an element is a list of integers. */ typedef int *lambda_vector; - DEF_VEC_P(lambda_vector); DEF_VEC_ALLOC_P(lambda_vector,heap); +typedef VEC(lambda_vector, heap) *lambda_vector_vec_p; +DEF_VEC_P (lambda_vector_vec_p); +DEF_VEC_ALLOC_P (lambda_vector_vec_p, heap); + /* An integer matrix. A matrix consists of m vectors of length n (IE all vectors are the same length). */ typedef lambda_vector *lambda_matrix; @@ -487,4 +490,3 @@ dependence_level (lambda_vector dist_vect, int length) } #endif /* LAMBDA_H */ - diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 7bed29c77bc..0267b43ff9e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,229 @@ +2008-05-20 Nathan Sidwell <nathan@codesourcery.com> + + * gcc.c-torture/execute/builtins/memops-asm.c: Set inside_main. + + * lib/gcc-dg.exp (cleanup-saved-temps): Add optional list of + suffixes not to delete. + * gcc.dg/pch/save-temps-1.c: Don't delete ".s" temp. + * g++.dg/pch/pch.C: Likewise. + + * g++.old-deja/g++.pt/static11.C: Replace xfail by target requirement. + + * lib/dg-pch.exp (dg-pch): Don't expect .s files if there are + dg-errors expected. + +2008-05-20 Janis Johnson <janis187@us.ibm.com> + + PR testsuite/20771 + * lib/dg-pch.exp: Move a flag in arguments to dg-test to differentiate + compile results for pch test lines in gcc.sum. + * gcc.dg/pch/counter-2.c: Add comments to dg-error directives to + make them unique in gcc.sum. + * gcc.dg/pch/valid-1.c: Ditto. + * gcc.dg/pch/valid-2.c: Ditto. + * gcc.dg/pch/valid-3.c: Ditto. + * gcc.dg/pch/warn-1.c: Same for dg-warning. + +2008-05-20 Andy Hutchinson <hutchinsonandy@aim.com> + + * gcc.dg/array-quals-1.c: xfail read only section + check for avr target. + +2008-05-20 Andy Hutchinson <hutchinsonandy@aim.com> + + PR testsuite/34889 + * gcc.c-torture/execute/builtins/pr23484-chk.c : Correct test for + 16bit int target. + +2008-05-20 Andy Hutchinson <hutchinsonandy@aim.com> + + * gcc.dg/tree-ssa/ifc-20040816-1.c : signal.h not required. + * gcc.c-torture/execute/ieee/fp-cmp-1.c : Do not include signal.h if + SIGNAL_SUPPRESS. + * gcc.c-torture/execute/ieee/fp-cmp-2.c : Ditto. + * gcc.c-torture/execute/ieee/fp-cmp-3.c : Ditto. + +2008-05-20 Andy Hutchinson <hutchinsonandy@aim.com> + + * gcc.dg/builtins-config.h: AVR does not have C99 runtime. + +2008-05-20 Janis Johnson <janis187@us.ibm.com> + + PR testsuite/22523 + * g++.dg/template/inline1.C: Handle syntax for more assemblers. + + * lib/scandump.exp (scan-dump): Handle non-existent dump file. + (scan-dump-times): Ditto. + (scan-dump-not): Ditto. + (scan-dump-dem): Ditto. + (scan-dump-dem-not): Ditto. + + * obj-c++.dg/bitfield-1.mm: XFAIL for ICE; move dg-options after other + test directives; use dg-prune-output instead of dg-excess-errors for + possible message to ignore; adjust line numbers for messages. + + * obj-c++.dg/comp-types-10.mm: XFAIL for ICE. + * obj-c++.dg/try-catch-9.mm: XFAILfor ICE, move dg-options after + other test directives. + + * obj-c++.dg/try-catch-2.mm: Move dg-options after dg-xfail-if. + * obj-c++.dg/encode-8.mm: Move dg-options after dg-do. + * obj-c++.dg/bitfield-4.mm: Ditto; use dg-prune-output instead of + dg-excess-errors for possible additional message. + * obj-c++.dg/layout-1.mm: Use dg-prune-output instead of + dg-excess-errors for possible additional message. + + * g++.dg/ext/vector14.C: Ignore a possible warning. + +2008-05-20 Samuel Tardieu <sam@rfc1149.net> + + * gnat.dg/modular.adb: Remove test, gnat.dg/modular1.adb already + checks that the bug is fixed and is more concise. + +2008-05-20 Samuel Tardieu <sam@rfc1149.net> + + PR ada/35791 + * gnat.dg/check_displace_generation.adb: New. + +2008-05-20 Samuel Tardieu <sam@rfc1149.net> + + PR ada/30740 + * gnat.dg/modular.adb: New test. + +2008-05-20 Jan Sjodin <jan.sjodin@amd.com> + Sebastian Pop <sebastian.pop@amd.com> + + PR tree-optimization/36181 + * gcc.dg/tree-ssa/pr36181.c: New. + +2008-05-20 Uros Bizjak <ubizjak@gmail.com> + + PR testsuite/36057 + * g++.dg/compat/struct-layout-1_generate.c (DG_OPTIONS): Remove. + (const char *dg_options): New array. + (switchfiles): Loop through dg_options array to generate dg-options + directives. Remove numbered arguments usage from fprintf + format strings. + +2008-05-20 Jan Sjodin <jan.sjodin@amd.com> + Sebastian Pop <sebastian.pop@amd.com> + + PR tree-optimization/36206 + * testsuite/gfortran.dg/pr36206.f: New. + +2008-05-20 Arnaud Charlet <charlet@adacore.com> + + * gnat.dg/testint.adb: New test. + * gnat.dg/modular1.adb: New test. + * gnat.dg/test_iface_aggr.adb: New test. + * gnat.dg/gen_disp.ad[sb]: New test. + * gnat.dg/specs/tag2.ads: Adjust. + * gnat.dg/specs/empty_variants.ads: Adjust. + +2008-05-20 Richard Guenther <rguenther@suse.de> + + * gcc.dg/tree-ssa/ssa-sink-1.c: Adjust. + * gcc.dg/tree-ssa/ssa-sink-2.c: Likewise. + * gcc.dg/tree-ssa/ssa-sink-3.c: Likewise. + * gcc.dg/tree-ssa/ssa-sink-4.c: Likewise. + +2008-05-20 Sandra Loosemore <sandra@codesourcery.com> + + * gcc.c-torture/compile/20061214-1.c: New test. + +2008-05-20 Richard Guenther <rguenther@suse.de> + + * gcc.c-torture/execute/20080519-1.c: New testcase. + +2008-05-19 Xinliang David Li <davidxl@google.com> + + * gcc.dg/cdce1.c: Remove test. + * gcc.dg/cdce2.c: Remove test. + +2008-05-19 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/36265 + * gfortran.dg/char_length_11.f90: New test. + +2008-05-19 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * gfortran.dg/widechar_intrinsics_5.f90: Add dg-do directive and + use -fbackslash option. + +2008-05-19 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * gfortran.dg/char_cast_2.f90: Adjust count in scanning the tree + dump file. + +2008-05-19 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * gfortran.dg/bind_c_module.f90: Adjust expected error messages. + +2008-05-19 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * gfortran.dg/char_cast_1.f90: Adjust count in scanning the tree + dump file. + +2008-05-18 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> + + * gcc.dg/builtins-error.c: Test __builtin_isinf_sign. + * gcc.dg/tg-tests.h: Likewise. Mark variables volatile. + * gcc.dg/torture/builtin-isinf_sign-1.c: New test. + +2008-05-18 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * gfortran.dg/achar_3.f90: Adjust error messages. + * gfortran.dg/achar_5.f90: New test. + * gfortran.dg/achar_6.F90: New test. + * gfortran.dg/widechar_1.f90: New test. + * gfortran.dg/widechar_2.f90: New test. + * gfortran.dg/widechar_3.f90: New test. + * gfortran.dg/widechar_4.f90: New test. + * gfortran.dg/widechar_intrinsics_1.f90: New test. + * gfortran.dg/widechar_intrinsics_2.f90: New test. + * gfortran.dg/widechar_intrinsics_3.f90: New test. + * gfortran.dg/widechar_intrinsics_4.f90: New test. + * gfortran.dg/widechar_intrinsics_5.f90: New test. + * gfortran.dg/widechar_select_1.f90: New test. + * gfortran.dg/widechar_select_2.f90: New test. + +2008-05-18 Eric Botcazou <ebotcazou@adacore.com> + + * gnat.dg/loop_optimization2.ad[sb]: New test. + +2008-05-18 Jakub Jelinek <jakub@redhat.com> + + PR target/36090 + * gcc.c-torture/execute/20080502-1.c: New test. + +2008-05-18 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * gfortran.dg/stat_1.f90: Skip on mingw. + * gfortran.dg/stat_2.f90: Skip on mingw. + +2008-05-18 Steven G. Kargl <kargls@comcast.net> + + PR fortran/36251 + gfortran.dg/public_private_module.f90: new test. + gfortran.dg/bind_c_module.f90: new test. + +2008-05-17 Xinliang David Li <davidxl@google.com> + + * gcc.dg/cdce1.c: New test + * gcc.dg/cdce2.c: New test + +2008-05-17 Tobias Burnus <burnus@net-b.de> + + * gfortran.dg/initialization_19.f90: New test. + +2008-05-17 Eric Botcazou <ebotcazou@adacore.com> + + * gnat.dg/bit_packed_array3.adb: New test. + +2008-05-17 Eric Botcazou <ebotcazou@adacore.com> + + * gnat.dg/warn4.adb: New test. + 2008-05-16 Paul Thomas <pault@gcc.gnu.org> PR fortran/35756 diff --git a/gcc/testsuite/g++.dg/compat/struct-layout-1_generate.c b/gcc/testsuite/g++.dg/compat/struct-layout-1_generate.c index 0bb70eacc6d..e6f4cb969ed 100644 --- a/gcc/testsuite/g++.dg/compat/struct-layout-1_generate.c +++ b/gcc/testsuite/g++.dg/compat/struct-layout-1_generate.c @@ -42,12 +42,13 @@ along with GCC; see the file COPYING3. If not see #define COMPAT_PRLL "ll" #endif -#define DG_OPTIONS "\ -/* { dg-options \"%1$s-I%2$s\" } */\n\ -/* { dg-options \"%1$s-I%2$s -mno-mmx\" { target i?86-*-* x86_64-*-* } } */\n\ -/* { dg-options \"%1$s-I%2$s -fno-common\" { target hppa*-*-hpux* } } */\n\ -/* { dg-options \"%1$s-I%2$s -mno-base-addresses\" { target mmix-*-* } } */\n\ -\n" +const char *dg_options[] = { +"/* { dg-options \"%s-I%s\" } */\n", +"/* { dg-options \"%s-I%s -mno-mmx\" { target i?86-*-* x86_64-*-* } } */\n", +"/* { dg-options \"%s-I%s -fno-common\" { target hppa*-*-hpux* } } */\n", +"/* { dg-options \"%s-I%s -mno-base-addresses\" { target mmix-*-* } } */\n" +#define NDG_OPTIONS (sizeof (dg_options) / sizeof (dg_options[0])) +}; typedef unsigned int hashval_t; @@ -501,6 +502,8 @@ switchfiles (int fields) { static int filecnt; static char *destbuf, *destptr; + int i; + ++filecnt; if (outfile) fclose (outfile); @@ -528,17 +531,19 @@ switchfiles (int fields) fputs ("failed to create test files\n", stderr); exit (1); } - fprintf (outfile, DG_OPTIONS "\ + for (i = 0; i < NDG_OPTIONS; i++) + fprintf (outfile, dg_options[i], "", srcdir); + fprintf (outfile, "\n\ #include \"struct-layout-1.h\"\n\ \n\ #define TX(n, type, attrs, fields, ops) extern void test##n (void);\n\ -#include \"t%3$03d_test.h\"\n\ +#include \"t%03d_test.h\"\n\ #undef TX\n\ \n\ int main (void)\n\ {\n\ #define TX(n, type, attrs, fields, ops) test##n ();\n\ -#include \"t%3$03d_test.h\"\n\ +#include \"t%03d_test.h\"\n\ #undef TX\n\ if (fails)\n\ {\n\ @@ -546,27 +551,31 @@ int main (void)\n\ abort ();\n\ }\n\ exit (0);\n\ -}\n", "", srcdir, filecnt); +}\n", filecnt, filecnt); fclose (outfile); sprintf (destptr, "t%03d_x.C", filecnt); outfile = fopen (destbuf, "w"); if (outfile == NULL) goto fail; - fprintf (outfile, DG_OPTIONS "\ + for (i = 0; i < NDG_OPTIONS; i++) + fprintf (outfile, dg_options[i], "-w ", srcdir); + fprintf (outfile, "\n\ #include \"struct-layout-1_x1.h\"\n\ -#include \"t%3$03d_test.h\"\n\ +#include \"t%03d_test.h\"\n\ #include \"struct-layout-1_x2.h\"\n\ -#include \"t%3$03d_test.h\"\n", "-w ", srcdir, filecnt); +#include \"t%03d_test.h\"\n", filecnt, filecnt); fclose (outfile); sprintf (destptr, "t%03d_y.C", filecnt); outfile = fopen (destbuf, "w"); if (outfile == NULL) goto fail; - fprintf (outfile, DG_OPTIONS "\ + for (i = 0; i < NDG_OPTIONS; i++) + fprintf (outfile, dg_options[i], "-w ", srcdir); + fprintf (outfile, "\n\ #include \"struct-layout-1_y1.h\"\n\ -#include \"t%3$03d_test.h\"\n\ +#include \"t%03d_test.h\"\n\ #include \"struct-layout-1_y2.h\"\n\ -#include \"t%3$03d_test.h\"\n", "-w ", srcdir, filecnt); +#include \"t%03d_test.h\"\n", filecnt, filecnt); fclose (outfile); sprintf (destptr, "t%03d_test.h", filecnt); outfile = fopen (destbuf, "w"); diff --git a/gcc/testsuite/g++.dg/ext/vector14.C b/gcc/testsuite/g++.dg/ext/vector14.C index 1739014f6a4..febdab91ebd 100644 --- a/gcc/testsuite/g++.dg/ext/vector14.C +++ b/gcc/testsuite/g++.dg/ext/vector14.C @@ -1,6 +1,8 @@ // PR c++/35758 // { dg-do compile } // { dg-options "-msse" { target { { i?86-*-* x86_64-*-* } && ilp32 } } } */ +// Ignore warning on some powerpc-linux configurations. +// { dg-prune-output "non-standard ABI extension" } #define vector __attribute__((vector_size(16))) diff --git a/gcc/testsuite/g++.dg/pch/pch.C b/gcc/testsuite/g++.dg/pch/pch.C index 08de37ecc92..9483efad0e2 100644 --- a/gcc/testsuite/g++.dg/pch/pch.C +++ b/gcc/testsuite/g++.dg/pch/pch.C @@ -6,4 +6,4 @@ int main() return 0; } -// { dg-final { cleanup-saved-temps } } +// { dg-final { cleanup-saved-temps ".s" } } diff --git a/gcc/testsuite/g++.dg/template/inline1.C b/gcc/testsuite/g++.dg/template/inline1.C index c5e39bb2738..d6904c42f16 100644 --- a/gcc/testsuite/g++.dg/template/inline1.C +++ b/gcc/testsuite/g++.dg/template/inline1.C @@ -1,6 +1,6 @@ // { dg-do compile } // { dg-options "-fno-default-inline -O0" } -// { dg-final { scan-assembler-not _ZN1X3FooIiEEvT_: } } +// { dg-final { scan-assembler-not "\[^ \t\]_ZN1X3FooIiEEvT_\[: \t\n\]" } } // Copyright (C) 2003 Free Software Foundation, Inc. // Contributed by Nathan Sidwell 27 Mar 2003 <nathan@codesourcery.com> diff --git a/gcc/testsuite/g++.old-deja/g++.pt/static11.C b/gcc/testsuite/g++.old-deja/g++.pt/static11.C index f3e119868f1..867436a6593 100644 --- a/gcc/testsuite/g++.old-deja/g++.pt/static11.C +++ b/gcc/testsuite/g++.old-deja/g++.pt/static11.C @@ -2,7 +2,7 @@ // in their dejagnu baseboard description) require that the status is // final when exit is entered (or main returns), and not "overruled" by a // destructor calling _exit. It's not really worth it to handle that. -// { dg-do run { xfail mmix-knuth-mmixware arm*-*-elf arm*-*-eabi m68k-*-elf } } +// { dg-do run { target unwrapped } } // Bug: g++ was failing to destroy C<int>::a because it was using two // different sentry variables for construction and destruction. diff --git a/gcc/testsuite/gcc.c-torture/compile/20061214-1.c b/gcc/testsuite/gcc.c-torture/compile/20061214-1.c new file mode 100644 index 00000000000..1e65a2a6e52 --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/compile/20061214-1.c @@ -0,0 +1,7 @@ +typedef unsigned long long ull; +ull bar (void); +void foo (ull *x) +{ + ull y = bar (); + *x += y >> 32; +} diff --git a/gcc/testsuite/gcc.c-torture/execute/20080502-1.c b/gcc/testsuite/gcc.c-torture/execute/20080502-1.c new file mode 100644 index 00000000000..ed9b2085e8e --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/execute/20080502-1.c @@ -0,0 +1,16 @@ +/* PR target/36090 */ + +extern void abort (void); + +long double __attribute__ ((noinline)) foo (long double x) +{ + return __builtin_signbit (x) ? 3.1415926535897932384626433832795029L : 0.0; +} + +int +main (void) +{ + if (foo (-1.0L) != 3.1415926535897932384626433832795029L) + abort (); + return 0; +} diff --git a/gcc/testsuite/gcc.c-torture/execute/20080519-1.c b/gcc/testsuite/gcc.c-torture/execute/20080519-1.c new file mode 100644 index 00000000000..303c4e65f63 --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/execute/20080519-1.c @@ -0,0 +1,58 @@ +extern void abort (void); + +typedef unsigned long HARD_REG_SET[2]; +HARD_REG_SET reg_class_contents[2]; + +struct du_chain +{ + struct du_chain *next_use; + int cl; +}; + +void __attribute__((noinline)) +merge_overlapping_regs (HARD_REG_SET *p) +{ + if ((*p)[0] != -1 || (*p)[1] != -1) + abort (); +} + +void __attribute__((noinline)) +regrename_optimize (struct du_chain *this) +{ + HARD_REG_SET this_unavailable; + unsigned long *scan_fp_; + int n_uses; + struct du_chain *last; + + this_unavailable[0] = 0; + this_unavailable[1] = 0; + + n_uses = 0; + for (last = this; last->next_use; last = last->next_use) + { + scan_fp_ = reg_class_contents[last->cl]; + n_uses++; + this_unavailable[0] |= ~ scan_fp_[0]; + this_unavailable[1] |= ~ scan_fp_[1]; + } + if (n_uses < 1) + return; + + scan_fp_ = reg_class_contents[last->cl]; + this_unavailable[0] |= ~ scan_fp_[0]; + this_unavailable[1] |= ~ scan_fp_[1]; + + merge_overlapping_regs (&this_unavailable); +} + +int main() +{ + struct du_chain du1 = { 0, 0 }; + struct du_chain du0 = { &du1, 1 }; + reg_class_contents[0][0] = -1; + reg_class_contents[0][1] = -1; + reg_class_contents[1][0] = 0; + reg_class_contents[1][1] = 0; + regrename_optimize (&du0); + return 0; +} diff --git a/gcc/testsuite/gcc.c-torture/execute/builtins/memops-asm.c b/gcc/testsuite/gcc.c-torture/execute/builtins/memops-asm.c index e793778053a..ed2b06cf06f 100644 --- a/gcc/testsuite/gcc.c-torture/execute/builtins/memops-asm.c +++ b/gcc/testsuite/gcc.c-torture/execute/builtins/memops-asm.c @@ -22,12 +22,16 @@ struct A { char c[32]; } a = { "foobar" }; char x[64] = "foobar", y[64]; int i = 39, j = 6, k = 4; +extern int inside_main; + void main_test (void) { struct A b = a; struct A c = { { 'x' } }; + inside_main = 1; + if (memcmp (b.c, x, 32) || c.c[0] != 'x' || memcmp (c.c + 1, x + 32, 31)) abort (); if (__builtin_memcpy (y, x, i) != y || memcmp (x, y, 64)) diff --git a/gcc/testsuite/gcc.c-torture/execute/builtins/pr23484-chk.c b/gcc/testsuite/gcc.c-torture/execute/builtins/pr23484-chk.c index 58d4db4b21b..446fb6c2f05 100644 --- a/gcc/testsuite/gcc.c-torture/execute/builtins/pr23484-chk.c +++ b/gcc/testsuite/gcc.c-torture/execute/builtins/pr23484-chk.c @@ -41,9 +41,15 @@ test1 (void) abort (); memset (buf, 'L', sizeof (buf)); +#if(__SIZEOF_INT__ >= 4) if (snprintf (buf, l1 ? sizeof (buf) : 4, "%d", l1 + 65536) != 5 || memcmp (buf, "655\0LLLL", 8)) abort (); +#else + if (snprintf (buf, l1 ? sizeof (buf) : 4, "%d", l1 + 32700) != 5 + || memcmp (buf, "327\0LLLL", 8)) + abort (); +#endif if (chk_calls) abort (); diff --git a/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-1.c b/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-1.c index 929639c31e2..0655c73a1f8 100644 --- a/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-1.c +++ b/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-1.c @@ -1,4 +1,6 @@ +#ifndef SIGNAL_SUPPRESS #include <signal.h> +#endif double dnan = 1.0/0.0 - 1.0/0.0; double x = 1.0; diff --git a/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-2.c b/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-2.c index 5d6538b9d74..0f4c6f145f1 100644 --- a/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-2.c +++ b/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-2.c @@ -1,4 +1,6 @@ +#ifndef SIGNAL_SUPPRESS #include <signal.h> +#endif float fnan = 1.0f/0.0f - 1.0f/0.0f; float x = 1.0f; diff --git a/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-3.c b/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-3.c index 993b8d33fbd..710b85ccb2a 100644 --- a/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-3.c +++ b/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-3.c @@ -1,4 +1,6 @@ +#ifndef SIGNAL_SUPPRESS #include <signal.h> +#endif long double dnan = 1.0l/0.0l - 1.0l/0.0l; long double x = 1.0l; diff --git a/gcc/testsuite/gcc.dg/array-quals-1.c b/gcc/testsuite/gcc.dg/array-quals-1.c index 514daf8bc55..fc5398ba338 100644 --- a/gcc/testsuite/gcc.dg/array-quals-1.c +++ b/gcc/testsuite/gcc.dg/array-quals-1.c @@ -4,7 +4,7 @@ /* Origin: Joseph Myers <jsm@polyomino.org.uk> */ /* { dg-do compile } */ /* The MMIX port always switches to the .data section at the end of a file. */ -/* { dg-final { scan-assembler-not "\\.data(?!\\.rel\\.ro)" { xfail powerpc*-*-aix* mmix-*-* x86_64-*-mingw* } } } */ +/* { dg-final { scan-assembler-not "\\.data(?!\\.rel\\.ro)" { xfail powerpc*-*-aix* mmix-*-* x86_64-*-mingw* avr-*-*} } } */ static const int a[2] = { 1, 2 }; const int a1[2] = { 1, 2 }; typedef const int ci; diff --git a/gcc/testsuite/gcc.dg/builtins-config.h b/gcc/testsuite/gcc.dg/builtins-config.h index a6d280ac509..556e87adee0 100644 --- a/gcc/testsuite/gcc.dg/builtins-config.h +++ b/gcc/testsuite/gcc.dg/builtins-config.h @@ -13,6 +13,8 @@ /* PA HP-UX doesn't have the entire C99 runtime. */ #elif defined(__sgi) /* Irix6 doesn't have the entire C99 runtime. */ +#elif defined(AVR) +/* AVR doesn't have the entire C99 runtime. */ #elif defined(__FreeBSD__) && (__FreeBSD__ < 5) /* FreeBSD before version 5 doesn't have the entire C99 runtime. */ #elif defined(__netware__) diff --git a/gcc/testsuite/gcc.dg/builtins-error.c b/gcc/testsuite/gcc.dg/builtins-error.c index 9f401bba1a0..2c0ece1934b 100644 --- a/gcc/testsuite/gcc.dg/builtins-error.c +++ b/gcc/testsuite/gcc.dg/builtins-error.c @@ -16,3 +16,8 @@ int test3(double x) { return __builtin_isinf(x, x); /* { dg-error "too many arguments" } */ } + +int test4(double x) +{ + return __builtin_isinf_sign(x, x); /* { dg-error "too many arguments" } */ +} diff --git a/gcc/testsuite/gcc.dg/pch/counter-2.c b/gcc/testsuite/gcc.dg/pch/counter-2.c index d0475ba1de3..22ba245b698 100644 --- a/gcc/testsuite/gcc.dg/pch/counter-2.c +++ b/gcc/testsuite/gcc.dg/pch/counter-2.c @@ -8,8 +8,8 @@ #endif #include "counter-2.h" /* { dg-warning "not used because `__COUNTER__' is invalid" } */ -/* { dg-error "counter-2.h: No such file or directory" "" { target *-*-* } 10 } */ -/* { dg-error "one or more PCH files were found, but they were invalid" "" { target *-*-* } 10 } */ +/* { dg-error "counter-2.h: No such file or directory" "no such file" { target *-*-* } 10 } */ +/* { dg-error "one or more PCH files were found, but they were invalid" "invalid files" { target *-*-* } 10 } */ int main(void) { diff --git a/gcc/testsuite/gcc.dg/pch/save-temps-1.c b/gcc/testsuite/gcc.dg/pch/save-temps-1.c index d84b99b953a..9a5e7223c73 100644 --- a/gcc/testsuite/gcc.dg/pch/save-temps-1.c +++ b/gcc/testsuite/gcc.dg/pch/save-temps-1.c @@ -6,4 +6,4 @@ #include <stddef.h> int x; -/* { dg-final { cleanup-saved-temps } } */ +/* { dg-final { cleanup-saved-temps ".s" } } */ diff --git a/gcc/testsuite/gcc.dg/pch/valid-1.c b/gcc/testsuite/gcc.dg/pch/valid-1.c index 256ed8f7ff7..1bf7d914467 100644 --- a/gcc/testsuite/gcc.dg/pch/valid-1.c +++ b/gcc/testsuite/gcc.dg/pch/valid-1.c @@ -1,7 +1,7 @@ /* { dg-options "-I. -Winvalid-pch -g" } */ #include "valid-1.h"/* { dg-warning "created with -gnone, but used with -g" } */ -/* { dg-error "No such file" "" { target *-*-* } 3 } */ -/* { dg-error "they were invalid" "" { target *-*-* } 3 } */ +/* { dg-error "No such file" "no such file" { target *-*-* } 3 } */ +/* { dg-error "they were invalid" "invalid files" { target *-*-* } 3 } */ int x; diff --git a/gcc/testsuite/gcc.dg/pch/valid-2.c b/gcc/testsuite/gcc.dg/pch/valid-2.c index 3ae18188084..4dbc4b2d37d 100644 --- a/gcc/testsuite/gcc.dg/pch/valid-2.c +++ b/gcc/testsuite/gcc.dg/pch/valid-2.c @@ -1,6 +1,6 @@ /* { dg-options "-I. -Winvalid-pch -fexceptions" } */ #include "valid-2.h" /* { dg-warning "settings for -fexceptions do not match" } */ -/* { dg-error "No such file" "" { target *-*-* } 3 } */ -/* { dg-error "they were invalid" "" { target *-*-* } 3 } */ +/* { dg-error "No such file" "no such file" { target *-*-* } 3 } */ +/* { dg-error "they were invalid" "invalid files" { target *-*-* } 3 } */ int x; diff --git a/gcc/testsuite/gcc.dg/pch/valid-3.c b/gcc/testsuite/gcc.dg/pch/valid-3.c index 9ee3f7da484..c7884f993a0 100644 --- a/gcc/testsuite/gcc.dg/pch/valid-3.c +++ b/gcc/testsuite/gcc.dg/pch/valid-3.c @@ -1,6 +1,6 @@ /* { dg-options "-I. -Winvalid-pch -fno-unit-at-a-time" } */ #include "valid-3.h"/* { dg-warning "settings for -funit-at-a-time do not match" } */ -/* { dg-error "No such file" "" { target *-*-* } 3 } */ -/* { dg-error "they were invalid" "" { target *-*-* } 3 } */ +/* { dg-error "No such file" "no such file" { target *-*-* } 3 } */ +/* { dg-error "they were invalid" "invalid files" { target *-*-* } 3 } */ int x; diff --git a/gcc/testsuite/gcc.dg/pch/warn-1.c b/gcc/testsuite/gcc.dg/pch/warn-1.c index c841bae4950..eaa9cafc39a 100644 --- a/gcc/testsuite/gcc.dg/pch/warn-1.c +++ b/gcc/testsuite/gcc.dg/pch/warn-1.c @@ -3,8 +3,8 @@ #define DEFINED_VALUE 3 #include "warn-1.h"/* { dg-warning "not used because .DEFINED_VALUE. is defined" } */ -/* { dg-error "No such file" "" { target *-*-* } 5 } */ -/* { dg-error "they were invalid" "" { target *-*-* } 5 } */ +/* { dg-error "No such file" "no such file" { target *-*-* } 5 } */ +/* { dg-error "they were invalid" "invalid files" { target *-*-* } 5 } */ int main(void) diff --git a/gcc/testsuite/gcc.dg/tg-tests.h b/gcc/testsuite/gcc.dg/tg-tests.h index 9d31e4b7bfa..c34e8888cfa 100644 --- a/gcc/testsuite/gcc.dg/tg-tests.h +++ b/gcc/testsuite/gcc.dg/tg-tests.h @@ -3,7 +3,7 @@ void __attribute__ ((__noinline__)) foo_1 (float f, double d, long double ld, int res_unord, int res_isnan, int res_isinf, - int res_isfin, int res_isnorm) + int res_isinf_sign, int res_isfin, int res_isnorm) { if (__builtin_isunordered (f, 0) != res_unord) __builtin_abort (); @@ -40,6 +40,13 @@ foo_1 (float f, double d, long double ld, if (__builtin_isinfl (ld) != res_isinf) __builtin_abort (); + if (__builtin_isinf_sign (f) != res_isinf_sign) + __builtin_abort (); + if (__builtin_isinf_sign (d) != res_isinf_sign) + __builtin_abort (); + if (__builtin_isinf_sign (ld) != res_isinf_sign) + __builtin_abort (); + if (__builtin_isnormal (f) != res_isnorm) __builtin_abort (); if (__builtin_isnormal (d) != res_isnorm) @@ -71,17 +78,17 @@ foo (float f, double d, long double ld, int res_unord, int res_isnan, int res_isinf, int res_isfin, int res_isnorm) { - foo_1 (f, d, ld, res_unord, res_isnan, res_isinf, res_isfin, res_isnorm); + foo_1 (f, d, ld, res_unord, res_isnan, res_isinf, res_isinf, res_isfin, res_isnorm); /* Try all the values negated as well. */ - foo_1 (-f, -d, -ld, res_unord, res_isnan, res_isinf, res_isfin, res_isnorm); + foo_1 (-f, -d, -ld, res_unord, res_isnan, res_isinf, -res_isinf, res_isfin, res_isnorm); } int __attribute__ ((__noinline__)) main_tests (void) { - float f; - double d; - long double ld; + volatile float f; + volatile double d; + volatile long double ld; /* Test NaN. */ f = __builtin_nanf(""); d = __builtin_nan(""); ld = __builtin_nanl(""); diff --git a/gcc/testsuite/gcc.dg/torture/builtin-isinf_sign-1.c b/gcc/testsuite/gcc.dg/torture/builtin-isinf_sign-1.c new file mode 100644 index 00000000000..6dc2326ede0 --- /dev/null +++ b/gcc/testsuite/gcc.dg/torture/builtin-isinf_sign-1.c @@ -0,0 +1,56 @@ +/* Copyright (C) 2008 Free Software Foundation. + + Verify that __builtin_isinf_sign folds correctly. + + Origin: Kaveh R. Ghazi, May 17, 2008. */ + +/* { dg-do link } */ + +/* All references to link_error should go away at compile-time. */ +extern void link_error(int); + +void __attribute__ ((__noinline__)) +foo (float f, double d, long double ld) +{ + /* Test the generic expansion of isinf_sign. */ + + if (__builtin_isinf_sign(f) + != (__builtin_isinf(f) ? (__builtin_signbitf(f) ? -1 : 1) : 0)) + link_error (__LINE__); + if (__builtin_isinf_sign(d) + != (__builtin_isinf(d) ? (__builtin_signbit(d) ? -1 : 1) : 0)) + link_error (__LINE__); + if (__builtin_isinf_sign(ld) + != (__builtin_isinf(ld) ? (__builtin_signbitl(ld) ? -1 : 1) : 0)) + link_error (__LINE__); + + /* In boolean contexts, GCC will fold the inner conditional + expression to 1. So isinf_sign folds to plain isinf. */ + + if ((_Bool)__builtin_isinf_sign(f) != (__builtin_isinf(f) != 0)) + link_error (__LINE__); + if ((_Bool)__builtin_isinf_sign(d) != (__builtin_isinf(d) != 0)) + link_error (__LINE__); + if ((_Bool)__builtin_isinf_sign(ld) != (__builtin_isinf(ld) != 0)) + link_error (__LINE__); + + if ((__builtin_isinf_sign(f) != 0) != (__builtin_isinf(f) != 0)) + link_error (__LINE__); + if ((__builtin_isinf_sign(d) != 0) != (__builtin_isinf(d) != 0)) + link_error (__LINE__); + if ((__builtin_isinf_sign(ld) != 0) != (__builtin_isinf(ld) != 0)) + link_error (__LINE__); + + if ((__builtin_isinf_sign(f) ? 5 : 6) != (__builtin_isinf(f) ? 5 : 6)) + link_error (__LINE__); + if ((__builtin_isinf_sign(d) ? 5 : 6) != (__builtin_isinf(d) ? 5 : 6)) + link_error (__LINE__); + if ((__builtin_isinf_sign(ld) ? 5 : 6) != (__builtin_isinf(ld) ? 5 : 6)) + link_error (__LINE__); +} + +int main (void) +{ + foo (1, 2, 3); + return 0; +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ifc-20040816-1.c b/gcc/testsuite/gcc.dg/tree-ssa/ifc-20040816-1.c index 9f8491f1dbf..691026d7905 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ifc-20040816-1.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ifc-20040816-1.c @@ -2,7 +2,6 @@ /* { dg-options "-c -O2 -ftree-vectorize -fdump-tree-ifcvt-stats" { target *-*-* } } */ #include <stdarg.h> -#include <signal.h> #define N 16 #define MAX 42 diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr36181.c b/gcc/testsuite/gcc.dg/tree-ssa/pr36181.c new file mode 100644 index 00000000000..6eda0a4270a --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr36181.c @@ -0,0 +1,13 @@ +/* { dg-do compile } */ +/* { dg-options "-O3 -ftree-parallelize-loops=2" } */ + +int foo () +{ + int i, sum = 0, data[1024]; + + for(i = 0; i<1024; i++) + sum += data[i]; + + return sum; +} + diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-sink-1.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-sink-1.c index 4dc415d438e..c3326d27e25 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-sink-1.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ssa-sink-1.c @@ -7,5 +7,5 @@ foo (int a, int b, int c) return c ? x : a; } /* We should sink the x = a * b calculation into the branch that returns x. */ -/* { dg-final { scan-tree-dump-times "Sunk statements:1" 1 "sink" } } */ +/* { dg-final { scan-tree-dump-times "Sunk statements: 1" 1 "sink" } } */ /* { dg-final { cleanup-tree-dump "sink" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-sink-2.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-sink-2.c index 259a11a34d1..1d54d019e7f 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-sink-2.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ssa-sink-2.c @@ -9,5 +9,5 @@ bar (int a, int b, int c) return y; } /* We should sink the x = a * b calculation into the else branch */ -/* { dg-final { scan-tree-dump-times "Sunk statements:1" 1 "sink" } } */ +/* { dg-final { scan-tree-dump-times "Sunk statements: 1" 1 "sink" } } */ /* { dg-final { cleanup-tree-dump "sink" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-sink-3.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-sink-3.c index 50efa339f5e..fceb509e8bc 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-sink-3.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ssa-sink-3.c @@ -12,5 +12,5 @@ main (int argc) } } /* We should sink the a = argc + 1 calculation into the if branch */ -/* { dg-final { scan-tree-dump-times "Sunk statements:1" 1 "sink" } } */ +/* { dg-final { scan-tree-dump-times "Sunk statements: 1" 1 "sink" } } */ /* { dg-final { cleanup-tree-dump "sink" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-sink-4.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-sink-4.c index c49c4f8d006..6e1cc50dc11 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-sink-4.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ssa-sink-4.c @@ -17,5 +17,5 @@ main (int argc) foo2 (a); } /* We should sink the first a = b + c calculation into the else branch */ -/* { dg-final { scan-tree-dump-times "Sunk statements:1" 1 "sink" } } */ +/* { dg-final { scan-tree-dump-times "Sunk statements: 1" 1 "sink" } } */ /* { dg-final { cleanup-tree-dump "sink" } } */ diff --git a/gcc/testsuite/gfortran.dg/achar_3.f90 b/gcc/testsuite/gfortran.dg/achar_3.f90 index 3b6f9022f46..b33bfd11d97 100644 --- a/gcc/testsuite/gfortran.dg/achar_3.f90 +++ b/gcc/testsuite/gfortran.dg/achar_3.f90 @@ -1,9 +1,9 @@ ! { dg-do compile } ! { dg-options "-Wall" } program main - print *,achar(-3) ! { dg-warning "outside of range" } + print *,achar(-3) ! { dg-error "negative" } print *,achar(200) ! { dg-warning "outside of range" } - print *,char(222+221) ! { dg-error "outside of range" } - print *,char(-44) ! { dg-error "outside of range" } + print *,char(222+221) ! { dg-error "too large for the collating sequence" } + print *,char(-44) ! { dg-error "negative" } print *,iachar("ü") ! { dg-warning "outside of range" } end program main diff --git a/gcc/testsuite/gfortran.dg/achar_5.f90 b/gcc/testsuite/gfortran.dg/achar_5.f90 new file mode 100644 index 00000000000..c4f78c0173c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/achar_5.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! +program test + + print *, char(255) + print *, achar(255) + print *, char(255,kind=1) + print *, achar(255,kind=1) + print *, char(255,kind=4) + print *, achar(255,kind=4) + + print *, char(0) + print *, achar(0) + print *, char(0,kind=1) + print *, achar(0,kind=1) + print *, char(0,kind=4) + print *, achar(0,kind=4) + + print *, char(297) ! { dg-error "too large for the collating sequence" } + print *, achar(297) ! { dg-error "too large for the collating sequence" } + print *, char(297,kind=1) ! { dg-error "too large for the collating sequence" } + print *, achar(297,kind=1) ! { dg-error "too large for the collating sequence" } + print *, char(297,kind=4) + print *, achar(297,kind=4) + + print *, char(-1) ! { dg-error "negative" } + print *, achar(-1) ! { dg-error "negative" } + print *, char(-1,kind=1) ! { dg-error "negative" } + print *, achar(-1,kind=1) ! { dg-error "negative" } + print *, char(-1,kind=4) ! { dg-error "negative" } + print *, achar(-1,kind=4) ! { dg-error "negative" } + + print *, char(huge(0_8)) ! { dg-error "too large for the collating sequence" } + print *, achar(huge(0_8)) ! { dg-error "too large for the collating sequence" } + print *, char(huge(0_8),kind=1) ! { dg-error "too large for the collating sequence" } + print *, achar(huge(0_8),kind=1) ! { dg-error "too large for the collating sequence" } + print *, char(huge(0_8),kind=4) ! { dg-error "too large for the collating sequence" } + print *, achar(huge(0_8),kind=4) ! { dg-error "too large for the collating sequence" } + + print *, char(z'FFFFFFFF', kind=4) + print *, achar(z'FFFFFFFF', kind=4) + print *, char(z'100000000', kind=4) ! { dg-error "too large for the collating sequence" } + print *, achar(z'100000000', kind=4) ! { dg-error "too large for the collating sequence" } + +end program test diff --git a/gcc/testsuite/gfortran.dg/achar_6.F90 b/gcc/testsuite/gfortran.dg/achar_6.F90 new file mode 100644 index 00000000000..dd93c27472c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/achar_6.F90 @@ -0,0 +1,70 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + +#define TEST(x,y,z) \ + call test (x, y, z, iachar(x), iachar(y), ichar(x), ichar(y)) + + TEST("a", 4_"a", 97) + TEST("\0", 4_"\0", 0) + TEST("\b", 4_"\b", 8) + TEST("\x80", 4_"\x80", int(z'80')) + TEST("\xFF", 4_"\xFF", int(z'FF')) + +#define TEST2(y,z) \ + call test_bis (y, z, iachar(y), ichar(y)) + + TEST2(4_"\u0100", int(z'0100')) + TEST2(4_"\ufe00", int(z'fe00')) + TEST2(4_"\u106a", int(z'106a')) + TEST2(4_"\uff00", int(z'ff00')) + TEST2(4_"\uffff", int(z'ffff')) + +contains + +subroutine test (s1, s4, i, i1, i2, i3, i4) + character(kind=1,len=1) :: s1 + character(kind=4,len=1) :: s4 + integer :: i, i1, i2, i3, i4 + + if (i /= i1) call abort + if (i /= i2) call abort + if (i /= i3) call abort + if (i /= i4) call abort + + if (iachar (s1) /= i) call abort + if (iachar (s4) /= i) call abort + + if (ichar (s1) /= i) call abort + if (ichar (s4) /= i) call abort + + if (achar(i, kind=1) /= s1) call abort + if (achar(i, kind=4) /= s4) call abort + + if (char(i, kind=1) /= s1) call abort + if (char(i, kind=4) /= s4) call abort + + if (iachar(achar(i, kind=1)) /= i) call abort + if (iachar(achar(i, kind=4)) /= i) call abort + + if (ichar(char(i, kind=1)) /= i) call abort + if (ichar(char(i, kind=4)) /= i) call abort + +end subroutine test + +subroutine test_bis (s4, i, i2, i4) + character(kind=4,len=1) :: s4 + integer :: i, i2, i4 + + if (i /= i2) call abort + if (i /= i4) call abort + + if (iachar (s4) /= i) call abort + if (ichar (s4) /= i) call abort + if (achar(i, kind=4) /= s4) call abort + if (char(i, kind=4) /= s4) call abort + if (iachar(achar(i, kind=4)) /= i) call abort + if (ichar(char(i, kind=4)) /= i) call abort + +end subroutine test_bis + +end diff --git a/gcc/testsuite/gfortran.dg/bind_c_module.f90 b/gcc/testsuite/gfortran.dg/bind_c_module.f90 new file mode 100644 index 00000000000..a17f5d0b34b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_module.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! See PR fortran/36251. +module a + implicit none + integer :: i = 42 +end module a + +! Causes ICE +module b + use iso_c_binding + use a + implicit none + bind(c) :: a ! { dg-error "applied to" } +end module b + +! Causes ICE +module d + use a + implicit none + bind(c) :: a ! { dg-error "applied to" } +end module d +! { dg-final { cleanup-modules "a" } } diff --git a/gcc/testsuite/gfortran.dg/char_cast_1.f90 b/gcc/testsuite/gfortran.dg/char_cast_1.f90 index b31db3adb36..270f7b95d8f 100644 --- a/gcc/testsuite/gfortran.dg/char_cast_1.f90 +++ b/gcc/testsuite/gfortran.dg/char_cast_1.f90 @@ -27,6 +27,5 @@ end ! The sign that all is well is that [S.5][1] appears twice. ! Platform dependent variations are [S$5][1], [__S_5][1], [S___5][1] -! With this regular expression we also find [S.15][1], so count is 3. -! { dg-final { scan-tree-dump-times "5\\\]\\\[1\\\]" 3 "original" } } +! { dg-final { scan-tree-dump-times "5\\\]\\\[1\\\]" 2 "original" } } ! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/char_cast_2.f90 b/gcc/testsuite/gfortran.dg/char_cast_2.f90 index 39566dac5e6..4c175bd0fd7 100644 --- a/gcc/testsuite/gfortran.dg/char_cast_2.f90 +++ b/gcc/testsuite/gfortran.dg/char_cast_2.f90 @@ -19,8 +19,8 @@ contains return end function Up end -! The sign that all is well is that [S.5][1] appears five times. +! The sign that all is well is that [S.5][1] appears twice. ! Platform dependent variations are [S$5][1], [__S_5][1], [S___5][1] ! so we count the occurrences of 5][1]. -! { dg-final { scan-tree-dump-times "5\\\]\\\[1\\\]" 5 "original" } } +! { dg-final { scan-tree-dump-times "5\\\]\\\[1\\\]" 2 "original" } } ! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/char_length_11.f90 b/gcc/testsuite/gfortran.dg/char_length_11.f90 new file mode 100644 index 00000000000..e745c123e3a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/char_length_11.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } + + character(len=*), parameter :: s = "foo" + write (*,*) adjustr(s(:)) +end diff --git a/gcc/testsuite/gfortran.dg/initialization_19.f90 b/gcc/testsuite/gfortran.dg/initialization_19.f90 new file mode 100644 index 00000000000..2465f9b3335 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/initialization_19.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! The following program fails with 4.3.0 +! but works with 4.4.0. See: +! +! http://gcc.gnu.org/ml/fortran/2008-05/msg00199.html +! +module c +type d + integer :: i=-1 +end type d +end module c + +module s +use c +contains +subroutine g + type(d) :: a + ! Without the following line it passes with 4.3.0: + print *, a%i + if(a%i /= -1) call abort() + a%i=0 +end subroutine g +end module s + +program t +use c +use s + +call g +call g + +end program t + +! ! { dg-final { cleanup-modules "c s" } } diff --git a/gcc/testsuite/gfortran.dg/pr36206.f b/gcc/testsuite/gfortran.dg/pr36206.f new file mode 100644 index 00000000000..7b0b56639dd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr36206.f @@ -0,0 +1,95 @@ +! { dg-do compile } +! { dg-options "-O3" } +! PR fortran/36206 + + SUBROUTINE SSPR(UPLO,N,ALPHA,X,INCX,AP) + REAL ALPHA + INTEGER INCX,N + CHARACTER UPLO + REAL AP(*),X(*) + REAL ZERO + PARAMETER (ZERO=0.0E+0) + REAL TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX + LOGICAL LSAME + EXTERNAL LSAME + EXTERNAL XERBLA + + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SSPR ',INFO) + RETURN + END IF + IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF + KK = 1 + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*X(J) + K = KK + DO 10 I = 1,J + AP(K) = AP(K) + X(I)*TEMP + K = K + 1 + 10 CONTINUE + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = KX + DO 30 K = KK,KK + J - 1 + AP(K) = AP(K) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*X(J) + K = KK + DO 50 I = J,N + AP(K) = AP(K) + X(I)*TEMP + K = K + 1 + 50 CONTINUE + END IF + KK = KK + N - J + 1 + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = JX + DO 70 K = KK,KK + N - J + AP(K) = AP(K) + X(IX)*TEMP + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF + RETURN + END diff --git a/gcc/testsuite/gfortran.dg/public_private_module.f90 b/gcc/testsuite/gfortran.dg/public_private_module.f90 new file mode 100644 index 00000000000..ca1ab4891f4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/public_private_module.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! See PR fortran/36251. +module a + implicit none + integer :: i = 42 +end module a + +module b + use a + implicit none + public a ! { dg-warning "attribute applied to" } +end module b + +module d + use a + implicit none + private a ! { dg-warning "attribute applied to" } +end module d +! { dg-final { cleanup-modules "a" } } diff --git a/gcc/testsuite/gfortran.dg/stat_1.f90 b/gcc/testsuite/gfortran.dg/stat_1.f90 index b9dc10095d2..df60c3948f2 100644 --- a/gcc/testsuite/gfortran.dg/stat_1.f90 +++ b/gcc/testsuite/gfortran.dg/stat_1.f90 @@ -1,4 +1,5 @@ ! { dg-do run { target fd_truncate } } +! { dg-skip-if "" { *-*-mingw* } { "*" } { "" } } ! { dg-options "-std=gnu" } character(len=*), parameter :: f = "testfile" integer :: s1(13), r1, s2(13), r2, s3(13), r3 diff --git a/gcc/testsuite/gfortran.dg/stat_2.f90 b/gcc/testsuite/gfortran.dg/stat_2.f90 index b57b52f9300..4622395c34d 100644 --- a/gcc/testsuite/gfortran.dg/stat_2.f90 +++ b/gcc/testsuite/gfortran.dg/stat_2.f90 @@ -1,4 +1,5 @@ ! { dg-do run { target fd_truncate } } +! { dg-skip-if "" { *-*-mingw* } { "*" } { "" } } ! { dg-options "-std=gnu" } character(len=*), parameter :: f = "testfile" integer :: s1(13), r1, s2(13), r2, s3(13), r3 diff --git a/gcc/testsuite/gfortran.dg/widechar_1.f90 b/gcc/testsuite/gfortran.dg/widechar_1.f90 new file mode 100644 index 00000000000..804de9d7a44 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_1.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-fbackslash" } + + character(len=20,kind=4) :: s4 + character(len=20,kind=1) :: s1 + + s1 = "foo\u0000" + s1 = "foo\u00ff" + s1 = "foo\u0100" ! { dg-error "is not representable" } + s1 = "foo\u0101" ! { dg-error "is not representable" } + s1 = "foo\U00000101" ! { dg-error "is not representable" } + + s1 = 4_"foo bar" + s1 = 4_"foo\u00ff" + s1 = 4_"foo\u0101" ! { dg-error "cannot be converted" } + s1 = 4_"foo\u1101" ! { dg-error "cannot be converted" } + s1 = 4_"foo\UFFFFFFFF" ! { dg-error "cannot be converted" } + + s4 = "foo\u0000" + s4 = "foo\u00ff" + s4 = "foo\u0100" ! { dg-error "is not representable" } + s4 = "foo\U00000100" ! { dg-error "is not representable" } + + s4 = 4_"foo bar" + s4 = 4_"\xFF\x96" + s4 = 4_"\x00\x96" + s4 = 4_"foo\u00ff" + s4 = 4_"foo\u0101" + s4 = 4_"foo\u1101" + s4 = 4_"foo\Uab98EF56" + s4 = 4_"foo\UFFFFFFFF" + +end diff --git a/gcc/testsuite/gfortran.dg/widechar_2.f90 b/gcc/testsuite/gfortran.dg/widechar_2.f90 new file mode 100644 index 00000000000..706901e6b1c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_2.f90 @@ -0,0 +1,69 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + character(kind=1,len=20) :: s1 + character(kind=4,len=20) :: s4 + + s1 = "this is me!" + s4 = s1 + call check(s1, 4_"this is me! ") + call check2(s1, 4_"this is me! ") + s4 = "this is me!" + call check(s1, 4_"this is me! ") + call check2(s1, 4_"this is me! ") + + s1 = "" + s4 = s1 + call check(s1, 4_" ") + call check2(s1, 4_" ") + s4 = "" + call check(s1, 4_" ") + call check2(s1, 4_" ") + + s1 = " \xFF" + s4 = s1 + call check(s1, 4_" \xFF ") + call check2(s1, 4_" \xFF ") + s4 = " \xFF" + call check(s1, 4_" \xFF ") + call check2(s1, 4_" \xFF ") + + s1 = " \xFF" + s4 = s1 + call check(s1, 4_" \xFF ") + call check2(s1, 4_" \xFF ") + s4 = " \xFF" + call check(s1, 4_" \xFF ") + call check2(s1, 4_" \xFF ") + +contains + subroutine check(s1,s4) + character(kind=1,len=20) :: s1, t1 + character(kind=4,len=20) :: s4 + t1 = s4 + if (t1 /= s1) call abort + if (len(s1) /= len(t1)) call abort + if (len(s1) /= len(s4)) call abort + if (len_trim(s1) /= len_trim(t1)) call abort + if (len_trim(s1) /= len_trim(s4)) call abort + end subroutine check + + subroutine check2(s1,s4) + character(kind=1,len=*) :: s1 + character(kind=4,len=*) :: s4 + character(kind=1,len=len(s1)) :: t1 + character(kind=4,len=len(s4)) :: t4 + + t1 = s4 + t4 = s1 + if (t1 /= s1) call abort + if (t4 /= s4) call abort + if (len(s1) /= len(t1)) call abort + if (len(s1) /= len(s4)) call abort + if (len(s1) /= len(t4)) call abort + if (len_trim(s1) /= len_trim(t1)) call abort + if (len_trim(s1) /= len_trim(s4)) call abort + if (len_trim(s1) /= len_trim(t4)) call abort + end subroutine check2 + +end diff --git a/gcc/testsuite/gfortran.dg/widechar_3.f90 b/gcc/testsuite/gfortran.dg/widechar_3.f90 new file mode 100644 index 00000000000..653f1d93ac1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_3.f90 @@ -0,0 +1,112 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=1000" } + + character(kind=1,len=20) :: s1, t1 + character(kind=4,len=20) :: s4, t4 + + print *, "" // "" + print *, "" // 4_"" ! { dg-error "Operands of string concatenation operator" } + print *, 4_"" // "" ! { dg-error "Operands of string concatenation operator" } + print *, 4_"" // 4_"" + + print *, s1 // "" + print *, s1 // 4_"" ! { dg-error "Operands of string concatenation operator" } + print *, s4 // "" ! { dg-error "Operands of string concatenation operator" } + print *, s4 // 4_"" + + print *, "" // s1 + print *, 4_"" // s1 ! { dg-error "Operands of string concatenation operator" } + print *, "" // s4 ! { dg-error "Operands of string concatenation operator" } + print *, 4_"" // s4 + + print *, s1 // t1 + print *, s1 // t4 ! { dg-error "Operands of string concatenation operator" } + print *, s4 // t1 ! { dg-error "Operands of string concatenation operator" } + print *, s4 // t4 + + print *, s1 .eq. "" + print *, s1 .eq. 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 .eq. "" ! { dg-error "Operands of comparison operator" } + print *, s4 .eq. 4_"" + + print *, s1 == "" + print *, s1 == 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 == "" ! { dg-error "Operands of comparison operator" } + print *, s4 == 4_"" + + print *, s1 .ne. "" + print *, s1 .ne. 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 .ne. "" ! { dg-error "Operands of comparison operator" } + print *, s4 .ne. 4_"" + + print *, s1 /= "" + print *, s1 /= 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 /= "" ! { dg-error "Operands of comparison operator" } + print *, s4 /= 4_"" + + print *, s1 .le. "" + print *, s1 .le. 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 .le. "" ! { dg-error "Operands of comparison operator" } + print *, s4 .le. 4_"" + + print *, s1 <= "" + print *, s1 <= 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 <= "" ! { dg-error "Operands of comparison operator" } + print *, s4 <= 4_"" + + print *, s1 .ge. "" + print *, s1 .ge. 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 .ge. "" ! { dg-error "Operands of comparison operator" } + print *, s4 .ge. 4_"" + + print *, s1 >= "" + print *, s1 >= 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 >= "" ! { dg-error "Operands of comparison operator" } + print *, s4 >= 4_"" + + print *, s1 .lt. "" + print *, s1 .lt. 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 .lt. "" ! { dg-error "Operands of comparison operator" } + print *, s4 .lt. 4_"" + + print *, s1 < "" + print *, s1 < 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 < "" ! { dg-error "Operands of comparison operator" } + print *, s4 < 4_"" + + print *, s1 .gt. "" + print *, s1 .gt. 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 .gt. "" ! { dg-error "Operands of comparison operator" } + print *, s4 .gt. 4_"" + + print *, s1 > "" + print *, s1 > 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 > "" ! { dg-error "Operands of comparison operator" } + print *, s4 > 4_"" + + print *, "" == "" + print *, 4_"" == "" ! { dg-error "Operands of comparison operator" } + print *, "" .eq. "" + print *, 4_"" .eq. "" ! { dg-error "Operands of comparison operator" } + print *, "" /= "" + print *, 4_"" /= "" ! { dg-error "Operands of comparison operator" } + print *, "" .ne. "" + print *, 4_"" .ne. "" ! { dg-error "Operands of comparison operator" } + print *, "" .lt. "" + print *, 4_"" .lt. "" ! { dg-error "Operands of comparison operator" } + print *, "" < "" + print *, 4_"" < "" ! { dg-error "Operands of comparison operator" } + print *, "" .le. "" + print *, 4_"" .le. "" ! { dg-error "Operands of comparison operator" } + print *, "" <= "" + print *, 4_"" <= "" ! { dg-error "Operands of comparison operator" } + print *, "" .gt. "" + print *, 4_"" .gt. "" ! { dg-error "Operands of comparison operator" } + print *, "" > "" + print *, 4_"" > "" ! { dg-error "Operands of comparison operator" } + print *, "" .ge. "" + print *, 4_"" .ge. "" ! { dg-error "Operands of comparison operator" } + print *, "" >= "" + print *, 4_"" >= "" ! { dg-error "Operands of comparison operator" } + + end diff --git a/gcc/testsuite/gfortran.dg/widechar_4.f90 b/gcc/testsuite/gfortran.dg/widechar_4.f90 new file mode 100644 index 00000000000..1166f8bfb77 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_4.f90 @@ -0,0 +1,147 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + character(kind=1,len=20) :: s1, t1 + character(kind=4,len=20) :: s4, t4 + + call test (4_"ccc ", 4_"bbb", 4_"ccc", 4_"ddd") + call test (4_" \xACp ", 4_" \x900000 ", 4_" \xACp ", 4_"ddd") + call test (4_" \xACp ", 4_" \x900000 ", 4_" \xACp ", 4_"ddd") + + call test2 (4_" \x900000 ", 4_" \xACp ", 4_"ddd") + +contains + + subroutine test(s4, t4, u4, v4) + character(kind=4,len=*) :: s4, t4, u4, v4 + + if (.not. (s4 >= t4)) call abort + if (.not. (s4 > t4)) call abort + if (.not. (s4 .ge. t4)) call abort + if (.not. (s4 .gt. t4)) call abort + if ( (s4 == t4)) call abort + if (.not. (s4 /= t4)) call abort + if ( (s4 .eq. t4)) call abort + if (.not. (s4 .ne. t4)) call abort + if ( (s4 <= t4)) call abort + if ( (s4 < t4)) call abort + if ( (s4 .le. t4)) call abort + if ( (s4 .lt. t4)) call abort + + if (.not. (s4 >= u4)) call abort + if ( (s4 > u4)) call abort + if (.not. (s4 .ge. u4)) call abort + if ( (s4 .gt. u4)) call abort + if (.not. (s4 == u4)) call abort + if ( (s4 /= u4)) call abort + if (.not. (s4 .eq. u4)) call abort + if ( (s4 .ne. u4)) call abort + if (.not. (s4 <= u4)) call abort + if ( (s4 < u4)) call abort + if (.not. (s4 .le. u4)) call abort + if ( (s4 .lt. u4)) call abort + + if ( (s4 >= v4)) call abort + if ( (s4 > v4)) call abort + if ( (s4 .ge. v4)) call abort + if ( (s4 .gt. v4)) call abort + if ( (s4 == v4)) call abort + if (.not. (s4 /= v4)) call abort + if ( (s4 .eq. v4)) call abort + if (.not. (s4 .ne. v4)) call abort + if (.not. (s4 <= v4)) call abort + if (.not. (s4 < v4)) call abort + if (.not. (s4 .le. v4)) call abort + if (.not. (s4 .lt. v4)) call abort + + end subroutine test + + subroutine test2(t4, u4, v4) + character(kind=4,len=*) :: t4, u4, v4 + + if (.not. (4_" \xACp " >= t4)) call abort + if (.not. (4_" \xACp " > t4)) call abort + if (.not. (4_" \xACp " .ge. t4)) call abort + if (.not. (4_" \xACp " .gt. t4)) call abort + if ( (4_" \xACp " == t4)) call abort + if (.not. (4_" \xACp " /= t4)) call abort + if ( (4_" \xACp " .eq. t4)) call abort + if (.not. (4_" \xACp " .ne. t4)) call abort + if ( (4_" \xACp " <= t4)) call abort + if ( (4_" \xACp " < t4)) call abort + if ( (4_" \xACp " .le. t4)) call abort + if ( (4_" \xACp " .lt. t4)) call abort + + if (.not. (4_" \xACp " >= u4)) call abort + if ( (4_" \xACp " > u4)) call abort + if (.not. (4_" \xACp " .ge. u4)) call abort + if ( (4_" \xACp " .gt. u4)) call abort + if (.not. (4_" \xACp " == u4)) call abort + if ( (4_" \xACp " /= u4)) call abort + if (.not. (4_" \xACp " .eq. u4)) call abort + if ( (4_" \xACp " .ne. u4)) call abort + if (.not. (4_" \xACp " <= u4)) call abort + if ( (4_" \xACp " < u4)) call abort + if (.not. (4_" \xACp " .le. u4)) call abort + if ( (4_" \xACp " .lt. u4)) call abort + + if ( (4_" \xACp " >= v4)) call abort + if ( (4_" \xACp " > v4)) call abort + if ( (4_" \xACp " .ge. v4)) call abort + if ( (4_" \xACp " .gt. v4)) call abort + if ( (4_" \xACp " == v4)) call abort + if (.not. (4_" \xACp " /= v4)) call abort + if ( (4_" \xACp " .eq. v4)) call abort + if (.not. (4_" \xACp " .ne. v4)) call abort + if (.not. (4_" \xACp " <= v4)) call abort + if (.not. (4_" \xACp " < v4)) call abort + if (.not. (4_" \xACp " .le. v4)) call abort + if (.not. (4_" \xACp " .lt. v4)) call abort + + end subroutine test2 + + subroutine test3(t4, u4, v4) + character(kind=4,len=*) :: t4, u4, v4 + + if (.not. (4_" \xACp " >= 4_" \x900000 ")) call abort + if (.not. (4_" \xACp " > 4_" \x900000 ")) call abort + if (.not. (4_" \xACp " .ge. 4_" \x900000 ")) call abort + if (.not. (4_" \xACp " .gt. 4_" \x900000 ")) call abort + if ( (4_" \xACp " == 4_" \x900000 ")) call abort + if (.not. (4_" \xACp " /= 4_" \x900000 ")) call abort + if ( (4_" \xACp " .eq. 4_" \x900000 ")) call abort + if (.not. (4_" \xACp " .ne. 4_" \x900000 ")) call abort + if ( (4_" \xACp " <= 4_" \x900000 ")) call abort + if ( (4_" \xACp " < 4_" \x900000 ")) call abort + if ( (4_" \xACp " .le. 4_" \x900000 ")) call abort + if ( (4_" \xACp " .lt. 4_" \x900000 ")) call abort + + if (.not. (4_" \xACp " >= 4_" \xACp ")) call abort + if ( (4_" \xACp " > 4_" \xACp ")) call abort + if (.not. (4_" \xACp " .ge. 4_" \xACp ")) call abort + if ( (4_" \xACp " .gt. 4_" \xACp ")) call abort + if (.not. (4_" \xACp " == 4_" \xACp ")) call abort + if ( (4_" \xACp " /= 4_" \xACp ")) call abort + if (.not. (4_" \xACp " .eq. 4_" \xACp ")) call abort + if ( (4_" \xACp " .ne. 4_" \xACp ")) call abort + if (.not. (4_" \xACp " <= 4_" \xACp ")) call abort + if ( (4_" \xACp " < 4_" \xACp ")) call abort + if (.not. (4_" \xACp " .le. 4_" \xACp ")) call abort + if ( (4_" \xACp " .lt. 4_" \xACp ")) call abort + + if ( (4_" \xACp " >= 4_"ddd")) call abort + if ( (4_" \xACp " > 4_"ddd")) call abort + if ( (4_" \xACp " .ge. 4_"ddd")) call abort + if ( (4_" \xACp " .gt. 4_"ddd")) call abort + if ( (4_" \xACp " == 4_"ddd")) call abort + if (.not. (4_" \xACp " /= 4_"ddd")) call abort + if ( (4_" \xACp " .eq. 4_"ddd")) call abort + if (.not. (4_" \xACp " .ne. 4_"ddd")) call abort + if (.not. (4_" \xACp " <= 4_"ddd")) call abort + if (.not. (4_" \xACp " < 4_"ddd")) call abort + if (.not. (4_" \xACp " .le. 4_"ddd")) call abort + if (.not. (4_" \xACp " .lt. 4_"ddd")) call abort + + end subroutine test3 + +end diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f90 new file mode 100644 index 00000000000..cb9804296dd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f90 @@ -0,0 +1,116 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=100000" } + + character(kind=1,len=20) :: s1, t1, u1, v1 + character(kind=4,len=20) :: s4, t4, u4, v4 + + call date_and_time(date=s1) + call date_and_time(time=s1) + call date_and_time(zone=s1) + call date_and_time(s1, t1, u1) + + call date_and_time(date=s4) ! { dg-error "must be of kind 1" } + call date_and_time(time=s4) ! { dg-error "must be of kind 1" } + call date_and_time(zone=s4) ! { dg-error "must be of kind 1" } + call date_and_time(s4, t4, u4) ! { dg-error "must be of kind 1" } + + call get_command(s1) + call get_command(s4) ! { dg-error "Type of argument" } + + call get_command_argument(1, s1) + call get_command_argument(1, s4) ! { dg-error "Type of argument" } + + call get_environment_variable("PATH", s1) + call get_environment_variable(s1) + call get_environment_variable(s1, t1) + call get_environment_variable(4_"PATH", s1) ! { dg-error "Type of argument" } + call get_environment_variable(s4) ! { dg-error "Type of argument" } + call get_environment_variable(s1, t4) ! { dg-error "Type of argument" } + call get_environment_variable(s4, t1) ! { dg-error "Type of argument" } + + print *, lge(s1,t1) + print *, lge(s1,"foo") + print *, lge("foo",t1) + print *, lge("bar","foo") + + print *, lge(s1,t4) ! { dg-error "must be of kind 1" } + print *, lge(s1,4_"foo") ! { dg-error "must be of kind 1" } + print *, lge("foo",t4) ! { dg-error "must be of kind 1" } + print *, lge("bar",4_"foo") ! { dg-error "must be of kind 1" } + + print *, lge(s4,t1) ! { dg-error "must be of kind 1" } + print *, lge(s4,"foo") ! { dg-error "must be of kind 1" } + print *, lge(4_"foo",t1) ! { dg-error "must be of kind 1" } + print *, lge(4_"bar","foo") ! { dg-error "must be of kind 1" } + + print *, lge(s4,t4) ! { dg-error "must be of kind 1" } + print *, lge(s4,4_"foo") ! { dg-error "must be of kind 1" } + print *, lge(4_"foo",t4) ! { dg-error "must be of kind 1" } + print *, lge(4_"bar",4_"foo") ! { dg-error "must be of kind 1" } + + print *, lgt(s1,t1) + print *, lgt(s1,"foo") + print *, lgt("foo",t1) + print *, lgt("bar","foo") + + print *, lgt(s1,t4) ! { dg-error "must be of kind 1" } + print *, lgt(s1,4_"foo") ! { dg-error "must be of kind 1" } + print *, lgt("foo",t4) ! { dg-error "must be of kind 1" } + print *, lgt("bar",4_"foo") ! { dg-error "must be of kind 1" } + + print *, lgt(s4,t1) ! { dg-error "must be of kind 1" } + print *, lgt(s4,"foo") ! { dg-error "must be of kind 1" } + print *, lgt(4_"foo",t1) ! { dg-error "must be of kind 1" } + print *, lgt(4_"bar","foo") ! { dg-error "must be of kind 1" } + + print *, lgt(s4,t4) ! { dg-error "must be of kind 1" } + print *, lgt(s4,4_"foo") ! { dg-error "must be of kind 1" } + print *, lgt(4_"foo",t4) ! { dg-error "must be of kind 1" } + print *, lgt(4_"bar",4_"foo") ! { dg-error "must be of kind 1" } + + print *, lle(s1,t1) + print *, lle(s1,"foo") + print *, lle("foo",t1) + print *, lle("bar","foo") + + print *, lle(s1,t4) ! { dg-error "must be of kind 1" } + print *, lle(s1,4_"foo") ! { dg-error "must be of kind 1" } + print *, lle("foo",t4) ! { dg-error "must be of kind 1" } + print *, lle("bar",4_"foo") ! { dg-error "must be of kind 1" } + + print *, lle(s4,t1) ! { dg-error "must be of kind 1" } + print *, lle(s4,"foo") ! { dg-error "must be of kind 1" } + print *, lle(4_"foo",t1) ! { dg-error "must be of kind 1" } + print *, lle(4_"bar","foo") ! { dg-error "must be of kind 1" } + + print *, lle(s4,t4) ! { dg-error "must be of kind 1" } + print *, lle(s4,4_"foo") ! { dg-error "must be of kind 1" } + print *, lle(4_"foo",t4) ! { dg-error "must be of kind 1" } + print *, lle(4_"bar",4_"foo") ! { dg-error "must be of kind 1" } + + print *, llt(s1,t1) + print *, llt(s1,"foo") + print *, llt("foo",t1) + print *, llt("bar","foo") + + print *, llt(s1,t4) ! { dg-error "must be of kind 1" } + print *, llt(s1,4_"foo") ! { dg-error "must be of kind 1" } + print *, llt("foo",t4) ! { dg-error "must be of kind 1" } + print *, llt("bar",4_"foo") ! { dg-error "must be of kind 1" } + + print *, llt(s4,t1) ! { dg-error "must be of kind 1" } + print *, llt(s4,"foo") ! { dg-error "must be of kind 1" } + print *, llt(4_"foo",t1) ! { dg-error "must be of kind 1" } + print *, llt(4_"bar","foo") ! { dg-error "must be of kind 1" } + + print *, llt(s4,t4) ! { dg-error "must be of kind 1" } + print *, llt(s4,4_"foo") ! { dg-error "must be of kind 1" } + print *, llt(4_"foo",t4) ! { dg-error "must be of kind 1" } + print *, llt(4_"bar",4_"foo") ! { dg-error "must be of kind 1" } + + print *, selected_char_kind("foo") + print *, selected_char_kind(4_"foo") ! { dg-error "must be of kind 1" } + print *, selected_char_kind(s1) + print *, selected_char_kind(s4) ! { dg-error "must be of kind 1" } + + end diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f90 new file mode 100644 index 00000000000..0a1d449b605 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f90 @@ -0,0 +1,129 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=1000" } + +program failme + + integer :: i, j, array(20) + integer(kind=4) :: i4 + integer(kind=8) :: i8 + character(kind=1,len=20) :: s1, t1 + character(kind=4,len=20) :: s4, t4 + + call ctime (i8, s1) + call ctime (i8, s4) ! { dg-error "must be of kind" } + + call chdir (s1) + call chdir (s1, i) + call chdir (s4) ! { dg-error "must be of kind" } + call chdir (s4, i) ! { dg-error "must be of kind" } + + call chmod (s1, t1) + call chmod (s1, t4) ! { dg-error "must be of kind" } + call chmod (s4, t1) ! { dg-error "must be of kind" } + call chmod (s4, t4) ! { dg-error "must be of kind" } + call chmod (s1, t1, i) + call chmod (s1, t4, i) ! { dg-error "must be of kind" } + call chmod (s4, t1, i) ! { dg-error "must be of kind" } + call chmod (s4, t4, i) ! { dg-error "must be of kind" } + + call fdate (s1) + call fdate (s4) ! { dg-error "must be of kind" } + + call gerror (s1) + call gerror (s4) ! { dg-error "must be of kind" } + + call getcwd (s1) + call getcwd (s1, i) + call getcwd (s4) ! { dg-error "must be of kind" } + call getcwd (s4, i) ! { dg-error "must be of kind" } + + call getenv (s1, t1) + call getenv (s1, t4) ! { dg-error "Type of argument" } + call getenv (s4, t1) ! { dg-error "Type of argument" } + call getenv (s4, t4) ! { dg-error "Type of argument" } + + call getarg (i, s1) + call getarg (i, s4) ! { dg-error "must be of kind" } + + call getlog (s1) + call getlog (s4) ! { dg-error "must be of kind" } + + call fgetc (j, s1) + call fgetc (j, s1, i) + call fgetc (j, s4) ! { dg-error "must be of kind" } + call fgetc (j, s4, i) ! { dg-error "must be of kind" } + + call fget (s1) + call fget (s1, i) + call fget (s4) ! { dg-error "must be of kind" } + call fget (s4, i) ! { dg-error "must be of kind" } + + call fputc (j, s1) + call fputc (j, s1, i) + call fputc (j, s4) ! { dg-error "must be of kind" } + call fputc (j, s4, i) ! { dg-error "must be of kind" } + + call fput (s1) + call fput (s1, i) + call fput (s4) ! { dg-error "must be of kind" } + call fput (s4, i) ! { dg-error "must be of kind" } + + call hostnm (s1) + call hostnm (s1, i) + call hostnm (s4) ! { dg-error "must be of kind" } + call hostnm (s4, i) ! { dg-error "must be of kind" } + + call link (s1, t1) + call link (s1, t4) ! { dg-error "must be of kind" } + call link (s4, t1) ! { dg-error "must be of kind" } + call link (s4, t4) ! { dg-error "must be of kind" } + call link (s1, t1, i) + call link (s1, t4, i) ! { dg-error "must be of kind" } + call link (s4, t1, i) ! { dg-error "must be of kind" } + call link (s4, t4, i) ! { dg-error "must be of kind" } + + call perror (s1) + call perror (s4) ! { dg-error "must be of kind" } + + call rename (s1, t1) + call rename (s1, t4) ! { dg-error "must be of kind" } + call rename (s4, t1) ! { dg-error "must be of kind" } + call rename (s4, t4) ! { dg-error "must be of kind" } + call rename (s1, t1, i) + call rename (s1, t4, i) ! { dg-error "must be of kind" } + call rename (s4, t1, i) ! { dg-error "must be of kind" } + call rename (s4, t4, i) ! { dg-error "must be of kind" } + + call lstat (s1, array) + call lstat (s1, array, i) + call lstat (s4, array) ! { dg-error "must be of kind" } + call lstat (s4, array, i) ! { dg-error "must be of kind" } + + call stat (s1, array) + call stat (s1, array, i) + call stat (s4, array) ! { dg-error "must be of kind" } + call stat (s4, array, i) ! { dg-error "must be of kind" } + + call symlnk (s1, t1) + call symlnk (s1, t4) ! { dg-error "must be of kind" } + call symlnk (s4, t1) ! { dg-error "must be of kind" } + call symlnk (s4, t4) ! { dg-error "must be of kind" } + call symlnk (s1, t1, i) + call symlnk (s1, t4, i) ! { dg-error "must be of kind" } + call symlnk (s4, t1, i) ! { dg-error "must be of kind" } + call symlnk (s4, t4, i) ! { dg-error "must be of kind" } + + call system (s1) + call system (s1, i) + call system (s4) ! { dg-error "Type of argument" } + call system (s4, i) ! { dg-error "Type of argument" } + + call ttynam (i, s1) + call ttynam (i, s4) ! { dg-error "must be of kind" } + + call unlink (s1) + call unlink (s1, i) + call unlink (s4) ! { dg-error "must be of kind" } + call unlink (s4, i) ! { dg-error "must be of kind" } + +end program failme diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f90 new file mode 100644 index 00000000000..7073b893bb3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f90 @@ -0,0 +1,69 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=1000" } + +program failme + + integer :: i, array(20) + integer(kind=4) :: i4 + integer(kind=8) :: i8 + character(kind=1,len=20) :: s1, t1 + character(kind=4,len=20) :: s4, t4 + + print *, access (s1, t1) + print *, access (s1, t4) ! { dg-error "must be of kind" } + print *, access (s4, t1) ! { dg-error "must be of kind" } + print *, access (s4, t4) ! { dg-error "must be of kind" } + + print *, chdir (s1) + print *, chdir (s4) ! { dg-error "must be of kind" } + + print *, chmod (s1, t1) + print *, chmod (s1, t4) ! { dg-error "must be of kind" } + print *, chmod (s4, t1) ! { dg-error "must be of kind" } + print *, chmod (s4, t4) ! { dg-error "must be of kind" } + + print *, fget (s1) + print *, fget (s4) ! { dg-error "must be of kind" } + + print *, fgetc (i, s1) + print *, fgetc (i, s4) ! { dg-error "must be of kind" } + + print *, fput (s1) + print *, fput (s4) ! { dg-error "must be of kind" } + + print *, fputc (i, s1) + print *, fputc (i, s4) ! { dg-error "must be of kind" } + + print *, getcwd (s1) + print *, getcwd (s4) ! { dg-error "Type of argument" } + + print *, hostnm (s1) + print *, hostnm (s4) ! { dg-error "must be of kind" } + + print *, link (s1, t1) + print *, link (s1, t4) ! { dg-error "must be of kind" } + print *, link (s4, t1) ! { dg-error "must be of kind" } + print *, link (s4, t4) ! { dg-error "must be of kind" } + + print *, lstat (s1, array) + print *, lstat (s4, array) ! { dg-error "must be of kind" } + print *, stat (s1, array) + print *, stat (s4, array) ! { dg-error "must be of kind" } + + print *, rename (s1, t1) + print *, rename (s1, t4) ! { dg-error "must be of kind" } + print *, rename (s4, t1) ! { dg-error "must be of kind" } + print *, rename (s4, t4) ! { dg-error "must be of kind" } + + print *, symlnk (s1, t1) + print *, symlnk (s1, t4) ! { dg-error "must be of kind" } + print *, symlnk (s4, t1) ! { dg-error "must be of kind" } + print *, symlnk (s4, t4) ! { dg-error "must be of kind" } + + print *, system (s1) + print *, system (s4) ! { dg-error "Type of argument" } + + print *, unlink (s1) + print *, unlink (s4) ! { dg-error "must be of kind" } + +end program failme diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_4.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_4.f90 new file mode 100644 index 00000000000..c9f8e8cd26c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_4.f90 @@ -0,0 +1,121 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + character(kind=1,len=20) :: s1 + character(kind=4,len=20) :: s4 + + call test_adjust1 (" foo bar ", 4_" foo bar ") + s1 = " foo bar " ; s4 = 4_" foo bar " + call test_adjust2 (s1, s4) + + call test_adjust1 (" foo bar \xFF", 4_" foo bar \xFF") + s1 = " foo bar \xFF" ; s4 = 4_" foo bar \xFF" + call test_adjust2 (s1, s4) + + call test_adjust1 ("\0 foo bar \xFF", 4_"\0 foo bar \xFF") + s1 = "\0 foo bar \xFF" ; s4 = 4_"\0 foo bar \xFF" + call test_adjust2 (s1, s4) + + s4 = "\0 foo bar \xFF" + if (adjustl (s4) /= adjustl (4_"\0 foo bar \xFF ")) call abort + if (adjustr (s4) /= adjustr (4_"\0 foo bar \xFF ")) call abort + + s4 = " \0 foo bar \xFF" + if (adjustl (s4) /= adjustl (4_" \0 foo bar \xFF ")) call abort + if (adjustr (s4) /= adjustr (4_" \0 foo bar \xFF ")) call abort + + s4 = 4_" \U12345678\xeD bar \ufd30" + if (adjustl (s4) /= & + adjustl (4_" \U12345678\xeD bar \ufd30 ")) call abort + if (adjustr (s4) /= & + adjustr (4_" \U12345678\xeD bar \ufd30 ")) call abort + +contains + + subroutine test_adjust1 (s1, s4) + + character(kind=1,len=*) :: s1 + character(kind=4,len=*) :: s4 + + character(kind=1,len=len(s4)) :: t1 + character(kind=4,len=len(s1)) :: t4 + + if (len(s1) /= len(s4)) call abort + if (len(t1) /= len(t4)) call abort + + if (len_trim(s1) /= len_trim (s4)) call abort + + t1 = adjustl (s4) + t4 = adjustl (s1) + if (t1 /= adjustl (s1)) call abort + if (t4 /= adjustl (s4)) call abort + if (len_trim (t1) /= len_trim (t4)) call abort + if (len_trim (adjustl (s1)) /= len_trim (t4)) call abort + if (len_trim (adjustl (s4)) /= len_trim (t1)) call abort + + if (len_trim (t1) /= len (trim (t1))) call abort + if (len_trim (s1) /= len (trim (s1))) call abort + if (len_trim (t4) /= len (trim (t4))) call abort + if (len_trim (s4) /= len (trim (s4))) call abort + + t1 = adjustr (s4) + t4 = adjustr (s1) + if (t1 /= adjustr (s1)) call abort + if (t4 /= adjustr (s4)) call abort + if (len_trim (t1) /= len_trim (t4)) call abort + if (len_trim (adjustr (s1)) /= len_trim (t4)) call abort + if (len_trim (adjustr (s4)) /= len_trim (t1)) call abort + if (len (t1) /= len_trim (t1)) call abort + if (len (t4) /= len_trim (t4)) call abort + + if (len_trim (t1) /= len (trim (t1))) call abort + if (len_trim (s1) /= len (trim (s1))) call abort + if (len_trim (t4) /= len (trim (t4))) call abort + if (len_trim (s4) /= len (trim (s4))) call abort + + end subroutine test_adjust1 + + subroutine test_adjust2 (s1, s4) + + character(kind=1,len=20) :: s1 + character(kind=4,len=20) :: s4 + + character(kind=1,len=len(s4)) :: t1 + character(kind=4,len=len(s1)) :: t4 + + if (len(s1) /= len(s4)) call abort + if (len(t1) /= len(t4)) call abort + + if (len_trim(s1) /= len_trim (s4)) call abort + + t1 = adjustl (s4) + t4 = adjustl (s1) + if (t1 /= adjustl (s1)) call abort + if (t4 /= adjustl (s4)) call abort + if (len_trim (t1) /= len_trim (t4)) call abort + if (len_trim (adjustl (s1)) /= len_trim (t4)) call abort + if (len_trim (adjustl (s4)) /= len_trim (t1)) call abort + + if (len_trim (t1) /= len (trim (t1))) call abort + if (len_trim (s1) /= len (trim (s1))) call abort + if (len_trim (t4) /= len (trim (t4))) call abort + if (len_trim (s4) /= len (trim (s4))) call abort + + t1 = adjustr (s4) + t4 = adjustr (s1) + if (t1 /= adjustr (s1)) call abort + if (t4 /= adjustr (s4)) call abort + if (len_trim (t1) /= len_trim (t4)) call abort + if (len_trim (adjustr (s1)) /= len_trim (t4)) call abort + if (len_trim (adjustr (s4)) /= len_trim (t1)) call abort + if (len (t1) /= len_trim (t1)) call abort + if (len (t4) /= len_trim (t4)) call abort + + if (len_trim (t1) /= len (trim (t1))) call abort + if (len_trim (s1) /= len (trim (s1))) call abort + if (len_trim (t4) /= len (trim (t4))) call abort + if (len_trim (s4) /= len (trim (s4))) call abort + + end subroutine test_adjust2 + +end diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_5.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_5.f90 new file mode 100644 index 00000000000..5c989cc25b3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_5.f90 @@ -0,0 +1,123 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + implicit none + integer :: i, j + character(kind=4,len=5), dimension(3,3), parameter :: & + p = reshape([4_" \xFF ", 4_"\0 ", 4_" foo ", & + 4_"\u1230\uD67Bde\U31DC8B30", 4_" ", 4_"fa fe", & + 4_" ", 4_"foo ", 4_"nul\0l"], [3,3]) + + character(kind=4,len=5), dimension(3,3) :: m1 + character(kind=4,len=5), allocatable, dimension(:,:) :: m2 + + if (kind (p) /= 4) call abort + if (kind (m1) /= 4) call abort + if (kind (m2) /= 4) call abort + + m1 = reshape (p, [3,3]) + + allocate (m2(3,3)) + m2(:,:) = reshape (m1, [3,3]) + + if (any (m1 /= p)) call abort + if (any (m2 /= p)) call abort + + if (size (p) /= 9) call abort + if (size (m1) /= 9) call abort + if (size (m2) /= 9) call abort + if (size (p,1) /= 3) call abort + if (size (m1,1) /= 3) call abort + if (size (m2,1) /= 3) call abort + if (size (p,2) /= 3) call abort + if (size (m1,2) /= 3) call abort + if (size (m2,2) /= 3) call abort + + call check_shape (p, (/3,3/), 5) + call check_shape (p, shape(p), 5) + call check_shape (m1, (/3,3/), 5) + call check_shape (m1, shape(m1), 5) + call check_shape (m1, (/3,3/), 5) + call check_shape (m1, shape(m1), 5) + + deallocate (m2) + + + allocate (m2(3,4)) + m2 = reshape (m1, [3,4], p) + if (any (m2(1:3,1:3) /= p)) call abort + if (any (m2(1:3,4) /= m1(1:3,1))) call abort + call check_shape (m2, (/3,4/), 5) + deallocate (m2) + + allocate (m2(3,3)) + do i = 1, 3 + do j = 1, 3 + m2(i,j) = m1(i,j) + end do + end do + + m2 = transpose(m2) + if (any(transpose(p) /= m2)) call abort + if (any(transpose(m1) /= m2)) call abort + if (any(transpose(m2) /= p)) call abort + if (any(transpose(m2) /= m1)) call abort + + m1 = transpose(p) + if (any(transpose(p) /= m2)) call abort + if (any(m1 /= m2)) call abort + if (any(transpose(m2) /= p)) call abort + if (any(transpose(m2) /= transpose(m1))) call abort + deallocate (m2) + + ! Tests below should be uncommented when PR36257 is fixed. + ! + !allocate (m2(3,3)) + !m2 = p + !m1 = m2 + !if (any (spread ( p, 1, 2) /= spread (m1, 1, 2))) call abort + !if (any (spread ( p, 1, 2) /= spread (m2, 1, 2))) call abort + !if (any (spread (m1, 1, 2) /= spread (m2, 1, 2))) call abort + !deallocate (m2) + + allocate (m2(3,3)) + m2 = p + m1 = m2 + if (any (pack (p, p /= 4_"") /= [4_" \xFF ", 4_"\0 ", 4_" foo ", & + 4_"\u1230\uD67Bde\U31DC8B30", 4_"fa fe", & + 4_"foo ", 4_"nul\0l"])) call abort + if (any (len_trim (pack (p, p /= 4_"")) /= [2,1,4,5,5,3,5])) call abort + if (any (pack (m1, m1 /= 4_"") /= [4_" \xFF ", 4_"\0 ", 4_" foo ", & + 4_"\u1230\uD67Bde\U31DC8B30", 4_"fa fe", & + 4_"foo ", 4_"nul\0l"])) call abort + if (any (len_trim (pack (m1, m1 /= 4_"")) /= [2,1,4,5,5,3,5])) call abort + if (any (pack (m2, m2 /= 4_"") /= [4_" \xFF ", 4_"\0 ", 4_" foo ", & + 4_"\u1230\uD67Bde\U31DC8B30", 4_"fa fe", & + 4_"foo ", 4_"nul\0l"])) call abort + if (any (len_trim (pack (m2, m2 /= 4_"")) /= [2,1,4,5,5,3,5])) call abort + deallocate (m2) + + allocate (m2(1,7)) + m2 = reshape ([4_" \xFF ", 4_"\0 ", 4_" foo ", & + 4_"\u1230\uD67Bde\U31DC8B30", 4_"fa fe", & + 4_"foo ", 4_"nul\0l"], [1,7]) + m1 = p + if (any (unpack(m2(1,:), p /= 4_"", 4_" ") /= p)) call abort + if (any (unpack(m2(1,:), m1 /= 4_"", 4_" ") /= m1)) call abort + deallocate (m2) + +contains + + subroutine check_shape (array, res, l) + character(kind=4,len=*), dimension(:,:) :: array + integer, dimension(:) :: res + integer :: l + + if (kind (array) /= 4) call abort + if (len(array) /= l) call abort + + if (size (res) /= size (shape (array))) call abort + if (any (shape (array) /= res)) call abort + end subroutine check_shape + +end diff --git a/gcc/testsuite/gfortran.dg/widechar_select_1.f90 b/gcc/testsuite/gfortran.dg/widechar_select_1.f90 new file mode 100644 index 00000000000..64315af0b71 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_select_1.f90 @@ -0,0 +1,55 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + call testme(test("foo"), test4(4_"foo"), 1) + call testme(test(""), test4(4_""), 1) + call testme(test("gee"), test4(4_"gee"), 4) + call testme(test("bar"), test4(4_"bar"), 1) + call testme(test("magi"), test4(4_"magi"), 4) + call testme(test("magic"), test4(4_"magic"), 2) + call testme(test("magic "), test4(4_"magic "), 2) + call testme(test("magica"), test4(4_"magica"), 4) + call testme(test("freeze"), test4(4_"freeze"), 3) + call testme(test("freeze "), test4(4_"freeze "), 3) + call testme(test("frugal"), test4(4_"frugal"), 3) + call testme(test("frugal "), test4(4_"frugal "), 3) + call testme(test("frugal \x01"), test4(4_"frugal \x01"), 3) + call testme(test("frugal \xFF"), test4(4_"frugal \xFF"), 4) + +contains + integer function test(s) + character(len=*) :: s + + select case (s) + case ("":"foo") + test = 1 + case ("magic") + test = 2 + case ("freeze":"frugal") + test = 3 + case default + test = 4 + end select + end function test + + integer function test4(s) + character(kind=4,len=*) :: s + + select case (s) + case (4_"":4_"foo") + test4 = 1 + case (4_"magic") + test4 = 2 + case (4_"freeze":4_"frugal") + test4 = 3 + case default + test4 = 4 + end select + end function test4 + + subroutine testme(x,y,z) + integer :: x, y, z + if (x /= y) call abort + if (x /= z) call abort + end subroutine testme +end diff --git a/gcc/testsuite/gfortran.dg/widechar_select_2.f90 b/gcc/testsuite/gfortran.dg/widechar_select_2.f90 new file mode 100644 index 00000000000..2eea9aed72d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_select_2.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } + + character(kind=1,len=20) :: s1 + character(kind=4,len=20) :: s4 + + select case (s1) + case ("":4_"foo") ! { dg-error "must be of kind" } + test = 1 + case (4_"gee") ! { dg-error "must be of kind" } + test = 1 + case ("bar") + test = 1 + case default + test = 4 + end select + + select case (s4) + case ("":4_"foo") ! { dg-error "must be of kind" } + test = 1 + case (4_"gee") + test = 1 + case ("bar") ! { dg-error "must be of kind" } + test = 1 + case default + test = 4 + end select + + select case (s4) + case (4_"foo":4_"bar") + test = 1 + case (4_"foo":4_"gee") ! { dg-error "overlaps with CASE label" } + test = 1 + case (4_"foo") ! { dg-error "overlaps with CASE label" } + test = 1 + end select + +end diff --git a/gcc/testsuite/gnat.dg/bit_packed_array3.adb b/gcc/testsuite/gnat.dg/bit_packed_array3.adb new file mode 100644 index 00000000000..0b121efdc5f --- /dev/null +++ b/gcc/testsuite/gnat.dg/bit_packed_array3.adb @@ -0,0 +1,40 @@ +-- { dg-do run } +-- { dg-options "-O2 -gnatp" } + +procedure Bit_Packed_Array3 is + + type Bitmap_T is array (1 .. 10) of Boolean; + pragma Pack (Bitmap_T); + + type Maps_T is record + M1 : Bitmap_T; + end record; + pragma Pack (Maps_T); + for Maps_T'Size use 10; + pragma Suppress_Initialization (Maps_T); + + Tmap : constant Bitmap_T := (others => True); + Fmap : constant Bitmap_T := (others => False); + Amap : constant Bitmap_T := + (1 => False, 2 => True, 3 => False, 4 => True, 5 => False, + 6 => True, 7 => False, 8 => True, 9 => False, 10 => True); + + function Some_Maps return Maps_T is + Value : Maps_T := (M1 => Amap); + begin + return Value; + end; + pragma Inline (Some_Maps); + + Maps : Maps_T; +begin + Maps := Some_Maps; + + for I in Maps.M1'Range loop + if (I mod 2 = 0 and then not Maps.M1 (I)) + or else (I mod 2 /= 0 and then Maps.M1 (I)) + then + raise Program_Error; + end if; + end loop; +end; diff --git a/gcc/testsuite/gnat.dg/check_displace_generation.adb b/gcc/testsuite/gnat.dg/check_displace_generation.adb new file mode 100644 index 00000000000..2ae2ed0be5b --- /dev/null +++ b/gcc/testsuite/gnat.dg/check_displace_generation.adb @@ -0,0 +1,50 @@ +-- { dg-do run } +procedure Check_Displace_Generation is + + package Stuff is + + type Base_1 is interface; + function F_1 (X : Base_1) return Integer is abstract; + + type Base_2 is interface; + function F_2 (X : Base_2) return Integer is abstract; + + type Concrete is new Base_1 and Base_2 with null record; + function F_1 (X : Concrete) return Integer; + function F_2 (X : Concrete) return Integer; + + end Stuff; + + package body Stuff is + + function F_1 (X : Concrete) return Integer is + begin + return 1; + end F_1; + + function F_2 (X : Concrete) return Integer is + begin + return 2; + end F_2; + + end Stuff; + + use Stuff; + + function Make_Concrete return Concrete is + C : Concrete; + begin + return C; + end Make_Concrete; + + B_1 : Base_1'Class := Make_Concrete; + B_2 : Base_2'Class := Make_Concrete; + +begin + if B_1.F_1 /= 1 then + raise Program_Error with "bad B_1.F_1 call"; + end if; + if B_2.F_2 /= 2 then + raise Program_Error with "bad B_2.F_2 call"; + end if; +end Check_Displace_Generation; diff --git a/gcc/testsuite/gnat.dg/gen_disp.adb b/gcc/testsuite/gnat.dg/gen_disp.adb new file mode 100644 index 00000000000..736b9cdc00f --- /dev/null +++ b/gcc/testsuite/gnat.dg/gen_disp.adb @@ -0,0 +1,45 @@ +-- { dg-do compile } +with Ada.Containers.Ordered_Maps; +with Ada.Tags.Generic_Dispatching_Constructor; +package body gen_disp is + + use type Ada.Tags.Tag; + + function "<" (L, R : in Ada.Tags.Tag) return Boolean is + begin + return Ada.Tags.External_Tag (L) < Ada.Tags.External_Tag (R); + end "<"; + + package Char_To_Tag_Map is new Ada.Containers.Ordered_Maps ( + Key_Type => Character, + Element_Type => Ada.Tags.Tag, + "<" => "<", + "=" => Ada.Tags. "="); + + package Tag_To_Char_Map is new Ada.Containers.Ordered_Maps ( + Key_Type => Ada.Tags.Tag, + Element_Type => Character, + "<" => "<", + "=" => "="); + + use type Char_To_Tag_Map.Cursor; + use type Tag_To_Char_Map.Cursor; + + Char_To_Tag : Char_To_Tag_Map.Map; + Tag_To_Char : Tag_To_Char_Map.Map; + + function Get_Object is new + Ada.Tags.Generic_Dispatching_Constructor + (Root_Type, Ada.Streams.Root_Stream_Type'Class, Root_Type'Input); + + function Root_Type_Class_Input + (S : not null access Ada.Streams.Root_Stream_Type'Class) + return Root_Type'Class + is + External_Tag : constant Character := Character'Input (S); + C : constant Char_To_Tag_Map.Cursor := Char_To_Tag.Find (External_Tag); + begin + + return Get_Object (Char_To_Tag_Map.Element (C), S); + end Root_Type_Class_Input; +end gen_disp; diff --git a/gcc/testsuite/gnat.dg/gen_disp.ads b/gcc/testsuite/gnat.dg/gen_disp.ads new file mode 100644 index 00000000000..722c0c1b1a1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/gen_disp.ads @@ -0,0 +1,10 @@ +with Ada.Streams, Ada.Tags; +package gen_disp is + type Root_Type is tagged null record; + + function Root_Type_Class_Input + (S : not null access Ada.Streams.Root_Stream_Type'Class) + return Root_Type'Class; + + for Root_Type'Class'Input use Root_Type_Class_Input; +end gen_disp; diff --git a/gcc/testsuite/gnat.dg/loop_optimization2.adb b/gcc/testsuite/gnat.dg/loop_optimization2.adb new file mode 100644 index 00000000000..f78cd989ab7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization2.adb @@ -0,0 +1,41 @@ +-- { dg-do compile } +-- { dg-options "-gnata -O2 -fno-inline" } + +with Ada.Unchecked_Conversion; + +package body Loop_Optimization2 is + + function To_Addr_Ptr is + new Ada.Unchecked_Conversion (System.Address, Addr_Ptr); + + function To_Address is + new Ada.Unchecked_Conversion (Tag, System.Address); + + function To_Type_Specific_Data_Ptr is + new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); + + function Interface_Ancestor_Tags (T : Tag) return Tag_Array is + TSD_Ptr : constant Addr_Ptr := To_Addr_Ptr (To_Address (T)); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table; + begin + if Iface_Table = null then + declare + Table : Tag_Array (1 .. 0); + begin + return Table; + end; + else + declare + Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces); + begin + for J in 1 .. Iface_Table.Nb_Ifaces loop + Table (J) := Iface_Table.Ifaces_Table (J).Iface_Tag; + end loop; + return Table; + end; + end if; + end Interface_Ancestor_Tags; + +end Loop_Optimization2; diff --git a/gcc/testsuite/gnat.dg/loop_optimization2.ads b/gcc/testsuite/gnat.dg/loop_optimization2.ads new file mode 100644 index 00000000000..39d83236b8d --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization2.ads @@ -0,0 +1,41 @@ +with System; + +package Loop_Optimization2 is + + type Prim_Ptr is access procedure; + type Address_Array is array (Positive range <>) of Prim_Ptr; + + subtype Dispatch_Table is Address_Array (1 .. 1); + + type Tag is access all Dispatch_Table; + + type Tag_Array is array (Positive range <>) of Tag; + + function Interface_Ancestor_Tags (T : Tag) return Tag_Array; + + type Interface_Data_Element is record + Iface_Tag : Tag; + end record; + + type Interfaces_Array is array (Natural range <>) of Interface_Data_Element; + + type Interface_Data (Nb_Ifaces : Positive) is record + Ifaces_Table : Interfaces_Array (1 .. Nb_Ifaces); + end record; + + type Interface_Data_Ptr is access all Interface_Data; + + type Type_Specific_Data (Idepth : Natural) is record + Interfaces_Table : Interface_Data_Ptr; + end record; + + type Type_Specific_Data_Ptr is access all Type_Specific_Data; + pragma No_Strict_Aliasing (Type_Specific_Data_Ptr); + + subtype Predef_Prims_Table is Address_Array (1 .. 16); + type Predef_Prims_Table_Ptr is access Predef_Prims_Table; + + type Addr_Ptr is access System.Address; + pragma No_Strict_Aliasing (Addr_Ptr); + +end Loop_Optimization2; diff --git a/gcc/testsuite/gnat.dg/modular1.adb b/gcc/testsuite/gnat.dg/modular1.adb new file mode 100644 index 00000000000..b9fcde95fd6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/modular1.adb @@ -0,0 +1,15 @@ +-- { dg-do run } + +with Ada.Text_IO; +procedure Modular1 is + type T1 is mod 9; + package T1_IO is new Ada.Text_IO.Modular_IO(T1); + X: T1 := 8; + J1: constant := 5; +begin for J2 in 5..5 loop + pragma Assert(X*(2**J1) = X*(2**J2)); + if X*(2**J1) /= X*(2**J2) then + raise Program_Error; + end if; + end loop; +end Modular1; diff --git a/gcc/testsuite/gnat.dg/specs/empty_variants.ads b/gcc/testsuite/gnat.dg/specs/empty_variants.ads new file mode 100644 index 00000000000..079b64ac812 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/empty_variants.ads @@ -0,0 +1,32 @@ +-- { dg-do compile } +-- { dg-options "-gnatdF" } + +package Empty_Variants is + + type Rec (D : Integer := 1) is record + case D is + when 1 => + I : Integer; + when 2 .. 5 => + J : Integer; + K : Integer; + when 6 => + null; + when 7 .. 8 => + null; + when others => + L : Integer; + M : Integer; + N : Integer; + end case; + end record; + + R : Rec; + + I : Integer := R.I; + J : Integer := R.J; + K : Integer := R.K; + L : Integer := R.L; + M : Integer := R.L; + +end Empty_Variants; diff --git a/gcc/testsuite/gnat.dg/specs/tag2.ads b/gcc/testsuite/gnat.dg/specs/tag2.ads index 8e09f25a059..67b44978dbf 100644 --- a/gcc/testsuite/gnat.dg/specs/tag2.ads +++ b/gcc/testsuite/gnat.dg/specs/tag2.ads @@ -10,7 +10,7 @@ package tag2 is type T6 is tagged; protected type T1 is end T1; -- { dg-error "must be a tagged type" } task type T2; -- { dg-error "must be a tagged type" } - type T3 is null record; -- { dg-error "must be tagged" } + type T3 is null record; -- { dg-error "must be a tagged type" } task type T4 is new I with end; protected type T5 is new I with end; type T6 is tagged null record; diff --git a/gcc/testsuite/gnat.dg/test_iface_aggr.adb b/gcc/testsuite/gnat.dg/test_iface_aggr.adb new file mode 100644 index 00000000000..85c1ceb0fbc --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_iface_aggr.adb @@ -0,0 +1,40 @@ +-- { dg-do run } + +with Ada.Text_IO, Ada.Tags; +procedure Test_Iface_Aggr is + package Pkg is + type Iface is interface; + function Constructor (S: Iface) return Iface'Class is abstract; + procedure Do_Test (It : Iface'class); + type Root is abstract tagged record + Comp_1 : Natural := 0; + end record; + type DT_1 is new Root and Iface with record + Comp_2, Comp_3 : Natural := 0; + end record; + function Constructor (S: DT_1) return Iface'Class; + type DT_2 is new DT_1 with null record; -- Test + function Constructor (S: DT_2) return Iface'Class; + end; + package body Pkg is + procedure Do_Test (It: in Iface'Class) is + Obj : Iface'Class := Constructor (It); + S : String := Ada.Tags.External_Tag (Obj'Tag); + begin + null; + end; + function Constructor (S: DT_1) return Iface'Class is + begin + return Iface'Class(DT_1'(others => <>)); + end; + function Constructor (S: DT_2) return Iface'Class is + Result : DT_2; + begin + return Iface'Class(DT_2'(others => <>)); -- Test + end; + end; + use Pkg; + Obj: DT_2; +begin + Do_Test (Obj); +end; diff --git a/gcc/testsuite/gnat.dg/testint.adb b/gcc/testsuite/gnat.dg/testint.adb new file mode 100644 index 00000000000..a5faf4a57ff --- /dev/null +++ b/gcc/testsuite/gnat.dg/testint.adb @@ -0,0 +1,13 @@ +-- { dg-do run } +-- { dg-options "-gnato" } + +with Text_IO; use Text_IO; +procedure testint is + function m1 (a, b : short_integer) return integer is + begin + return integer (a + b); + end m1; + f : integer; +begin + f := m1 (short_integer'Last, short_integer'Last); +end testint; diff --git a/gcc/testsuite/gnat.dg/warn4.adb b/gcc/testsuite/gnat.dg/warn4.adb new file mode 100644 index 00000000000..94147c1e6f5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/warn4.adb @@ -0,0 +1,30 @@ +-- { dg-do compile } +-- { dg-options "-O2" } + +with Unchecked_Conversion; + +procedure Warn4 is + + type POSIX_Character is new Standard.Character; + type POSIX_String is array (Positive range <>) of aliased POSIX_Character; + + type String_Ptr is access all String; + type POSIX_String_Ptr is access all POSIX_String; + + function sptr_to_psptr is new Unchecked_Conversion -- { dg-warning "aliasing problem" } + (String_Ptr, POSIX_String_Ptr); -- { dg-warning "" "" { target *-*-* } 14 } + + function To_POSIX_String (Str : String) return POSIX_String; + function To_POSIX_String (Str : String) + return POSIX_String is + begin + return sptr_to_psptr (Str'Unrestricted_Access).all; + end To_POSIX_String; + + A : Boolean; + S : String := "ABCD/abcd"; + P : Posix_String := "ABCD/abcd"; + +begin + A := To_POSIX_String (S) = P; +end; diff --git a/gcc/testsuite/lib/dg-pch.exp b/gcc/testsuite/lib/dg-pch.exp index d74739e6836..60ec5046de1 100644 --- a/gcc/testsuite/lib/dg-pch.exp +++ b/gcc/testsuite/lib/dg-pch.exp @@ -44,36 +44,45 @@ proc dg-pch { subdir test options suffix } { # For the rest, the default is to compile to .s. set dg-do-what-default compile + set have_errs [llength [grep $test "{\[ \t\]\+dg-error\[ \t\]\+.*\[ \t\]\+}"]] + if { [ file_on_host exists "$bname$suffix.gch" ] } { # Ensure that the PCH file is used, not the original header. file_on_host delete "$bname$suffix" - dg-test -keep-output $test $flags "-I." + dg-test -keep-output $test "$flags -I." "" file_on_host delete "$bname$suffix.gch" - if { [ file_on_host exists "$bname.s" ] } { - remote_upload host "$bname.s" "$bname.s-gch" - remote_download host "$bname.s-gch" - gcc_copy_files "[file rootname $test]${suffix}s" "$bname$suffix" - dg-test -keep-output $test $flags "-I." - remote_upload host "$bname.s" - set tmp [ diff "$bname.s" "$bname.s-gch" ] - if { $tmp == 0 } { - untested "$nshort $flags assembly comparison" - } elseif { $tmp == 1 } { - pass "$nshort $flags assembly comparison" + if { !$have_errs } { + if { [ file_on_host exists "$bname.s" ] } { + remote_upload host "$bname.s" "$bname.s-gch" + remote_download host "$bname.s-gch" + gcc_copy_files "[file rootname $test]${suffix}s" "$bname$suffix" + dg-test -keep-output $test $flags "-I." + remote_upload host "$bname.s" + set tmp [ diff "$bname.s" "$bname.s-gch" ] + if { $tmp == 0 } { + verbose -log "assembly file '$bname.s', '$bname.s-gch' comparison error" + fail "$nshort $flags assembly comparison" + } elseif { $tmp == 1 } { + pass "$nshort $flags assembly comparison" + } else { + fail "$nshort $flags assembly comparison" + } + file_on_host delete "$bname$suffix" + file_on_host delete "$bname.s" + file_on_host delete "$bname.s-gch" } else { - fail "$nshort $flags assembly comparison" + verbose -log "assembly file '$bname.s' missing" + fail "$nshort $flags assembly comparison" } - file_on_host delete "$bname$suffix" - file_on_host delete "$bname.s" - file_on_host delete "$bname.s-gch" } else { - untested "$nshort $flags assembly comparison" + verbose -log "assembly file '$bname$suffix.gch' missing" + fail "$nshort $flags" + if { !$have_errs } { + verbose -log "assembly file '$bname.s' missing" 1 + fail "$nshort $flags assembly comparison" + } } - - } else { - untested "$nshort $flags" - untested "$nshort $flags assembly comparison" } } } diff --git a/gcc/testsuite/lib/gcc-dg.exp b/gcc/testsuite/lib/gcc-dg.exp index ad5fc26c73f..9a3f12b5131 100644 --- a/gcc/testsuite/lib/gcc-dg.exp +++ b/gcc/testsuite/lib/gcc-dg.exp @@ -441,21 +441,32 @@ proc cleanup-dump { suffix } { # # Currently this is only .i, .ii and .s files, but more can be added # if there are tests generating them. -proc cleanup-saved-temps { } { +# ARGS is a list of suffixes to NOT delete. +proc cleanup-saved-temps { args } { global additional_sources + set suffixes {} + + # add the to-be-kept suffixes + foreach suffix {".ii" ".i" ".s"} { + if {[lsearch $args $suffix] < 0} { + lappend suffixes $suffix + } + } # This assumes that we are two frames down from dg-test or some other proc # that stores the filename of the testcase in a local variable "name". # A cleaner solution would require a new DejaGnu release. upvar 2 name testcase - remove-build-file "[file rootname [file tail $testcase]].ii" - remove-build-file "[file rootname [file tail $testcase]].i" + foreach suffix $suffixes { + remove-build-file "[file rootname [file tail $testcase]]$suffix" + } # Clean up saved temp files for additional source files. if [info exists additional_sources] { foreach srcfile $additional_sources { - remove-build-file "[file rootname [file tail $srcfile]].ii" - remove-build-file "[file rootname [file tail $srcfile]].i" + foreach suffix $suffixes { + remove-build-file "[file rootname [file tail $srcfile]]$suffix" + } } } } diff --git a/gcc/testsuite/lib/scandump.exp b/gcc/testsuite/lib/scandump.exp index 9dde9004837..373052b4566 100644 --- a/gcc/testsuite/lib/scandump.exp +++ b/gcc/testsuite/lib/scandump.exp @@ -49,18 +49,23 @@ proc scan-dump { args } { # A cleaner solution would require a new DejaGnu release. upvar 3 name testcase + set suf [dump-suffix [lindex $args 2]] + set testname "$testcase scan-[lindex $args 0]-dump $suf \"[lindex $args 1]\"" set src [file tail [lindex $testcase 0]] - set output_file "[glob $src.[lindex $args 2]]" + set output_file "[glob -nocomplain $src.[lindex $args 2]]" + if { $output_file == "" } { + fail "$testname: dump file does not exist" + return + } set fd [open $output_file r] set text [read $fd] close $fd - set suf [dump-suffix [lindex $args 2]] if [regexp -- [lindex $args 1] $text] { - pass "$testcase scan-[lindex $args 0]-dump $suf \"[lindex $args 1]\"" + pass "$testname" } else { - fail "$testcase scan-[lindex $args 0]-dump $suf \"[lindex $args 1]\"" + fail "$testname" } } @@ -86,18 +91,23 @@ proc scan-dump-times { args } { # A cleaner solution would require a new DejaGnu release. upvar 3 name testcase + set suf [dump-suffix [lindex $args 3]] + set testname "$testcase scan-[lindex $args 0]-dump-times $suf \"[lindex $args 1]\" [lindex $args 2]" set src [file tail [lindex $testcase 0]] - set output_file "[glob $src.[lindex $args 3]]" + set output_file "[glob -nocomplain $src.[lindex $args 3]]" + if { $output_file == "" } { + fail "$testname: dump file does not exist" + return + } set fd [open $output_file r] set text [read $fd] close $fd - set suf [dump-suffix [lindex $args 3]] if { [llength [regexp -inline -all -- [lindex $args 1] $text]] == [lindex $args 2]} { - pass "$testcase scan-[lindex $args 0]-dump-times $suf \"[lindex $args 1]\" [lindex $args 2]" + pass "$testname" } else { - fail "$testcase scan-[lindex $args 0]-dump-times $suf \"[lindex $args 1]\" [lindex $args 2]" + fail "$testname" } } @@ -122,18 +132,24 @@ proc scan-dump-not { args } { # it still stores the filename of the testcase in a local variable "name". # A cleaner solution would require a new DejaGnu release. upvar 3 name testcase + + set suf [dump-suffix [lindex $args 2]] + set testname "$testcase scan-[lindex $args 0]-dump-not $suf \"[lindex $args 1]\"" set src [file tail [lindex $testcase 0]] - set output_file "[glob $src.[lindex $args 2]]" + set output_file "[glob -nocomplain $src.[lindex $args 2]]" + if { $output_file == "" } { + fail "$testname: dump file does not exist" + return + } set fd [open $output_file r] set text [read $fd] close $fd - set suf [dump-suffix [lindex $args 2]] if ![regexp -- [lindex $args 1] $text] { - pass "$testcase scan-[lindex $args 0]-dump-not $suf \"[lindex $args 1]\"" + pass "$testname" } else { - fail "$testcase scan-[lindex $args 0]-dump-not $suf \"[lindex $args 1]\"" + fail "$testname" } } @@ -168,18 +184,23 @@ proc scan-dump-dem { args } { } upvar 3 name testcase + set suf [dump-suffix [lindex $args 2]] + set testname "$testcase scan-[lindex $args 0]-dump-dem $suf \"[lindex $args 1]\"" set src [file tail [lindex $testcase 0]] - set output_file "[glob $src.[lindex $args 2]]" + set output_file "[glob -nocomplain $src.[lindex $args 2]]" + if { $output_file == "" } { + fail "$testname: dump file does not exist" + return + } set fd [open "| $cxxfilt < $output_file" r] set text [read $fd] close $fd - set suf [dump-suffix [lindex $args 2]] if [regexp -- [lindex $args 1] $text] { - pass "$testcase scan-[lindex $args 0]-dump-dem $suf \"[lindex $args 1]\"" + pass "$testname" } else { - fail "$testcase scan-[lindex $args 0]-dump-dem $suf \"[lindex $args 1]\"" + fail "$testname" } } @@ -213,17 +234,23 @@ proc scan-dump-dem-not { args } { } upvar 3 name testcase + + set suf [dump-suffix [lindex $args 2]] + set testname "$testcase scan-[lindex $args 0]-dump-dem-not $suf \"[lindex $args 1]\"" set src [file tail [lindex $testcase 0]] - set output_file "[glob $src.[lindex $args 2]]" + set output_file "[glob -nocomplain $src.[lindex $args 2]]" + if { $output_file == "" } { + fail "$testname: dump file does not exist" + return + } set fd [open "| $cxxfilt < $output_file" r] set text [read $fd] close $fd - set suf [dump-suffix [lindex $args 2]] if ![regexp -- [lindex $args 1] $text] { - pass "$testcase scan-[lindex $args 0]-dump-dem-not $suf \"[lindex $args 1]\"" + pass "$testname" } else { - fail "$testcase scan-[lindex $args 0]-dump-dem-not $suf \"[lindex $args 1]\"" + fail "$testname" } } diff --git a/gcc/testsuite/obj-c++.dg/bitfield-1.mm b/gcc/testsuite/obj-c++.dg/bitfield-1.mm index fa8e7265d37..087a13ff7ad 100644 --- a/gcc/testsuite/obj-c++.dg/bitfield-1.mm +++ b/gcc/testsuite/obj-c++.dg/bitfield-1.mm @@ -4,8 +4,10 @@ were defined at once (i.e., any padding introduced for superclasses should be removed). */ /* Contributed by Ziemowit Laski <zlaski@apple.com>. */ -/* { dg-options "-Wpadded -Wabi" } */ /* { dg-do run } */ +/* { dg-xfail-if "PR31032" { *-*-* } { "*" } { "" } } */ +/* { dg-prune-output ".*internal compiler error.*" } */ +/* { dg-options "-Wpadded -Wabi" } */ #include <objc/objc.h> #include <objc/Object.h> @@ -112,12 +114,11 @@ int main(void) return 0; } -/* { dg-excess-errors "In file included from" { target lp64 } } */ +/* { dg-prune-output "In file included from" } Ignore this message. */ /* { dg-bogus "padding struct to align" "PR23610" { xfail lp64 } 1 } */ - -/* { dg-bogus "padding struct size" "PR23610" { xfail lp64 } 40 } */ -/* { dg-bogus "padding struct size" "PR23610" { xfail lp64 } 43 } */ -/* { dg-bogus "padding struct size" "PR23610" { xfail lp64 } 57 } */ -/* { dg-bogus "padding struct size" "PR23610" { xfail lp64 } 60 } */ -/* { dg-bogus "padding struct size" "PR23610" { xfail lp64 } 75 } */ -/* { dg-bogus "padding struct size" "PR23610" { xfail lp64 } 76 } */ +/* { dg-bogus "padding struct size" "PR23610" { xfail lp64 } 42 } */ +/* { dg-bogus "padding struct size" "PR23610" { xfail lp64 } 45 } */ +/* { dg-bogus "padding struct size" "PR23610" { xfail lp64 } 59 } */ +/* { dg-bogus "padding struct size" "PR23610" { xfail lp64 } 62 } */ +/* { dg-bogus "padding struct size" "PR23610" { xfail lp64 } 77 } */ +/* { dg-bogus "padding struct size" "PR23610" { xfail lp64 } 78 } */ diff --git a/gcc/testsuite/obj-c++.dg/bitfield-4.mm b/gcc/testsuite/obj-c++.dg/bitfield-4.mm index 0344dcdfab6..72c1396d706 100644 --- a/gcc/testsuite/obj-c++.dg/bitfield-4.mm +++ b/gcc/testsuite/obj-c++.dg/bitfield-4.mm @@ -1,8 +1,8 @@ /* Check if the @defs() construct preserves the correct layout of bitfields. */ /* Contributed by Ziemowit Laski <zlaski@apple.com>. */ -/* { dg-options "-lobjc -Wpadded" } */ /* { dg-do run } */ +/* { dg-options "-lobjc -Wpadded" } */ #include <objc/Object.h> @@ -49,7 +49,7 @@ int main(void) return 0; } -/* { dg-excess-errors "In file included from" { target lp64 } } */ +/* { dg-prune-output "In file included from" } Ignore this message. */ /* { dg-bogus "padding struct to align" "PR23610" { xfail lp64 } 1 } */ /* { dg-bogus "padding struct size" "PR23610" { xfail lp64 } 28 } */ diff --git a/gcc/testsuite/obj-c++.dg/comp-types-10.mm b/gcc/testsuite/obj-c++.dg/comp-types-10.mm index 3abcde5bec6..0a8f1c9b2c2 100644 --- a/gcc/testsuite/obj-c++.dg/comp-types-10.mm +++ b/gcc/testsuite/obj-c++.dg/comp-types-10.mm @@ -1,5 +1,7 @@ /* Yet another mysterious gimplifier crasher. */ /* { dg-do compile } */ +/* { dg-xfail-if "PR23716" { *-*-* } { "*" } { "" } } */ +/* { dg-prune-output ".*internal compiler error.*" } */ /* { dg-options "-O3" } */ @class NSString; diff --git a/gcc/testsuite/obj-c++.dg/encode-8.mm b/gcc/testsuite/obj-c++.dg/encode-8.mm index bfd34754ff4..53ad4e3222c 100644 --- a/gcc/testsuite/obj-c++.dg/encode-8.mm +++ b/gcc/testsuite/obj-c++.dg/encode-8.mm @@ -2,8 +2,8 @@ 'BOOL *' (which should be encoded as '^c') and 'char *' (which should be encoded as '*'). */ /* Contributed by Ziemowit Laski <zlaski@apple.com>. */ -/* { dg-options "-lobjc" } */ /* { dg-do run { xfail { "*-*-*" } } } PR27249 */ +/* { dg-options "-lobjc" } */ #include <string.h> #include <stdlib.h> diff --git a/gcc/testsuite/obj-c++.dg/layout-1.mm b/gcc/testsuite/obj-c++.dg/layout-1.mm index 246dcc329b2..35ffa49da3b 100644 --- a/gcc/testsuite/obj-c++.dg/layout-1.mm +++ b/gcc/testsuite/obj-c++.dg/layout-1.mm @@ -13,5 +13,5 @@ - (id) foo; @end -/* { dg-excess-errors "In file included from" { target lp64 } } */ +/* { dg-prune-output "In output included from" } Ignore this message. */ /* { dg-bogus "padding struct to align" "PR23610" { xfail lp64 } 1 } */ diff --git a/gcc/testsuite/obj-c++.dg/try-catch-2.mm b/gcc/testsuite/obj-c++.dg/try-catch-2.mm index 7809b890db9..d7b386a1bfa 100644 --- a/gcc/testsuite/obj-c++.dg/try-catch-2.mm +++ b/gcc/testsuite/obj-c++.dg/try-catch-2.mm @@ -2,9 +2,9 @@ all uncaught exceptions. */ /* Developed by Ziemowit Laski <zlaski@apple.com>. */ -/* { dg-options "-fobjc-exceptions" } */ -/* { dg-xfail-if "PR23616" { "*-*-*" } { "*" } { "" } } */ /* { dg-do run } */ +/* { dg-xfail-if "PR23616" { "*-*-*" } { "*" } { "" } } */ +/* { dg-options "-fobjc-exceptions" } */ #include <objc/Object.h> #include <stdio.h> diff --git a/gcc/testsuite/obj-c++.dg/try-catch-9.mm b/gcc/testsuite/obj-c++.dg/try-catch-9.mm index 56bbdd1e554..f79f52fbb9a 100644 --- a/gcc/testsuite/obj-c++.dg/try-catch-9.mm +++ b/gcc/testsuite/obj-c++.dg/try-catch-9.mm @@ -2,9 +2,10 @@ block survive until the @catch block is reached. */ /* Developed by Ziemowit Laski <zlaski@apple.com>. */ -/* { dg-options "-fobjc-exceptions -O2" } */ -/* { dg-xfail-if "PR23616" { "*-*-*" } { "*" } { "" } } */ /* { dg-do run } */ +/* { dg-xfail-if "PR23616" { *-*-* } { "*" } { "" } } */ +/* { dg-prune-output ".*internal compiler error.*" } */ +/* { dg-options "-fobjc-exceptions -O2" } */ #include <objc/Object.h> #include <stdlib.h> diff --git a/gcc/tree-cfg.c b/gcc/tree-cfg.c index 4eab1fd449e..c0cb7b87488 100644 --- a/gcc/tree-cfg.c +++ b/gcc/tree-cfg.c @@ -3658,7 +3658,10 @@ verify_gimple_expr (tree expr) there is no sign or zero extension involved. */ if (((POINTER_TYPE_P (type) && INTEGRAL_TYPE_P (TREE_TYPE (op))) || (POINTER_TYPE_P (TREE_TYPE (op)) && INTEGRAL_TYPE_P (type))) - && TYPE_PRECISION (type) == TYPE_PRECISION (TREE_TYPE (op))) + && (TYPE_PRECISION (type) == TYPE_PRECISION (TREE_TYPE (op)) + /* For targets were the precision of sizetype doesn't + match that of pointers we need the following. */ + || type == sizetype || TREE_TYPE (op) == sizetype)) return false; /* Allow conversion from integer to offset type and vice versa. */ diff --git a/gcc/tree-chrec.h b/gcc/tree-chrec.h index c908ec5c66b..7f240c6c739 100644 --- a/gcc/tree-chrec.h +++ b/gcc/tree-chrec.h @@ -168,10 +168,10 @@ evolution_function_is_constant_p (const_tree chrec) } } -/* Determine whether the given tree is an affine evolution function or not. */ +/* Determine whether CHREC is an affine evolution function in LOOPNUM. */ static inline bool -evolution_function_is_affine_p (const_tree chrec) +evolution_function_is_affine_in_loop (const_tree chrec, int loopnum) { if (chrec == NULL_TREE) return false; @@ -179,10 +179,8 @@ evolution_function_is_affine_p (const_tree chrec) switch (TREE_CODE (chrec)) { case POLYNOMIAL_CHREC: - if (evolution_function_is_invariant_p (CHREC_LEFT (chrec), - CHREC_VARIABLE (chrec)) - && evolution_function_is_invariant_p (CHREC_RIGHT (chrec), - CHREC_VARIABLE (chrec))) + if (evolution_function_is_invariant_p (CHREC_LEFT (chrec), loopnum) + && evolution_function_is_invariant_p (CHREC_RIGHT (chrec), loopnum)) return true; else return false; @@ -192,14 +190,28 @@ evolution_function_is_affine_p (const_tree chrec) } } -/* Determine whether the given tree is an affine or constant evolution - function. */ +/* Determine whether CHREC is an affine evolution function or not. */ static inline bool -evolution_function_is_affine_or_constant_p (const_tree chrec) +evolution_function_is_affine_p (const_tree chrec) { - return evolution_function_is_affine_p (chrec) - || evolution_function_is_constant_p (chrec); + if (chrec == NULL_TREE) + return false; + + switch (TREE_CODE (chrec)) + { + case POLYNOMIAL_CHREC: + if (evolution_function_is_invariant_p (CHREC_LEFT (chrec), + CHREC_VARIABLE (chrec)) + && evolution_function_is_invariant_p (CHREC_RIGHT (chrec), + CHREC_VARIABLE (chrec))) + return true; + else + return false; + + default: + return false; + } } /* Determines whether EXPR does not contains chrec expressions. */ @@ -221,5 +233,24 @@ chrec_type (const_tree chrec) return TREE_TYPE (chrec); } +static inline tree +chrec_fold_op (enum tree_code code, tree type, tree op0, tree op1) +{ + switch (code) + { + case PLUS_EXPR: + return chrec_fold_plus (type, op0, op1); + + case MINUS_EXPR: + return chrec_fold_minus (type, op0, op1); + + case MULT_EXPR: + return chrec_fold_multiply (type, op0, op1); + + default: + gcc_unreachable (); + } + +} #endif /* GCC_TREE_CHREC_H */ diff --git a/gcc/tree-data-ref.c b/gcc/tree-data-ref.c index 7e9c99fc53a..bf9516cd672 100644 --- a/gcc/tree-data-ref.c +++ b/gcc/tree-data-ref.c @@ -754,7 +754,7 @@ dr_analyze_indices (struct data_reference *dr, struct loop *nest) { op = TREE_OPERAND (aref, 0); access_fn = analyze_scalar_evolution (loop, op); - access_fn = resolve_mixers (nest, access_fn); + access_fn = instantiate_scev (nest, loop, access_fn); base = initial_condition (access_fn); split_constant_offset (base, &base, &off); access_fn = chrec_replace_initial_condition (access_fn, @@ -1849,16 +1849,42 @@ analyze_siv_subscript_cst_affine (tree chrec_a, /* Helper recursive function for initializing the matrix A. Returns the initial value of CHREC. */ -static HOST_WIDE_INT +static tree initialize_matrix_A (lambda_matrix A, tree chrec, unsigned index, int mult) { gcc_assert (chrec); - if (TREE_CODE (chrec) != POLYNOMIAL_CHREC) - return int_cst_value (chrec); + switch (TREE_CODE (chrec)) + { + case POLYNOMIAL_CHREC: + gcc_assert (TREE_CODE (CHREC_RIGHT (chrec)) == INTEGER_CST); + + A[index][0] = mult * int_cst_value (CHREC_RIGHT (chrec)); + return initialize_matrix_A (A, CHREC_LEFT (chrec), index + 1, mult); + + case PLUS_EXPR: + case MULT_EXPR: + case MINUS_EXPR: + { + tree op0 = initialize_matrix_A (A, TREE_OPERAND (chrec, 0), index, mult); + tree op1 = initialize_matrix_A (A, TREE_OPERAND (chrec, 1), index, mult); + + return chrec_fold_op (TREE_CODE (chrec), chrec_type (chrec), op0, op1); + } + + case NOP_EXPR: + { + tree op = initialize_matrix_A (A, TREE_OPERAND (chrec, 0), index, mult); + return chrec_convert (chrec_type (chrec), op, NULL_TREE); + } + + case INTEGER_CST: + return chrec; - A[index][0] = mult * int_cst_value (CHREC_RIGHT (chrec)); - return initialize_matrix_A (A, CHREC_LEFT (chrec), index + 1, mult); + default: + gcc_unreachable (); + return NULL_TREE; + } } #define FLOOR_DIV(x,y) ((x) / (y)) @@ -2090,8 +2116,8 @@ analyze_subscript_affine_affine (tree chrec_a, A = lambda_matrix_new (dim, 1); S = lambda_matrix_new (dim, 1); - init_a = initialize_matrix_A (A, chrec_a, 0, 1); - init_b = initialize_matrix_A (A, chrec_b, nb_vars_a, -1); + init_a = int_cst_value (initialize_matrix_A (A, chrec_a, 0, 1)); + init_b = int_cst_value (initialize_matrix_A (A, chrec_b, nb_vars_a, -1)); gamma = init_b - init_a; /* Don't do all the hard work of solving the Diophantine equation @@ -2369,7 +2395,8 @@ analyze_siv_subscript (tree chrec_a, tree chrec_b, conflict_function **overlaps_a, conflict_function **overlaps_b, - tree *last_conflicts) + tree *last_conflicts, + int loop_nest_num) { dependence_stats.num_siv++; @@ -2377,17 +2404,17 @@ analyze_siv_subscript (tree chrec_a, fprintf (dump_file, "(analyze_siv_subscript \n"); if (evolution_function_is_constant_p (chrec_a) - && evolution_function_is_affine_p (chrec_b)) + && evolution_function_is_affine_in_loop (chrec_b, loop_nest_num)) analyze_siv_subscript_cst_affine (chrec_a, chrec_b, overlaps_a, overlaps_b, last_conflicts); - else if (evolution_function_is_affine_p (chrec_a) + else if (evolution_function_is_affine_in_loop (chrec_a, loop_nest_num) && evolution_function_is_constant_p (chrec_b)) analyze_siv_subscript_cst_affine (chrec_b, chrec_a, overlaps_b, overlaps_a, last_conflicts); - else if (evolution_function_is_affine_p (chrec_a) - && evolution_function_is_affine_p (chrec_b)) + else if (evolution_function_is_affine_in_loop (chrec_a, loop_nest_num) + && evolution_function_is_affine_in_loop (chrec_b, loop_nest_num)) { if (!chrec_contains_symbols (chrec_a) && !chrec_contains_symbols (chrec_b)) @@ -2649,7 +2676,7 @@ analyze_overlapping_iterations (tree chrec_a, else if (siv_subscript_p (chrec_a, chrec_b)) analyze_siv_subscript (chrec_a, chrec_b, overlap_iterations_a, overlap_iterations_b, - last_conflicts); + last_conflicts, lnn); else analyze_miv_subscript (chrec_a, chrec_b, @@ -4153,18 +4180,20 @@ find_loop_nest (struct loop *loop, VEC (loop_p, heap) **loop_nest) return true; } -/* Given a loop nest LOOP, the following vectors are returned: +/* Returns true when the data dependences have been computed, false otherwise. + Given a loop nest LOOP, the following vectors are returned: DATAREFS is initialized to all the array elements contained in this loop, DEPENDENCE_RELATIONS contains the relations between the data references. Compute read-read and self relations if COMPUTE_SELF_AND_READ_READ_DEPENDENCES is TRUE. */ -void +bool compute_data_dependences_for_loop (struct loop *loop, bool compute_self_and_read_read_dependences, VEC (data_reference_p, heap) **datarefs, VEC (ddr_p, heap) **dependence_relations) { + bool res = true; VEC (loop_p, heap) *vloops = VEC_alloc (loop_p, heap, 3); memset (&dependence_stats, 0, sizeof (dependence_stats)); @@ -4182,6 +4211,7 @@ compute_data_dependences_for_loop (struct loop *loop, chrec_dont_know. */ ddr = initialize_data_dependence_relation (NULL, NULL, vloops); VEC_safe_push (ddr_p, heap, *dependence_relations, ddr); + res = false; } else compute_all_dependences (*datarefs, dependence_relations, vloops, @@ -4233,7 +4263,9 @@ compute_data_dependences_for_loop (struct loop *loop, dependence_stats.num_miv_independent); fprintf (dump_file, "Number of miv tests unimplemented: %d\n", dependence_stats.num_miv_unimplemented); - } + } + + return res; } /* Entry point (for testing only). Analyze all the data references @@ -5005,3 +5037,20 @@ remove_similar_memory_refs (VEC (tree, heap) **stmts) htab_delete (seen); } +/* Returns the index of PARAMETER in the parameters vector of the + ACCESS_MATRIX. If PARAMETER does not exist return -1. */ + +int +access_matrix_get_index_for_parameter (tree parameter, + struct access_matrix *access_matrix) +{ + int i; + VEC (tree,heap) *lambda_parameters = AM_PARAMETERS (access_matrix); + tree lambda_parameter; + + for (i = 0; VEC_iterate (tree, lambda_parameters, i, lambda_parameter); i++) + if (lambda_parameter == parameter) + return i + AM_NB_INDUCTION_VARS (access_matrix); + + return -1; +} diff --git a/gcc/tree-data-ref.h b/gcc/tree-data-ref.h index 5e668cbaf43..c1672eb3d53 100644 --- a/gcc/tree-data-ref.h +++ b/gcc/tree-data-ref.h @@ -96,6 +96,63 @@ struct dr_alias bitmap vops; }; +/* Each vector of the access matrix represents a linear access + function for a subscript. First elements correspond to the + leftmost indices, ie. for a[i][j] the first vector corresponds to + the subscript in "i". The elements of a vector are relative to + the loop nests in which the data reference is considered, + i.e. the vector is relative to the SCoP that provides the context + in which this data reference occurs. + + For example, in + + | loop_1 + | loop_2 + | a[i+3][2*j+n-1] + + if "i" varies in loop_1 and "j" varies in loop_2, the access + matrix with respect to the loop nest {loop_1, loop_2} is: + + | loop_1 loop_2 param_n cst + | 1 0 0 3 + | 0 2 1 -1 + + whereas the access matrix with respect to loop_2 considers "i" as + a parameter: + + | loop_2 param_i param_n cst + | 0 1 0 3 + | 2 0 1 -1 +*/ +struct access_matrix +{ + int loop_nest_num; + int nb_induction_vars; + VEC (tree, heap) *parameters; + VEC (lambda_vector, heap) *matrix; +}; + +#define AM_LOOP_NEST_NUM(M) (M)->loop_nest_num +#define AM_NB_INDUCTION_VARS(M) (M)->nb_induction_vars +#define AM_PARAMETERS(M) (M)->parameters +#define AM_MATRIX(M) (M)->matrix +#define AM_NB_PARAMETERS(M) (VEC_length (tree, AM_PARAMETERS(M))) +#define AM_CONST_COLUMN_INDEX(M) (AM_NB_INDUCTION_VARS (M) + AM_NB_PARAMETERS (M)) +#define AM_NB_COLUMNS(M) (AM_NB_INDUCTION_VARS (M) + AM_NB_PARAMETERS (M) + 1) +#define AM_GET_SUBSCRIPT_ACCESS_VECTOR(M, I) VEC_index (lambda_vector, AM_MATRIX (M), I) +#define AM_GET_ACCESS_MATRIX_ELEMENT(M, I, J) AM_GET_SUBSCRIPT_ACCESS_VECTOR (M, I)[J] + +/* Return the column in the access matrix of LOOP_NUM. */ + +static inline int +am_vector_index_for_loop (struct access_matrix *access_matrix, int loop_num) +{ + gcc_assert (loop_num >= AM_LOOP_NEST_NUM (access_matrix)); + return loop_num - AM_LOOP_NEST_NUM (access_matrix); +} + +int access_matrix_get_index_for_parameter (tree, struct access_matrix *); + struct data_reference { /* A pointer to the statement that contains this DR. */ @@ -118,11 +175,10 @@ struct data_reference /* Alias information for the data reference. */ struct dr_alias alias; -}; -typedef struct data_reference *data_reference_p; -DEF_VEC_P(data_reference_p); -DEF_VEC_ALLOC_P (data_reference_p, heap); + /* Matrix representation for the data access functions. */ + struct access_matrix *access_matrix; +}; #define DR_STMT(DR) (DR)->stmt #define DR_REF(DR) (DR)->ref @@ -139,6 +195,11 @@ DEF_VEC_ALLOC_P (data_reference_p, heap); #define DR_PTR_INFO(DR) (DR)->alias.ptr_info #define DR_VOPS(DR) (DR)->alias.vops #define DR_ALIGNED_TO(DR) (DR)->innermost.aligned_to +#define DR_ACCESS_MATRIX(DR) (DR)->access_matrix + +typedef struct data_reference *data_reference_p; +DEF_VEC_P(data_reference_p); +DEF_VEC_ALLOC_P (data_reference_p, heap); enum data_dependence_direction { dir_positive, @@ -309,7 +370,7 @@ DEF_VEC_ALLOC_O (data_ref_loc, heap); bool get_references_in_stmt (tree, VEC (data_ref_loc, heap) **); void dr_analyze_innermost (struct data_reference *); -extern void compute_data_dependences_for_loop (struct loop *, bool, +extern bool compute_data_dependences_for_loop (struct loop *, bool, VEC (data_reference_p, heap) **, VEC (ddr_p, heap) **); extern void print_direction_vector (FILE *, lambda_vector, int); @@ -493,7 +554,12 @@ rdg_has_similar_memory_accesses (struct graph *rdg, int v1, int v2) } /* In lambda-code.c */ -bool lambda_transform_legal_p (lambda_trans_matrix, int, VEC (ddr_p, heap) *); +bool lambda_transform_legal_p (lambda_trans_matrix, int, + VEC (ddr_p, heap) *); +void lambda_collect_parameters (VEC (data_reference_p, heap) *, + VEC (tree, heap) **); +bool lambda_compute_access_matrices (VEC (data_reference_p, heap) *, + VEC (tree, heap) *, int); /* In tree-data-refs.c */ void split_constant_offset (tree , tree *, tree *); diff --git a/gcc/tree-inline.c b/gcc/tree-inline.c index 1ba7b60f6f1..fb4f765a200 100644 --- a/gcc/tree-inline.c +++ b/gcc/tree-inline.c @@ -1440,7 +1440,6 @@ setup_one_parameter (copy_body_data *id, tree p, tree value, tree fn, { tree init_stmt; tree var; - tree var_sub; tree rhs = value; tree def = (gimple_in_ssa_p (cfun) ? gimple_default_def (id->src_cfun, p) : NULL); @@ -1496,23 +1495,10 @@ setup_one_parameter (copy_body_data *id, tree p, tree value, tree fn, add_referenced_var (var); } - /* See if the frontend wants to pass this by invisible reference. If - so, our new VAR_DECL will have REFERENCE_TYPE, and we need to - replace uses of the PARM_DECL with dereferences. */ - if (TREE_TYPE (var) != TREE_TYPE (p) - && POINTER_TYPE_P (TREE_TYPE (var)) - && TREE_TYPE (TREE_TYPE (var)) == TREE_TYPE (p)) - { - insert_decl_map (id, var, var); - var_sub = build_fold_indirect_ref (var); - } - else - var_sub = var; - /* Register the VAR_DECL as the equivalent for the PARM_DECL; that way, when the PARM_DECL is encountered, it will be automatically replaced by the VAR_DECL. */ - insert_decl_map (id, p, var_sub); + insert_decl_map (id, p, var); /* Declare this new variable. */ TREE_CHAIN (var) = *vars; @@ -1572,7 +1558,7 @@ setup_one_parameter (copy_body_data *id, tree p, tree value, tree fn, if (rhs == error_mark_node) { - insert_decl_map (id, p, var_sub); + insert_decl_map (id, p, var); return; } diff --git a/gcc/tree-loop-linear.c b/gcc/tree-loop-linear.c index 806d9e6d1cb..f58bd11b7fb 100644 --- a/gcc/tree-loop-linear.c +++ b/gcc/tree-loop-linear.c @@ -146,19 +146,17 @@ gather_interchange_stats (VEC (ddr_p, heap) *dependence_relations, for (it = 0; it < DR_NUM_DIMENSIONS (dr); it++, ref = TREE_OPERAND (ref, 0)) { - tree chrec = DR_ACCESS_FN (dr, it); - tree tstride = evolution_part_in_loop_num (chrec, loop->num); + int num = am_vector_index_for_loop (DR_ACCESS_MATRIX (dr), loop->num); + int istride = AM_GET_ACCESS_MATRIX_ELEMENT (DR_ACCESS_MATRIX (dr), it, num); tree array_size = TYPE_SIZE (TREE_TYPE (ref)); double_int dstride; - if (tstride == NULL_TREE - || array_size == NULL_TREE - || TREE_CODE (tstride) != INTEGER_CST + if (array_size == NULL_TREE || TREE_CODE (array_size) != INTEGER_CST) continue; dstride = double_int_mul (tree_to_double_int (array_size), - tree_to_double_int (tstride)); + shwi_to_double_int (istride)); (*access_strides) = double_int_add (*access_strides, dstride); } } @@ -320,6 +318,7 @@ linear_transform_loops (void) loop_iterator li; VEC(tree,heap) *oldivs = NULL; VEC(tree,heap) *invariants = NULL; + VEC(tree,heap) *lambda_parameters = NULL; VEC(tree,heap) *remove_ivs = VEC_alloc (tree, heap, 3); struct loop *loop_nest; tree oldiv_stmt; @@ -330,6 +329,7 @@ linear_transform_loops (void) unsigned int depth = 0; VEC (ddr_p, heap) *dependence_relations; VEC (data_reference_p, heap) *datarefs; + lambda_loopnest before, after; lambda_trans_matrix trans; struct obstack lambda_obstack; @@ -341,11 +341,18 @@ linear_transform_loops (void) VEC_truncate (tree, oldivs, 0); VEC_truncate (tree, invariants, 0); + VEC_truncate (tree, lambda_parameters, 0); datarefs = VEC_alloc (data_reference_p, heap, 10); dependence_relations = VEC_alloc (ddr_p, heap, 10 * 10); - compute_data_dependences_for_loop (loop_nest, true, &datarefs, - &dependence_relations); + if (!compute_data_dependences_for_loop (loop_nest, true, &datarefs, + &dependence_relations)) + continue; + + lambda_collect_parameters (datarefs, &lambda_parameters); + if (!lambda_compute_access_matrices (datarefs, lambda_parameters, + loop_nest->num)) + continue; if (dump_file && (dump_flags & TDF_DETAILS)) dump_ddrs (dump_file, dependence_relations); diff --git a/gcc/tree-parloops.c b/gcc/tree-parloops.c index de4f3065a52..109e3058921 100644 --- a/gcc/tree-parloops.c +++ b/gcc/tree-parloops.c @@ -1797,6 +1797,27 @@ gen_parallel_loop (struct loop *loop, htab_t reduction_list, omp_expand_local (parallel_head); } +/* Returns true when LOOP contains vector phi nodes. */ + +static bool +loop_has_vector_phi_nodes (struct loop *loop) +{ + unsigned i; + basic_block *bbs = get_loop_body_in_dom_order (loop); + bool res = true; + tree phi; + + for (i = 0; i < loop->num_nodes; i++) + for (phi = phi_nodes (bbs[i]); phi; phi = PHI_CHAIN (phi)) + if (TREE_CODE (TREE_TYPE (PHI_RESULT (phi))) == VECTOR_TYPE) + goto end; + + res = false; + end: + free (bbs); + return res; +} + /* Detect parallel loops and generate parallel code using libgomp primitives. Returns true if some loop was parallelized, false otherwise. */ @@ -1828,6 +1849,8 @@ parallelize_loops (void) /* And of course, the loop must be parallelizable. */ || !can_duplicate_loop_p (loop) || loop_has_blocks_with_irreducible_flag (loop) + /* FIXME: the check for vector phi nodes could be removed. */ + || loop_has_vector_phi_nodes (loop) || !loop_parallel_p (loop, reduction_list, &niter_desc)) continue; diff --git a/gcc/tree-scalar-evolution.c b/gcc/tree-scalar-evolution.c index cc2df617294..7c9736a3b02 100644 --- a/gcc/tree-scalar-evolution.c +++ b/gcc/tree-scalar-evolution.c @@ -1952,26 +1952,23 @@ loop_closed_phi_def (tree var) } /* Analyze all the parameters of the chrec, between INSTANTIATION_LOOP - and EVOLUTION_LOOP, that were left under a symbolic form. CHREC is - the scalar evolution to instantiate. CACHE is the cache of already - instantiated values. FLAGS modify the way chrecs are instantiated. + and EVOLUTION_LOOP, that were left under a symbolic form. + + CHREC is the scalar evolution to instantiate. + + CACHE is the cache of already instantiated values. + + FOLD_CONVERSIONS should be set to true when the conversions that + may wrap in signed/pointer type are folded, as long as the value of + the chrec is preserved. + SIZE_EXPR is used for computing the size of the expression to be instantiated, and to stop if it exceeds some limit. */ - -/* Values for FLAGS. */ -enum -{ - INSERT_SUPERLOOP_CHRECS = 1, /* Loop invariants are replaced with chrecs - in outer loops. */ - FOLD_CONVERSIONS = 2 /* The conversions that may wrap in - signed/pointer type are folded, as long as the - value of the chrec is preserved. */ -}; static tree instantiate_scev_1 (struct loop *instantiation_loop, struct loop *evolution_loop, tree chrec, - int flags, htab_t cache, int size_expr) + bool fold_conversions, htab_t cache, int size_expr) { tree res, op0, op1, op2; basic_block def_bb; @@ -1995,8 +1992,7 @@ instantiate_scev_1 (struct loop *instantiation_loop, evolutions in outer loops), nothing to do. */ if (!def_bb || loop_depth (def_bb->loop_father) == 0 - || (!(flags & INSERT_SUPERLOOP_CHRECS) - && !flow_bb_inside_loop_p (instantiation_loop, def_bb))) + || !flow_bb_inside_loop_p (instantiation_loop, def_bb)) return chrec; /* We cache the value of instantiated variable to avoid exponential @@ -2052,7 +2048,7 @@ instantiate_scev_1 (struct loop *instantiation_loop, else if (res != chrec_dont_know) res = instantiate_scev_1 (instantiation_loop, evolution_loop, res, - flags, cache, size_expr); + fold_conversions, cache, size_expr); bitmap_clear_bit (already_instantiated, SSA_NAME_VERSION (chrec)); @@ -2062,12 +2058,14 @@ instantiate_scev_1 (struct loop *instantiation_loop, case POLYNOMIAL_CHREC: op0 = instantiate_scev_1 (instantiation_loop, evolution_loop, - CHREC_LEFT (chrec), flags, cache, size_expr); + CHREC_LEFT (chrec), fold_conversions, cache, + size_expr); if (op0 == chrec_dont_know) return chrec_dont_know; op1 = instantiate_scev_1 (instantiation_loop, evolution_loop, - CHREC_RIGHT (chrec), flags, cache, size_expr); + CHREC_RIGHT (chrec), fold_conversions, cache, + size_expr); if (op1 == chrec_dont_know) return chrec_dont_know; @@ -2082,13 +2080,13 @@ instantiate_scev_1 (struct loop *instantiation_loop, case POINTER_PLUS_EXPR: case PLUS_EXPR: op0 = instantiate_scev_1 (instantiation_loop, evolution_loop, - TREE_OPERAND (chrec, 0), flags, cache, + TREE_OPERAND (chrec, 0), fold_conversions, cache, size_expr); if (op0 == chrec_dont_know) return chrec_dont_know; op1 = instantiate_scev_1 (instantiation_loop, evolution_loop, - TREE_OPERAND (chrec, 1), flags, cache, + TREE_OPERAND (chrec, 1), fold_conversions, cache, size_expr); if (op1 == chrec_dont_know) return chrec_dont_know; @@ -2104,14 +2102,14 @@ instantiate_scev_1 (struct loop *instantiation_loop, case MINUS_EXPR: op0 = instantiate_scev_1 (instantiation_loop, evolution_loop, - TREE_OPERAND (chrec, 0), flags, cache, + TREE_OPERAND (chrec, 0), fold_conversions, cache, size_expr); if (op0 == chrec_dont_know) return chrec_dont_know; op1 = instantiate_scev_1 (instantiation_loop, evolution_loop, TREE_OPERAND (chrec, 1), - flags, cache, size_expr); + fold_conversions, cache, size_expr); if (op1 == chrec_dont_know) return chrec_dont_know; @@ -2127,13 +2125,13 @@ instantiate_scev_1 (struct loop *instantiation_loop, case MULT_EXPR: op0 = instantiate_scev_1 (instantiation_loop, evolution_loop, TREE_OPERAND (chrec, 0), - flags, cache, size_expr); + fold_conversions, cache, size_expr); if (op0 == chrec_dont_know) return chrec_dont_know; op1 = instantiate_scev_1 (instantiation_loop, evolution_loop, TREE_OPERAND (chrec, 1), - flags, cache, size_expr); + fold_conversions, cache, size_expr); if (op1 == chrec_dont_know) return chrec_dont_know; @@ -2149,11 +2147,11 @@ instantiate_scev_1 (struct loop *instantiation_loop, CASE_CONVERT: op0 = instantiate_scev_1 (instantiation_loop, evolution_loop, TREE_OPERAND (chrec, 0), - flags, cache, size_expr); + fold_conversions, cache, size_expr); if (op0 == chrec_dont_know) return chrec_dont_know; - if (flags & FOLD_CONVERSIONS) + if (fold_conversions) { tree tmp = chrec_convert_aggressive (TREE_TYPE (chrec), op0); if (tmp) @@ -2166,7 +2164,7 @@ instantiate_scev_1 (struct loop *instantiation_loop, /* If we used chrec_convert_aggressive, we can no longer assume that signed chrecs do not overflow, as chrec_convert does, so avoid calling it in that case. */ - if (flags & FOLD_CONVERSIONS) + if (fold_conversions) return fold_convert (TREE_TYPE (chrec), op0); return chrec_convert (TREE_TYPE (chrec), op0, NULL_TREE); @@ -2187,19 +2185,19 @@ instantiate_scev_1 (struct loop *instantiation_loop, case 3: op0 = instantiate_scev_1 (instantiation_loop, evolution_loop, TREE_OPERAND (chrec, 0), - flags, cache, size_expr); + fold_conversions, cache, size_expr); if (op0 == chrec_dont_know) return chrec_dont_know; op1 = instantiate_scev_1 (instantiation_loop, evolution_loop, TREE_OPERAND (chrec, 1), - flags, cache, size_expr); + fold_conversions, cache, size_expr); if (op1 == chrec_dont_know) return chrec_dont_know; op2 = instantiate_scev_1 (instantiation_loop, evolution_loop, TREE_OPERAND (chrec, 2), - flags, cache, size_expr); + fold_conversions, cache, size_expr); if (op2 == chrec_dont_know) return chrec_dont_know; @@ -2214,13 +2212,13 @@ instantiate_scev_1 (struct loop *instantiation_loop, case 2: op0 = instantiate_scev_1 (instantiation_loop, evolution_loop, TREE_OPERAND (chrec, 0), - flags, cache, size_expr); + fold_conversions, cache, size_expr); if (op0 == chrec_dont_know) return chrec_dont_know; op1 = instantiate_scev_1 (instantiation_loop, evolution_loop, TREE_OPERAND (chrec, 1), - flags, cache, size_expr); + fold_conversions, cache, size_expr); if (op1 == chrec_dont_know) return chrec_dont_know; @@ -2232,7 +2230,7 @@ instantiate_scev_1 (struct loop *instantiation_loop, case 1: op0 = instantiate_scev_1 (instantiation_loop, evolution_loop, TREE_OPERAND (chrec, 0), - flags, cache, size_expr); + fold_conversions, cache, size_expr); if (op0 == chrec_dont_know) return chrec_dont_know; if (op0 == TREE_OPERAND (chrec, 0)) @@ -2272,8 +2270,8 @@ instantiate_scev (struct loop *instantiation_loop, struct loop *evolution_loop, fprintf (dump_file, ")\n"); } - res = instantiate_scev_1 (instantiation_loop, evolution_loop, chrec, - INSERT_SUPERLOOP_CHRECS, cache, 0); + res = instantiate_scev_1 (instantiation_loop, evolution_loop, chrec, false, + cache, 0); if (dump_file && (dump_flags & TDF_DETAILS)) { @@ -2296,7 +2294,7 @@ tree resolve_mixers (struct loop *loop, tree chrec) { htab_t cache = htab_create (10, hash_scev_info, eq_scev_info, del_scev_info); - tree ret = instantiate_scev_1 (loop, loop, chrec, FOLD_CONVERSIONS, cache, 0); + tree ret = instantiate_scev_1 (loop, loop, chrec, true, cache, 0); htab_delete (cache); return ret; } diff --git a/gcc/tree-ssa-dce.c b/gcc/tree-ssa-dce.c index 95457eb7fe4..760e20d14bc 100644 --- a/gcc/tree-ssa-dce.c +++ b/gcc/tree-ssa-dce.c @@ -735,22 +735,19 @@ eliminate_unnecessary_stmts (void) static void print_stats (void) { - if (dump_file && (dump_flags & (TDF_STATS|TDF_DETAILS))) - { - float percg; + float percg; - percg = ((float) stats.removed / (float) stats.total) * 100; - fprintf (dump_file, "Removed %d of %d statements (%d%%)\n", - stats.removed, stats.total, (int) percg); + percg = ((float) stats.removed / (float) stats.total) * 100; + fprintf (dump_file, "Removed %d of %d statements (%d%%)\n", + stats.removed, stats.total, (int) percg); - if (stats.total_phis == 0) - percg = 0; - else - percg = ((float) stats.removed_phis / (float) stats.total_phis) * 100; + if (stats.total_phis == 0) + percg = 0; + else + percg = ((float) stats.removed_phis / (float) stats.total_phis) * 100; - fprintf (dump_file, "Removed %d of %d PHI nodes (%d%%)\n", - stats.removed_phis, stats.total_phis, (int) percg); - } + fprintf (dump_file, "Removed %d of %d PHI nodes (%d%%)\n", + stats.removed_phis, stats.total_phis, (int) percg); } /* Initialization for this pass. Set up the used data structures. */ @@ -854,8 +851,11 @@ perform_tree_ssa_dce (bool aggressive) if (cfg_altered) free_dominance_info (CDI_DOMINATORS); + statistics_counter_event (cfun, "Statements deleted", stats.removed); + statistics_counter_event (cfun, "PHI nodes deleted", stats.removed_phis); + /* Debugging dumps. */ - if (dump_file) + if (dump_file && (dump_flags & (TDF_STATS|TDF_DETAILS))) print_stats (); tree_dce_done (aggressive); diff --git a/gcc/tree-ssa-dom.c b/gcc/tree-ssa-dom.c index 909bfeba682..255f24b98e7 100644 --- a/gcc/tree-ssa-dom.c +++ b/gcc/tree-ssa-dom.c @@ -319,6 +319,23 @@ tree_ssa_dominator_optimize (void) such edges from the CFG as needed. */ if (!bitmap_empty_p (need_eh_cleanup)) { + unsigned i; + bitmap_iterator bi; + + /* Jump threading may have created forwarder blocks from blocks + needing EH cleanup; the new successor of these blocks, which + has inherited from the original block, needs the cleanup. */ + EXECUTE_IF_SET_IN_BITMAP (need_eh_cleanup, 0, i, bi) + { + basic_block bb = BASIC_BLOCK (i); + if (single_succ_p (bb) == 1 + && (single_succ_edge (bb)->flags & EDGE_EH) == 0) + { + bitmap_clear_bit (need_eh_cleanup, i); + bitmap_set_bit (need_eh_cleanup, single_succ (bb)->index); + } + } + tree_purge_all_dead_eh_edges (need_eh_cleanup); bitmap_zero (need_eh_cleanup); } @@ -340,6 +357,13 @@ tree_ssa_dominator_optimize (void) SSA_NAME_VALUE (name) = NULL; } + statistics_counter_event (cfun, "Redundant expressions eliminated", + opt_stats.num_re); + statistics_counter_event (cfun, "Constants propagated", + opt_stats.num_const_prop); + statistics_counter_event (cfun, "Copies propagated", + opt_stats.num_copy_prop); + /* Debugging dumps. */ if (dump_file && (dump_flags & TDF_STATS)) dump_dominator_optimization_stats (dump_file); @@ -851,25 +875,11 @@ record_equivalences_from_incoming_edge (basic_block bb) void dump_dominator_optimization_stats (FILE *file) { - long n_exprs; - fprintf (file, "Total number of statements: %6ld\n\n", opt_stats.num_stmts); fprintf (file, "Exprs considered for dominator optimizations: %6ld\n", opt_stats.num_exprs_considered); - n_exprs = opt_stats.num_exprs_considered; - if (n_exprs == 0) - n_exprs = 1; - - fprintf (file, " Redundant expressions eliminated: %6ld (%.0f%%)\n", - opt_stats.num_re, PERCENT (opt_stats.num_re, - n_exprs)); - fprintf (file, " Constants propagated: %6ld\n", - opt_stats.num_const_prop); - fprintf (file, " Copies propagated: %6ld\n", - opt_stats.num_copy_prop); - fprintf (file, "\nHash table statistics:\n"); fprintf (file, " avail_exprs: "); diff --git a/gcc/tree-ssa-reassoc.c b/gcc/tree-ssa-reassoc.c index 19e10398168..5fcaa7bbb16 100644 --- a/gcc/tree-ssa-reassoc.c +++ b/gcc/tree-ssa-reassoc.c @@ -1487,18 +1487,14 @@ init_reassoc (void) static void fini_reassoc (void) { - if (dump_file && (dump_flags & TDF_STATS)) - { - fprintf (dump_file, "Reassociation stats:\n"); - fprintf (dump_file, "Linearized: %d\n", - reassociate_stats.linearized); - fprintf (dump_file, "Constants eliminated: %d\n", - reassociate_stats.constants_eliminated); - fprintf (dump_file, "Ops eliminated: %d\n", - reassociate_stats.ops_eliminated); - fprintf (dump_file, "Statements rewritten: %d\n", - reassociate_stats.rewritten); - } + statistics_counter_event (cfun, "Linearized", + reassociate_stats.linearized); + statistics_counter_event (cfun, "Constants eliminated", + reassociate_stats.constants_eliminated); + statistics_counter_event (cfun, "Ops eliminated", + reassociate_stats.ops_eliminated); + statistics_counter_event (cfun, "Statements rewritten", + reassociate_stats.rewritten); pointer_map_destroy (operand_rank); free_alloc_pool (operand_entry_pool); diff --git a/gcc/tree-ssa-sccvn.c b/gcc/tree-ssa-sccvn.c index 0b20a4ebc72..86777c784f0 100644 --- a/gcc/tree-ssa-sccvn.c +++ b/gcc/tree-ssa-sccvn.c @@ -1947,9 +1947,7 @@ process_scc (VEC (tree, heap) *scc) changed |= visit_use (var); } - if (dump_file && (dump_flags & TDF_STATS)) - fprintf (dump_file, "Processing SCC required %d iterations\n", - iterations); + statistics_histogram_event (cfun, "SCC iterations", iterations); /* Finally, visit the SCC once using the valid table. */ current_info = valid_info; @@ -1958,6 +1956,53 @@ process_scc (VEC (tree, heap) *scc) } } +DEF_VEC_O(ssa_op_iter); +DEF_VEC_ALLOC_O(ssa_op_iter,heap); + +/* Pop the components of the found SCC for NAME off the SCC stack + and process them. Returns true if all went well, false if + we run into resource limits. */ + +static bool +extract_and_process_scc_for_name (tree name) +{ + VEC (tree, heap) *scc = NULL; + tree x; + + /* Found an SCC, pop the components off the SCC stack and + process them. */ + do + { + x = VEC_pop (tree, sccstack); + + VN_INFO (x)->on_sccstack = false; + VEC_safe_push (tree, heap, scc, x); + } while (x != name); + + /* Bail out of SCCVN in case a SCC turns out to be incredibly large. */ + if (VEC_length (tree, scc) + > (unsigned)PARAM_VALUE (PARAM_SCCVN_MAX_SCC_SIZE)) + { + if (dump_file) + fprintf (dump_file, "WARNING: Giving up with SCCVN due to " + "SCC size %u exceeding %u\n", VEC_length (tree, scc), + (unsigned)PARAM_VALUE (PARAM_SCCVN_MAX_SCC_SIZE)); + return false; + } + + if (VEC_length (tree, scc) > 1) + sort_scc (scc); + + if (dump_file && (dump_flags & TDF_DETAILS)) + print_scc (dump_file, scc); + + process_scc (scc); + + VEC_free (tree, heap, scc); + + return true; +} + /* Depth first search on NAME to discover and process SCC's in the SSA graph. Execution of this algorithm relies on the fact that the SCC's are @@ -1968,10 +2013,13 @@ process_scc (VEC (tree, heap) *scc) static bool DFS (tree name) { + VEC(ssa_op_iter, heap) *itervec = NULL; + VEC(tree, heap) *namevec = NULL; + use_operand_p usep = NULL; + tree defstmt, use; ssa_op_iter iter; - use_operand_p usep; - tree defstmt; +start_over: /* SCC info */ VN_INFO (name)->dfsnum = next_dfs_num++; VN_INFO (name)->visited = true; @@ -1984,20 +2032,63 @@ DFS (tree name) /* Recursively DFS on our operands, looking for SCC's. */ if (!IS_EMPTY_STMT (defstmt)) { - FOR_EACH_PHI_OR_STMT_USE (usep, SSA_NAME_DEF_STMT (name), iter, - SSA_OP_ALL_USES) + /* Push a new iterator. */ + if (TREE_CODE (defstmt) == PHI_NODE) + usep = op_iter_init_phiuse (&iter, defstmt, SSA_OP_ALL_USES); + else + usep = op_iter_init_use (&iter, defstmt, SSA_OP_ALL_USES); + } + else + iter.done = true; + + while (1) + { + /* If we are done processing uses of a name, go up the stack + of iterators and process SCCs as we found them. */ + if (op_iter_done (&iter)) { - tree use = USE_FROM_PTR (usep); + /* See if we found an SCC. */ + if (VN_INFO (name)->low == VN_INFO (name)->dfsnum) + if (!extract_and_process_scc_for_name (name)) + { + VEC_free (tree, heap, namevec); + VEC_free (ssa_op_iter, heap, itervec); + return false; + } - /* Since we handle phi nodes, we will sometimes get - invariants in the use expression. */ - if (TREE_CODE (use) != SSA_NAME) - continue; + /* Check if we are done. */ + if (VEC_empty (tree, namevec)) + { + VEC_free (tree, heap, namevec); + VEC_free (ssa_op_iter, heap, itervec); + return true; + } + + /* Restore the last use walker and continue walking there. */ + use = name; + name = VEC_pop (tree, namevec); + memcpy (&iter, VEC_last (ssa_op_iter, itervec), + sizeof (ssa_op_iter)); + VEC_pop (ssa_op_iter, itervec); + goto continue_walking; + } + use = USE_FROM_PTR (usep); + + /* Since we handle phi nodes, we will sometimes get + invariants in the use expression. */ + if (TREE_CODE (use) == SSA_NAME) + { if (! (VN_INFO (use)->visited)) { - if (!DFS (use)) - return false; + /* Recurse by pushing the current use walking state on + the stack and starting over. */ + VEC_safe_push(ssa_op_iter, heap, itervec, &iter); + VEC_safe_push(tree, heap, namevec, name); + name = use; + goto start_over; + +continue_walking: VN_INFO (name)->low = MIN (VN_INFO (name)->low, VN_INFO (use)->low); } @@ -2008,47 +2099,9 @@ DFS (tree name) VN_INFO (name)->low); } } - } - - /* See if we found an SCC. */ - if (VN_INFO (name)->low == VN_INFO (name)->dfsnum) - { - VEC (tree, heap) *scc = NULL; - tree x; - - /* Found an SCC, pop the components off the SCC stack and - process them. */ - do - { - x = VEC_pop (tree, sccstack); - - VN_INFO (x)->on_sccstack = false; - VEC_safe_push (tree, heap, scc, x); - } while (x != name); - - /* Bail out of SCCVN in case a SCC turns out to be incredibly large. */ - if (VEC_length (tree, scc) - > (unsigned)PARAM_VALUE (PARAM_SCCVN_MAX_SCC_SIZE)) - { - if (dump_file) - fprintf (dump_file, "WARNING: Giving up with SCCVN due to " - "SCC size %u exceeding %u\n", VEC_length (tree, scc), - (unsigned)PARAM_VALUE (PARAM_SCCVN_MAX_SCC_SIZE)); - return false; - } - if (VEC_length (tree, scc) > 1) - sort_scc (scc); - - if (dump_file && (dump_flags & TDF_DETAILS)) - print_scc (dump_file, scc); - - process_scc (scc); - - VEC_free (tree, heap, scc); + usep = op_iter_next_use (&iter); } - - return true; } /* Allocate a value number table. */ diff --git a/gcc/tree-ssa-sink.c b/gcc/tree-ssa-sink.c index 40a3640b736..8945a612663 100644 --- a/gcc/tree-ssa-sink.c +++ b/gcc/tree-ssa-sink.c @@ -546,8 +546,7 @@ execute_sink_code (void) calculate_dominance_info (CDI_DOMINATORS); calculate_dominance_info (CDI_POST_DOMINATORS); sink_code_in_bb (EXIT_BLOCK_PTR); - if (dump_file && (dump_flags & TDF_STATS)) - fprintf (dump_file, "Sunk statements:%d\n", sink_stats.sunk); + statistics_counter_event (cfun, "Sunk statements", sink_stats.sunk); free_dominance_info (CDI_POST_DOMINATORS); remove_fake_exit_edges (); loop_optimizer_finalize (); diff --git a/gcc/tree-ssa-threadupdate.c b/gcc/tree-ssa-threadupdate.c index fe3876ec332..359702161c1 100644 --- a/gcc/tree-ssa-threadupdate.c +++ b/gcc/tree-ssa-threadupdate.c @@ -1069,9 +1069,8 @@ thread_through_all_blocks (bool may_peel_loop_headers) retval |= thread_through_loop_header (loop, may_peel_loop_headers); } - if (dump_file && (dump_flags & TDF_STATS)) - fprintf (dump_file, "\nJumps threaded: %lu\n", - thread_stats.num_threaded_edges); + statistics_counter_event (cfun, "Jumps threaded", + thread_stats.num_threaded_edges); free_original_copy_tables (); diff --git a/gcc/tree-vectorizer.c b/gcc/tree-vectorizer.c index 79a7461a1a9..d374a0640d2 100644 --- a/gcc/tree-vectorizer.c +++ b/gcc/tree-vectorizer.c @@ -2691,6 +2691,7 @@ vectorize_loops (void) } vect_loop_location = UNKNOWN_LOC; + statistics_counter_event (cfun, "Vectorized loops", num_vectorized_loops); if (vect_print_dump_info (REPORT_UNVECTORIZED_LOOPS) || (vect_print_dump_info (REPORT_VECTORIZED_LOOPS) && num_vectorized_loops > 0)) diff --git a/gcc/tree-vn.c b/gcc/tree-vn.c index 40efea6f8f7..1d2e5a55de0 100644 --- a/gcc/tree-vn.c +++ b/gcc/tree-vn.c @@ -306,7 +306,9 @@ vn_lookup_with_vuses (tree expr, VEC (tree, gc) *vuses) if (is_gimple_min_invariant (expr) || TREE_CODE (expr) == FIELD_DECL) return expr; - return vn_reference_lookup (expr, vuses, true); + /* We may not walk the use-def chains here as the alias oracle cannot + properly deal with VALUE_HANDLE tree nodes we feed it here. */ + return vn_reference_lookup (expr, vuses, false); } static tree diff --git a/gcc/tree-vrp.c b/gcc/tree-vrp.c index 8636c5f4fa7..15e7ee57dd6 100644 --- a/gcc/tree-vrp.c +++ b/gcc/tree-vrp.c @@ -4540,9 +4540,8 @@ process_assert_insertions (void) if (update_edges_p) bsi_commit_edge_inserts (); - if (dump_file && (dump_flags & TDF_STATS)) - fprintf (dump_file, "\nNumber of ASSERT_EXPR expressions inserted: %d\n\n", - num_asserts); + statistics_counter_event (cfun, "Number of ASSERT_EXPR expressions inserted", + num_asserts); } diff --git a/gcc/tree.c b/gcc/tree.c index 5a0656c67ac..51eba929ff5 100644 --- a/gcc/tree.c +++ b/gcc/tree.c @@ -2516,8 +2516,7 @@ substitute_in_expr (tree exp, tree f, tree r) { enum tree_code code = TREE_CODE (exp); tree op0, op1, op2, op3; - tree new; - tree inner; + tree new, inner; /* We handle TREE_LIST and COMPONENT_REF separately. */ if (code == TREE_LIST) @@ -2627,13 +2626,15 @@ substitute_in_expr (tree exp, tree f, tree r) for (i = 1; i < TREE_OPERAND_LENGTH (exp); i++) { tree op = TREE_OPERAND (exp, i); - tree newop = SUBSTITUTE_IN_EXPR (op, f, r); - if (newop != op) + tree new_op = SUBSTITUTE_IN_EXPR (op, f, r); + if (new_op != op) { - copy = copy_node (exp); - TREE_OPERAND (copy, i) = newop; + if (!copy) + copy = copy_node (exp); + TREE_OPERAND (copy, i) = new_op; } } + if (copy) new = fold (copy); else @@ -2777,18 +2778,19 @@ substitute_placeholder_in_expr (tree exp, tree obj) { tree copy = NULL_TREE; int i; - int n = TREE_OPERAND_LENGTH (exp); - for (i = 1; i < n; i++) + + for (i = 1; i < TREE_OPERAND_LENGTH (exp); i++) { tree op = TREE_OPERAND (exp, i); - tree newop = SUBSTITUTE_PLACEHOLDER_IN_EXPR (op, obj); - if (newop != op) + tree new_op = SUBSTITUTE_PLACEHOLDER_IN_EXPR (op, obj); + if (new_op != op) { if (!copy) copy = copy_node (exp); - TREE_OPERAND (copy, i) = newop; + TREE_OPERAND (copy, i) = new_op; } } + if (copy) return fold (copy); else diff --git a/gnattools/ChangeLog b/gnattools/ChangeLog index 7375dbea33b..c9685f81db2 100644 --- a/gnattools/ChangeLog +++ b/gnattools/ChangeLog @@ -1,3 +1,8 @@ +2008-05-20 Arnaud Charlet <charlet@adacore.com> + + * Makefile.in (GNATTOOLS2_FILES): Replaced by common-tools target + in gcc/ada/Makefile.in + 2008-05-13 Arnaud Charlet <charlet@adacore.com> PR ada/31808 diff --git a/gnattools/Makefile.in b/gnattools/Makefile.in index 4c50d6e1cce..46da2df8ba7 100644 --- a/gnattools/Makefile.in +++ b/gnattools/Makefile.in @@ -146,18 +146,6 @@ TOOLS_FLAGS_TO_PASS_CROSS= \ EXTRA_GNATTOOLS = @EXTRA_GNATTOOLS@ TOOLS_TARGET_PAIRS = @TOOLS_TARGET_PAIRS@ -# These are built by gnatmake, and in both native and cross configurations. -GNATTOOLS2_FILES = \ - ../../gnatchop$(exeext) \ - ../../gnat$(exeext) \ - ../../gnatkr$(exeext) \ - ../../gnatls$(exeext) \ - ../../gnatprep$(exeext) \ - ../../gnatxref$(exeext) \ - ../../gnatfind$(exeext) \ - ../../gnatname$(exeext) \ - ../../gnatclean$(exeext) - # Makefile targets # ---------------- @@ -202,8 +190,7 @@ gnattools-native: $(GCC_DIR)/stamp-tools $(GCC_DIR)/stamp-gnatlib ../../gnatmake$(exeext) ../../gnatlink$(exeext) # gnattools2 $(MAKE) -C $(GCC_DIR)/ada/tools -f ../Makefile \ - $(TOOLS_FLAGS_TO_PASS_NATIVE) \ - $(GNATTOOLS2_FILES) + $(TOOLS_FLAGS_TO_PASS_NATIVE) common-tools # gnatmake/link can be built with recent gnatmake/link if they are available. # This is especially convenient for building cross tools or for rebuilding @@ -215,8 +202,7 @@ regnattools: $(GCC_DIR)/stamp-gnatlib gnatmake-re gnatlink-re # gnattools2 $(MAKE) -C $(GCC_DIR)/ada/tools -f ../Makefile \ - $(TOOLS_FLAGS_TO_PASS_NATIVE) \ - $(GNATTOOLS2_FILES) + $(TOOLS_FLAGS_TO_PASS_NATIVE) common-tools # For cross builds of gnattools, # put the host RTS dir first in the PATH to hide the default runtime @@ -230,8 +216,7 @@ gnattools-cross: $(GCC_DIR)/stamp-tools gnatmake-re gnatlink-re # gnattools2 $(MAKE) -C $(GCC_DIR)/ada/tools -f ../Makefile \ - $(TOOLS_FLAGS_TO_PASS_CROSS) \ - $(GNATTOOLS2_FILES) + $(TOOLS_FLAGS_TO_PASS_CROSS) common-tools # Rename cross tools to where the GCC makefile wants them when # installing. FIXME: installation should be done elsewhere. if [ -f $(GCC_DIR)/gnatbind$(exeext) ] ; then \ diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 4d095a6ddcd..671ae4be37d 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,190 @@ +2008-05-18 Thomas Koenig <tkoenig@gcc.gnu.org> + + * m4/in_pack.m4 (internal_pack_'rtype_code`): Destination + pointer is restrict. + * m4/transpose.m4 (transpose_'rtype_code`): Likewise. + * m4/pack.m4 (pack_'rtype_code`): Likewise. + * m4/spread.m4 (spread_'rtype_code`): Likewise. + (spread_scalar_'rtype_code`): Likewise. + * m4/iforeach.m4 (name`'rtype_qual`_'atype_code): Likewise. + * m4/eoshift1.m4 (eoshift1): Likewise. + * m4/eoshift3.m4 (eoshift3): Likewise. + * m4/in_unpack.m4 (internal_unpack_'rtype_ccode`): Likewise. + * m4/unpack.m4 (unpack0_'rtype_code`): Likewise. + (unpack1_'rtype_code`): Likewise. + * intrinsics/pack_generic.c (pack_generic.c): Likewise. + * intrinsics/unpack_generic.c (unpack_internal): Likewise. + * intrinsics/eoshift0.c (eoshift0): Likewise. + * intrinsics/eoshift2.c (eoshift2): Likewise. + * intrinsics/reshape_generic.c (reshape_internal): Likewise. + * intrinsics/reshape_packed.c (reshape_packed): Likewise. + * generated/eoshift1_16.c: Regenerated. + * generated/eoshift1_4.c: Regenerated. + * generated/eoshift1_8.c: Regenerated. + * generated/eoshift3_16.c: Regenerated. + * generated/eoshift3_4.c: Regenerated. + * generated/eoshift3_8.c: Regenerated. + * generated/in_pack_c10.c: Regenerated. + * generated/in_pack_c16.c: Regenerated. + * generated/in_pack_c4.c: Regenerated. + * generated/in_pack_c8.c: Regenerated. + * generated/in_pack_i1.c: Regenerated. + * generated/in_pack_i16.c: Regenerated. + * generated/in_pack_i2.c: Regenerated. + * generated/in_pack_i4.c: Regenerated. + * generated/in_pack_i8.c: Regenerated. + * generated/in_pack_r10.c: Regenerated. + * generated/in_pack_r16.c: Regenerated. + * generated/in_pack_r4.c: Regenerated. + * generated/in_pack_r8.c: Regenerated. + * generated/in_unpack_c10.c: Regenerated. + * generated/in_unpack_c16.c: Regenerated. + * generated/in_unpack_c4.c: Regenerated. + * generated/in_unpack_c8.c: Regenerated. + * generated/in_unpack_i1.c: Regenerated. + * generated/in_unpack_i16.c: Regenerated. + * generated/in_unpack_i2.c: Regenerated. + * generated/in_unpack_i4.c: Regenerated. + * generated/in_unpack_i8.c: Regenerated. + * generated/in_unpack_r10.c: Regenerated. + * generated/in_unpack_r16.c: Regenerated. + * generated/in_unpack_r4.c: Regenerated. + * generated/in_unpack_r8.c: Regenerated. + * generated/maxloc0_16_i1.c: Regenerated. + * generated/maxloc0_16_i16.c: Regenerated. + * generated/maxloc0_16_i2.c: Regenerated. + * generated/maxloc0_16_i4.c: Regenerated. + * generated/maxloc0_16_i8.c: Regenerated. + * generated/maxloc0_16_r10.c: Regenerated. + * generated/maxloc0_16_r16.c: Regenerated. + * generated/maxloc0_16_r4.c: Regenerated. + * generated/maxloc0_16_r8.c: Regenerated. + * generated/maxloc0_4_i1.c: Regenerated. + * generated/maxloc0_4_i16.c: Regenerated. + * generated/maxloc0_4_i2.c: Regenerated. + * generated/maxloc0_4_i4.c: Regenerated. + * generated/maxloc0_4_i8.c: Regenerated. + * generated/maxloc0_4_r10.c: Regenerated. + * generated/maxloc0_4_r16.c: Regenerated. + * generated/maxloc0_4_r4.c: Regenerated. + * generated/maxloc0_4_r8.c: Regenerated. + * generated/maxloc0_8_i1.c: Regenerated. + * generated/maxloc0_8_i16.c: Regenerated. + * generated/maxloc0_8_i2.c: Regenerated. + * generated/maxloc0_8_i4.c: Regenerated. + * generated/maxloc0_8_i8.c: Regenerated. + * generated/maxloc0_8_r10.c: Regenerated. + * generated/maxloc0_8_r16.c: Regenerated. + * generated/maxloc0_8_r4.c: Regenerated. + * generated/maxloc0_8_r8.c: Regenerated. + * generated/minloc0_16_i1.c: Regenerated. + * generated/minloc0_16_i16.c: Regenerated. + * generated/minloc0_16_i2.c: Regenerated. + * generated/minloc0_16_i4.c: Regenerated. + * generated/minloc0_16_i8.c: Regenerated. + * generated/minloc0_16_r10.c: Regenerated. + * generated/minloc0_16_r16.c: Regenerated. + * generated/minloc0_16_r4.c: Regenerated. + * generated/minloc0_16_r8.c: Regenerated. + * generated/minloc0_4_i1.c: Regenerated. + * generated/minloc0_4_i16.c: Regenerated. + * generated/minloc0_4_i2.c: Regenerated. + * generated/minloc0_4_i4.c: Regenerated. + * generated/minloc0_4_i8.c: Regenerated. + * generated/minloc0_4_r10.c: Regenerated. + * generated/minloc0_4_r16.c: Regenerated. + * generated/minloc0_4_r4.c: Regenerated. + * generated/minloc0_4_r8.c: Regenerated. + * generated/minloc0_8_i1.c: Regenerated. + * generated/minloc0_8_i16.c: Regenerated. + * generated/minloc0_8_i2.c: Regenerated. + * generated/minloc0_8_i4.c: Regenerated. + * generated/minloc0_8_i8.c: Regenerated. + * generated/minloc0_8_r10.c: Regenerated. + * generated/minloc0_8_r16.c: Regenerated. + * generated/minloc0_8_r4.c: Regenerated. + * generated/minloc0_8_r8.c: Regenerated. + * generated/pack_c10.c: Regenerated. + * generated/pack_c16.c: Regenerated. + * generated/pack_c4.c: Regenerated. + * generated/pack_c8.c: Regenerated. + * generated/pack_i1.c: Regenerated. + * generated/pack_i16.c: Regenerated. + * generated/pack_i2.c: Regenerated. + * generated/pack_i4.c: Regenerated. + * generated/pack_i8.c: Regenerated. + * generated/pack_r10.c: Regenerated. + * generated/pack_r16.c: Regenerated. + * generated/pack_r4.c: Regenerated. + * generated/pack_r8.c: Regenerated. + * generated/spread_c10.c: Regenerated. + * generated/spread_c16.c: Regenerated. + * generated/spread_c4.c: Regenerated. + * generated/spread_c8.c: Regenerated. + * generated/spread_i1.c: Regenerated. + * generated/spread_i16.c: Regenerated. + * generated/spread_i2.c: Regenerated. + * generated/spread_i4.c: Regenerated. + * generated/spread_i8.c: Regenerated. + * generated/spread_r10.c: Regenerated. + * generated/spread_r16.c: Regenerated. + * generated/spread_r4.c: Regenerated. + * generated/spread_r8.c: Regenerated. + * generated/transpose_c10.c: Regenerated. + * generated/transpose_c16.c: Regenerated. + * generated/transpose_c4.c: Regenerated. + * generated/transpose_c8.c: Regenerated. + * generated/transpose_i16.c: Regenerated. + * generated/transpose_i4.c: Regenerated. + * generated/transpose_i8.c: Regenerated. + * generated/transpose_r10.c: Regenerated. + * generated/transpose_r16.c: Regenerated. + * generated/transpose_r4.c: Regenerated. + * generated/transpose_r8.c: Regenerated. + * generated/unpack_c10.c: Regenerated. + * generated/unpack_c16.c: Regenerated. + * generated/unpack_c4.c: Regenerated. + * generated/unpack_c8.c: Regenerated. + * generated/unpack_i1.c: Regenerated. + * generated/unpack_i16.c: Regenerated. + * generated/unpack_i2.c: Regenerated. + * generated/unpack_i4.c: Regenerated. + * generated/unpack_i8.c: Regenerated. + * generated/unpack_r10.c: Regenerated. + * generated/unpack_r16.c: Regenerated. + * generated/unpack_r4.c: Regenerated. + * generated/unpack_r8.c: Regenerated. + +2008-05-18 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * runtime/select.c: Moved content to select_inc.c. Include it. + Add macros for different character types. + * runtime/select_inc.c: New file. + * runtime/convert_char.c: New file. + * intrinsics/pack_generic.c (pack_char4, pack_s_char4): New + functions. + * intrinsics/transpose_generic.c (transpose_char4): New function. + * intrinsics/spread_generic.c (spread_char4, spread_char4_scalar): + New functions. + * intrinsics/unpack_generic.c (unpack1_char4, unpack0_char4): + New functions. + * intrinsics/reshape_generic.c (reshape_char): Use + gfc_charlen_type as type for length variables. + (reshape_char4): New function. + * gfortran.map (GFORTRAN_1.1): Add _gfortran_select_string_char4, + _gfortran_convert_char1_to_char4, _gfortran_convert_char4_to_char1, + _gfortran_transpose_char4, _gfortran_spread_char4, + _gfortran_spread_char4_scalar, _gfortran_reshape_char4, + _gfortran_pack_char4, _gfortran_pack_s_char4, + _gfortran_unpack0_char4 and _gfortran_unpack1_char4. + * Makefile.am: Add runtime/convert_char.c. + * Makefile.in: Regenerate. + +2008-05-17 Thomas Koenig <tkoenig@gcc.gnu.org> + + * io/list_read.c (list_formatted_read_scalar): Declare + type as volatile to shut up compiler warning. + 2008-05-16 Janne Blomqvist <jb@gcc.gnu.org> PR libfortran/25561 diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am index ed7ad21801c..65a307af4bc 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -118,6 +118,7 @@ runtime/in_unpack_generic.c gfor_src= \ runtime/backtrace.c \ runtime/compile_options.c \ +runtime/convert_char.c \ runtime/environ.c \ runtime/error.c \ runtime/fpu.c \ diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index 1db39915eab..594d22863c8 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -79,15 +79,15 @@ toolexeclibLTLIBRARIES_INSTALL = $(INSTALL) LTLIBRARIES = $(myexeclib_LTLIBRARIES) $(toolexeclib_LTLIBRARIES) libgfortran_la_LIBADD = am__libgfortran_la_SOURCES_DIST = runtime/backtrace.c \ - runtime/compile_options.c runtime/environ.c runtime/error.c \ - runtime/fpu.c runtime/main.c runtime/memory.c runtime/pause.c \ - runtime/stop.c runtime/string.c runtime/select.c \ - $(srcdir)/generated/all_l1.c $(srcdir)/generated/all_l2.c \ - $(srcdir)/generated/all_l4.c $(srcdir)/generated/all_l8.c \ - $(srcdir)/generated/all_l16.c $(srcdir)/generated/any_l1.c \ - $(srcdir)/generated/any_l2.c $(srcdir)/generated/any_l4.c \ - $(srcdir)/generated/any_l8.c $(srcdir)/generated/any_l16.c \ - $(srcdir)/generated/count_1_l.c \ + runtime/compile_options.c runtime/convert_char.c \ + runtime/environ.c runtime/error.c runtime/fpu.c runtime/main.c \ + runtime/memory.c runtime/pause.c runtime/stop.c \ + runtime/string.c runtime/select.c $(srcdir)/generated/all_l1.c \ + $(srcdir)/generated/all_l2.c $(srcdir)/generated/all_l4.c \ + $(srcdir)/generated/all_l8.c $(srcdir)/generated/all_l16.c \ + $(srcdir)/generated/any_l1.c $(srcdir)/generated/any_l2.c \ + $(srcdir)/generated/any_l4.c $(srcdir)/generated/any_l8.c \ + $(srcdir)/generated/any_l16.c $(srcdir)/generated/count_1_l.c \ $(srcdir)/generated/count_2_l.c \ $(srcdir)/generated/count_4_l.c \ $(srcdir)/generated/count_8_l.c \ @@ -567,8 +567,9 @@ am__libgfortran_la_SOURCES_DIST = runtime/backtrace.c \ $(srcdir)/generated/misc_specifics.F90 intrinsics/dprod_r8.f90 \ intrinsics/f2c_specifics.F90 libgfortran_c.c $(filter-out \ %.c,$(prereq_SRC)) -am__objects_1 = backtrace.lo compile_options.lo environ.lo error.lo \ - fpu.lo main.lo memory.lo pause.lo stop.lo string.lo select.lo +am__objects_1 = backtrace.lo compile_options.lo convert_char.lo \ + environ.lo error.lo fpu.lo main.lo memory.lo pause.lo stop.lo \ + string.lo select.lo am__objects_2 = all_l1.lo all_l2.lo all_l4.lo all_l8.lo all_l16.lo am__objects_3 = any_l1.lo any_l2.lo any_l4.lo any_l8.lo any_l16.lo am__objects_4 = count_1_l.lo count_2_l.lo count_4_l.lo count_8_l.lo \ @@ -1017,6 +1018,7 @@ runtime/in_unpack_generic.c gfor_src = \ runtime/backtrace.c \ runtime/compile_options.c \ +runtime/convert_char.c \ runtime/environ.c \ runtime/error.c \ runtime/fpu.c \ @@ -1761,6 +1763,7 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/clock.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/close.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/compile_options.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/convert_char.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/count_16_l.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/count_1_l.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/count_2_l.Plo@am__quote@ @@ -2620,6 +2623,13 @@ compile_options.lo: runtime/compile_options.c @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o compile_options.lo `test -f 'runtime/compile_options.c' || echo '$(srcdir)/'`runtime/compile_options.c +convert_char.lo: runtime/convert_char.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT convert_char.lo -MD -MP -MF "$(DEPDIR)/convert_char.Tpo" -c -o convert_char.lo `test -f 'runtime/convert_char.c' || echo '$(srcdir)/'`runtime/convert_char.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/convert_char.Tpo" "$(DEPDIR)/convert_char.Plo"; else rm -f "$(DEPDIR)/convert_char.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='runtime/convert_char.c' object='convert_char.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o convert_char.lo `test -f 'runtime/convert_char.c' || echo '$(srcdir)/'`runtime/convert_char.c + environ.lo: runtime/environ.c @am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT environ.lo -MD -MP -MF "$(DEPDIR)/environ.Tpo" -c -o environ.lo `test -f 'runtime/environ.c' || echo '$(srcdir)/'`runtime/environ.c; \ @am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/environ.Tpo" "$(DEPDIR)/environ.Plo"; else rm -f "$(DEPDIR)/environ.Tpo"; exit 1; fi diff --git a/libgfortran/generated/eoshift1_16.c b/libgfortran/generated/eoshift1_16.c index 628fa0ccca3..e16db209e3d 100644 --- a/libgfortran/generated/eoshift1_16.c +++ b/libgfortran/generated/eoshift1_16.c @@ -49,7 +49,7 @@ eoshift1 (gfc_array_char * const restrict ret, index_type rstride0; index_type roffset; char *rptr; - char *dest; + char * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/eoshift1_4.c b/libgfortran/generated/eoshift1_4.c index 6253c6f2cf0..11cc71fc917 100644 --- a/libgfortran/generated/eoshift1_4.c +++ b/libgfortran/generated/eoshift1_4.c @@ -49,7 +49,7 @@ eoshift1 (gfc_array_char * const restrict ret, index_type rstride0; index_type roffset; char *rptr; - char *dest; + char * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/eoshift1_8.c b/libgfortran/generated/eoshift1_8.c index 983e1bf7523..4b7d0e04f31 100644 --- a/libgfortran/generated/eoshift1_8.c +++ b/libgfortran/generated/eoshift1_8.c @@ -49,7 +49,7 @@ eoshift1 (gfc_array_char * const restrict ret, index_type rstride0; index_type roffset; char *rptr; - char *dest; + char * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/eoshift3_16.c b/libgfortran/generated/eoshift3_16.c index 0898455cb1b..1dda668d47b 100644 --- a/libgfortran/generated/eoshift3_16.c +++ b/libgfortran/generated/eoshift3_16.c @@ -49,7 +49,7 @@ eoshift3 (gfc_array_char * const restrict ret, index_type rstride0; index_type roffset; char *rptr; - char *dest; + char * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/eoshift3_4.c b/libgfortran/generated/eoshift3_4.c index 7f35a4c80f8..aa46f7c5a10 100644 --- a/libgfortran/generated/eoshift3_4.c +++ b/libgfortran/generated/eoshift3_4.c @@ -49,7 +49,7 @@ eoshift3 (gfc_array_char * const restrict ret, index_type rstride0; index_type roffset; char *rptr; - char *dest; + char * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/eoshift3_8.c b/libgfortran/generated/eoshift3_8.c index 1792507f6fb..04e81b8eb39 100644 --- a/libgfortran/generated/eoshift3_8.c +++ b/libgfortran/generated/eoshift3_8.c @@ -49,7 +49,7 @@ eoshift3 (gfc_array_char * const restrict ret, index_type rstride0; index_type roffset; char *rptr; - char *dest; + char * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/in_pack_c10.c b/libgfortran/generated/in_pack_c10.c index 60029536bf2..594393b8cb2 100644 --- a/libgfortran/generated/in_pack_c10.c +++ b/libgfortran/generated/in_pack_c10.c @@ -48,7 +48,7 @@ internal_pack_c10 (gfc_array_c10 * source) index_type dim; index_type ssize; const GFC_COMPLEX_10 *src; - GFC_COMPLEX_10 *dest; + GFC_COMPLEX_10 * restrict dest; GFC_COMPLEX_10 *destptr; int n; int packed; diff --git a/libgfortran/generated/in_pack_c16.c b/libgfortran/generated/in_pack_c16.c index 560a574df91..846545d9ad0 100644 --- a/libgfortran/generated/in_pack_c16.c +++ b/libgfortran/generated/in_pack_c16.c @@ -48,7 +48,7 @@ internal_pack_c16 (gfc_array_c16 * source) index_type dim; index_type ssize; const GFC_COMPLEX_16 *src; - GFC_COMPLEX_16 *dest; + GFC_COMPLEX_16 * restrict dest; GFC_COMPLEX_16 *destptr; int n; int packed; diff --git a/libgfortran/generated/in_pack_c4.c b/libgfortran/generated/in_pack_c4.c index ea608d7b8b4..bf1a4d6c18e 100644 --- a/libgfortran/generated/in_pack_c4.c +++ b/libgfortran/generated/in_pack_c4.c @@ -48,7 +48,7 @@ internal_pack_c4 (gfc_array_c4 * source) index_type dim; index_type ssize; const GFC_COMPLEX_4 *src; - GFC_COMPLEX_4 *dest; + GFC_COMPLEX_4 * restrict dest; GFC_COMPLEX_4 *destptr; int n; int packed; diff --git a/libgfortran/generated/in_pack_c8.c b/libgfortran/generated/in_pack_c8.c index 7e8203ee933..3462f5c57d2 100644 --- a/libgfortran/generated/in_pack_c8.c +++ b/libgfortran/generated/in_pack_c8.c @@ -48,7 +48,7 @@ internal_pack_c8 (gfc_array_c8 * source) index_type dim; index_type ssize; const GFC_COMPLEX_8 *src; - GFC_COMPLEX_8 *dest; + GFC_COMPLEX_8 * restrict dest; GFC_COMPLEX_8 *destptr; int n; int packed; diff --git a/libgfortran/generated/in_pack_i1.c b/libgfortran/generated/in_pack_i1.c index b5be016cf37..840918f6e64 100644 --- a/libgfortran/generated/in_pack_i1.c +++ b/libgfortran/generated/in_pack_i1.c @@ -48,7 +48,7 @@ internal_pack_1 (gfc_array_i1 * source) index_type dim; index_type ssize; const GFC_INTEGER_1 *src; - GFC_INTEGER_1 *dest; + GFC_INTEGER_1 * restrict dest; GFC_INTEGER_1 *destptr; int n; int packed; diff --git a/libgfortran/generated/in_pack_i16.c b/libgfortran/generated/in_pack_i16.c index eb729b6d38c..4620b19fb58 100644 --- a/libgfortran/generated/in_pack_i16.c +++ b/libgfortran/generated/in_pack_i16.c @@ -48,7 +48,7 @@ internal_pack_16 (gfc_array_i16 * source) index_type dim; index_type ssize; const GFC_INTEGER_16 *src; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; GFC_INTEGER_16 *destptr; int n; int packed; diff --git a/libgfortran/generated/in_pack_i2.c b/libgfortran/generated/in_pack_i2.c index 240409a357e..4650f6a9f8c 100644 --- a/libgfortran/generated/in_pack_i2.c +++ b/libgfortran/generated/in_pack_i2.c @@ -48,7 +48,7 @@ internal_pack_2 (gfc_array_i2 * source) index_type dim; index_type ssize; const GFC_INTEGER_2 *src; - GFC_INTEGER_2 *dest; + GFC_INTEGER_2 * restrict dest; GFC_INTEGER_2 *destptr; int n; int packed; diff --git a/libgfortran/generated/in_pack_i4.c b/libgfortran/generated/in_pack_i4.c index 0e3bf2302b7..b773a0cf4b6 100644 --- a/libgfortran/generated/in_pack_i4.c +++ b/libgfortran/generated/in_pack_i4.c @@ -48,7 +48,7 @@ internal_pack_4 (gfc_array_i4 * source) index_type dim; index_type ssize; const GFC_INTEGER_4 *src; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; GFC_INTEGER_4 *destptr; int n; int packed; diff --git a/libgfortran/generated/in_pack_i8.c b/libgfortran/generated/in_pack_i8.c index e2337ffdb2b..99677256525 100644 --- a/libgfortran/generated/in_pack_i8.c +++ b/libgfortran/generated/in_pack_i8.c @@ -48,7 +48,7 @@ internal_pack_8 (gfc_array_i8 * source) index_type dim; index_type ssize; const GFC_INTEGER_8 *src; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; GFC_INTEGER_8 *destptr; int n; int packed; diff --git a/libgfortran/generated/in_pack_r10.c b/libgfortran/generated/in_pack_r10.c index 892c6bb9dc5..d8dfcc6da6e 100644 --- a/libgfortran/generated/in_pack_r10.c +++ b/libgfortran/generated/in_pack_r10.c @@ -48,7 +48,7 @@ internal_pack_r10 (gfc_array_r10 * source) index_type dim; index_type ssize; const GFC_REAL_10 *src; - GFC_REAL_10 *dest; + GFC_REAL_10 * restrict dest; GFC_REAL_10 *destptr; int n; int packed; diff --git a/libgfortran/generated/in_pack_r16.c b/libgfortran/generated/in_pack_r16.c index 15ab585050f..95cdc9c7520 100644 --- a/libgfortran/generated/in_pack_r16.c +++ b/libgfortran/generated/in_pack_r16.c @@ -48,7 +48,7 @@ internal_pack_r16 (gfc_array_r16 * source) index_type dim; index_type ssize; const GFC_REAL_16 *src; - GFC_REAL_16 *dest; + GFC_REAL_16 * restrict dest; GFC_REAL_16 *destptr; int n; int packed; diff --git a/libgfortran/generated/in_pack_r4.c b/libgfortran/generated/in_pack_r4.c index a1f352c4fdd..eb68180e51c 100644 --- a/libgfortran/generated/in_pack_r4.c +++ b/libgfortran/generated/in_pack_r4.c @@ -48,7 +48,7 @@ internal_pack_r4 (gfc_array_r4 * source) index_type dim; index_type ssize; const GFC_REAL_4 *src; - GFC_REAL_4 *dest; + GFC_REAL_4 * restrict dest; GFC_REAL_4 *destptr; int n; int packed; diff --git a/libgfortran/generated/in_pack_r8.c b/libgfortran/generated/in_pack_r8.c index 76cee7afe86..cfa861ca167 100644 --- a/libgfortran/generated/in_pack_r8.c +++ b/libgfortran/generated/in_pack_r8.c @@ -48,7 +48,7 @@ internal_pack_r8 (gfc_array_r8 * source) index_type dim; index_type ssize; const GFC_REAL_8 *src; - GFC_REAL_8 *dest; + GFC_REAL_8 * restrict dest; GFC_REAL_8 *destptr; int n; int packed; diff --git a/libgfortran/generated/in_unpack_c10.c b/libgfortran/generated/in_unpack_c10.c index 078fab0cd38..2d971bf14cc 100644 --- a/libgfortran/generated/in_unpack_c10.c +++ b/libgfortran/generated/in_unpack_c10.c @@ -45,7 +45,7 @@ internal_unpack_c10 (gfc_array_c10 * d, const GFC_COMPLEX_10 * src) index_type stride0; index_type dim; index_type dsize; - GFC_COMPLEX_10 *dest; + GFC_COMPLEX_10 * restrict dest; int n; dest = d->data; diff --git a/libgfortran/generated/in_unpack_c16.c b/libgfortran/generated/in_unpack_c16.c index 3adc947b673..f09b0b44faf 100644 --- a/libgfortran/generated/in_unpack_c16.c +++ b/libgfortran/generated/in_unpack_c16.c @@ -45,7 +45,7 @@ internal_unpack_c16 (gfc_array_c16 * d, const GFC_COMPLEX_16 * src) index_type stride0; index_type dim; index_type dsize; - GFC_COMPLEX_16 *dest; + GFC_COMPLEX_16 * restrict dest; int n; dest = d->data; diff --git a/libgfortran/generated/in_unpack_c4.c b/libgfortran/generated/in_unpack_c4.c index 32bcddb7c9e..ed77a700ebf 100644 --- a/libgfortran/generated/in_unpack_c4.c +++ b/libgfortran/generated/in_unpack_c4.c @@ -45,7 +45,7 @@ internal_unpack_c4 (gfc_array_c4 * d, const GFC_COMPLEX_4 * src) index_type stride0; index_type dim; index_type dsize; - GFC_COMPLEX_4 *dest; + GFC_COMPLEX_4 * restrict dest; int n; dest = d->data; diff --git a/libgfortran/generated/in_unpack_c8.c b/libgfortran/generated/in_unpack_c8.c index 5c88e975672..e1fada33802 100644 --- a/libgfortran/generated/in_unpack_c8.c +++ b/libgfortran/generated/in_unpack_c8.c @@ -45,7 +45,7 @@ internal_unpack_c8 (gfc_array_c8 * d, const GFC_COMPLEX_8 * src) index_type stride0; index_type dim; index_type dsize; - GFC_COMPLEX_8 *dest; + GFC_COMPLEX_8 * restrict dest; int n; dest = d->data; diff --git a/libgfortran/generated/in_unpack_i1.c b/libgfortran/generated/in_unpack_i1.c index 4b455b73d28..0e7ab116125 100644 --- a/libgfortran/generated/in_unpack_i1.c +++ b/libgfortran/generated/in_unpack_i1.c @@ -45,7 +45,7 @@ internal_unpack_1 (gfc_array_i1 * d, const GFC_INTEGER_1 * src) index_type stride0; index_type dim; index_type dsize; - GFC_INTEGER_1 *dest; + GFC_INTEGER_1 * restrict dest; int n; dest = d->data; diff --git a/libgfortran/generated/in_unpack_i16.c b/libgfortran/generated/in_unpack_i16.c index 82f535eb3ba..36584859dbe 100644 --- a/libgfortran/generated/in_unpack_i16.c +++ b/libgfortran/generated/in_unpack_i16.c @@ -45,7 +45,7 @@ internal_unpack_16 (gfc_array_i16 * d, const GFC_INTEGER_16 * src) index_type stride0; index_type dim; index_type dsize; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; int n; dest = d->data; diff --git a/libgfortran/generated/in_unpack_i2.c b/libgfortran/generated/in_unpack_i2.c index 91e6fca9ded..246c3f3999d 100644 --- a/libgfortran/generated/in_unpack_i2.c +++ b/libgfortran/generated/in_unpack_i2.c @@ -45,7 +45,7 @@ internal_unpack_2 (gfc_array_i2 * d, const GFC_INTEGER_2 * src) index_type stride0; index_type dim; index_type dsize; - GFC_INTEGER_2 *dest; + GFC_INTEGER_2 * restrict dest; int n; dest = d->data; diff --git a/libgfortran/generated/in_unpack_i4.c b/libgfortran/generated/in_unpack_i4.c index 8d808db6686..d0c0f15640e 100644 --- a/libgfortran/generated/in_unpack_i4.c +++ b/libgfortran/generated/in_unpack_i4.c @@ -45,7 +45,7 @@ internal_unpack_4 (gfc_array_i4 * d, const GFC_INTEGER_4 * src) index_type stride0; index_type dim; index_type dsize; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; int n; dest = d->data; diff --git a/libgfortran/generated/in_unpack_i8.c b/libgfortran/generated/in_unpack_i8.c index 39482b82705..5f2975e7432 100644 --- a/libgfortran/generated/in_unpack_i8.c +++ b/libgfortran/generated/in_unpack_i8.c @@ -45,7 +45,7 @@ internal_unpack_8 (gfc_array_i8 * d, const GFC_INTEGER_8 * src) index_type stride0; index_type dim; index_type dsize; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; int n; dest = d->data; diff --git a/libgfortran/generated/in_unpack_r10.c b/libgfortran/generated/in_unpack_r10.c index 5514763146f..66ebe82663d 100644 --- a/libgfortran/generated/in_unpack_r10.c +++ b/libgfortran/generated/in_unpack_r10.c @@ -45,7 +45,7 @@ internal_unpack_r10 (gfc_array_r10 * d, const GFC_REAL_10 * src) index_type stride0; index_type dim; index_type dsize; - GFC_REAL_10 *dest; + GFC_REAL_10 * restrict dest; int n; dest = d->data; diff --git a/libgfortran/generated/in_unpack_r16.c b/libgfortran/generated/in_unpack_r16.c index 3abe19df076..722dee76af5 100644 --- a/libgfortran/generated/in_unpack_r16.c +++ b/libgfortran/generated/in_unpack_r16.c @@ -45,7 +45,7 @@ internal_unpack_r16 (gfc_array_r16 * d, const GFC_REAL_16 * src) index_type stride0; index_type dim; index_type dsize; - GFC_REAL_16 *dest; + GFC_REAL_16 * restrict dest; int n; dest = d->data; diff --git a/libgfortran/generated/in_unpack_r4.c b/libgfortran/generated/in_unpack_r4.c index c3c27425095..65bdb078c96 100644 --- a/libgfortran/generated/in_unpack_r4.c +++ b/libgfortran/generated/in_unpack_r4.c @@ -45,7 +45,7 @@ internal_unpack_r4 (gfc_array_r4 * d, const GFC_REAL_4 * src) index_type stride0; index_type dim; index_type dsize; - GFC_REAL_4 *dest; + GFC_REAL_4 * restrict dest; int n; dest = d->data; diff --git a/libgfortran/generated/in_unpack_r8.c b/libgfortran/generated/in_unpack_r8.c index 9ece8b0a4d2..70c11b5f54f 100644 --- a/libgfortran/generated/in_unpack_r8.c +++ b/libgfortran/generated/in_unpack_r8.c @@ -45,7 +45,7 @@ internal_unpack_r8 (gfc_array_r8 * d, const GFC_REAL_8 * src) index_type stride0; index_type dim; index_type dsize; - GFC_REAL_8 *dest; + GFC_REAL_8 * restrict dest; int n; dest = d->data; diff --git a/libgfortran/generated/maxloc0_16_i1.c b/libgfortran/generated/maxloc0_16_i1.c index 7fc44432fa4..6be5448fc63 100644 --- a/libgfortran/generated/maxloc0_16_i1.c +++ b/libgfortran/generated/maxloc0_16_i1.c @@ -50,7 +50,7 @@ maxloc0_16_i1 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_1 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_16_i16.c b/libgfortran/generated/maxloc0_16_i16.c index 29eb3ccecf1..777d3d02e9d 100644 --- a/libgfortran/generated/maxloc0_16_i16.c +++ b/libgfortran/generated/maxloc0_16_i16.c @@ -50,7 +50,7 @@ maxloc0_16_i16 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_16 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_16_i2.c b/libgfortran/generated/maxloc0_16_i2.c index 30b693c1068..11b14787962 100644 --- a/libgfortran/generated/maxloc0_16_i2.c +++ b/libgfortran/generated/maxloc0_16_i2.c @@ -50,7 +50,7 @@ maxloc0_16_i2 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_2 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_16_i4.c b/libgfortran/generated/maxloc0_16_i4.c index 03f2794f30b..0c1ff86e9b0 100644 --- a/libgfortran/generated/maxloc0_16_i4.c +++ b/libgfortran/generated/maxloc0_16_i4.c @@ -50,7 +50,7 @@ maxloc0_16_i4 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_4 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_16_i8.c b/libgfortran/generated/maxloc0_16_i8.c index be18af39ce8..b2098a73701 100644 --- a/libgfortran/generated/maxloc0_16_i8.c +++ b/libgfortran/generated/maxloc0_16_i8.c @@ -50,7 +50,7 @@ maxloc0_16_i8 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_8 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_16_r10.c b/libgfortran/generated/maxloc0_16_r10.c index 48ba77e8732..1773c679d6d 100644 --- a/libgfortran/generated/maxloc0_16_r10.c +++ b/libgfortran/generated/maxloc0_16_r10.c @@ -50,7 +50,7 @@ maxloc0_16_r10 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_10 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_16_r16.c b/libgfortran/generated/maxloc0_16_r16.c index 9d2ce087015..3eeaefa0a0b 100644 --- a/libgfortran/generated/maxloc0_16_r16.c +++ b/libgfortran/generated/maxloc0_16_r16.c @@ -50,7 +50,7 @@ maxloc0_16_r16 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_16 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_16_r4.c b/libgfortran/generated/maxloc0_16_r4.c index e908dadcdd0..09e97bcb378 100644 --- a/libgfortran/generated/maxloc0_16_r4.c +++ b/libgfortran/generated/maxloc0_16_r4.c @@ -50,7 +50,7 @@ maxloc0_16_r4 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_4 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_16_r8.c b/libgfortran/generated/maxloc0_16_r8.c index cb01745a44c..764cb57a16e 100644 --- a/libgfortran/generated/maxloc0_16_r8.c +++ b/libgfortran/generated/maxloc0_16_r8.c @@ -50,7 +50,7 @@ maxloc0_16_r8 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_8 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_4_i1.c b/libgfortran/generated/maxloc0_4_i1.c index 21ab578c402..45d175d00af 100644 --- a/libgfortran/generated/maxloc0_4_i1.c +++ b/libgfortran/generated/maxloc0_4_i1.c @@ -50,7 +50,7 @@ maxloc0_4_i1 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_1 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_4_i16.c b/libgfortran/generated/maxloc0_4_i16.c index 6803420884c..a34654066f8 100644 --- a/libgfortran/generated/maxloc0_4_i16.c +++ b/libgfortran/generated/maxloc0_4_i16.c @@ -50,7 +50,7 @@ maxloc0_4_i16 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_16 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_4_i2.c b/libgfortran/generated/maxloc0_4_i2.c index 27cccae9784..36a1da39290 100644 --- a/libgfortran/generated/maxloc0_4_i2.c +++ b/libgfortran/generated/maxloc0_4_i2.c @@ -50,7 +50,7 @@ maxloc0_4_i2 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_2 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_4_i4.c b/libgfortran/generated/maxloc0_4_i4.c index 650da03a1ed..398ffb55dec 100644 --- a/libgfortran/generated/maxloc0_4_i4.c +++ b/libgfortran/generated/maxloc0_4_i4.c @@ -50,7 +50,7 @@ maxloc0_4_i4 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_4 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_4_i8.c b/libgfortran/generated/maxloc0_4_i8.c index 48e1d3e5215..dcf74810989 100644 --- a/libgfortran/generated/maxloc0_4_i8.c +++ b/libgfortran/generated/maxloc0_4_i8.c @@ -50,7 +50,7 @@ maxloc0_4_i8 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_8 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_4_r10.c b/libgfortran/generated/maxloc0_4_r10.c index 05e31659238..1f22f07e86c 100644 --- a/libgfortran/generated/maxloc0_4_r10.c +++ b/libgfortran/generated/maxloc0_4_r10.c @@ -50,7 +50,7 @@ maxloc0_4_r10 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_10 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_4_r16.c b/libgfortran/generated/maxloc0_4_r16.c index 38cf3527282..71f171c64bb 100644 --- a/libgfortran/generated/maxloc0_4_r16.c +++ b/libgfortran/generated/maxloc0_4_r16.c @@ -50,7 +50,7 @@ maxloc0_4_r16 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_16 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_4_r4.c b/libgfortran/generated/maxloc0_4_r4.c index 5ab9429028e..d52e4836077 100644 --- a/libgfortran/generated/maxloc0_4_r4.c +++ b/libgfortran/generated/maxloc0_4_r4.c @@ -50,7 +50,7 @@ maxloc0_4_r4 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_4 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_4_r8.c b/libgfortran/generated/maxloc0_4_r8.c index 2658e4a5b9a..50304818801 100644 --- a/libgfortran/generated/maxloc0_4_r8.c +++ b/libgfortran/generated/maxloc0_4_r8.c @@ -50,7 +50,7 @@ maxloc0_4_r8 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_8 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_8_i1.c b/libgfortran/generated/maxloc0_8_i1.c index ce71eb1ebbd..1eabde6883d 100644 --- a/libgfortran/generated/maxloc0_8_i1.c +++ b/libgfortran/generated/maxloc0_8_i1.c @@ -50,7 +50,7 @@ maxloc0_8_i1 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_1 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_8_i16.c b/libgfortran/generated/maxloc0_8_i16.c index e808a91cf59..6630c06171f 100644 --- a/libgfortran/generated/maxloc0_8_i16.c +++ b/libgfortran/generated/maxloc0_8_i16.c @@ -50,7 +50,7 @@ maxloc0_8_i16 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_16 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_8_i2.c b/libgfortran/generated/maxloc0_8_i2.c index 8bc1961ea3a..bc438e55063 100644 --- a/libgfortran/generated/maxloc0_8_i2.c +++ b/libgfortran/generated/maxloc0_8_i2.c @@ -50,7 +50,7 @@ maxloc0_8_i2 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_2 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_8_i4.c b/libgfortran/generated/maxloc0_8_i4.c index 8b6d2128a5d..7cac2815702 100644 --- a/libgfortran/generated/maxloc0_8_i4.c +++ b/libgfortran/generated/maxloc0_8_i4.c @@ -50,7 +50,7 @@ maxloc0_8_i4 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_4 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_8_i8.c b/libgfortran/generated/maxloc0_8_i8.c index 121827eabb3..15798f83150 100644 --- a/libgfortran/generated/maxloc0_8_i8.c +++ b/libgfortran/generated/maxloc0_8_i8.c @@ -50,7 +50,7 @@ maxloc0_8_i8 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_8 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_8_r10.c b/libgfortran/generated/maxloc0_8_r10.c index 8fb4b13eb69..fc393e9552c 100644 --- a/libgfortran/generated/maxloc0_8_r10.c +++ b/libgfortran/generated/maxloc0_8_r10.c @@ -50,7 +50,7 @@ maxloc0_8_r10 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_10 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_8_r16.c b/libgfortran/generated/maxloc0_8_r16.c index 7a5a4f354af..99d31ff3077 100644 --- a/libgfortran/generated/maxloc0_8_r16.c +++ b/libgfortran/generated/maxloc0_8_r16.c @@ -50,7 +50,7 @@ maxloc0_8_r16 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_16 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_8_r4.c b/libgfortran/generated/maxloc0_8_r4.c index 8e02dcb7718..ced61aec3b9 100644 --- a/libgfortran/generated/maxloc0_8_r4.c +++ b/libgfortran/generated/maxloc0_8_r4.c @@ -50,7 +50,7 @@ maxloc0_8_r4 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_4 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/maxloc0_8_r8.c b/libgfortran/generated/maxloc0_8_r8.c index c539df0596d..8222c5c02f8 100644 --- a/libgfortran/generated/maxloc0_8_r8.c +++ b/libgfortran/generated/maxloc0_8_r8.c @@ -50,7 +50,7 @@ maxloc0_8_r8 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_8 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_16_i1.c b/libgfortran/generated/minloc0_16_i1.c index d0d6903bf41..41924a3999a 100644 --- a/libgfortran/generated/minloc0_16_i1.c +++ b/libgfortran/generated/minloc0_16_i1.c @@ -50,7 +50,7 @@ minloc0_16_i1 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_1 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_16_i16.c b/libgfortran/generated/minloc0_16_i16.c index 59c1d0abbf8..655d587b8c8 100644 --- a/libgfortran/generated/minloc0_16_i16.c +++ b/libgfortran/generated/minloc0_16_i16.c @@ -50,7 +50,7 @@ minloc0_16_i16 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_16 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_16_i2.c b/libgfortran/generated/minloc0_16_i2.c index 0df6bd189c5..bca08a5f6a3 100644 --- a/libgfortran/generated/minloc0_16_i2.c +++ b/libgfortran/generated/minloc0_16_i2.c @@ -50,7 +50,7 @@ minloc0_16_i2 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_2 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_16_i4.c b/libgfortran/generated/minloc0_16_i4.c index 48bb60be737..50105af002a 100644 --- a/libgfortran/generated/minloc0_16_i4.c +++ b/libgfortran/generated/minloc0_16_i4.c @@ -50,7 +50,7 @@ minloc0_16_i4 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_4 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_16_i8.c b/libgfortran/generated/minloc0_16_i8.c index b92f7e43031..d12663f1436 100644 --- a/libgfortran/generated/minloc0_16_i8.c +++ b/libgfortran/generated/minloc0_16_i8.c @@ -50,7 +50,7 @@ minloc0_16_i8 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_8 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_16_r10.c b/libgfortran/generated/minloc0_16_r10.c index 6480a8dd681..9c93f144cd7 100644 --- a/libgfortran/generated/minloc0_16_r10.c +++ b/libgfortran/generated/minloc0_16_r10.c @@ -50,7 +50,7 @@ minloc0_16_r10 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_10 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_16_r16.c b/libgfortran/generated/minloc0_16_r16.c index 325c8f68d50..83624d2e436 100644 --- a/libgfortran/generated/minloc0_16_r16.c +++ b/libgfortran/generated/minloc0_16_r16.c @@ -50,7 +50,7 @@ minloc0_16_r16 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_16 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_16_r4.c b/libgfortran/generated/minloc0_16_r4.c index 2376d4034b6..4225805d991 100644 --- a/libgfortran/generated/minloc0_16_r4.c +++ b/libgfortran/generated/minloc0_16_r4.c @@ -50,7 +50,7 @@ minloc0_16_r4 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_4 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_16_r8.c b/libgfortran/generated/minloc0_16_r8.c index e72abab2c5b..74c5358e4fc 100644 --- a/libgfortran/generated/minloc0_16_r8.c +++ b/libgfortran/generated/minloc0_16_r8.c @@ -50,7 +50,7 @@ minloc0_16_r8 (gfc_array_i16 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_8 *base; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_4_i1.c b/libgfortran/generated/minloc0_4_i1.c index ce045a28e73..53ddea210c6 100644 --- a/libgfortran/generated/minloc0_4_i1.c +++ b/libgfortran/generated/minloc0_4_i1.c @@ -50,7 +50,7 @@ minloc0_4_i1 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_1 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_4_i16.c b/libgfortran/generated/minloc0_4_i16.c index 9ae856e686c..88c5a0ab542 100644 --- a/libgfortran/generated/minloc0_4_i16.c +++ b/libgfortran/generated/minloc0_4_i16.c @@ -50,7 +50,7 @@ minloc0_4_i16 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_16 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_4_i2.c b/libgfortran/generated/minloc0_4_i2.c index c33e99cfedb..2db4557979f 100644 --- a/libgfortran/generated/minloc0_4_i2.c +++ b/libgfortran/generated/minloc0_4_i2.c @@ -50,7 +50,7 @@ minloc0_4_i2 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_2 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_4_i4.c b/libgfortran/generated/minloc0_4_i4.c index 9d7eda6c839..49e74f527e9 100644 --- a/libgfortran/generated/minloc0_4_i4.c +++ b/libgfortran/generated/minloc0_4_i4.c @@ -50,7 +50,7 @@ minloc0_4_i4 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_4 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_4_i8.c b/libgfortran/generated/minloc0_4_i8.c index 046e040daf0..2be844fec89 100644 --- a/libgfortran/generated/minloc0_4_i8.c +++ b/libgfortran/generated/minloc0_4_i8.c @@ -50,7 +50,7 @@ minloc0_4_i8 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_8 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_4_r10.c b/libgfortran/generated/minloc0_4_r10.c index 8f7b9247868..a1d390c00b7 100644 --- a/libgfortran/generated/minloc0_4_r10.c +++ b/libgfortran/generated/minloc0_4_r10.c @@ -50,7 +50,7 @@ minloc0_4_r10 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_10 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_4_r16.c b/libgfortran/generated/minloc0_4_r16.c index 1539192ca15..e4ecd12febc 100644 --- a/libgfortran/generated/minloc0_4_r16.c +++ b/libgfortran/generated/minloc0_4_r16.c @@ -50,7 +50,7 @@ minloc0_4_r16 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_16 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_4_r4.c b/libgfortran/generated/minloc0_4_r4.c index 86ffdb8c6ef..a115c017d17 100644 --- a/libgfortran/generated/minloc0_4_r4.c +++ b/libgfortran/generated/minloc0_4_r4.c @@ -50,7 +50,7 @@ minloc0_4_r4 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_4 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_4_r8.c b/libgfortran/generated/minloc0_4_r8.c index e78cdd898f5..6162cfd2884 100644 --- a/libgfortran/generated/minloc0_4_r8.c +++ b/libgfortran/generated/minloc0_4_r8.c @@ -50,7 +50,7 @@ minloc0_4_r8 (gfc_array_i4 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_8 *base; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_8_i1.c b/libgfortran/generated/minloc0_8_i1.c index 5872d85560d..b755ed7348b 100644 --- a/libgfortran/generated/minloc0_8_i1.c +++ b/libgfortran/generated/minloc0_8_i1.c @@ -50,7 +50,7 @@ minloc0_8_i1 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_1 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_8_i16.c b/libgfortran/generated/minloc0_8_i16.c index b56409a050c..72906034904 100644 --- a/libgfortran/generated/minloc0_8_i16.c +++ b/libgfortran/generated/minloc0_8_i16.c @@ -50,7 +50,7 @@ minloc0_8_i16 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_16 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_8_i2.c b/libgfortran/generated/minloc0_8_i2.c index 63cd947c42d..70cc8705eb5 100644 --- a/libgfortran/generated/minloc0_8_i2.c +++ b/libgfortran/generated/minloc0_8_i2.c @@ -50,7 +50,7 @@ minloc0_8_i2 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_2 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_8_i4.c b/libgfortran/generated/minloc0_8_i4.c index 5092f89f706..5cd60c3d18e 100644 --- a/libgfortran/generated/minloc0_8_i4.c +++ b/libgfortran/generated/minloc0_8_i4.c @@ -50,7 +50,7 @@ minloc0_8_i4 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_4 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_8_i8.c b/libgfortran/generated/minloc0_8_i8.c index e1b99ef9f94..2c2c2d235cb 100644 --- a/libgfortran/generated/minloc0_8_i8.c +++ b/libgfortran/generated/minloc0_8_i8.c @@ -50,7 +50,7 @@ minloc0_8_i8 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_INTEGER_8 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_8_r10.c b/libgfortran/generated/minloc0_8_r10.c index 600b3aa6af0..2b2f3cf1c74 100644 --- a/libgfortran/generated/minloc0_8_r10.c +++ b/libgfortran/generated/minloc0_8_r10.c @@ -50,7 +50,7 @@ minloc0_8_r10 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_10 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_8_r16.c b/libgfortran/generated/minloc0_8_r16.c index fa4b5cd1d56..a93e1da5d3b 100644 --- a/libgfortran/generated/minloc0_8_r16.c +++ b/libgfortran/generated/minloc0_8_r16.c @@ -50,7 +50,7 @@ minloc0_8_r16 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_16 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_8_r4.c b/libgfortran/generated/minloc0_8_r4.c index 1347f15c8a8..45d2ebabf1b 100644 --- a/libgfortran/generated/minloc0_8_r4.c +++ b/libgfortran/generated/minloc0_8_r4.c @@ -50,7 +50,7 @@ minloc0_8_r4 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_4 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/minloc0_8_r8.c b/libgfortran/generated/minloc0_8_r8.c index 6a7b2f0d6b0..f4041155e0c 100644 --- a/libgfortran/generated/minloc0_8_r8.c +++ b/libgfortran/generated/minloc0_8_r8.c @@ -50,7 +50,7 @@ minloc0_8_r8 (gfc_array_i8 * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const GFC_REAL_8 *base; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/generated/pack_c10.c b/libgfortran/generated/pack_c10.c index 0bad32385d8..7aad775131a 100644 --- a/libgfortran/generated/pack_c10.c +++ b/libgfortran/generated/pack_c10.c @@ -82,7 +82,7 @@ pack_c10 (gfc_array_c10 *ret, const gfc_array_c10 *array, { /* r.* indicates the return array. */ index_type rstride0; - GFC_COMPLEX_10 *rptr; + GFC_COMPLEX_10 * restrict rptr; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/pack_c16.c b/libgfortran/generated/pack_c16.c index a0c87ec8a26..6249ef4480a 100644 --- a/libgfortran/generated/pack_c16.c +++ b/libgfortran/generated/pack_c16.c @@ -82,7 +82,7 @@ pack_c16 (gfc_array_c16 *ret, const gfc_array_c16 *array, { /* r.* indicates the return array. */ index_type rstride0; - GFC_COMPLEX_16 *rptr; + GFC_COMPLEX_16 * restrict rptr; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/pack_c4.c b/libgfortran/generated/pack_c4.c index 2fb6a20ad9c..a450a7386fa 100644 --- a/libgfortran/generated/pack_c4.c +++ b/libgfortran/generated/pack_c4.c @@ -82,7 +82,7 @@ pack_c4 (gfc_array_c4 *ret, const gfc_array_c4 *array, { /* r.* indicates the return array. */ index_type rstride0; - GFC_COMPLEX_4 *rptr; + GFC_COMPLEX_4 * restrict rptr; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/pack_c8.c b/libgfortran/generated/pack_c8.c index 1a4e78ec792..d9ae193d7d7 100644 --- a/libgfortran/generated/pack_c8.c +++ b/libgfortran/generated/pack_c8.c @@ -82,7 +82,7 @@ pack_c8 (gfc_array_c8 *ret, const gfc_array_c8 *array, { /* r.* indicates the return array. */ index_type rstride0; - GFC_COMPLEX_8 *rptr; + GFC_COMPLEX_8 * restrict rptr; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/pack_i1.c b/libgfortran/generated/pack_i1.c index 44c6c677e44..1f8259769bd 100644 --- a/libgfortran/generated/pack_i1.c +++ b/libgfortran/generated/pack_i1.c @@ -82,7 +82,7 @@ pack_i1 (gfc_array_i1 *ret, const gfc_array_i1 *array, { /* r.* indicates the return array. */ index_type rstride0; - GFC_INTEGER_1 *rptr; + GFC_INTEGER_1 * restrict rptr; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/pack_i16.c b/libgfortran/generated/pack_i16.c index e9c15437977..a175d02d34d 100644 --- a/libgfortran/generated/pack_i16.c +++ b/libgfortran/generated/pack_i16.c @@ -82,7 +82,7 @@ pack_i16 (gfc_array_i16 *ret, const gfc_array_i16 *array, { /* r.* indicates the return array. */ index_type rstride0; - GFC_INTEGER_16 *rptr; + GFC_INTEGER_16 * restrict rptr; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/pack_i2.c b/libgfortran/generated/pack_i2.c index 51380c26ba7..1788b6c9a7f 100644 --- a/libgfortran/generated/pack_i2.c +++ b/libgfortran/generated/pack_i2.c @@ -82,7 +82,7 @@ pack_i2 (gfc_array_i2 *ret, const gfc_array_i2 *array, { /* r.* indicates the return array. */ index_type rstride0; - GFC_INTEGER_2 *rptr; + GFC_INTEGER_2 * restrict rptr; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/pack_i4.c b/libgfortran/generated/pack_i4.c index 861670d6865..32ec8e30881 100644 --- a/libgfortran/generated/pack_i4.c +++ b/libgfortran/generated/pack_i4.c @@ -82,7 +82,7 @@ pack_i4 (gfc_array_i4 *ret, const gfc_array_i4 *array, { /* r.* indicates the return array. */ index_type rstride0; - GFC_INTEGER_4 *rptr; + GFC_INTEGER_4 * restrict rptr; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/pack_i8.c b/libgfortran/generated/pack_i8.c index c547f3809f2..49b34cad220 100644 --- a/libgfortran/generated/pack_i8.c +++ b/libgfortran/generated/pack_i8.c @@ -82,7 +82,7 @@ pack_i8 (gfc_array_i8 *ret, const gfc_array_i8 *array, { /* r.* indicates the return array. */ index_type rstride0; - GFC_INTEGER_8 *rptr; + GFC_INTEGER_8 * restrict rptr; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/pack_r10.c b/libgfortran/generated/pack_r10.c index 4b8c5784aef..3218bb342a5 100644 --- a/libgfortran/generated/pack_r10.c +++ b/libgfortran/generated/pack_r10.c @@ -82,7 +82,7 @@ pack_r10 (gfc_array_r10 *ret, const gfc_array_r10 *array, { /* r.* indicates the return array. */ index_type rstride0; - GFC_REAL_10 *rptr; + GFC_REAL_10 * restrict rptr; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/pack_r16.c b/libgfortran/generated/pack_r16.c index a691f7c4041..7415814951e 100644 --- a/libgfortran/generated/pack_r16.c +++ b/libgfortran/generated/pack_r16.c @@ -82,7 +82,7 @@ pack_r16 (gfc_array_r16 *ret, const gfc_array_r16 *array, { /* r.* indicates the return array. */ index_type rstride0; - GFC_REAL_16 *rptr; + GFC_REAL_16 * restrict rptr; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/pack_r4.c b/libgfortran/generated/pack_r4.c index c008aadf4d4..c5871414c1c 100644 --- a/libgfortran/generated/pack_r4.c +++ b/libgfortran/generated/pack_r4.c @@ -82,7 +82,7 @@ pack_r4 (gfc_array_r4 *ret, const gfc_array_r4 *array, { /* r.* indicates the return array. */ index_type rstride0; - GFC_REAL_4 *rptr; + GFC_REAL_4 * restrict rptr; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/pack_r8.c b/libgfortran/generated/pack_r8.c index 7b360479628..f1a6a684bfe 100644 --- a/libgfortran/generated/pack_r8.c +++ b/libgfortran/generated/pack_r8.c @@ -82,7 +82,7 @@ pack_r8 (gfc_array_r8 *ret, const gfc_array_r8 *array, { /* r.* indicates the return array. */ index_type rstride0; - GFC_REAL_8 *rptr; + GFC_REAL_8 * restrict rptr; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/generated/spread_c10.c b/libgfortran/generated/spread_c10.c index 76a361406c1..868a75f898f 100644 --- a/libgfortran/generated/spread_c10.c +++ b/libgfortran/generated/spread_c10.c @@ -48,7 +48,7 @@ spread_c10 (gfc_array_c10 *ret, const gfc_array_c10 *source, index_type rrank; index_type rs; GFC_COMPLEX_10 *rptr; - GFC_COMPLEX_10 *dest; + GFC_COMPLEX_10 * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; @@ -240,7 +240,7 @@ spread_scalar_c10 (gfc_array_c10 *ret, const GFC_COMPLEX_10 *source, { int n; int ncopies = pncopies; - GFC_COMPLEX_10 * dest; + GFC_COMPLEX_10 * restrict dest; index_type stride; if (GFC_DESCRIPTOR_RANK (ret) != 1) @@ -275,3 +275,4 @@ spread_scalar_c10 (gfc_array_c10 *ret, const GFC_COMPLEX_10 *source, } #endif + diff --git a/libgfortran/generated/spread_c16.c b/libgfortran/generated/spread_c16.c index 0ea57561849..5aa45e6d0f5 100644 --- a/libgfortran/generated/spread_c16.c +++ b/libgfortran/generated/spread_c16.c @@ -48,7 +48,7 @@ spread_c16 (gfc_array_c16 *ret, const gfc_array_c16 *source, index_type rrank; index_type rs; GFC_COMPLEX_16 *rptr; - GFC_COMPLEX_16 *dest; + GFC_COMPLEX_16 * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; @@ -240,7 +240,7 @@ spread_scalar_c16 (gfc_array_c16 *ret, const GFC_COMPLEX_16 *source, { int n; int ncopies = pncopies; - GFC_COMPLEX_16 * dest; + GFC_COMPLEX_16 * restrict dest; index_type stride; if (GFC_DESCRIPTOR_RANK (ret) != 1) @@ -275,3 +275,4 @@ spread_scalar_c16 (gfc_array_c16 *ret, const GFC_COMPLEX_16 *source, } #endif + diff --git a/libgfortran/generated/spread_c4.c b/libgfortran/generated/spread_c4.c index f86da84a58f..f1b16e7e132 100644 --- a/libgfortran/generated/spread_c4.c +++ b/libgfortran/generated/spread_c4.c @@ -48,7 +48,7 @@ spread_c4 (gfc_array_c4 *ret, const gfc_array_c4 *source, index_type rrank; index_type rs; GFC_COMPLEX_4 *rptr; - GFC_COMPLEX_4 *dest; + GFC_COMPLEX_4 * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; @@ -240,7 +240,7 @@ spread_scalar_c4 (gfc_array_c4 *ret, const GFC_COMPLEX_4 *source, { int n; int ncopies = pncopies; - GFC_COMPLEX_4 * dest; + GFC_COMPLEX_4 * restrict dest; index_type stride; if (GFC_DESCRIPTOR_RANK (ret) != 1) @@ -275,3 +275,4 @@ spread_scalar_c4 (gfc_array_c4 *ret, const GFC_COMPLEX_4 *source, } #endif + diff --git a/libgfortran/generated/spread_c8.c b/libgfortran/generated/spread_c8.c index 7a3f4dfd210..ed79c2844a5 100644 --- a/libgfortran/generated/spread_c8.c +++ b/libgfortran/generated/spread_c8.c @@ -48,7 +48,7 @@ spread_c8 (gfc_array_c8 *ret, const gfc_array_c8 *source, index_type rrank; index_type rs; GFC_COMPLEX_8 *rptr; - GFC_COMPLEX_8 *dest; + GFC_COMPLEX_8 * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; @@ -240,7 +240,7 @@ spread_scalar_c8 (gfc_array_c8 *ret, const GFC_COMPLEX_8 *source, { int n; int ncopies = pncopies; - GFC_COMPLEX_8 * dest; + GFC_COMPLEX_8 * restrict dest; index_type stride; if (GFC_DESCRIPTOR_RANK (ret) != 1) @@ -275,3 +275,4 @@ spread_scalar_c8 (gfc_array_c8 *ret, const GFC_COMPLEX_8 *source, } #endif + diff --git a/libgfortran/generated/spread_i1.c b/libgfortran/generated/spread_i1.c index 396a521eab8..b5798dff5a8 100644 --- a/libgfortran/generated/spread_i1.c +++ b/libgfortran/generated/spread_i1.c @@ -48,7 +48,7 @@ spread_i1 (gfc_array_i1 *ret, const gfc_array_i1 *source, index_type rrank; index_type rs; GFC_INTEGER_1 *rptr; - GFC_INTEGER_1 *dest; + GFC_INTEGER_1 * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; @@ -240,7 +240,7 @@ spread_scalar_i1 (gfc_array_i1 *ret, const GFC_INTEGER_1 *source, { int n; int ncopies = pncopies; - GFC_INTEGER_1 * dest; + GFC_INTEGER_1 * restrict dest; index_type stride; if (GFC_DESCRIPTOR_RANK (ret) != 1) @@ -275,3 +275,4 @@ spread_scalar_i1 (gfc_array_i1 *ret, const GFC_INTEGER_1 *source, } #endif + diff --git a/libgfortran/generated/spread_i16.c b/libgfortran/generated/spread_i16.c index 55993424054..0f6002f682a 100644 --- a/libgfortran/generated/spread_i16.c +++ b/libgfortran/generated/spread_i16.c @@ -48,7 +48,7 @@ spread_i16 (gfc_array_i16 *ret, const gfc_array_i16 *source, index_type rrank; index_type rs; GFC_INTEGER_16 *rptr; - GFC_INTEGER_16 *dest; + GFC_INTEGER_16 * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; @@ -240,7 +240,7 @@ spread_scalar_i16 (gfc_array_i16 *ret, const GFC_INTEGER_16 *source, { int n; int ncopies = pncopies; - GFC_INTEGER_16 * dest; + GFC_INTEGER_16 * restrict dest; index_type stride; if (GFC_DESCRIPTOR_RANK (ret) != 1) @@ -275,3 +275,4 @@ spread_scalar_i16 (gfc_array_i16 *ret, const GFC_INTEGER_16 *source, } #endif + diff --git a/libgfortran/generated/spread_i2.c b/libgfortran/generated/spread_i2.c index d8ac9dc9af1..ac49aa9d999 100644 --- a/libgfortran/generated/spread_i2.c +++ b/libgfortran/generated/spread_i2.c @@ -48,7 +48,7 @@ spread_i2 (gfc_array_i2 *ret, const gfc_array_i2 *source, index_type rrank; index_type rs; GFC_INTEGER_2 *rptr; - GFC_INTEGER_2 *dest; + GFC_INTEGER_2 * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; @@ -240,7 +240,7 @@ spread_scalar_i2 (gfc_array_i2 *ret, const GFC_INTEGER_2 *source, { int n; int ncopies = pncopies; - GFC_INTEGER_2 * dest; + GFC_INTEGER_2 * restrict dest; index_type stride; if (GFC_DESCRIPTOR_RANK (ret) != 1) @@ -275,3 +275,4 @@ spread_scalar_i2 (gfc_array_i2 *ret, const GFC_INTEGER_2 *source, } #endif + diff --git a/libgfortran/generated/spread_i4.c b/libgfortran/generated/spread_i4.c index c0890b666a1..bef7a37b6b0 100644 --- a/libgfortran/generated/spread_i4.c +++ b/libgfortran/generated/spread_i4.c @@ -48,7 +48,7 @@ spread_i4 (gfc_array_i4 *ret, const gfc_array_i4 *source, index_type rrank; index_type rs; GFC_INTEGER_4 *rptr; - GFC_INTEGER_4 *dest; + GFC_INTEGER_4 * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; @@ -240,7 +240,7 @@ spread_scalar_i4 (gfc_array_i4 *ret, const GFC_INTEGER_4 *source, { int n; int ncopies = pncopies; - GFC_INTEGER_4 * dest; + GFC_INTEGER_4 * restrict dest; index_type stride; if (GFC_DESCRIPTOR_RANK (ret) != 1) @@ -275,3 +275,4 @@ spread_scalar_i4 (gfc_array_i4 *ret, const GFC_INTEGER_4 *source, } #endif + diff --git a/libgfortran/generated/spread_i8.c b/libgfortran/generated/spread_i8.c index b0032bf64dd..db5572aff67 100644 --- a/libgfortran/generated/spread_i8.c +++ b/libgfortran/generated/spread_i8.c @@ -48,7 +48,7 @@ spread_i8 (gfc_array_i8 *ret, const gfc_array_i8 *source, index_type rrank; index_type rs; GFC_INTEGER_8 *rptr; - GFC_INTEGER_8 *dest; + GFC_INTEGER_8 * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; @@ -240,7 +240,7 @@ spread_scalar_i8 (gfc_array_i8 *ret, const GFC_INTEGER_8 *source, { int n; int ncopies = pncopies; - GFC_INTEGER_8 * dest; + GFC_INTEGER_8 * restrict dest; index_type stride; if (GFC_DESCRIPTOR_RANK (ret) != 1) @@ -275,3 +275,4 @@ spread_scalar_i8 (gfc_array_i8 *ret, const GFC_INTEGER_8 *source, } #endif + diff --git a/libgfortran/generated/spread_r10.c b/libgfortran/generated/spread_r10.c index 404aaa4654c..9d5afc22504 100644 --- a/libgfortran/generated/spread_r10.c +++ b/libgfortran/generated/spread_r10.c @@ -48,7 +48,7 @@ spread_r10 (gfc_array_r10 *ret, const gfc_array_r10 *source, index_type rrank; index_type rs; GFC_REAL_10 *rptr; - GFC_REAL_10 *dest; + GFC_REAL_10 * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; @@ -240,7 +240,7 @@ spread_scalar_r10 (gfc_array_r10 *ret, const GFC_REAL_10 *source, { int n; int ncopies = pncopies; - GFC_REAL_10 * dest; + GFC_REAL_10 * restrict dest; index_type stride; if (GFC_DESCRIPTOR_RANK (ret) != 1) @@ -275,3 +275,4 @@ spread_scalar_r10 (gfc_array_r10 *ret, const GFC_REAL_10 *source, } #endif + diff --git a/libgfortran/generated/spread_r16.c b/libgfortran/generated/spread_r16.c index 122673305e8..0b4d3ca22c4 100644 --- a/libgfortran/generated/spread_r16.c +++ b/libgfortran/generated/spread_r16.c @@ -48,7 +48,7 @@ spread_r16 (gfc_array_r16 *ret, const gfc_array_r16 *source, index_type rrank; index_type rs; GFC_REAL_16 *rptr; - GFC_REAL_16 *dest; + GFC_REAL_16 * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; @@ -240,7 +240,7 @@ spread_scalar_r16 (gfc_array_r16 *ret, const GFC_REAL_16 *source, { int n; int ncopies = pncopies; - GFC_REAL_16 * dest; + GFC_REAL_16 * restrict dest; index_type stride; if (GFC_DESCRIPTOR_RANK (ret) != 1) @@ -275,3 +275,4 @@ spread_scalar_r16 (gfc_array_r16 *ret, const GFC_REAL_16 *source, } #endif + diff --git a/libgfortran/generated/spread_r4.c b/libgfortran/generated/spread_r4.c index 1569dbc09f3..191203a6d56 100644 --- a/libgfortran/generated/spread_r4.c +++ b/libgfortran/generated/spread_r4.c @@ -48,7 +48,7 @@ spread_r4 (gfc_array_r4 *ret, const gfc_array_r4 *source, index_type rrank; index_type rs; GFC_REAL_4 *rptr; - GFC_REAL_4 *dest; + GFC_REAL_4 * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; @@ -240,7 +240,7 @@ spread_scalar_r4 (gfc_array_r4 *ret, const GFC_REAL_4 *source, { int n; int ncopies = pncopies; - GFC_REAL_4 * dest; + GFC_REAL_4 * restrict dest; index_type stride; if (GFC_DESCRIPTOR_RANK (ret) != 1) @@ -275,3 +275,4 @@ spread_scalar_r4 (gfc_array_r4 *ret, const GFC_REAL_4 *source, } #endif + diff --git a/libgfortran/generated/spread_r8.c b/libgfortran/generated/spread_r8.c index c028f804079..a710111c9df 100644 --- a/libgfortran/generated/spread_r8.c +++ b/libgfortran/generated/spread_r8.c @@ -48,7 +48,7 @@ spread_r8 (gfc_array_r8 *ret, const gfc_array_r8 *source, index_type rrank; index_type rs; GFC_REAL_8 *rptr; - GFC_REAL_8 *dest; + GFC_REAL_8 * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; @@ -240,7 +240,7 @@ spread_scalar_r8 (gfc_array_r8 *ret, const GFC_REAL_8 *source, { int n; int ncopies = pncopies; - GFC_REAL_8 * dest; + GFC_REAL_8 * restrict dest; index_type stride; if (GFC_DESCRIPTOR_RANK (ret) != 1) @@ -275,3 +275,4 @@ spread_scalar_r8 (gfc_array_r8 *ret, const GFC_REAL_8 *source, } #endif + diff --git a/libgfortran/generated/transpose_c10.c b/libgfortran/generated/transpose_c10.c index f809f01eb0e..72235967b34 100644 --- a/libgfortran/generated/transpose_c10.c +++ b/libgfortran/generated/transpose_c10.c @@ -44,7 +44,7 @@ transpose_c10 (gfc_array_c10 * const restrict ret, { /* r.* indicates the return array. */ index_type rxstride, rystride; - GFC_COMPLEX_10 *rptr; + GFC_COMPLEX_10 * restrict rptr; /* s.* indicates the source array. */ index_type sxstride, systride; const GFC_COMPLEX_10 *sptr; diff --git a/libgfortran/generated/transpose_c16.c b/libgfortran/generated/transpose_c16.c index 06adc81d9f1..e3863f1f2ad 100644 --- a/libgfortran/generated/transpose_c16.c +++ b/libgfortran/generated/transpose_c16.c @@ -44,7 +44,7 @@ transpose_c16 (gfc_array_c16 * const restrict ret, { /* r.* indicates the return array. */ index_type rxstride, rystride; - GFC_COMPLEX_16 *rptr; + GFC_COMPLEX_16 * restrict rptr; /* s.* indicates the source array. */ index_type sxstride, systride; const GFC_COMPLEX_16 *sptr; diff --git a/libgfortran/generated/transpose_c4.c b/libgfortran/generated/transpose_c4.c index 4a2a8c06d93..cdb5a9a06e1 100644 --- a/libgfortran/generated/transpose_c4.c +++ b/libgfortran/generated/transpose_c4.c @@ -44,7 +44,7 @@ transpose_c4 (gfc_array_c4 * const restrict ret, { /* r.* indicates the return array. */ index_type rxstride, rystride; - GFC_COMPLEX_4 *rptr; + GFC_COMPLEX_4 * restrict rptr; /* s.* indicates the source array. */ index_type sxstride, systride; const GFC_COMPLEX_4 *sptr; diff --git a/libgfortran/generated/transpose_c8.c b/libgfortran/generated/transpose_c8.c index cdfb6c94068..91fb1042499 100644 --- a/libgfortran/generated/transpose_c8.c +++ b/libgfortran/generated/transpose_c8.c @@ -44,7 +44,7 @@ transpose_c8 (gfc_array_c8 * const restrict ret, { /* r.* indicates the return array. */ index_type rxstride, rystride; - GFC_COMPLEX_8 *rptr; + GFC_COMPLEX_8 * restrict rptr; /* s.* indicates the source array. */ index_type sxstride, systride; const GFC_COMPLEX_8 *sptr; diff --git a/libgfortran/generated/transpose_i16.c b/libgfortran/generated/transpose_i16.c index 23183bb27e1..b7564ad17aa 100644 --- a/libgfortran/generated/transpose_i16.c +++ b/libgfortran/generated/transpose_i16.c @@ -44,7 +44,7 @@ transpose_i16 (gfc_array_i16 * const restrict ret, { /* r.* indicates the return array. */ index_type rxstride, rystride; - GFC_INTEGER_16 *rptr; + GFC_INTEGER_16 * restrict rptr; /* s.* indicates the source array. */ index_type sxstride, systride; const GFC_INTEGER_16 *sptr; diff --git a/libgfortran/generated/transpose_i4.c b/libgfortran/generated/transpose_i4.c index f426ddf9daa..51472fd09a0 100644 --- a/libgfortran/generated/transpose_i4.c +++ b/libgfortran/generated/transpose_i4.c @@ -44,7 +44,7 @@ transpose_i4 (gfc_array_i4 * const restrict ret, { /* r.* indicates the return array. */ index_type rxstride, rystride; - GFC_INTEGER_4 *rptr; + GFC_INTEGER_4 * restrict rptr; /* s.* indicates the source array. */ index_type sxstride, systride; const GFC_INTEGER_4 *sptr; diff --git a/libgfortran/generated/transpose_i8.c b/libgfortran/generated/transpose_i8.c index dec4f6b3865..37428ddacbd 100644 --- a/libgfortran/generated/transpose_i8.c +++ b/libgfortran/generated/transpose_i8.c @@ -44,7 +44,7 @@ transpose_i8 (gfc_array_i8 * const restrict ret, { /* r.* indicates the return array. */ index_type rxstride, rystride; - GFC_INTEGER_8 *rptr; + GFC_INTEGER_8 * restrict rptr; /* s.* indicates the source array. */ index_type sxstride, systride; const GFC_INTEGER_8 *sptr; diff --git a/libgfortran/generated/transpose_r10.c b/libgfortran/generated/transpose_r10.c index 6f01d562fab..32704166b1d 100644 --- a/libgfortran/generated/transpose_r10.c +++ b/libgfortran/generated/transpose_r10.c @@ -44,7 +44,7 @@ transpose_r10 (gfc_array_r10 * const restrict ret, { /* r.* indicates the return array. */ index_type rxstride, rystride; - GFC_REAL_10 *rptr; + GFC_REAL_10 * restrict rptr; /* s.* indicates the source array. */ index_type sxstride, systride; const GFC_REAL_10 *sptr; diff --git a/libgfortran/generated/transpose_r16.c b/libgfortran/generated/transpose_r16.c index 1991e521013..858b3a56555 100644 --- a/libgfortran/generated/transpose_r16.c +++ b/libgfortran/generated/transpose_r16.c @@ -44,7 +44,7 @@ transpose_r16 (gfc_array_r16 * const restrict ret, { /* r.* indicates the return array. */ index_type rxstride, rystride; - GFC_REAL_16 *rptr; + GFC_REAL_16 * restrict rptr; /* s.* indicates the source array. */ index_type sxstride, systride; const GFC_REAL_16 *sptr; diff --git a/libgfortran/generated/transpose_r4.c b/libgfortran/generated/transpose_r4.c index 257d6787f36..1968302dd35 100644 --- a/libgfortran/generated/transpose_r4.c +++ b/libgfortran/generated/transpose_r4.c @@ -44,7 +44,7 @@ transpose_r4 (gfc_array_r4 * const restrict ret, { /* r.* indicates the return array. */ index_type rxstride, rystride; - GFC_REAL_4 *rptr; + GFC_REAL_4 * restrict rptr; /* s.* indicates the source array. */ index_type sxstride, systride; const GFC_REAL_4 *sptr; diff --git a/libgfortran/generated/transpose_r8.c b/libgfortran/generated/transpose_r8.c index 5430845391d..bbd87649126 100644 --- a/libgfortran/generated/transpose_r8.c +++ b/libgfortran/generated/transpose_r8.c @@ -44,7 +44,7 @@ transpose_r8 (gfc_array_r8 * const restrict ret, { /* r.* indicates the return array. */ index_type rxstride, rystride; - GFC_REAL_8 *rptr; + GFC_REAL_8 * restrict rptr; /* s.* indicates the source array. */ index_type sxstride, systride; const GFC_REAL_8 *sptr; diff --git a/libgfortran/generated/unpack_c10.c b/libgfortran/generated/unpack_c10.c index e6f3ecf2652..5881ece0eeb 100644 --- a/libgfortran/generated/unpack_c10.c +++ b/libgfortran/generated/unpack_c10.c @@ -45,7 +45,7 @@ unpack0_c10 (gfc_array_c10 *ret, const gfc_array_c10 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_COMPLEX_10 *rptr; + GFC_COMPLEX_10 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_COMPLEX_10 *vptr; @@ -188,7 +188,7 @@ unpack1_c10 (gfc_array_c10 *ret, const gfc_array_c10 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_COMPLEX_10 *rptr; + GFC_COMPLEX_10 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_COMPLEX_10 *vptr; diff --git a/libgfortran/generated/unpack_c16.c b/libgfortran/generated/unpack_c16.c index 2d82a10fc84..7941ff9289a 100644 --- a/libgfortran/generated/unpack_c16.c +++ b/libgfortran/generated/unpack_c16.c @@ -45,7 +45,7 @@ unpack0_c16 (gfc_array_c16 *ret, const gfc_array_c16 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_COMPLEX_16 *rptr; + GFC_COMPLEX_16 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_COMPLEX_16 *vptr; @@ -188,7 +188,7 @@ unpack1_c16 (gfc_array_c16 *ret, const gfc_array_c16 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_COMPLEX_16 *rptr; + GFC_COMPLEX_16 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_COMPLEX_16 *vptr; diff --git a/libgfortran/generated/unpack_c4.c b/libgfortran/generated/unpack_c4.c index 472ce48c26e..3ef95147ab8 100644 --- a/libgfortran/generated/unpack_c4.c +++ b/libgfortran/generated/unpack_c4.c @@ -45,7 +45,7 @@ unpack0_c4 (gfc_array_c4 *ret, const gfc_array_c4 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_COMPLEX_4 *rptr; + GFC_COMPLEX_4 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_COMPLEX_4 *vptr; @@ -188,7 +188,7 @@ unpack1_c4 (gfc_array_c4 *ret, const gfc_array_c4 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_COMPLEX_4 *rptr; + GFC_COMPLEX_4 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_COMPLEX_4 *vptr; diff --git a/libgfortran/generated/unpack_c8.c b/libgfortran/generated/unpack_c8.c index 62116b78bb2..bc32b27016e 100644 --- a/libgfortran/generated/unpack_c8.c +++ b/libgfortran/generated/unpack_c8.c @@ -45,7 +45,7 @@ unpack0_c8 (gfc_array_c8 *ret, const gfc_array_c8 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_COMPLEX_8 *rptr; + GFC_COMPLEX_8 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_COMPLEX_8 *vptr; @@ -188,7 +188,7 @@ unpack1_c8 (gfc_array_c8 *ret, const gfc_array_c8 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_COMPLEX_8 *rptr; + GFC_COMPLEX_8 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_COMPLEX_8 *vptr; diff --git a/libgfortran/generated/unpack_i1.c b/libgfortran/generated/unpack_i1.c index 46a9d4eb6f2..17090328eb5 100644 --- a/libgfortran/generated/unpack_i1.c +++ b/libgfortran/generated/unpack_i1.c @@ -45,7 +45,7 @@ unpack0_i1 (gfc_array_i1 *ret, const gfc_array_i1 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_INTEGER_1 *rptr; + GFC_INTEGER_1 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_INTEGER_1 *vptr; @@ -188,7 +188,7 @@ unpack1_i1 (gfc_array_i1 *ret, const gfc_array_i1 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_INTEGER_1 *rptr; + GFC_INTEGER_1 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_INTEGER_1 *vptr; diff --git a/libgfortran/generated/unpack_i16.c b/libgfortran/generated/unpack_i16.c index 0fbd7449ffe..2adf0603d42 100644 --- a/libgfortran/generated/unpack_i16.c +++ b/libgfortran/generated/unpack_i16.c @@ -45,7 +45,7 @@ unpack0_i16 (gfc_array_i16 *ret, const gfc_array_i16 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_INTEGER_16 *rptr; + GFC_INTEGER_16 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_INTEGER_16 *vptr; @@ -188,7 +188,7 @@ unpack1_i16 (gfc_array_i16 *ret, const gfc_array_i16 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_INTEGER_16 *rptr; + GFC_INTEGER_16 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_INTEGER_16 *vptr; diff --git a/libgfortran/generated/unpack_i2.c b/libgfortran/generated/unpack_i2.c index 096c7858de1..b83b8757f76 100644 --- a/libgfortran/generated/unpack_i2.c +++ b/libgfortran/generated/unpack_i2.c @@ -45,7 +45,7 @@ unpack0_i2 (gfc_array_i2 *ret, const gfc_array_i2 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_INTEGER_2 *rptr; + GFC_INTEGER_2 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_INTEGER_2 *vptr; @@ -188,7 +188,7 @@ unpack1_i2 (gfc_array_i2 *ret, const gfc_array_i2 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_INTEGER_2 *rptr; + GFC_INTEGER_2 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_INTEGER_2 *vptr; diff --git a/libgfortran/generated/unpack_i4.c b/libgfortran/generated/unpack_i4.c index 08f197c376c..82b1e650330 100644 --- a/libgfortran/generated/unpack_i4.c +++ b/libgfortran/generated/unpack_i4.c @@ -45,7 +45,7 @@ unpack0_i4 (gfc_array_i4 *ret, const gfc_array_i4 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_INTEGER_4 *rptr; + GFC_INTEGER_4 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_INTEGER_4 *vptr; @@ -188,7 +188,7 @@ unpack1_i4 (gfc_array_i4 *ret, const gfc_array_i4 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_INTEGER_4 *rptr; + GFC_INTEGER_4 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_INTEGER_4 *vptr; diff --git a/libgfortran/generated/unpack_i8.c b/libgfortran/generated/unpack_i8.c index 0847c1fa0da..ebd9fc7c48c 100644 --- a/libgfortran/generated/unpack_i8.c +++ b/libgfortran/generated/unpack_i8.c @@ -45,7 +45,7 @@ unpack0_i8 (gfc_array_i8 *ret, const gfc_array_i8 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_INTEGER_8 *rptr; + GFC_INTEGER_8 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_INTEGER_8 *vptr; @@ -188,7 +188,7 @@ unpack1_i8 (gfc_array_i8 *ret, const gfc_array_i8 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_INTEGER_8 *rptr; + GFC_INTEGER_8 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_INTEGER_8 *vptr; diff --git a/libgfortran/generated/unpack_r10.c b/libgfortran/generated/unpack_r10.c index 694d2c542ee..a57c3bf926f 100644 --- a/libgfortran/generated/unpack_r10.c +++ b/libgfortran/generated/unpack_r10.c @@ -45,7 +45,7 @@ unpack0_r10 (gfc_array_r10 *ret, const gfc_array_r10 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_REAL_10 *rptr; + GFC_REAL_10 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_REAL_10 *vptr; @@ -188,7 +188,7 @@ unpack1_r10 (gfc_array_r10 *ret, const gfc_array_r10 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_REAL_10 *rptr; + GFC_REAL_10 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_REAL_10 *vptr; diff --git a/libgfortran/generated/unpack_r16.c b/libgfortran/generated/unpack_r16.c index 65121c1b90e..6cbb7b24ce0 100644 --- a/libgfortran/generated/unpack_r16.c +++ b/libgfortran/generated/unpack_r16.c @@ -45,7 +45,7 @@ unpack0_r16 (gfc_array_r16 *ret, const gfc_array_r16 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_REAL_16 *rptr; + GFC_REAL_16 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_REAL_16 *vptr; @@ -188,7 +188,7 @@ unpack1_r16 (gfc_array_r16 *ret, const gfc_array_r16 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_REAL_16 *rptr; + GFC_REAL_16 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_REAL_16 *vptr; diff --git a/libgfortran/generated/unpack_r4.c b/libgfortran/generated/unpack_r4.c index b9983182b6f..d20856cf641 100644 --- a/libgfortran/generated/unpack_r4.c +++ b/libgfortran/generated/unpack_r4.c @@ -45,7 +45,7 @@ unpack0_r4 (gfc_array_r4 *ret, const gfc_array_r4 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_REAL_4 *rptr; + GFC_REAL_4 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_REAL_4 *vptr; @@ -188,7 +188,7 @@ unpack1_r4 (gfc_array_r4 *ret, const gfc_array_r4 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_REAL_4 *rptr; + GFC_REAL_4 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_REAL_4 *vptr; diff --git a/libgfortran/generated/unpack_r8.c b/libgfortran/generated/unpack_r8.c index cccf7596f9b..f3223c45af8 100644 --- a/libgfortran/generated/unpack_r8.c +++ b/libgfortran/generated/unpack_r8.c @@ -45,7 +45,7 @@ unpack0_r8 (gfc_array_r8 *ret, const gfc_array_r8 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_REAL_8 *rptr; + GFC_REAL_8 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_REAL_8 *vptr; @@ -188,7 +188,7 @@ unpack1_r8 (gfc_array_r8 *ret, const gfc_array_r8 *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - GFC_REAL_8 *rptr; + GFC_REAL_8 * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; GFC_REAL_8 *vptr; diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index bd51d80edf3..deac160423c 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -1049,6 +1049,17 @@ GFORTRAN_1.1 { _gfortran_string_scan_char4; _gfortran_string_trim_char4; _gfortran_string_verify_char4; + _gfortran_select_string_char4; + _gfortran_convert_char1_to_char4; + _gfortran_convert_char4_to_char1; + _gfortran_transpose_char4; + _gfortran_spread_char4; + _gfortran_spread_char4_scalar; + _gfortran_reshape_char4; + _gfortran_pack_char4; + _gfortran_pack_s_char4; + _gfortran_unpack0_char4; + _gfortran_unpack1_char4; } GFORTRAN_1.0; F2C_1.0 { diff --git a/libgfortran/intrinsics/eoshift0.c b/libgfortran/intrinsics/eoshift0.c index 594944d4508..9946b4877e3 100644 --- a/libgfortran/intrinsics/eoshift0.c +++ b/libgfortran/intrinsics/eoshift0.c @@ -45,7 +45,7 @@ eoshift0 (gfc_array_char * ret, const gfc_array_char * array, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type roffset; - char *rptr; + char * restrict rptr; char *dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; diff --git a/libgfortran/intrinsics/eoshift2.c b/libgfortran/intrinsics/eoshift2.c index bfbcc3e6a80..ca870d245fb 100644 --- a/libgfortran/intrinsics/eoshift2.c +++ b/libgfortran/intrinsics/eoshift2.c @@ -45,7 +45,7 @@ eoshift2 (gfc_array_char *ret, const gfc_array_char *array, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type roffset; - char *rptr; + char * restrict rptr; char *dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; diff --git a/libgfortran/intrinsics/pack_generic.c b/libgfortran/intrinsics/pack_generic.c index bb4abaeae4b..6e3d2cb19c6 100644 --- a/libgfortran/intrinsics/pack_generic.c +++ b/libgfortran/intrinsics/pack_generic.c @@ -80,7 +80,7 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array, { /* r.* indicates the return array. */ index_type rstride0; - char *rptr; + char * restrict rptr; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; @@ -457,6 +457,7 @@ pack (gfc_array_char *ret, const gfc_array_char *array, pack_internal (ret, array, mask, vector, size); } + extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *, const gfc_array_l1 *, const gfc_array_char *, GFC_INTEGER_4, GFC_INTEGER_4); @@ -472,6 +473,23 @@ pack_char (gfc_array_char *ret, pack_internal (ret, array, mask, vector, array_length); } + +extern void pack_char4 (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *, + const gfc_array_l1 *, const gfc_array_char *, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(pack_char4); + +void +pack_char4 (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char *array, const gfc_array_l1 *mask, + const gfc_array_char *vector, GFC_INTEGER_4 array_length, + GFC_INTEGER_4 vector_length __attribute__((unused))) +{ + pack_internal (ret, array, mask, vector, array_length * sizeof (gfc_char4_t)); +} + + static void pack_s_internal (gfc_array_char *ret, const gfc_array_char *array, const GFC_LOGICAL_4 *mask, const gfc_array_char *vector, @@ -641,6 +659,7 @@ pack_s (gfc_array_char *ret, const gfc_array_char *array, pack_s_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array)); } + extern void pack_s_char (gfc_array_char *ret, GFC_INTEGER_4, const gfc_array_char *array, const GFC_LOGICAL_4 *, const gfc_array_char *, GFC_INTEGER_4, @@ -656,3 +675,21 @@ pack_s_char (gfc_array_char *ret, { pack_s_internal (ret, array, mask, vector, array_length); } + + +extern void pack_s_char4 (gfc_array_char *ret, GFC_INTEGER_4, + const gfc_array_char *array, const GFC_LOGICAL_4 *, + const gfc_array_char *, GFC_INTEGER_4, + GFC_INTEGER_4); +export_proto(pack_s_char4); + +void +pack_s_char4 (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char *array, const GFC_LOGICAL_4 *mask, + const gfc_array_char *vector, GFC_INTEGER_4 array_length, + GFC_INTEGER_4 vector_length __attribute__((unused))) +{ + pack_s_internal (ret, array, mask, vector, + array_length * sizeof (gfc_char4_t)); +} diff --git a/libgfortran/intrinsics/reshape_generic.c b/libgfortran/intrinsics/reshape_generic.c index e28ed69feba..de1e9426756 100644 --- a/libgfortran/intrinsics/reshape_generic.c +++ b/libgfortran/intrinsics/reshape_generic.c @@ -49,7 +49,7 @@ reshape_internal (parray *ret, parray *source, shape_type *shape, index_type rsize; index_type rs; index_type rex; - char *rptr; + char * restrict rptr; /* s.* indicates the source array. */ index_type scount[GFC_MAX_DIMENSIONS]; index_type sextent[GFC_MAX_DIMENSIONS]; @@ -298,16 +298,33 @@ reshape (parray *ret, parray *source, shape_type *shape, parray *pad, GFC_DESCRIPTOR_SIZE (source)); } -extern void reshape_char (parray *, GFC_INTEGER_4, parray *, shape_type *, - parray *, shape_type *, GFC_INTEGER_4, - GFC_INTEGER_4); + +extern void reshape_char (parray *, gfc_charlen_type, parray *, shape_type *, + parray *, shape_type *, gfc_charlen_type, + gfc_charlen_type); export_proto(reshape_char); void -reshape_char (parray *ret, GFC_INTEGER_4 ret_length __attribute__((unused)), +reshape_char (parray *ret, gfc_charlen_type ret_length __attribute__((unused)), parray *source, shape_type *shape, parray *pad, - shape_type *order, GFC_INTEGER_4 source_length, - GFC_INTEGER_4 pad_length __attribute__((unused))) + shape_type *order, gfc_charlen_type source_length, + gfc_charlen_type pad_length __attribute__((unused))) { reshape_internal (ret, source, shape, pad, order, source_length); } + + +extern void reshape_char4 (parray *, gfc_charlen_type, parray *, shape_type *, + parray *, shape_type *, gfc_charlen_type, + gfc_charlen_type); +export_proto(reshape_char4); + +void +reshape_char4 (parray *ret, gfc_charlen_type ret_length __attribute__((unused)), + parray *source, shape_type *shape, parray *pad, + shape_type *order, gfc_charlen_type source_length, + gfc_charlen_type pad_length __attribute__((unused))) +{ + reshape_internal (ret, source, shape, pad, order, + source_length * sizeof (gfc_char4_t)); +} diff --git a/libgfortran/intrinsics/reshape_packed.c b/libgfortran/intrinsics/reshape_packed.c index cf61f31d4d1..fdc794419fa 100644 --- a/libgfortran/intrinsics/reshape_packed.c +++ b/libgfortran/intrinsics/reshape_packed.c @@ -35,7 +35,7 @@ Boston, MA 02110-1301, USA. */ /* Reshape function where all arrays are packed. Basically just memcpy. */ void -reshape_packed (char * ret, index_type rsize, const char * source, +reshape_packed (char * restrict ret, index_type rsize, const char * source, index_type ssize, const char * pad, index_type psize) { index_type size; diff --git a/libgfortran/intrinsics/spread_generic.c b/libgfortran/intrinsics/spread_generic.c index e37b6e10bbc..68ea6b169c4 100644 --- a/libgfortran/intrinsics/spread_generic.c +++ b/libgfortran/intrinsics/spread_generic.c @@ -408,6 +408,7 @@ spread (gfc_array_char *ret, const gfc_array_char *source, spread_internal (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (source)); } + extern void spread_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *, const index_type *, const index_type *, GFC_INTEGER_4); @@ -422,6 +423,23 @@ spread_char (gfc_array_char *ret, spread_internal (ret, source, along, pncopies, source_length); } + +extern void spread_char4 (gfc_array_char *, GFC_INTEGER_4, + const gfc_array_char *, const index_type *, + const index_type *, GFC_INTEGER_4); +export_proto(spread_char4); + +void +spread_char4 (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char *source, const index_type *along, + const index_type *pncopies, GFC_INTEGER_4 source_length) +{ + spread_internal (ret, source, along, pncopies, + source_length * sizeof (gfc_char4_t)); +} + + /* The following are the prototypes for the versions of spread with a scalar source. */ @@ -584,3 +602,21 @@ spread_char_scalar (gfc_array_char *ret, spread_internal_scalar (ret, source, along, pncopies, source_length); } + +extern void spread_char4_scalar (gfc_array_char *, GFC_INTEGER_4, + const char *, const index_type *, + const index_type *, GFC_INTEGER_4); +export_proto(spread_char4_scalar); + +void +spread_char4_scalar (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const char *source, const index_type *along, + const index_type *pncopies, GFC_INTEGER_4 source_length) +{ + if (!ret->dtype) + runtime_error ("return array missing descriptor in spread()"); + spread_internal_scalar (ret, source, along, pncopies, + source_length * sizeof (gfc_char4_t)); +} + diff --git a/libgfortran/intrinsics/transpose_generic.c b/libgfortran/intrinsics/transpose_generic.c index 97b97133698..5b1929ca55d 100644 --- a/libgfortran/intrinsics/transpose_generic.c +++ b/libgfortran/intrinsics/transpose_generic.c @@ -94,6 +94,7 @@ transpose_internal (gfc_array_char *ret, gfc_array_char *source, } } + extern void transpose (gfc_array_char *, gfc_array_char *); export_proto(transpose); @@ -103,6 +104,7 @@ transpose (gfc_array_char *ret, gfc_array_char *source) transpose_internal (ret, source, GFC_DESCRIPTOR_SIZE (source)); } + extern void transpose_char (gfc_array_char *, GFC_INTEGER_4, gfc_array_char *, GFC_INTEGER_4); export_proto(transpose_char); @@ -114,3 +116,16 @@ transpose_char (gfc_array_char *ret, { transpose_internal (ret, source, source_length); } + + +extern void transpose_char4 (gfc_array_char *, GFC_INTEGER_4, + gfc_array_char *, GFC_INTEGER_4); +export_proto(transpose_char4); + +void +transpose_char4 (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + gfc_array_char *source, GFC_INTEGER_4 source_length) +{ + transpose_internal (ret, source, source_length * sizeof (gfc_char4_t)); +} diff --git a/libgfortran/intrinsics/unpack_generic.c b/libgfortran/intrinsics/unpack_generic.c index 82607bd5897..1800be4ce65 100644 --- a/libgfortran/intrinsics/unpack_generic.c +++ b/libgfortran/intrinsics/unpack_generic.c @@ -42,7 +42,7 @@ unpack_internal (gfc_array_char *ret, const gfc_array_char *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - char *rptr; + char * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; char *vptr; @@ -335,6 +335,7 @@ unpack1 (gfc_array_char *ret, const gfc_array_char *vector, GFC_DESCRIPTOR_SIZE (field)); } + extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *, const gfc_array_l1 *, const gfc_array_char *, GFC_INTEGER_4, @@ -351,6 +352,26 @@ unpack1_char (gfc_array_char *ret, unpack_internal (ret, vector, mask, field, vector_length, field_length); } + +extern void unpack1_char4 (gfc_array_char *, GFC_INTEGER_4, + const gfc_array_char *, const gfc_array_l1 *, + const gfc_array_char *, GFC_INTEGER_4, + GFC_INTEGER_4); +export_proto(unpack1_char4); + +void +unpack1_char4 (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char *vector, const gfc_array_l1 *mask, + const gfc_array_char *field, GFC_INTEGER_4 vector_length, + GFC_INTEGER_4 field_length) +{ + unpack_internal (ret, vector, mask, field, + vector_length * sizeof (gfc_char4_t), + field_length * sizeof (gfc_char4_t)); +} + + extern void unpack0 (gfc_array_char *, const gfc_array_char *, const gfc_array_l1 *, char *); export_proto(unpack0); @@ -500,6 +521,7 @@ unpack0 (gfc_array_char *ret, const gfc_array_char *vector, unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector), 0); } + extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *, const gfc_array_l1 *, char *, GFC_INTEGER_4, GFC_INTEGER_4); @@ -519,3 +541,25 @@ unpack0_char (gfc_array_char *ret, tmp.data = field; unpack_internal (ret, vector, mask, &tmp, vector_length, 0); } + + +extern void unpack0_char4 (gfc_array_char *, GFC_INTEGER_4, + const gfc_array_char *, const gfc_array_l1 *, + char *, GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(unpack0_char4); + +void +unpack0_char4 (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char *vector, const gfc_array_l1 *mask, + char *field, GFC_INTEGER_4 vector_length, + GFC_INTEGER_4 field_length __attribute__((unused))) +{ + gfc_array_char tmp; + + memset (&tmp, 0, sizeof (tmp)); + tmp.dtype = 0; + tmp.data = field; + unpack_internal (ret, vector, mask, &tmp, + vector_length * sizeof (gfc_char4_t), 0); +} diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index 3837f7ecf2e..1aa84704d8a 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -1724,8 +1724,8 @@ check_type (st_parameter_dt *dtp, bt type, int len) greater than one, we copy the data item multiple times. */ static void -list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, - size_t size) +list_formatted_read_scalar (st_parameter_dt *dtp, volatile bt type, void *p, + int kind, size_t size) { char c; int m; diff --git a/libgfortran/m4/eoshift1.m4 b/libgfortran/m4/eoshift1.m4 index 53ec168da61..efa38b201af 100644 --- a/libgfortran/m4/eoshift1.m4 +++ b/libgfortran/m4/eoshift1.m4 @@ -50,7 +50,7 @@ eoshift1 (gfc_array_char * const restrict ret, index_type rstride0; index_type roffset; char *rptr; - char *dest; + char * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/m4/eoshift3.m4 b/libgfortran/m4/eoshift3.m4 index db04ae8f0e6..050f5277822 100644 --- a/libgfortran/m4/eoshift3.m4 +++ b/libgfortran/m4/eoshift3.m4 @@ -50,7 +50,7 @@ eoshift3 (gfc_array_char * const restrict ret, index_type rstride0; index_type roffset; char *rptr; - char *dest; + char * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/m4/iforeach.m4 b/libgfortran/m4/iforeach.m4 index 071900b03b8..a8a353a4bdb 100644 --- a/libgfortran/m4/iforeach.m4 +++ b/libgfortran/m4/iforeach.m4 @@ -17,7 +17,7 @@ name`'rtype_qual`_'atype_code (rtype * const restrict retarray, index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const atype_name *base; - rtype_name *dest; + rtype_name * restrict dest; index_type rank; index_type n; diff --git a/libgfortran/m4/in_pack.m4 b/libgfortran/m4/in_pack.m4 index ce13f954170..5d9b4b719a0 100644 --- a/libgfortran/m4/in_pack.m4 +++ b/libgfortran/m4/in_pack.m4 @@ -51,7 +51,7 @@ internal_pack_'rtype_ccode` ('rtype` * source) index_type dim; index_type ssize; const 'rtype_name` *src; - 'rtype_name` *dest; + 'rtype_name` * restrict dest; 'rtype_name` *destptr; int n; int packed; diff --git a/libgfortran/m4/in_unpack.m4 b/libgfortran/m4/in_unpack.m4 index 00f4f12da33..5c5b5b12a1b 100644 --- a/libgfortran/m4/in_unpack.m4 +++ b/libgfortran/m4/in_unpack.m4 @@ -48,7 +48,7 @@ internal_unpack_'rtype_ccode` ('rtype` * d, const 'rtype_name` * src) index_type stride0; index_type dim; index_type dsize; - 'rtype_name` *dest; + 'rtype_name` * restrict dest; int n; dest = d->data; diff --git a/libgfortran/m4/pack.m4 b/libgfortran/m4/pack.m4 index 4f31ffdd15e..9198b65b20e 100644 --- a/libgfortran/m4/pack.m4 +++ b/libgfortran/m4/pack.m4 @@ -83,7 +83,7 @@ pack_'rtype_code` ('rtype` *ret, const 'rtype` *array, { /* r.* indicates the return array. */ index_type rstride0; - 'rtype_name` *rptr; + 'rtype_name` * restrict rptr; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; diff --git a/libgfortran/m4/spread.m4 b/libgfortran/m4/spread.m4 index c301d1f1e32..b4bdce64316 100644 --- a/libgfortran/m4/spread.m4 +++ b/libgfortran/m4/spread.m4 @@ -49,7 +49,7 @@ spread_'rtype_code` ('rtype` *ret, const 'rtype` *source, index_type rrank; index_type rs; 'rtype_name` *rptr; - 'rtype_name` *dest; + 'rtype_name` * restrict dest; /* s.* indicates the source array. */ index_type sstride[GFC_MAX_DIMENSIONS]; index_type sstride0; @@ -241,7 +241,7 @@ spread_scalar_'rtype_code` ('rtype` *ret, const 'rtype_name` *source, { int n; int ncopies = pncopies; - 'rtype_name` * dest; + 'rtype_name` * restrict dest; index_type stride; if (GFC_DESCRIPTOR_RANK (ret) != 1) diff --git a/libgfortran/m4/transpose.m4 b/libgfortran/m4/transpose.m4 index 177e86dcdc1..103cc0296fb 100644 --- a/libgfortran/m4/transpose.m4 +++ b/libgfortran/m4/transpose.m4 @@ -45,7 +45,7 @@ transpose_'rtype_code` ('rtype` * const restrict ret, { /* r.* indicates the return array. */ index_type rxstride, rystride; - 'rtype_name` *rptr; + 'rtype_name` * restrict rptr; /* s.* indicates the source array. */ index_type sxstride, systride; const 'rtype_name` *sptr; diff --git a/libgfortran/m4/unpack.m4 b/libgfortran/m4/unpack.m4 index 2ad6841a081..fa2b5f1588b 100644 --- a/libgfortran/m4/unpack.m4 +++ b/libgfortran/m4/unpack.m4 @@ -46,7 +46,7 @@ unpack0_'rtype_code` ('rtype` *ret, const 'rtype` *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - 'rtype_name` *rptr; + 'rtype_name` * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; 'rtype_name` *vptr; @@ -189,7 +189,7 @@ unpack1_'rtype_code` ('rtype` *ret, const 'rtype` *vector, index_type rstride[GFC_MAX_DIMENSIONS]; index_type rstride0; index_type rs; - 'rtype_name` *rptr; + 'rtype_name` * restrict rptr; /* v.* indicates the vector array. */ index_type vstride0; 'rtype_name` *vptr; diff --git a/libgfortran/runtime/convert_char.c b/libgfortran/runtime/convert_char.c new file mode 100644 index 00000000000..aa500bb6c8b --- /dev/null +++ b/libgfortran/runtime/convert_char.c @@ -0,0 +1,74 @@ +/* Runtime conversion of strings from one character kind to another. + Copyright 2008 Free Software Foundation, Inc. + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran 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 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran 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 libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" + +#include <stdlib.h> +#include <string.h> + + +extern void convert_char1_to_char4 (gfc_char4_t **, gfc_charlen_type, + const unsigned char *); +export_proto(convert_char1_to_char4); + +extern void convert_char4_to_char1 (unsigned char **, gfc_charlen_type, + const gfc_char4_t *); +export_proto(convert_char4_to_char1); + + +void +convert_char1_to_char4 (gfc_char4_t **dst, gfc_charlen_type len, + const unsigned char *src) +{ + gfc_charlen_type i, l; + + l = len > 0 ? len : 0; + *dst = get_mem ((l + 1) * sizeof (gfc_char4_t)); + + for (i = 0; i < l; i++) + (*dst)[i] = src[i]; + + (*dst)[l] = '\0'; +} + + +void +convert_char4_to_char1 (unsigned char **dst, gfc_charlen_type len, + const gfc_char4_t *src) +{ + gfc_charlen_type i, l; + + l = len > 0 ? len : 0; + *dst = get_mem ((l + 1) * sizeof (unsigned char)); + + for (i = 0; i < l; i++) + (*dst)[i] = src[i]; + + (*dst)[l] = '\0'; +} diff --git a/libgfortran/runtime/select.c b/libgfortran/runtime/select.c index 44c353235a0..688acfc3852 100644 --- a/libgfortran/runtime/select.c +++ b/libgfortran/runtime/select.c @@ -1,12 +1,12 @@ /* Implement the SELECT statement for character variables. - Contributed by Andy Vaught + Copyright 2008 Free Software Foundation, Inc. -This file is part of the GNU Fortran 95 runtime library (libgfortran). +This file is part of the GNU Fortran runtime library (libgfortran). -Libgfortran 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 2, or (at your option) -any later version. +Libgfortran 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 2 of the License, or (at your option) any later version. In addition to the permissions in the GNU General Public License, the Free Software Foundation gives you unlimited permission to link the @@ -22,116 +22,31 @@ 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 libgfortran; see the file COPYING. If not, write to -the Free Software Foundation, 51 Franklin Street, Fifth Floor, +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ -#include "libgfortran.h" - -typedef struct -{ - char *low; - int low_len; - char *high; - int high_len; - int address; -} -select_struct; - -extern int select_string (select_struct *table, int table_len, - const char *selector, int selector_len); -export_proto(select_string); - - -/* select_string()-- Given a selector string and a table of - * select_struct structures, return the address to jump to. */ - -int -select_string (select_struct *table, int table_len, const char *selector, - int selector_len) -{ - select_struct *t; - int i, low, high, mid; - int default_jump = -1; - - if (table_len == 0) - return -1; - - /* Record the default address if present */ - - if (table->low == NULL && table->high == NULL) - { - default_jump = table->address; - table++; - table_len--; - if (table_len == 0) - return default_jump; - } - - /* Try the high and low bounds if present. */ - - if (table->low == NULL) - { - if (compare_string (table->high_len, table->high, - selector_len, selector) >= 0) - return table->address; - - table++; - table_len--; - if (table_len == 0) - return default_jump; - } - - t = table + table_len - 1; - - if (t->high == NULL) - { - if (compare_string (t->low_len, t->low, - selector_len, selector) <= 0) - return t->address; - - table_len--; - if (table_len == 0) - return default_jump; - } - - /* At this point, the only table entries are bounded entries. Find - the right entry with a binary chop. */ - - low = -1; - high = table_len; +#include "libgfortran.h" - while (low + 1 < high) - { - mid = (low + high) / 2; - t = table + mid; - i = compare_string (t->low_len, t->low, selector_len, selector); +/* The string selection function is defined using a few generic macros + in select_inc.c, so we avoid code duplication between the various + character type kinds. */ - if (i == 0) - return t->address; +#undef CHARTYPE +#define CHARTYPE char +#undef SUFFIX +#define SUFFIX(x) x - if (i < 0) - low = mid; - else - high = mid; - } +#include "select_inc.c" - /* The string now lies between the low indeces of the now-adjacent - high and low entries. Because it is less than the low entry of - 'high', it can't be that one. If low is still -1, then no - entries match. Otherwise, we have to check the high entry of - 'low'. */ - if (low == -1) - return default_jump; +#undef CHARTYPE +#define CHARTYPE gfc_char4_t +#undef SUFFIX +#define SUFFIX(x) x ## _char4 - t = table + low; - if (compare_string (selector_len, selector, - t->high_len, t->high) <= 0) - return t->address; +#include "select_inc.c" - return default_jump; -} diff --git a/libgfortran/runtime/select_inc.c b/libgfortran/runtime/select_inc.c new file mode 100644 index 00000000000..81a8dabf739 --- /dev/null +++ b/libgfortran/runtime/select_inc.c @@ -0,0 +1,139 @@ +/* Implement the SELECT statement for character variables. + Copyright 2008 Free Software Foundation, Inc. + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran 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 2, or (at your option) +any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran 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 libgfortran; see the file COPYING. If not, write to +the Free Software Foundation, 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + + +#define select_string SUFFIX(select_string) +#define select_struct SUFFIX(select_struct) +#define compare_string SUFFIX(compare_string) + +typedef struct +{ + CHARTYPE *low; + gfc_charlen_type low_len; + CHARTYPE *high; + gfc_charlen_type high_len; + int address; +} +select_struct; + +extern int select_string (select_struct *table, int table_len, + const CHARTYPE *selector, + gfc_charlen_type selector_len); +export_proto(select_string); + + +/* select_string()-- Given a selector string and a table of + * select_struct structures, return the address to jump to. */ + +int +select_string (select_struct *table, int table_len, const CHARTYPE *selector, + gfc_charlen_type selector_len) +{ + select_struct *t; + int i, low, high, mid; + int default_jump = -1; + + if (table_len == 0) + return -1; + + /* Record the default address if present */ + + if (table->low == NULL && table->high == NULL) + { + default_jump = table->address; + + table++; + table_len--; + if (table_len == 0) + return default_jump; + } + + /* Try the high and low bounds if present. */ + + if (table->low == NULL) + { + if (compare_string (table->high_len, table->high, + selector_len, selector) >= 0) + return table->address; + + table++; + table_len--; + if (table_len == 0) + return default_jump; + } + + t = table + table_len - 1; + + if (t->high == NULL) + { + if (compare_string (t->low_len, t->low, selector_len, selector) <= 0) + return t->address; + + table_len--; + if (table_len == 0) + return default_jump; + } + + /* At this point, the only table entries are bounded entries. Find + the right entry with a binary chop. */ + + low = -1; + high = table_len; + + while (low + 1 < high) + { + mid = (low + high) / 2; + + t = table + mid; + i = compare_string (t->low_len, t->low, selector_len, selector); + + if (i == 0) + return t->address; + + if (i < 0) + low = mid; + else + high = mid; + } + + /* The string now lies between the low indeces of the now-adjacent + high and low entries. Because it is less than the low entry of + 'high', it can't be that one. If low is still -1, then no + entries match. Otherwise, we have to check the high entry of + 'low'. */ + + if (low == -1) + return default_jump; + + t = table + low; + if (compare_string (selector_len, selector, t->high_len, t->high) <= 0) + return t->address; + + return default_jump; +} diff --git a/libjava/ChangeLog b/libjava/ChangeLog index c639181c878..e8cd46e8947 100644 --- a/libjava/ChangeLog +++ b/libjava/ChangeLog @@ -1,3 +1,16 @@ +2008-05-20 David Daney <ddaney@avtrex.com> + + PR libgcj/36252 + * java/lang/natString.ccn: Add + #include <java/io/CharConversionException.h>. + (init (byte[], int, int, String)): Catch and ignore + CharConversionException. Break out of conversion loop + on incomplete input. + * testsuite/libjava.lang/PR36252.java: New test. + * testsuite/libjava.lang/PR36252.out: New file, its expected output. + * testsuite/libjava.lang/PR36252.jar: New file, its pre-compiled + jar file. + 2008-04-19 Tom Tromey <tromey@redhat.com> PR libgcj/35979: diff --git a/libjava/java/lang/natString.cc b/libjava/java/lang/natString.cc index f177c23ccc4..75006a7c9a7 100644 --- a/libjava/java/lang/natString.cc +++ b/libjava/java/lang/natString.cc @@ -1,6 +1,7 @@ // natString.cc - Implementation of java.lang.String native methods. -/* Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation +/* Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, + 2007, 2008 Free Software Foundation This file is part of libgcj. @@ -23,6 +24,7 @@ details. */ #include <java/lang/NullPointerException.h> #include <java/lang/StringBuffer.h> #include <java/io/ByteArrayOutputStream.h> +#include <java/io/CharConversionException.h> #include <java/io/OutputStreamWriter.h> #include <java/io/ByteArrayInputStream.h> #include <java/io/InputStreamReader.h> @@ -493,9 +495,28 @@ java::lang::String::init (jbyteArray bytes, jint offset, jint count, converter->setInput(bytes, offset, offset+count); while (converter->inpos < converter->inlength) { - int done = converter->read(array, outpos, avail); + int done; + try + { + done = converter->read(array, outpos, avail); + } + catch (::java::io::CharConversionException *e) + { + // Ignore it and silently throw away the offending data. + break; + } if (done == 0) { + // done is zero if either there is no space available in the + // output *or* the input is incomplete. We assume that if + // there are 20 characters available in the output, the + // input must be incomplete and there is no more work to do. + // This means we may skip several bytes of input, but that + // is OK as the behavior is explicitly unspecified in this + // case. + if (avail - outpos > 20) + break; + jint new_size = 2 * (outpos + avail); jcharArray new_array = JvNewCharArray (new_size); memcpy (elements (new_array), elements (array), diff --git a/libjava/testsuite/libjava.lang/PR36252.jar b/libjava/testsuite/libjava.lang/PR36252.jar Binary files differnew file mode 100644 index 00000000000..2c0d2c0e906 --- /dev/null +++ b/libjava/testsuite/libjava.lang/PR36252.jar diff --git a/libjava/testsuite/libjava.lang/PR36252.java b/libjava/testsuite/libjava.lang/PR36252.java new file mode 100644 index 00000000000..4f39a678b1a --- /dev/null +++ b/libjava/testsuite/libjava.lang/PR36252.java @@ -0,0 +1,16 @@ +import java.io.UnsupportedEncodingException; + +public class PR36252 +{ + public static void main(String[] args) + { + try { + byte[] txt = new byte[] {-55, 87, -55, -42, -55, -20}; + // This new String(...) should not throw an OutOfMemoryError. + String s = new String(txt, 0, 6, "MS932"); + } catch (UnsupportedEncodingException e) { + // Silently ignore. + } + System.out.println("ok"); + } +} diff --git a/libjava/testsuite/libjava.lang/PR36252.out b/libjava/testsuite/libjava.lang/PR36252.out new file mode 100644 index 00000000000..9766475a418 --- /dev/null +++ b/libjava/testsuite/libjava.lang/PR36252.out @@ -0,0 +1 @@ +ok diff --git a/libstdc++-v3/ChangeLog b/libstdc++-v3/ChangeLog index 1a32e5572e4..c2b2ea60340 100644 --- a/libstdc++-v3/ChangeLog +++ b/libstdc++-v3/ChangeLog @@ -1,3 +1,27 @@ +2008-05-20 Paolo Carlini <paolo.carlini@oracle.com> + + PR c++/33979 (partial) + * include/tr1_impl/functional_hash.h (hash<char16_t>, + hash<char32_t>): Add specializations. + * include/tr1_impl/type_traits (is_integral<char16_t>, + is_integral<char32_t>): Likewise. + * include/std/limits (numeric_limits<char16_t>, + numeric_limits<char32_t>): Likewise. + * src/limits_c++0x.cc: Add. + * src/Makefile.am: Update. + * testsuite/20_util/hash/requirements/explicit_instantiation.cc: + Update. + * testsuite/20_util/is_integral/value.cc: New. + * testsuite/20_util/is_integral/requirements/typedefs.cc: Likewise. + * testsuite/20_util/is_integral/requirements/ + explicit_instantiation.cc: Likewise. + * testsuite/18_support/numeric_limits/char16_32_t.cc: Likewise. + * config/abi/pre/gnu.ver: Export new numeric_limits symbols at + GLIBCXX_3.4.11. + * configure: Regenerate. + * src/Makefile.in: Likewise. + * config.h.in: Likewise. + 2008-05-16 Benjamin Kosnik <bkoz@redhat.com> * include/std/system_error: Align to current draft specifications. diff --git a/libstdc++-v3/config.h.in b/libstdc++-v3/config.h.in index d4eee4482ff..bb7ecafc12d 100644 --- a/libstdc++-v3/config.h.in +++ b/libstdc++-v3/config.h.in @@ -379,9 +379,6 @@ /* Define to 1 if you have the <sys/machine.h> header file. */ #undef HAVE_SYS_MACHINE_H -/* Define if sys_nerr exists. */ -#undef HAVE_SYS_NERR - /* Define to 1 if you have the <sys/param.h> header file. */ #undef HAVE_SYS_PARAM_H diff --git a/libstdc++-v3/config/abi/pre/gnu.ver b/libstdc++-v3/config/abi/pre/gnu.ver index 225e6e5c71f..547624c893f 100644 --- a/libstdc++-v3/config/abi/pre/gnu.ver +++ b/libstdc++-v3/config/abi/pre/gnu.ver @@ -383,7 +383,8 @@ GLIBCXX_3.4 { _ZNKSt9money_putI[cw]St19ostreambuf_iteratorI[cw]St11char_traitsI[cw]EEE*; # std::numeric_limits - _ZNSt14numeric_limitsI[^g]*; + # _ZNSt14numeric_limitsI[^g]*; + _ZNSt14numeric_limitsI[a-z]E*; # std::_Rb_tree _ZSt18_Rb_tree_decrementPKSt18_Rb_tree_node_base; @@ -891,6 +892,9 @@ GLIBCXX_3.4.11 { _ZNSt11system_time16ticks_per_secondE; _ZNSt11system_time12is_subsecondE; + # char16_t and char32_t + _ZNSt14numeric_limitsIu8char*; + } GLIBCXX_3.4.10; # Symbols in the support library (libsupc++) have their own tag. diff --git a/libstdc++-v3/configure b/libstdc++-v3/configure index 662ff3d25a0..dddf05b8630 100755 --- a/libstdc++-v3/configure +++ b/libstdc++-v3/configure @@ -458,7 +458,7 @@ ac_includes_default="\ # include <unistd.h> #endif" -ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS libtool_VERSION multi_basedir build build_cpu build_vendor build_os host host_cpu host_vendor host_os target target_cpu target_vendor target_os INSTALL_PROGRAM INSTALL_SCRIPT INSTALL_DATA CYGPATH_W PACKAGE VERSION ACLOCAL AUTOCONF AUTOMAKE AUTOHEADER MAKEINFO install_sh STRIP ac_ct_STRIP INSTALL_STRIP_PROGRAM mkdir_p AWK SET_MAKE am__leading_dot AMTAR am__tar am__untar glibcxx_builddir glibcxx_srcdir toplevel_srcdir CC ac_ct_CC EXEEXT OBJEXT CXX ac_ct_CXX CFLAGS CXXFLAGS LN_S AS ac_ct_AS AR ac_ct_AR RANLIB ac_ct_RANLIB MAINTAINER_MODE_TRUE MAINTAINER_MODE_FALSE MAINT CPP CPPFLAGS EGREP LIBTOOL SED FGREP GREP LD DUMPBIN ac_ct_DUMPBIN NM lt_ECHO LDFLAGS CXXCPP enable_shared enable_static GLIBCXX_HOSTED_TRUE GLIBCXX_HOSTED_FALSE GLIBCXX_BUILD_PCH_TRUE GLIBCXX_BUILD_PCH_FALSE glibcxx_PCHFLAGS CSTDIO_H BASIC_FILE_H BASIC_FILE_CC check_msgfmt glibcxx_MOFILES glibcxx_POFILES glibcxx_localedir USE_NLS CLOCALE_H CMESSAGES_H CCODECVT_CC CCOLLATE_CC CCTYPE_CC CMESSAGES_CC CMONEY_CC CNUMERIC_CC CTIME_H CTIME_CC CLOCALE_CC CLOCALE_INTERNAL_H ALLOCATOR_H ALLOCATOR_NAME C_INCLUDE_DIR GLIBCXX_C_HEADERS_C_TRUE GLIBCXX_C_HEADERS_C_FALSE GLIBCXX_C_HEADERS_C_STD_TRUE GLIBCXX_C_HEADERS_C_STD_FALSE GLIBCXX_C_HEADERS_C_GLOBAL_TRUE GLIBCXX_C_HEADERS_C_GLOBAL_FALSE GLIBCXX_C_HEADERS_COMPATIBILITY_TRUE GLIBCXX_C_HEADERS_COMPATIBILITY_FALSE GLIBCXX_C_HEADERS_EXTRA_TRUE GLIBCXX_C_HEADERS_EXTRA_FALSE DEBUG_FLAGS GLIBCXX_BUILD_DEBUG_TRUE GLIBCXX_BUILD_DEBUG_FALSE ENABLE_PARALLEL_TRUE ENABLE_PARALLEL_FALSE EXTRA_CXX_FLAGS glibcxx_thread_h WERROR SECTION_FLAGS SECTION_LDFLAGS OPT_LDFLAGS LIBMATHOBJS LIBICONV LTLIBICONV SYMVER_FILE port_specific_symbol_files ENABLE_SYMVERS_TRUE ENABLE_SYMVERS_FALSE ENABLE_SYMVERS_GNU_TRUE ENABLE_SYMVERS_GNU_FALSE ENABLE_SYMVERS_GNU_NAMESPACE_TRUE ENABLE_SYMVERS_GNU_NAMESPACE_FALSE ENABLE_SYMVERS_DARWIN_TRUE ENABLE_SYMVERS_DARWIN_FALSE ENABLE_VISIBILITY_TRUE ENABLE_VISIBILITY_FALSE GLIBCXX_LDBL_COMPAT_TRUE GLIBCXX_LDBL_COMPAT_FALSE baseline_dir ATOMICITY_SRCDIR ATOMIC_WORD_SRCDIR ATOMIC_FLAGS CPU_DEFINES_SRCDIR ABI_TWEAKS_SRCDIR OS_INC_SRCDIR ERROR_CONSTANTS_SRCDIR glibcxx_prefixdir gxx_include_dir glibcxx_toolexecdir glibcxx_toolexeclibdir GLIBCXX_INCLUDES TOPLEVEL_INCLUDES OPTIMIZE_CXXFLAGS WARN_FLAGS LIBSUPCXX_PICFLAGS LIBOBJS LTLIBOBJS' +ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS libtool_VERSION multi_basedir build build_cpu build_vendor build_os host host_cpu host_vendor host_os target target_cpu target_vendor target_os INSTALL_PROGRAM INSTALL_SCRIPT INSTALL_DATA CYGPATH_W PACKAGE VERSION ACLOCAL AUTOCONF AUTOMAKE AUTOHEADER MAKEINFO install_sh STRIP ac_ct_STRIP INSTALL_STRIP_PROGRAM mkdir_p AWK SET_MAKE am__leading_dot AMTAR am__tar am__untar glibcxx_builddir glibcxx_srcdir toplevel_srcdir CC ac_ct_CC EXEEXT OBJEXT CXX ac_ct_CXX CFLAGS CXXFLAGS LN_S AS ac_ct_AS AR ac_ct_AR RANLIB ac_ct_RANLIB MAINTAINER_MODE_TRUE MAINTAINER_MODE_FALSE MAINT CPP CPPFLAGS EGREP LIBTOOL SED FGREP GREP LD DUMPBIN ac_ct_DUMPBIN NM lt_ECHO LDFLAGS CXXCPP enable_shared enable_static GLIBCXX_HOSTED_TRUE GLIBCXX_HOSTED_FALSE GLIBCXX_BUILD_PCH_TRUE GLIBCXX_BUILD_PCH_FALSE glibcxx_PCHFLAGS glibcxx_thread_h WERROR SECTION_FLAGS CSTDIO_H BASIC_FILE_H BASIC_FILE_CC check_msgfmt glibcxx_MOFILES glibcxx_POFILES glibcxx_localedir USE_NLS CLOCALE_H CMESSAGES_H CCODECVT_CC CCOLLATE_CC CCTYPE_CC CMESSAGES_CC CMONEY_CC CNUMERIC_CC CTIME_H CTIME_CC CLOCALE_CC CLOCALE_INTERNAL_H ALLOCATOR_H ALLOCATOR_NAME C_INCLUDE_DIR GLIBCXX_C_HEADERS_C_TRUE GLIBCXX_C_HEADERS_C_FALSE GLIBCXX_C_HEADERS_C_STD_TRUE GLIBCXX_C_HEADERS_C_STD_FALSE GLIBCXX_C_HEADERS_C_GLOBAL_TRUE GLIBCXX_C_HEADERS_C_GLOBAL_FALSE GLIBCXX_C_HEADERS_COMPATIBILITY_TRUE GLIBCXX_C_HEADERS_COMPATIBILITY_FALSE GLIBCXX_C_HEADERS_EXTRA_TRUE GLIBCXX_C_HEADERS_EXTRA_FALSE DEBUG_FLAGS GLIBCXX_BUILD_DEBUG_TRUE GLIBCXX_BUILD_DEBUG_FALSE ENABLE_PARALLEL_TRUE ENABLE_PARALLEL_FALSE EXTRA_CXX_FLAGS SECTION_LDFLAGS OPT_LDFLAGS LIBMATHOBJS LIBICONV LTLIBICONV SYMVER_FILE port_specific_symbol_files ENABLE_SYMVERS_TRUE ENABLE_SYMVERS_FALSE ENABLE_SYMVERS_GNU_TRUE ENABLE_SYMVERS_GNU_FALSE ENABLE_SYMVERS_GNU_NAMESPACE_TRUE ENABLE_SYMVERS_GNU_NAMESPACE_FALSE ENABLE_SYMVERS_DARWIN_TRUE ENABLE_SYMVERS_DARWIN_FALSE ENABLE_VISIBILITY_TRUE ENABLE_VISIBILITY_FALSE GLIBCXX_LDBL_COMPAT_TRUE GLIBCXX_LDBL_COMPAT_FALSE baseline_dir ATOMICITY_SRCDIR ATOMIC_WORD_SRCDIR ATOMIC_FLAGS CPU_DEFINES_SRCDIR ABI_TWEAKS_SRCDIR OS_INC_SRCDIR ERROR_CONSTANTS_SRCDIR glibcxx_prefixdir gxx_include_dir glibcxx_toolexecdir glibcxx_toolexeclibdir GLIBCXX_INCLUDES TOPLEVEL_INCLUDES OPTIMIZE_CXXFLAGS WARN_FLAGS LIBSUPCXX_PICFLAGS LIBOBJS LTLIBOBJS' ac_subst_files='' # Initialize some variables set by options. @@ -4146,10 +4146,12 @@ echo "$as_me: OS config directory is $os_include_dir" >&6;} -enable_dlopen=yes +if test "x${with_newlib}" != "xyes"; then + enable_dlopen=yes +fi macro_version='2.1a' @@ -4666,13 +4668,13 @@ if test "${lt_cv_nm_interface+set}" = set; then else lt_cv_nm_interface="BSD nm" echo "int some_variable = 0;" > conftest.$ac_ext - (eval echo "\"\$as_me:4669: $ac_compile\"" >&5) + (eval echo "\"\$as_me:4671: $ac_compile\"" >&5) (eval "$ac_compile" 2>conftest.err) cat conftest.err >&5 - (eval echo "\"\$as_me:4672: $NM \\\"conftest.$ac_objext\\\"\"" >&5) + (eval echo "\"\$as_me:4674: $NM \\\"conftest.$ac_objext\\\"\"" >&5) (eval "$NM \"conftest.$ac_objext\"" 2>conftest.err > conftest.out) cat conftest.err >&5 - (eval echo "\"\$as_me:4675: output\"" >&5) + (eval echo "\"\$as_me:4677: output\"" >&5) cat conftest.out >&5 if $GREP 'External.*some_variable' conftest.out > /dev/null; then lt_cv_nm_interface="MS dumpbin" @@ -5716,7 +5718,7 @@ ia64-*-hpux*) ;; *-*-irix6*) # Find out which ABI we are using. - echo '#line 5719 "configure"' > conftest.$ac_ext + echo '#line 5721 "configure"' > conftest.$ac_ext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>&5 ac_status=$? @@ -7178,11 +7180,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:7181: $lt_compile\"" >&5) + (eval echo "\"\$as_me:7183: $lt_compile\"" >&5) (eval "$lt_compile" 2>conftest.err) ac_status=$? cat conftest.err >&5 - echo "$as_me:7185: \$? = $ac_status" >&5 + echo "$as_me:7187: \$? = $ac_status" >&5 if (exit $ac_status) && test -s "$ac_outfile"; then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings other than the usual output. @@ -7500,11 +7502,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:7503: $lt_compile\"" >&5) + (eval echo "\"\$as_me:7505: $lt_compile\"" >&5) (eval "$lt_compile" 2>conftest.err) ac_status=$? cat conftest.err >&5 - echo "$as_me:7507: \$? = $ac_status" >&5 + echo "$as_me:7509: \$? = $ac_status" >&5 if (exit $ac_status) && test -s "$ac_outfile"; then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings other than the usual output. @@ -7605,11 +7607,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:7608: $lt_compile\"" >&5) + (eval echo "\"\$as_me:7610: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 - echo "$as_me:7612: \$? = $ac_status" >&5 + echo "$as_me:7614: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized @@ -7660,11 +7662,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:7663: $lt_compile\"" >&5) + (eval echo "\"\$as_me:7665: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 - echo "$as_me:7667: \$? = $ac_status" >&5 + echo "$as_me:7669: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized @@ -10512,7 +10514,7 @@ else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 lt_status=$lt_dlunknown cat > conftest.$ac_ext <<_LT_EOF -#line 10515 "configure" +#line 10517 "configure" #include "confdefs.h" #if HAVE_DLFCN_H @@ -10612,7 +10614,7 @@ else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 lt_status=$lt_dlunknown cat > conftest.$ac_ext <<_LT_EOF -#line 10615 "configure" +#line 10617 "configure" #include "confdefs.h" #if HAVE_DLFCN_H @@ -12650,11 +12652,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:12653: $lt_compile\"" >&5) + (eval echo "\"\$as_me:12655: $lt_compile\"" >&5) (eval "$lt_compile" 2>conftest.err) ac_status=$? cat conftest.err >&5 - echo "$as_me:12657: \$? = $ac_status" >&5 + echo "$as_me:12659: \$? = $ac_status" >&5 if (exit $ac_status) && test -s "$ac_outfile"; then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings other than the usual output. @@ -12749,11 +12751,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:12752: $lt_compile\"" >&5) + (eval echo "\"\$as_me:12754: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 - echo "$as_me:12756: \$? = $ac_status" >&5 + echo "$as_me:12758: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized @@ -12801,11 +12803,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:12804: $lt_compile\"" >&5) + (eval echo "\"\$as_me:12806: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 - echo "$as_me:12808: \$? = $ac_status" >&5 + echo "$as_me:12810: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized @@ -13850,7 +13852,7 @@ fi; # # Fake what AC_TRY_COMPILE does. XXX Look at redoing this new-style. cat > conftest.$ac_ext << EOF -#line 13853 "configure" +#line 13855 "configure" struct S { ~S(); }; void bar(); void foo() @@ -13979,6 +13981,354 @@ echo "${ECHO_T}$enable_libstdcxx_pch" >&6 + + + ac_ext=cc +ac_cpp='$CXXCPP $CPPFLAGS' +ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_cxx_compiler_gnu + + old_CXXFLAGS="$CXXFLAGS" + + # Compile unoptimized. + CXXFLAGS='-O0 -S' + + # Fake what AC_TRY_COMPILE does, without linking as this is + # unnecessary for a builtins test. + + cat > conftest.$ac_ext << EOF +#line 14001 "configure" +int main() +{ + // NB: _Atomic_word not necessarily int. + typedef int atomic_type; + atomic_type c1; + atomic_type c2; + const atomic_type c3(0); + __sync_fetch_and_add(&c1, c2); + __sync_val_compare_and_swap(&c1, c3, c2); + __sync_lock_test_and_set(&c1, c3); + __sync_lock_release(&c1); + __sync_synchronize(); + return 0; +} +EOF + + echo "$as_me:$LINENO: checking for atomic builtins for int" >&5 +echo $ECHO_N "checking for atomic builtins for int... $ECHO_C" >&6 + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + if grep __sync_ conftest.s >/dev/null 2>&1 ; then + enable_atomic_builtinsi=no + else + +cat >>confdefs.h <<\_ACEOF +#define _GLIBCXX_ATOMIC_BUILTINS_4 1 +_ACEOF + + enable_atomic_builtinsi=yes + fi + fi + echo "$as_me:$LINENO: result: $enable_atomic_builtinsi" >&5 +echo "${ECHO_T}$enable_atomic_builtinsi" >&6 + rm -f conftest* + + cat > conftest.$ac_ext << EOF +#line 14041 "configure" +int main() +{ + typedef bool atomic_type; + atomic_type c1; + atomic_type c2; + const atomic_type c3(0); + __sync_fetch_and_add(&c1, c2); + __sync_val_compare_and_swap(&c1, c3, c2); + __sync_lock_test_and_set(&c1, c3); + __sync_lock_release(&c1); + __sync_synchronize(); + return 0; +} +EOF + + echo "$as_me:$LINENO: checking for atomic builtins for bool" >&5 +echo $ECHO_N "checking for atomic builtins for bool... $ECHO_C" >&6 + if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + if grep __sync_ conftest.s >/dev/null 2>&1 ; then + enable_atomic_builtinsb=no + else + +cat >>confdefs.h <<\_ACEOF +#define _GLIBCXX_ATOMIC_BUILTINS_1 1 +_ACEOF + + enable_atomic_builtinsb=yes + fi + fi + echo "$as_me:$LINENO: result: $enable_atomic_builtinsb" >&5 +echo "${ECHO_T}$enable_atomic_builtinsb" >&6 + rm -f conftest* + + CXXFLAGS="$old_CXXFLAGS" + ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + # Set atomicity_dir to builtins if either of above tests pass. + if test $enable_atomic_builtinsi = yes || test $enable_atomic_builtinsb = yes ; then + atomicity_dir=cpu/generic/atomicity_builtins + fi + + # If still generic, set to mutex. + if test $atomicity_dir = "cpu/generic" ; then + atomicity_dir=cpu/generic/atomicity_mutex + { echo "$as_me:$LINENO: WARNING: No native atomic operations are provided for this platform." >&5 +echo "$as_me: WARNING: No native atomic operations are provided for this platform." >&2;} + if test $target_thread_file = single; then + { echo "$as_me:$LINENO: WARNING: They cannot be faked when thread support is disabled." >&5 +echo "$as_me: WARNING: They cannot be faked when thread support is disabled." >&2;} + { echo "$as_me:$LINENO: WARNING: Thread-safety of certain classes is not guaranteed." >&5 +echo "$as_me: WARNING: Thread-safety of certain classes is not guaranteed." >&2;} + else + { echo "$as_me:$LINENO: WARNING: They will be faked using a mutex." >&5 +echo "$as_me: WARNING: They will be faked using a mutex." >&2;} + { echo "$as_me:$LINENO: WARNING: Performance of certain classes will degrade as a result." >&5 +echo "$as_me: WARNING: Performance of certain classes will degrade as a result." >&2;} + fi + fi + + + + echo "$as_me:$LINENO: checking for thread model used by GCC" >&5 +echo $ECHO_N "checking for thread model used by GCC... $ECHO_C" >&6 + target_thread_file=`$CXX -v 2>&1 | sed -n 's/^Thread model: //p'` + echo "$as_me:$LINENO: result: $target_thread_file" >&5 +echo "${ECHO_T}$target_thread_file" >&6 + + if test $target_thread_file != single; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_GTHR_DEFAULT 1 +_ACEOF + + fi + + glibcxx_thread_h=gthr-$target_thread_file.h + + gthread_file=${toplevel_srcdir}/gcc/${glibcxx_thread_h} + if grep __GTHREADS $gthread_file >/dev/null 2>&1 ; then + enable_thread=yes + else + enable_thread=no + fi + + + + +# Checks for compiler support that don't require linking. + + # All these tests are for C++; save the language and the compiler flags. + # The CXXFLAGS thing is suspicious, but based on similar bits previously + # found in GLIBCXX_CONFIGURE. + + + ac_ext=cc +ac_cpp='$CXXCPP $CPPFLAGS' +ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_cxx_compiler_gnu + + ac_test_CXXFLAGS="${CXXFLAGS+set}" + ac_save_CXXFLAGS="$CXXFLAGS" + + # Check for maintainer-mode bits. + if test x"$USE_MAINTAINER_MODE" = xno; then + WERROR='' + else + WERROR='-Werror' + fi + + # Check for -ffunction-sections -fdata-sections + echo "$as_me:$LINENO: checking for g++ that supports -ffunction-sections -fdata-sections" >&5 +echo $ECHO_N "checking for g++ that supports -ffunction-sections -fdata-sections... $ECHO_C" >&6 + CXXFLAGS='-g -Werror -ffunction-sections -fdata-sections' + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +int foo; void bar() { }; +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_cxx_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_fdsections=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_fdsections=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + if test "$ac_test_CXXFLAGS" = set; then + CXXFLAGS="$ac_save_CXXFLAGS" + else + # this is the suspicious part + CXXFLAGS='' + fi + if test x"$ac_fdsections" = x"yes"; then + SECTION_FLAGS='-ffunction-sections -fdata-sections' + fi + echo "$as_me:$LINENO: result: $ac_fdsections" >&5 +echo "${ECHO_T}$ac_fdsections" >&6 + + ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + + + + + echo "$as_me:$LINENO: checking for ISO C++200x standard layout type support" >&5 +echo $ECHO_N "checking for ISO C++200x standard layout type support... $ECHO_C" >&6 + if test "${ac_standard_layout+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + + + + ac_ext=cc +ac_cpp='$CXXCPP $CPPFLAGS' +ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_cxx_compiler_gnu + + ac_test_CXXFLAGS="${CXXFLAGS+set}" + ac_save_CXXFLAGS="$CXXFLAGS" + CXXFLAGS='-std=gnu++0x' + + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +struct b + { + bool t; + + // Need standard layout relaxation from POD + private: + b& operator=(const b&); + b(const b&); + }; + + int main() + { + b tst1 = { false }; + return 0; + } +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_cxx_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_standard_layout=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_standard_layout=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + + CXXFLAGS="$ac_save_CXXFLAGS" + ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +fi + + echo "$as_me:$LINENO: result: $ac_standard_layout" >&5 +echo "${ECHO_T}$ac_standard_layout" >&6 + if test x"$ac_standard_layout" = x"yes"; then + +cat >>confdefs.h <<\_ACEOF +#define _GLIBCXX_USE_STANDARD_LAYOUT 1 +_ACEOF + + fi + + # Enable all the variable C++ runtime options that doesn't require linking. echo "$as_me:$LINENO: checking for underlying I/O to use" >&5 @@ -15558,7 +15908,7 @@ fi # Check for the existence of <math.h> functions used if C99 is enabled. echo "$as_me:$LINENO: checking for ISO C99 support in <math.h>" >&5 echo $ECHO_N "checking for ISO C99 support in <math.h>... $ECHO_C" >&6 - if test "${ac_c99_math+set}" = set; then + if test "${glibcxx_cv_c99_math+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -15615,12 +15965,12 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_c99_math=yes + glibcxx_cv_c99_math=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_c99_math=no +glibcxx_cv_c99_math=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext else @@ -15681,12 +16031,12 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_c99_math=yes + glibcxx_cv_c99_math=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_c99_math=no +glibcxx_cv_c99_math=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext @@ -15694,9 +16044,9 @@ fi fi - echo "$as_me:$LINENO: result: $ac_c99_math" >&5 -echo "${ECHO_T}$ac_c99_math" >&6 - if test x"$ac_c99_math" = x"yes"; then + echo "$as_me:$LINENO: result: $glibcxx_cv_c99_math" >&5 +echo "${ECHO_T}$glibcxx_cv_c99_math" >&6 + if test x"$glibcxx_cv_c99_math" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define _GLIBCXX_USE_C99_MATH 1 @@ -16012,7 +16362,7 @@ fi done - ac_c99_complex=no; + glibcxx_cv_c99_complex=no; if test x"$ac_has_complex_h" = x"yes"; then echo "$as_me:$LINENO: checking for ISO C99 support in <complex.h>" >&5 echo $ECHO_N "checking for ISO C99 support in <complex.h>... $ECHO_C" >&6 @@ -16099,12 +16449,12 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_c99_complex=yes + glibcxx_cv_c99_complex=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_c99_complex=no +glibcxx_cv_c99_complex=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext else @@ -16195,20 +16545,20 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_c99_complex=yes + glibcxx_cv_c99_complex=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_c99_complex=no +glibcxx_cv_c99_complex=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi fi - echo "$as_me:$LINENO: result: $ac_c99_complex" >&5 -echo "${ECHO_T}$ac_c99_complex" >&6 - if test x"$ac_c99_complex" = x"yes"; then + echo "$as_me:$LINENO: result: $glibcxx_cv_c99_complex" >&5 +echo "${ECHO_T}$glibcxx_cv_c99_complex" >&6 + if test x"$glibcxx_cv_c99_complex" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define _GLIBCXX_USE_C99_COMPLEX 1 @@ -16219,7 +16569,7 @@ _ACEOF # Check for the existence in <stdio.h> of vscanf, et. al. echo "$as_me:$LINENO: checking for ISO C99 support in <stdio.h>" >&5 echo $ECHO_N "checking for ISO C99 support in <stdio.h>... $ECHO_C" >&6 - if test "${ac_c99_stdio+set}" = set; then + if test "${glibcxx_cv_c99_stdio+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -16270,12 +16620,12 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_c99_stdio=yes + glibcxx_cv_c99_stdio=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_c99_stdio=no +glibcxx_cv_c99_stdio=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext else @@ -16330,12 +16680,12 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_c99_stdio=yes + glibcxx_cv_c99_stdio=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_c99_stdio=no +glibcxx_cv_c99_stdio=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext @@ -16343,13 +16693,13 @@ fi fi - echo "$as_me:$LINENO: result: $ac_c99_stdio" >&5 -echo "${ECHO_T}$ac_c99_stdio" >&6 + echo "$as_me:$LINENO: result: $glibcxx_cv_c99_stdio" >&5 +echo "${ECHO_T}$glibcxx_cv_c99_stdio" >&6 # Check for the existence in <stdlib.h> of lldiv_t, et. al. echo "$as_me:$LINENO: checking for ISO C99 support in <stdlib.h>" >&5 echo $ECHO_N "checking for ISO C99 support in <stdlib.h>... $ECHO_C" >&6 - if test "${ac_c99_stdlib+set}" = set; then + if test "${glibcxx_cv_c99_stdlib+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -16406,12 +16756,12 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_c99_stdlib=yes + glibcxx_cv_c99_stdlib=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_c99_stdlib=no +glibcxx_cv_c99_stdlib=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext else @@ -16472,12 +16822,12 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_c99_stdlib=yes + glibcxx_cv_c99_stdlib=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_c99_stdlib=no +glibcxx_cv_c99_stdlib=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext @@ -16485,11 +16835,11 @@ fi fi - echo "$as_me:$LINENO: result: $ac_c99_stdlib" >&5 -echo "${ECHO_T}$ac_c99_stdlib" >&6 + echo "$as_me:$LINENO: result: $glibcxx_cv_c99_stdlib" >&5 +echo "${ECHO_T}$glibcxx_cv_c99_stdlib" >&6 # Check for the existence in <wchar.h> of wcstold, etc. - ac_c99_wchar=no; + glibcxx_cv_c99_wchar=no; if test x"$ac_has_wchar_h" = xyes && test x"$ac_has_wctype_h" = xyes; then echo "$as_me:$LINENO: checking for ISO C99 support in <wchar.h>" >&5 @@ -16538,12 +16888,12 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_c99_wchar=yes + glibcxx_cv_c99_wchar=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_c99_wchar=no +glibcxx_cv_c99_wchar=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext @@ -16800,16 +17150,16 @@ sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext - echo "$as_me:$LINENO: result: $ac_c99_wchar" >&5 -echo "${ECHO_T}$ac_c99_wchar" >&6 + echo "$as_me:$LINENO: result: $glibcxx_cv_c99_wchar" >&5 +echo "${ECHO_T}$glibcxx_cv_c99_wchar" >&6 fi # Option parsed, now set things appropriately. - if test x"$ac_c99_math" = x"no" || - test x"$ac_c99_complex" = x"no" || - test x"$ac_c99_stdio" = x"no" || - test x"$ac_c99_stdlib" = x"no" || - test x"$ac_c99_wchar" = x"no"; then + if test x"$glibcxx_cv_c99_math" = x"no" || + test x"$glibcxx_cv_c99_complex" = x"no" || + test x"$glibcxx_cv_c99_stdio" = x"no" || + test x"$glibcxx_cv_c99_stdlib" = x"no" || + test x"$glibcxx_cv_c99_wchar" = x"no"; then enable_c99=no; else @@ -16906,9 +17256,10 @@ echo "${ECHO_T}$enable_libstdcxx_debug" >&6 - # NB: libstdc++ may be configured before libgomp: can't check for the actual - # dependencies (omp.h and libgomp). enable_parallel=no; + + # See if configured libgomp/omp.h exists. (libgomp may be in + # noconfigdirs but not explicitly disabled.) if test -f $glibcxx_builddir/../libgomp/omp.h; then enable_parallel=yes; else @@ -16916,14 +17267,6 @@ echo "${ECHO_T}$enable_libstdcxx_debug" >&6 echo "$as_me: $glibcxx_builddir/../libgomp/omp.h not found" >&6;} fi - # Check to see if it's explicitly disabled. -# GLIBCXX_ENABLE(libgomp,,,[enable code depending on libgomp], -# [permit yes|no]) - -# if test x$enable_libgomp = xno; then -# enable_parallel=no -# fi - echo "$as_me:$LINENO: checking for parallel mode support" >&5 echo $ECHO_N "checking for parallel mode support... $ECHO_C" >&6 echo "$as_me:$LINENO: result: $enable_parallel" >&5 @@ -16995,13 +17338,13 @@ _ACEOF # Checks for operating systems support that don't require linking. - echo "$as_me:$LINENO: checking for EOWNERDEAD" >&5 +echo "$as_me:$LINENO: checking for EOWNERDEAD" >&5 echo $ECHO_N "checking for EOWNERDEAD... $ECHO_C" >&6 - if test "${ac_system_error1+set}" = set; then +if test "${glibcxx_cv_system_error1+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat >conftest.$ac_ext <<_ACEOF +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext @@ -17011,7 +17354,7 @@ cat >>conftest.$ac_ext <<_ACEOF int main () { - int i = EOWNERDEAD; +int i = EOWNERDEAD; ; return 0; } @@ -17038,34 +17381,33 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_system_error1=yes + glibcxx_cv_system_error1=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_system_error1=no +glibcxx_cv_system_error1=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_system_error1" >&5 -echo "${ECHO_T}$ac_system_error1" >&6 - if test x"$ac_system_error1" = x"yes"; then +echo "$as_me:$LINENO: result: $glibcxx_cv_system_error1" >&5 +echo "${ECHO_T}$glibcxx_cv_system_error1" >&6 +if test x"$glibcxx_cv_system_error1" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_EOWNERDEAD 1 _ACEOF - fi - - echo "$as_me:$LINENO: checking for ENOTRECOVERABLE" >&5 +fi +echo "$as_me:$LINENO: checking for ENOTRECOVERABLE" >&5 echo $ECHO_N "checking for ENOTRECOVERABLE... $ECHO_C" >&6 - if test "${ac_system_error2+set}" = set; then +if test "${glibcxx_cv_system_error2+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat >conftest.$ac_ext <<_ACEOF +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext @@ -17075,7 +17417,7 @@ cat >>conftest.$ac_ext <<_ACEOF int main () { - int i = ENOTRECOVERABLE; +int i = ENOTRECOVERABLE; ; return 0; } @@ -17102,34 +17444,33 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_system_error2=yes + glibcxx_cv_system_error2=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_system_error2=no +glibcxx_cv_system_error2=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_system_error2" >&5 -echo "${ECHO_T}$ac_system_error2" >&6 - if test x"$ac_system_error2" = x"yes"; then +echo "$as_me:$LINENO: result: $glibcxx_cv_system_error2" >&5 +echo "${ECHO_T}$glibcxx_cv_system_error2" >&6 +if test x"$glibcxx_cv_system_error2" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_ENOTRECOVERABLE 1 _ACEOF - fi - - echo "$as_me:$LINENO: checking for ENOLINK" >&5 +fi +echo "$as_me:$LINENO: checking for ENOLINK" >&5 echo $ECHO_N "checking for ENOLINK... $ECHO_C" >&6 - if test "${ac_system_error3+set}" = set; then +if test "${glibcxx_cv_system_error3+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat >conftest.$ac_ext <<_ACEOF +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext @@ -17139,7 +17480,7 @@ cat >>conftest.$ac_ext <<_ACEOF int main () { - int i = ENOLINK; +int i = ENOLINK; ; return 0; } @@ -17166,34 +17507,33 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_system_error3=yes + glibcxx_cv_system_error3=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_system_error3=no +glibcxx_cv_system_error3=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_system_error3" >&5 -echo "${ECHO_T}$ac_system_error3" >&6 - if test x"$ac_system_error3" = x"yes"; then +echo "$as_me:$LINENO: result: $glibcxx_cv_system_error3" >&5 +echo "${ECHO_T}$glibcxx_cv_system_error3" >&6 +if test x"$glibcxx_cv_system_error3" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_ENOLINK 1 _ACEOF - fi - - echo "$as_me:$LINENO: checking for EPROTO" >&5 +fi +echo "$as_me:$LINENO: checking for EPROTO" >&5 echo $ECHO_N "checking for EPROTO... $ECHO_C" >&6 - if test "${ac_system_error_4+set}" = set; then +if test "${glibcxx_cv_system_error4+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat >conftest.$ac_ext <<_ACEOF +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext @@ -17203,7 +17543,7 @@ cat >>conftest.$ac_ext <<_ACEOF int main () { - int i = EPROTO; +int i = EPROTO; ; return 0; } @@ -17230,34 +17570,33 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_system_error_4=yes + glibcxx_cv_system_error4=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_system_error_4=no +glibcxx_cv_system_error4=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_system_error_4" >&5 -echo "${ECHO_T}$ac_system_error_4" >&6 - if test x"$ac_system_error_4" = x"yes"; then +echo "$as_me:$LINENO: result: $glibcxx_cv_system_error4" >&5 +echo "${ECHO_T}$glibcxx_cv_system_error4" >&6 +if test x"$glibcxx_cv_system_error4" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_EPROTO 1 _ACEOF - fi - - echo "$as_me:$LINENO: checking for ENODATA" >&5 +fi +echo "$as_me:$LINENO: checking for ENODATA" >&5 echo $ECHO_N "checking for ENODATA... $ECHO_C" >&6 - if test "${ac_system_error_5+set}" = set; then +if test "${glibcxx_cv_system_error5+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat >conftest.$ac_ext <<_ACEOF +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext @@ -17267,7 +17606,7 @@ cat >>conftest.$ac_ext <<_ACEOF int main () { - int i = ENODATA; +int i = ENODATA; ; return 0; } @@ -17294,34 +17633,33 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_system_error_5=yes + glibcxx_cv_system_error5=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_system_error_5=no +glibcxx_cv_system_error5=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_system_error_5" >&5 -echo "${ECHO_T}$ac_system_error_5" >&6 - if test x"$ac_system_error_5" = x"yes"; then +echo "$as_me:$LINENO: result: $glibcxx_cv_system_error5" >&5 +echo "${ECHO_T}$glibcxx_cv_system_error5" >&6 +if test x"$glibcxx_cv_system_error5" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_ENODATA 1 _ACEOF - fi - - echo "$as_me:$LINENO: checking for ENOSR" >&5 +fi +echo "$as_me:$LINENO: checking for ENOSR" >&5 echo $ECHO_N "checking for ENOSR... $ECHO_C" >&6 - if test "${ac_system_error_6+set}" = set; then +if test "${glibcxx_cv_system_error6+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat >conftest.$ac_ext <<_ACEOF +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext @@ -17331,7 +17669,7 @@ cat >>conftest.$ac_ext <<_ACEOF int main () { - int i = ENOSR; +int i = ENOSR; ; return 0; } @@ -17358,34 +17696,33 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_system_error_6=yes + glibcxx_cv_system_error6=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_system_error_6=no +glibcxx_cv_system_error6=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_system_error_6" >&5 -echo "${ECHO_T}$ac_system_error_6" >&6 - if test x"$ac_system_error_6" = x"yes"; then +echo "$as_me:$LINENO: result: $glibcxx_cv_system_error6" >&5 +echo "${ECHO_T}$glibcxx_cv_system_error6" >&6 +if test x"$glibcxx_cv_system_error6" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_ENOSR 1 _ACEOF - fi - - echo "$as_me:$LINENO: checking for ENOSTR" >&5 +fi +echo "$as_me:$LINENO: checking for ENOSTR" >&5 echo $ECHO_N "checking for ENOSTR... $ECHO_C" >&6 - if test "${ac_system_error_7+set}" = set; then +if test "${glibcxx_cv_system_error7+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat >conftest.$ac_ext <<_ACEOF +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext @@ -17395,7 +17732,7 @@ cat >>conftest.$ac_ext <<_ACEOF int main () { - int i = ENOSTR; +int i = ENOSTR; ; return 0; } @@ -17422,34 +17759,33 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_system_error_7=yes + glibcxx_cv_system_error7=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_system_error_7=no +glibcxx_cv_system_error7=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_system_error_7" >&5 -echo "${ECHO_T}$ac_system_error_7" >&6 - if test x"$ac_system_error_7" = x"yes"; then +echo "$as_me:$LINENO: result: $glibcxx_cv_system_error7" >&5 +echo "${ECHO_T}$glibcxx_cv_system_error7" >&6 +if test x"$glibcxx_cv_system_error7" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_ENOSTR 1 _ACEOF - fi - - echo "$as_me:$LINENO: checking for ETIME" >&5 +fi +echo "$as_me:$LINENO: checking for ETIME" >&5 echo $ECHO_N "checking for ETIME... $ECHO_C" >&6 - if test "${ac_system_error_8+set}" = set; then +if test "${glibcxx_cv_system_error8+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat >conftest.$ac_ext <<_ACEOF +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext @@ -17459,7 +17795,7 @@ cat >>conftest.$ac_ext <<_ACEOF int main () { - int i = ETIME; +int i = ETIME; ; return 0; } @@ -17486,98 +17822,33 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_system_error_8=yes + glibcxx_cv_system_error8=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_system_error_8=no +glibcxx_cv_system_error8=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_system_error_8" >&5 -echo "${ECHO_T}$ac_system_error_8" >&6 - if test x"$ac_system_error_8" = x"yes"; then +echo "$as_me:$LINENO: result: $glibcxx_cv_system_error8" >&5 +echo "${ECHO_T}$glibcxx_cv_system_error8" >&6 +if test x"$glibcxx_cv_system_error8" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_ETIME 1 _ACEOF - fi - - echo "$as_me:$LINENO: checking for sys_nerr" >&5 -echo $ECHO_N "checking for sys_nerr... $ECHO_C" >&6 - if test "${ac_system_error9+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include <errno.h> -int -main () -{ - int i = sys_nerr; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_system_error9=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -ac_system_error9=no fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext - -fi - - echo "$as_me:$LINENO: result: $ac_system_error9" >&5 -echo "${ECHO_T}$ac_system_error9" >&6 - if test x"$ac_system_error9" = x"yes"; then - -cat >>confdefs.h <<\_ACEOF -#define HAVE_SYS_NERR 1 -_ACEOF - - fi - - echo "$as_me:$LINENO: checking for EBADMSG" >&5 +echo "$as_me:$LINENO: checking for EBADMSG" >&5 echo $ECHO_N "checking for EBADMSG... $ECHO_C" >&6 - if test "${ac_system_error_10+set}" = set; then +if test "${glibcxx_cv_system_error9+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat >conftest.$ac_ext <<_ACEOF +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext @@ -17587,7 +17858,7 @@ cat >>conftest.$ac_ext <<_ACEOF int main () { - int i = EBADMSG; +int i = EBADMSG; ; return 0; } @@ -17614,34 +17885,33 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_system_error_10=yes + glibcxx_cv_system_error9=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_system_error_10=no +glibcxx_cv_system_error9=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_system_error_10" >&5 -echo "${ECHO_T}$ac_system_error_10" >&6 - if test x"$ac_system_error_10" = x"yes"; then +echo "$as_me:$LINENO: result: $glibcxx_cv_system_error9" >&5 +echo "${ECHO_T}$glibcxx_cv_system_error9" >&6 +if test x"$glibcxx_cv_system_error9" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_EBADMSG 1 _ACEOF - fi - - echo "$as_me:$LINENO: checking for ECANCELED" >&5 +fi +echo "$as_me:$LINENO: checking for ECANCELED" >&5 echo $ECHO_N "checking for ECANCELED... $ECHO_C" >&6 - if test "${ac_system_error_11+set}" = set; then +if test "${glibcxx_cv_system_error10+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat >conftest.$ac_ext <<_ACEOF +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext @@ -17651,7 +17921,7 @@ cat >>conftest.$ac_ext <<_ACEOF int main () { - int i = ECANCELED; +int i = ECANCELED; ; return 0; } @@ -17678,34 +17948,33 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_system_error_11=yes + glibcxx_cv_system_error10=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_system_error_11=no +glibcxx_cv_system_error10=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_system_error_11" >&5 -echo "${ECHO_T}$ac_system_error_11" >&6 - if test x"$ac_system_error_11" = x"yes"; then +echo "$as_me:$LINENO: result: $glibcxx_cv_system_error10" >&5 +echo "${ECHO_T}$glibcxx_cv_system_error10" >&6 +if test x"$glibcxx_cv_system_error10" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_ECANCELED 1 _ACEOF - fi - - echo "$as_me:$LINENO: checking for EOVERFLOW" >&5 +fi +echo "$as_me:$LINENO: checking for EOVERFLOW" >&5 echo $ECHO_N "checking for EOVERFLOW... $ECHO_C" >&6 - if test "${ac_system_error_12+set}" = set; then +if test "${glibcxx_cv_system_error11+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat >conftest.$ac_ext <<_ACEOF +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext @@ -17715,7 +17984,7 @@ cat >>conftest.$ac_ext <<_ACEOF int main () { - int i = EOVERFLOW; +int i = EOVERFLOW; ; return 0; } @@ -17742,34 +18011,33 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_system_error_12=yes + glibcxx_cv_system_error11=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_system_error_12=no +glibcxx_cv_system_error11=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_system_error_12" >&5 -echo "${ECHO_T}$ac_system_error_12" >&6 - if test x"$ac_system_error_12" = x"yes"; then +echo "$as_me:$LINENO: result: $glibcxx_cv_system_error11" >&5 +echo "${ECHO_T}$glibcxx_cv_system_error11" >&6 +if test x"$glibcxx_cv_system_error11" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_EOVERFLOW 1 _ACEOF - fi - - echo "$as_me:$LINENO: checking for ENOTSUP" >&5 +fi +echo "$as_me:$LINENO: checking for ENOTSUP" >&5 echo $ECHO_N "checking for ENOTSUP... $ECHO_C" >&6 - if test "${ac_system_error_13+set}" = set; then +if test "${glibcxx_cv_system_error12+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat >conftest.$ac_ext <<_ACEOF +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext @@ -17779,7 +18047,7 @@ cat >>conftest.$ac_ext <<_ACEOF int main () { - int i = ENOTSUP; +int i = ENOTSUP; ; return 0; } @@ -17806,72 +18074,43 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_system_error_13=yes + glibcxx_cv_system_error12=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_system_error_13=no +glibcxx_cv_system_error12=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_system_error_13" >&5 -echo "${ECHO_T}$ac_system_error_13" >&6 - if test x"$ac_system_error_13" = x"yes"; then +echo "$as_me:$LINENO: result: $glibcxx_cv_system_error12" >&5 +echo "${ECHO_T}$glibcxx_cv_system_error12" >&6 +if test x"$glibcxx_cv_system_error12" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_ENOTSUP 1 _ACEOF - fi - - - - echo "$as_me:$LINENO: checking for ISO C++200x standard layout type support" >&5 -echo $ECHO_N "checking for ISO C++200x standard layout type support... $ECHO_C" >&6 - if test "${ac_standard_layout+set}" = set; then +fi +echo "$as_me:$LINENO: checking for EIDRM" >&5 +echo $ECHO_N "checking for EIDRM... $ECHO_C" >&6 +if test "${glibcxx_cv_system_error13+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - - - ac_ext=cc -ac_cpp='$CXXCPP $CPPFLAGS' -ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_cxx_compiler_gnu - - ac_test_CXXFLAGS="${CXXFLAGS+set}" - ac_save_CXXFLAGS="$CXXFLAGS" - CXXFLAGS='-std=gnu++0x' - - cat >conftest.$ac_ext <<_ACEOF +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ -struct b - { - bool t; - - // Need standard layout relaxation from POD - private: - b& operator=(const b&); - b(const b&); - }; - - int main() - { - b tst1 = { false }; - return 0; - } +#include <errno.h> int main () { - +int i = EIDRM; ; return 0; } @@ -17885,7 +18124,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_cxx_werror_flag" + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 @@ -17898,180 +18137,43 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_standard_layout=yes + glibcxx_cv_system_error13=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_standard_layout=no +glibcxx_cv_system_error13=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext - CXXFLAGS="$ac_save_CXXFLAGS" - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - fi - echo "$as_me:$LINENO: result: $ac_standard_layout" >&5 -echo "${ECHO_T}$ac_standard_layout" >&6 - if test x"$ac_standard_layout" = x"yes"; then +echo "$as_me:$LINENO: result: $glibcxx_cv_system_error13" >&5 +echo "${ECHO_T}$glibcxx_cv_system_error13" >&6 +if test x"$glibcxx_cv_system_error13" = x"yes"; then cat >>confdefs.h <<\_ACEOF -#define _GLIBCXX_USE_STANDARD_LAYOUT 1 +#define HAVE_EIDRM 1 _ACEOF - fi - - -# No surprises, no surprises... - - echo "$as_me:$LINENO: checking for thread model used by GCC" >&5 -echo $ECHO_N "checking for thread model used by GCC... $ECHO_C" >&6 - target_thread_file=`$CXX -v 2>&1 | sed -n 's/^Thread model: //p'` - echo "$as_me:$LINENO: result: $target_thread_file" >&5 -echo "${ECHO_T}$target_thread_file" >&6 - - if test $target_thread_file != single; then - -cat >>confdefs.h <<\_ACEOF -#define HAVE_GTHR_DEFAULT 1 -_ACEOF - - fi - - glibcxx_thread_h=gthr-$target_thread_file.h - - gthread_file=${toplevel_srcdir}/gcc/${glibcxx_thread_h} - if grep __GTHREADS $gthread_file >/dev/null 2>&1 ; then - enable_thread=yes - else - enable_thread=no - fi - - - - - echo "$as_me:$LINENO: checking for atomic builtins" >&5 -echo $ECHO_N "checking for atomic builtins... $ECHO_C" >&6 - - - ac_ext=cc -ac_cpp='$CXXCPP $CPPFLAGS' -ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_cxx_compiler_gnu - - - # Fake what AC_TRY_COMPILE does. XXX Look at redoing this new-style. - cat > conftest.$ac_ext << EOF -#line 18100 "configure" -int main() -{ - // NB: _Atomic_word not necessarily int. - typedef int atomic_type; - atomic_type c1; - atomic_type c2; - const atomic_type c3(0); - if (__sync_fetch_and_add(&c1, c2) == c3) - { - // Do something. - } - return 0; -} -EOF - old_CXXFLAGS="$CXXFLAGS" - CXXFLAGS='-O0 -S' - if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; then - if grep __sync_fetch_and_add conftest.s >/dev/null 2>&1 ; then - enable_atomic_builtins=no - else - -cat >>confdefs.h <<\_ACEOF -#define _GLIBCXX_ATOMIC_BUILTINS 1 -_ACEOF - - enable_atomic_builtins=yes - atomicity_dir=cpu/generic/atomicity_builtins - fi - fi - echo "$as_me:$LINENO: result: $enable_atomic_builtins" >&5 -echo "${ECHO_T}$enable_atomic_builtins" >&6 - CXXFLAGS="$old_CXXFLAGS" - rm -f conftest* - - # Now, if still generic, set to mutex. - if test $atomicity_dir = "cpu/generic" ; then - atomicity_dir=cpu/generic/atomicity_mutex - fi - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - -if test $atomicity_dir = cpu/generic/atomicity_mutex ; then - { echo "$as_me:$LINENO: WARNING: No native atomic operations are provided for this platform." >&5 -echo "$as_me: WARNING: No native atomic operations are provided for this platform." >&2;} - if test $target_thread_file = single; then - { echo "$as_me:$LINENO: WARNING: They cannot be faked when thread support is disabled." >&5 -echo "$as_me: WARNING: They cannot be faked when thread support is disabled." >&2;} - { echo "$as_me:$LINENO: WARNING: Thread-safety of certain classes is not guaranteed." >&5 -echo "$as_me: WARNING: Thread-safety of certain classes is not guaranteed." >&2;} - else - { echo "$as_me:$LINENO: WARNING: They will be faked using a mutex." >&5 -echo "$as_me: WARNING: They will be faked using a mutex." >&2;} - { echo "$as_me:$LINENO: WARNING: Performance of certain classes will degrade as a result." >&5 -echo "$as_me: WARNING: Performance of certain classes will degrade as a result." >&2;} - fi fi +echo "$as_me:$LINENO: checking for ETXTBSY" >&5 +echo $ECHO_N "checking for ETXTBSY... $ECHO_C" >&6 +if test "${glibcxx_cv_system_error14+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else - - # All these tests are for C++; save the language and the compiler flags. - # The CXXFLAGS thing is suspicious, but based on similar bits previously - # found in GLIBCXX_CONFIGURE. - - - ac_ext=cc -ac_cpp='$CXXCPP $CPPFLAGS' -ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_cxx_compiler_gnu - - ac_test_CXXFLAGS="${CXXFLAGS+set}" - ac_save_CXXFLAGS="$CXXFLAGS" - - # Check for maintainer-mode bits. - if test x"$USE_MAINTAINER_MODE" = xno; then - WERROR='' - else - WERROR='-Werror' - fi - - # Check for -ffunction-sections -fdata-sections - echo "$as_me:$LINENO: checking for g++ that supports -ffunction-sections -fdata-sections" >&5 -echo $ECHO_N "checking for g++ that supports -ffunction-sections -fdata-sections... $ECHO_C" >&6 - CXXFLAGS='-g -Werror -ffunction-sections -fdata-sections' - cat >conftest.$ac_ext <<_ACEOF +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ -int foo; void bar() { }; +#include <errno.h> int main () { - +int i = ETXTBSY; ; return 0; } @@ -18085,7 +18187,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_cxx_werror_flag" + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 @@ -18098,36 +18200,31 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_fdsections=yes + glibcxx_cv_system_error14=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_fdsections=no +glibcxx_cv_system_error14=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext - if test "$ac_test_CXXFLAGS" = set; then - CXXFLAGS="$ac_save_CXXFLAGS" - else - # this is the suspicious part - CXXFLAGS='' - fi - if test x"$ac_fdsections" = x"yes"; then - SECTION_FLAGS='-ffunction-sections -fdata-sections' - fi - echo "$as_me:$LINENO: result: $ac_fdsections" >&5 -echo "${ECHO_T}$ac_fdsections" >&6 - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu +fi +echo "$as_me:$LINENO: result: $glibcxx_cv_system_error14" >&5 +echo "${ECHO_T}$glibcxx_cv_system_error14" >&6 +if test x"$glibcxx_cv_system_error14" = x"yes"; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_ETXTBSY 1 +_ACEOF + +fi +# Only do link tests if native. Else, hardcode. if $GLIBCXX_IS_NATIVE; then # We can do more elaborate tests that assume a working linker. @@ -39974,7 +40071,7 @@ _ACEOF # Check for the existence of <ctype.h> functions. echo "$as_me:$LINENO: checking for ISO C99 support to TR1 in <ctype.h>" >&5 echo $ECHO_N "checking for ISO C99 support to TR1 in <ctype.h>... $ECHO_C" >&6 - if test "${ac_c99_ctype_tr1+set}" = set; then + if test "${glibcxx_cv_c99_ctype_tr1+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -40018,20 +40115,20 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_c99_ctype_tr1=yes + glibcxx_cv_c99_ctype_tr1=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_c99_ctype_tr1=no +glibcxx_cv_c99_ctype_tr1=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_c99_ctype_tr1" >&5 -echo "${ECHO_T}$ac_c99_ctype_tr1" >&6 - if test x"$ac_c99_ctype_tr1" = x"yes"; then + echo "$as_me:$LINENO: result: $glibcxx_cv_c99_ctype_tr1" >&5 +echo "${ECHO_T}$glibcxx_cv_c99_ctype_tr1" >&6 + if test x"$glibcxx_cv_c99_ctype_tr1" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define _GLIBCXX_USE_C99_CTYPE_TR1 1 @@ -40270,7 +40367,7 @@ _ACEOF # Check for the existence of <stdint.h> types. echo "$as_me:$LINENO: checking for ISO C99 support to TR1 in <stdint.h>" >&5 echo $ECHO_N "checking for ISO C99 support to TR1 in <stdint.h>... $ECHO_C" >&6 - if test "${ac_c99_stdint_tr1+set}" = set; then + if test "${glibcxx_cv_c99_stdint_tr1+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -40339,20 +40436,20 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_c99_stdint_tr1=yes + glibcxx_cv_c99_stdint_tr1=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_c99_stdint_tr1=no +glibcxx_cv_c99_stdint_tr1=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_c99_stdint_tr1" >&5 -echo "${ECHO_T}$ac_c99_stdint_tr1" >&6 - if test x"$ac_c99_stdint_tr1" = x"yes"; then + echo "$as_me:$LINENO: result: $glibcxx_cv_c99_stdint_tr1" >&5 +echo "${ECHO_T}$glibcxx_cv_c99_stdint_tr1" >&6 + if test x"$glibcxx_cv_c99_stdint_tr1" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define _GLIBCXX_USE_C99_STDINT_TR1 1 @@ -40363,7 +40460,7 @@ _ACEOF # Check for the existence of <math.h> functions. echo "$as_me:$LINENO: checking for ISO C99 support to TR1 in <math.h>" >&5 echo $ECHO_N "checking for ISO C99 support to TR1 in <math.h>... $ECHO_C" >&6 - if test "${ac_c99_math_tr1+set}" = set; then + if test "${glibcxx_cv_c99_math_tr1+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -40511,20 +40608,20 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_c99_math_tr1=yes + glibcxx_cv_c99_math_tr1=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_c99_math_tr1=no +glibcxx_cv_c99_math_tr1=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_c99_math_tr1" >&5 -echo "${ECHO_T}$ac_c99_math_tr1" >&6 - if test x"$ac_c99_math_tr1" = x"yes"; then + echo "$as_me:$LINENO: result: $glibcxx_cv_c99_math_tr1" >&5 +echo "${ECHO_T}$glibcxx_cv_c99_math_tr1" >&6 + if test x"$glibcxx_cv_c99_math_tr1" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define _GLIBCXX_USE_C99_MATH_TR1 1 @@ -40535,7 +40632,7 @@ _ACEOF # Check for the existence of <inttypes.h> functions (NB: doesn't make # sense if the previous check fails, per C99, 7.8/1). ac_c99_inttypes_tr1=no; - if test x"$ac_c99_stdint_tr1" = x"yes"; then + if test x"$glibcxx_cv_c99_stdint_tr1" = x"yes"; then echo "$as_me:$LINENO: checking for ISO C99 support to TR1 in <inttypes.h>" >&5 echo $ECHO_N "checking for ISO C99 support to TR1 in <inttypes.h>... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF @@ -40767,12 +40864,12 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu echo "$as_me:$LINENO: checking for \"dev/random\" and \"dev/urandom\" for TR1 random_device" >&5 echo $ECHO_N "checking for \"dev/random\" and \"dev/urandom\" for TR1 random_device... $ECHO_C" >&6 - if test "${ac_random_tr1+set}" = set; then + if test "${glibcxx_cv_random_tr1+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "$cross_compiling" = yes; then - ac_random_tr1=no + glibcxx_cv_random_tr1=no else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ @@ -40799,23 +40896,23 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_random_tr1=yes + glibcxx_cv_random_tr1=yes else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) -ac_random_tr1=no +glibcxx_cv_random_tr1=no fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi - echo "$as_me:$LINENO: result: $ac_random_tr1" >&5 -echo "${ECHO_T}$ac_random_tr1" >&6 - if test x"$ac_random_tr1" = x"yes"; then + echo "$as_me:$LINENO: result: $glibcxx_cv_random_tr1" >&5 +echo "${ECHO_T}$glibcxx_cv_random_tr1" >&6 + if test x"$glibcxx_cv_random_tr1" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define _GLIBCXX_USE_RANDOM_TR1 1 @@ -109083,7 +109180,7 @@ _ACEOF # Check for the existence of <ctype.h> functions. echo "$as_me:$LINENO: checking for ISO C99 support to TR1 in <ctype.h>" >&5 echo $ECHO_N "checking for ISO C99 support to TR1 in <ctype.h>... $ECHO_C" >&6 - if test "${ac_c99_ctype_tr1+set}" = set; then + if test "${glibcxx_cv_c99_ctype_tr1+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -109127,20 +109224,20 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_c99_ctype_tr1=yes + glibcxx_cv_c99_ctype_tr1=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_c99_ctype_tr1=no +glibcxx_cv_c99_ctype_tr1=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_c99_ctype_tr1" >&5 -echo "${ECHO_T}$ac_c99_ctype_tr1" >&6 - if test x"$ac_c99_ctype_tr1" = x"yes"; then + echo "$as_me:$LINENO: result: $glibcxx_cv_c99_ctype_tr1" >&5 +echo "${ECHO_T}$glibcxx_cv_c99_ctype_tr1" >&6 + if test x"$glibcxx_cv_c99_ctype_tr1" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define _GLIBCXX_USE_C99_CTYPE_TR1 1 @@ -109379,7 +109476,7 @@ _ACEOF # Check for the existence of <stdint.h> types. echo "$as_me:$LINENO: checking for ISO C99 support to TR1 in <stdint.h>" >&5 echo $ECHO_N "checking for ISO C99 support to TR1 in <stdint.h>... $ECHO_C" >&6 - if test "${ac_c99_stdint_tr1+set}" = set; then + if test "${glibcxx_cv_c99_stdint_tr1+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -109448,20 +109545,20 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_c99_stdint_tr1=yes + glibcxx_cv_c99_stdint_tr1=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_c99_stdint_tr1=no +glibcxx_cv_c99_stdint_tr1=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_c99_stdint_tr1" >&5 -echo "${ECHO_T}$ac_c99_stdint_tr1" >&6 - if test x"$ac_c99_stdint_tr1" = x"yes"; then + echo "$as_me:$LINENO: result: $glibcxx_cv_c99_stdint_tr1" >&5 +echo "${ECHO_T}$glibcxx_cv_c99_stdint_tr1" >&6 + if test x"$glibcxx_cv_c99_stdint_tr1" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define _GLIBCXX_USE_C99_STDINT_TR1 1 @@ -109472,7 +109569,7 @@ _ACEOF # Check for the existence of <math.h> functions. echo "$as_me:$LINENO: checking for ISO C99 support to TR1 in <math.h>" >&5 echo $ECHO_N "checking for ISO C99 support to TR1 in <math.h>... $ECHO_C" >&6 - if test "${ac_c99_math_tr1+set}" = set; then + if test "${glibcxx_cv_c99_math_tr1+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -109620,20 +109717,20 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_c99_math_tr1=yes + glibcxx_cv_c99_math_tr1=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_c99_math_tr1=no +glibcxx_cv_c99_math_tr1=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - echo "$as_me:$LINENO: result: $ac_c99_math_tr1" >&5 -echo "${ECHO_T}$ac_c99_math_tr1" >&6 - if test x"$ac_c99_math_tr1" = x"yes"; then + echo "$as_me:$LINENO: result: $glibcxx_cv_c99_math_tr1" >&5 +echo "${ECHO_T}$glibcxx_cv_c99_math_tr1" >&6 + if test x"$glibcxx_cv_c99_math_tr1" = x"yes"; then cat >>confdefs.h <<\_ACEOF #define _GLIBCXX_USE_C99_MATH_TR1 1 @@ -109644,7 +109741,7 @@ _ACEOF # Check for the existence of <inttypes.h> functions (NB: doesn't make # sense if the previous check fails, per C99, 7.8/1). ac_c99_inttypes_tr1=no; - if test x"$ac_c99_stdint_tr1" = x"yes"; then + if test x"$glibcxx_cv_c99_stdint_tr1" = x"yes"; then echo "$as_me:$LINENO: checking for ISO C99 support to TR1 in <inttypes.h>" >&5 echo $ECHO_N "checking for ISO C99 support to TR1 in <inttypes.h>... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF @@ -119023,7 +119120,7 @@ fi; if test x$enable_visibility = xyes ; then echo "$as_me:$LINENO: checking whether the target supports hidden visibility" >&5 echo $ECHO_N "checking whether the target supports hidden visibility... $ECHO_C" >&6 -if test "${have_attribute_visibility+set}" = set; then +if test "${glibcxx_cv_have_attribute_visibility+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -119066,19 +119163,19 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - have_attribute_visibility=yes + glibcxx_cv_have_attribute_visibility=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -have_attribute_visibility=no +glibcxx_cv_have_attribute_visibility=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext CFLAGS="$save_CFLAGS" fi -echo "$as_me:$LINENO: result: $have_attribute_visibility" >&5 -echo "${ECHO_T}$have_attribute_visibility" >&6 - if test $have_attribute_visibility = no; then +echo "$as_me:$LINENO: result: $glibcxx_cv_have_attribute_visibility" >&5 +echo "${ECHO_T}$glibcxx_cv_have_attribute_visibility" >&6 + if test $glibcxx_cv_have_attribute_visibility = no; then enable_visibility=no fi fi @@ -119621,7 +119718,7 @@ echo "${ECHO_T}$res" >&6 # Check for rlimit, setrlimit. - if test "${ac_setrlimit+set}" = set; then + if test "${glibcxx_cv_setrlimit+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -119666,12 +119763,12 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_setrlimit=yes + glibcxx_cv_setrlimit=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_setrlimit=no +glibcxx_cv_setrlimit=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext @@ -119681,7 +119778,7 @@ fi echo "$as_me:$LINENO: checking for testsuite resource limits support" >&5 echo $ECHO_N "checking for testsuite resource limits support... $ECHO_C" >&6 - if test $setrlimit_have_headers = yes && test $ac_setrlimit = yes; then + if test $setrlimit_have_headers = yes && test $glibcxx_cv_setrlimit = yes; then ac_res_limits=yes cat >>confdefs.h <<\_ACEOF @@ -121484,6 +121581,9 @@ s,@GLIBCXX_HOSTED_FALSE@,$GLIBCXX_HOSTED_FALSE,;t t s,@GLIBCXX_BUILD_PCH_TRUE@,$GLIBCXX_BUILD_PCH_TRUE,;t t s,@GLIBCXX_BUILD_PCH_FALSE@,$GLIBCXX_BUILD_PCH_FALSE,;t t s,@glibcxx_PCHFLAGS@,$glibcxx_PCHFLAGS,;t t +s,@glibcxx_thread_h@,$glibcxx_thread_h,;t t +s,@WERROR@,$WERROR,;t t +s,@SECTION_FLAGS@,$SECTION_FLAGS,;t t s,@CSTDIO_H@,$CSTDIO_H,;t t s,@BASIC_FILE_H@,$BASIC_FILE_H,;t t s,@BASIC_FILE_CC@,$BASIC_FILE_CC,;t t @@ -121523,9 +121623,6 @@ s,@GLIBCXX_BUILD_DEBUG_FALSE@,$GLIBCXX_BUILD_DEBUG_FALSE,;t t s,@ENABLE_PARALLEL_TRUE@,$ENABLE_PARALLEL_TRUE,;t t s,@ENABLE_PARALLEL_FALSE@,$ENABLE_PARALLEL_FALSE,;t t s,@EXTRA_CXX_FLAGS@,$EXTRA_CXX_FLAGS,;t t -s,@glibcxx_thread_h@,$glibcxx_thread_h,;t t -s,@WERROR@,$WERROR,;t t -s,@SECTION_FLAGS@,$SECTION_FLAGS,;t t s,@SECTION_LDFLAGS@,$SECTION_LDFLAGS,;t t s,@OPT_LDFLAGS@,$OPT_LDFLAGS,;t t s,@LIBMATHOBJS@,$LIBMATHOBJS,;t t diff --git a/libstdc++-v3/include/std/limits b/libstdc++-v3/include/std/limits index 7f7dd9ceeca..f5494ed38f5 100644 --- a/libstdc++-v3/include/std/limits +++ b/libstdc++-v3/include/std/limits @@ -566,6 +566,110 @@ _GLIBCXX_BEGIN_NAMESPACE(std) static const float_round_style round_style = round_toward_zero; }; +#ifdef __GXX_EXPERIMENTAL_CXX0X__ + /// numeric_limits<char16_t> specialization. + template<> + struct numeric_limits<char16_t> + { + static const bool is_specialized = true; + + static char16_t min() throw() + { return __glibcxx_min (char16_t); } + static char16_t max() throw() + { return __glibcxx_max (char16_t); } + + static const int digits = __glibcxx_digits (char16_t); + static const int digits10 = __glibcxx_digits10 (char16_t); + static const bool is_signed = __glibcxx_signed (char16_t); + static const bool is_integer = true; + static const bool is_exact = true; + static const int radix = 2; + static char16_t epsilon() throw() + { return 0; } + static char16_t round_error() throw() + { return 0; } + + static const int min_exponent = 0; + static const int min_exponent10 = 0; + static const int max_exponent = 0; + static const int max_exponent10 = 0; + + static const bool has_infinity = false; + static const bool has_quiet_NaN = false; + static const bool has_signaling_NaN = false; + static const float_denorm_style has_denorm = denorm_absent; + static const bool has_denorm_loss = false; + + static char16_t infinity() throw() + { return char16_t(); } + static char16_t quiet_NaN() throw() + { return char16_t(); } + static char16_t signaling_NaN() throw() + { return char16_t(); } + static char16_t denorm_min() throw() + { return char16_t(); } + + static const bool is_iec559 = false; + static const bool is_bounded = true; + static const bool is_modulo = true; + + static const bool traps = __glibcxx_integral_traps; + static const bool tinyness_before = false; + static const float_round_style round_style = round_toward_zero; + }; + + /// numeric_limits<char32_t> specialization. + template<> + struct numeric_limits<char32_t> + { + static const bool is_specialized = true; + + static char32_t min() throw() + { return __glibcxx_min (char32_t); } + static char32_t max() throw() + { return __glibcxx_max (char32_t); } + + static const int digits = __glibcxx_digits (char32_t); + static const int digits10 = __glibcxx_digits10 (char32_t); + static const bool is_signed = __glibcxx_signed (char32_t); + static const bool is_integer = true; + static const bool is_exact = true; + static const int radix = 2; + static char32_t epsilon() throw() + { return 0; } + static char32_t round_error() throw() + { return 0; } + + static const int min_exponent = 0; + static const int min_exponent10 = 0; + static const int max_exponent = 0; + static const int max_exponent10 = 0; + + static const bool has_infinity = false; + static const bool has_quiet_NaN = false; + static const bool has_signaling_NaN = false; + static const float_denorm_style has_denorm = denorm_absent; + static const bool has_denorm_loss = false; + + static char32_t infinity() throw() + { return char32_t(); } + static char32_t quiet_NaN() throw() + { return char32_t(); } + static char32_t signaling_NaN() throw() + { return char32_t(); } + static char32_t denorm_min() throw() + { return char32_t(); } + + static const bool is_iec559 = false; + static const bool is_bounded = true; + static const bool is_modulo = true; + + static const bool traps = __glibcxx_integral_traps; + static const bool tinyness_before = false; + static const float_round_style round_style = round_toward_zero; + }; +#endif + /// numeric_limits<short> specialization. template<> struct numeric_limits<short> diff --git a/libstdc++-v3/include/tr1_impl/functional_hash.h b/libstdc++-v3/include/tr1_impl/functional_hash.h index 0611f70d34a..49f2cb7384d 100644 --- a/libstdc++-v3/include/tr1_impl/functional_hash.h +++ b/libstdc++-v3/include/tr1_impl/functional_hash.h @@ -67,6 +67,10 @@ _GLIBCXX_BEGIN_NAMESPACE_TR1 _TR1_hashtable_define_trivial_hash(signed char); _TR1_hashtable_define_trivial_hash(unsigned char); _TR1_hashtable_define_trivial_hash(wchar_t); +#ifdef _GLIBCXX_INCLUDE_AS_CXX0X + _TR1_hashtable_define_trivial_hash(char16_t); + _TR1_hashtable_define_trivial_hash(char32_t); +#endif _TR1_hashtable_define_trivial_hash(short); _TR1_hashtable_define_trivial_hash(int); _TR1_hashtable_define_trivial_hash(long); diff --git a/libstdc++-v3/include/tr1_impl/type_traits b/libstdc++-v3/include/tr1_impl/type_traits index 4cf97dff31f..5d0824a365f 100644 --- a/libstdc++-v3/include/tr1_impl/type_traits +++ b/libstdc++-v3/include/tr1_impl/type_traits @@ -102,6 +102,10 @@ _GLIBCXX_BEGIN_NAMESPACE_TR1 #ifdef _GLIBCXX_USE_WCHAR_T _DEFINE_SPEC(0, is_integral, wchar_t, true) #endif +#ifdef _GLIBCXX_INCLUDE_AS_CXX0X + _DEFINE_SPEC(0, is_integral, char16_t, true) + _DEFINE_SPEC(0, is_integral, char32_t, true) +#endif _DEFINE_SPEC(0, is_integral, short, true) _DEFINE_SPEC(0, is_integral, unsigned short, true) _DEFINE_SPEC(0, is_integral, int, true) diff --git a/libstdc++-v3/src/Makefile.am b/libstdc++-v3/src/Makefile.am index 0b5f2a70885..f5d99c63525 100644 --- a/libstdc++-v3/src/Makefile.am +++ b/libstdc++-v3/src/Makefile.am @@ -1,6 +1,7 @@ ## Makefile for the src subdirectory of the GNU C++ Standard library. ## -## Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2005 +## Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 +## 2006, 2007, 2008 ## Free Software Foundation, Inc. ## ## This file is part of the libstdc++ version 3 distribution. @@ -155,6 +156,7 @@ sources = \ ios_init.cc \ ios_locale.cc \ limits.cc \ + limits_c++0x.cc \ list.cc \ debug_list.cc \ locale.cc \ @@ -261,6 +263,11 @@ hashtable_c++0x.lo: hashtable_c++0x.cc hashtable_c++0x.o: hashtable_c++0x.cc $(CXXCOMPILE) -std=gnu++0x -c $< +limits_c++0x.lo: limits_c++0x.cc + $(LTCXXCOMPILE) -std=gnu++0x -c $< +limits_c++0x.o: limits_c++0x.cc + $(CXXCOMPILE) -std=gnu++0x -c $< + date_time.lo: date_time.cc $(LTCXXCOMPILE) -std=gnu++0x -c $< date_time.o: date_time.cc diff --git a/libstdc++-v3/src/Makefile.in b/libstdc++-v3/src/Makefile.in index c1e56fb4071..508a399e7e8 100644 --- a/libstdc++-v3/src/Makefile.in +++ b/libstdc++-v3/src/Makefile.in @@ -77,17 +77,17 @@ am__libstdc___la_SOURCES_DIST = atomic.cc bitmap_allocator.cc \ complex_io.cc ctype.cc date_time.cc debug.cc functexcept.cc \ hash.cc hash_c++0x.cc globals_io.cc hashtable.cc \ hashtable_c++0x.cc ios.cc ios_failure.cc ios_init.cc \ - ios_locale.cc limits.cc list.cc debug_list.cc locale.cc \ - locale_init.cc locale_facets.cc localename.cc stdexcept.cc \ - strstream.cc system_error.cc tree.cc allocator-inst.cc \ - concept-inst.cc fstream-inst.cc ext-inst.cc ios-inst.cc \ - iostream-inst.cc istream-inst.cc istream.cc locale-inst.cc \ - misc-inst.cc ostream-inst.cc sstream-inst.cc streambuf-inst.cc \ - streambuf.cc string-inst.cc valarray-inst.cc wlocale-inst.cc \ - wstring-inst.cc mutex.cc condition_variable.cc atomicity.cc \ - codecvt_members.cc collate_members.cc ctype_members.cc \ - messages_members.cc monetary_members.cc numeric_members.cc \ - time_members.cc basic_file.cc c++locale.cc \ + ios_locale.cc limits.cc limits_c++0x.cc list.cc debug_list.cc \ + locale.cc locale_init.cc locale_facets.cc localename.cc \ + stdexcept.cc strstream.cc system_error.cc tree.cc \ + allocator-inst.cc concept-inst.cc fstream-inst.cc ext-inst.cc \ + ios-inst.cc iostream-inst.cc istream-inst.cc istream.cc \ + locale-inst.cc misc-inst.cc ostream-inst.cc sstream-inst.cc \ + streambuf-inst.cc streambuf.cc string-inst.cc valarray-inst.cc \ + wlocale-inst.cc wstring-inst.cc mutex.cc condition_variable.cc \ + atomicity.cc codecvt_members.cc collate_members.cc \ + ctype_members.cc messages_members.cc monetary_members.cc \ + numeric_members.cc time_members.cc basic_file.cc c++locale.cc \ compatibility-ldbl.cc parallel_list.cc parallel_settings.cc am__objects_1 = atomicity.lo codecvt_members.lo collate_members.lo \ ctype_members.lo messages_members.lo monetary_members.lo \ @@ -102,7 +102,7 @@ am__objects_5 = atomic.lo bitmap_allocator.lo pool_allocator.lo \ ctype.lo date_time.lo debug.lo functexcept.lo hash.lo \ hash_c++0x.lo globals_io.lo hashtable.lo hashtable_c++0x.lo \ ios.lo ios_failure.lo ios_init.lo ios_locale.lo limits.lo \ - list.lo debug_list.lo locale.lo locale_init.lo \ + limits_c++0x.lo list.lo debug_list.lo locale.lo locale_init.lo \ locale_facets.lo localename.lo stdexcept.lo strstream.lo \ system_error.lo tree.lo allocator-inst.lo concept-inst.lo \ fstream-inst.lo ext-inst.lo ios-inst.lo iostream-inst.lo \ @@ -392,6 +392,7 @@ sources = \ ios_init.cc \ ios_locale.cc \ limits.cc \ + limits_c++0x.cc \ list.cc \ debug_list.cc \ locale.cc \ @@ -856,6 +857,11 @@ hashtable_c++0x.lo: hashtable_c++0x.cc hashtable_c++0x.o: hashtable_c++0x.cc $(CXXCOMPILE) -std=gnu++0x -c $< +limits_c++0x.lo: limits_c++0x.cc + $(LTCXXCOMPILE) -std=gnu++0x -c $< +limits_c++0x.o: limits_c++0x.cc + $(CXXCOMPILE) -std=gnu++0x -c $< + date_time.lo: date_time.cc $(LTCXXCOMPILE) -std=gnu++0x -c $< date_time.o: date_time.cc diff --git a/libstdc++-v3/src/limits_c++0x.cc b/libstdc++-v3/src/limits_c++0x.cc new file mode 100644 index 00000000000..d3d5df68ab8 --- /dev/null +++ b/libstdc++-v3/src/limits_c++0x.cc @@ -0,0 +1,81 @@ +// std::limits definitions -*- C++ -*- + +// Copyright (C) 2008 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 2, 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 COPYING. If not, write to the Free +// Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +// USA. + +// As a special exception, you may use this file as part of a free software +// library without restriction. Specifically, if other files instantiate +// templates or use macros or inline functions from this file, or you compile +// this file and link it with other files to produce an executable, this +// file does not by itself cause the resulting executable to be covered by +// the GNU General Public License. This exception does not however +// invalidate any other reasons why the executable file might be covered by +// the GNU General Public License. + +#include <limits> + +namespace std +{ + // char16_t + const bool numeric_limits<char16_t>::is_specialized; + const int numeric_limits<char16_t>::digits; + const int numeric_limits<char16_t>::digits10; + const bool numeric_limits<char16_t>::is_signed; + const bool numeric_limits<char16_t>::is_integer; + const bool numeric_limits<char16_t>::is_exact; + const int numeric_limits<char16_t>::radix; + const int numeric_limits<char16_t>::min_exponent; + const int numeric_limits<char16_t>::min_exponent10; + const int numeric_limits<char16_t>::max_exponent; + const int numeric_limits<char16_t>::max_exponent10; + const bool numeric_limits<char16_t>::has_infinity; + const bool numeric_limits<char16_t>::has_quiet_NaN; + const bool numeric_limits<char16_t>::has_signaling_NaN; + const float_denorm_style numeric_limits<char16_t>::has_denorm; + const bool numeric_limits<char16_t>::has_denorm_loss; + const bool numeric_limits<char16_t>::is_iec559; + const bool numeric_limits<char16_t>::is_bounded; + const bool numeric_limits<char16_t>::is_modulo; + const bool numeric_limits<char16_t>::traps; + const bool numeric_limits<char16_t>::tinyness_before; + const float_round_style numeric_limits<char16_t>::round_style; + + // char32_t + const bool numeric_limits<char32_t>::is_specialized; + const int numeric_limits<char32_t>::digits; + const int numeric_limits<char32_t>::digits10; + const bool numeric_limits<char32_t>::is_signed; + const bool numeric_limits<char32_t>::is_integer; + const bool numeric_limits<char32_t>::is_exact; + const int numeric_limits<char32_t>::radix; + const int numeric_limits<char32_t>::min_exponent; + const int numeric_limits<char32_t>::min_exponent10; + const int numeric_limits<char32_t>::max_exponent; + const int numeric_limits<char32_t>::max_exponent10; + const bool numeric_limits<char32_t>::has_infinity; + const bool numeric_limits<char32_t>::has_quiet_NaN; + const bool numeric_limits<char32_t>::has_signaling_NaN; + const float_denorm_style numeric_limits<char32_t>::has_denorm; + const bool numeric_limits<char32_t>::has_denorm_loss; + const bool numeric_limits<char32_t>::is_iec559; + const bool numeric_limits<char32_t>::is_bounded; + const bool numeric_limits<char32_t>::is_modulo; + const bool numeric_limits<char32_t>::traps; + const bool numeric_limits<char32_t>::tinyness_before; + const float_round_style numeric_limits<char32_t>::round_style; +} diff --git a/libstdc++-v3/testsuite/18_support/numeric_limits/char16_32_t.cc b/libstdc++-v3/testsuite/18_support/numeric_limits/char16_32_t.cc new file mode 100644 index 00000000000..c2957506cb0 --- /dev/null +++ b/libstdc++-v3/testsuite/18_support/numeric_limits/char16_32_t.cc @@ -0,0 +1,77 @@ +// { dg-options "-std=gnu++0x" } +// 2008-05-20 Paolo Carlini <paolo.carlini@oracle.com> +// +// Copyright (C) 2008 Free Software Foundation +// +// 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 2, 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 COPYING. If not, write to the Free +// Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +// USA. + +// 18.2.1.1 template class numeric_limits + +#include <limits> +#include <cstdint> +#include <testsuite_hooks.h> + +// Test specializations for char16_t and char32_t, in C++0x. +template<typename T, typename R> + void + do_test() + { + bool test __attribute__((unused)) = true; + + typedef std::numeric_limits<T> char_type; + typedef std::numeric_limits<R> impl_type; + + VERIFY( char_type::is_specialized == impl_type::is_specialized ); + VERIFY( char_type::min() == impl_type::min() ); + VERIFY( char_type::max() == impl_type::max() ); + VERIFY( char_type::digits == impl_type::digits ); + VERIFY( char_type::digits10 == impl_type::digits10 ); + VERIFY( char_type::is_signed == impl_type::is_signed ); + VERIFY( char_type::is_integer == impl_type::is_integer ); + VERIFY( char_type::is_exact == impl_type::is_exact ); + VERIFY( char_type::radix == impl_type::radix ); + VERIFY( char_type::epsilon() == impl_type::epsilon() ); + VERIFY( char_type::round_error() == impl_type::round_error() ); + VERIFY( char_type::min_exponent == impl_type::min_exponent ); + VERIFY( char_type::min_exponent10 == impl_type::min_exponent10 ); + VERIFY( char_type::max_exponent == impl_type::max_exponent ); + VERIFY( char_type::max_exponent10 == impl_type::max_exponent10 ); + VERIFY( char_type::has_infinity == impl_type::has_infinity ); + VERIFY( char_type::has_quiet_NaN == impl_type::has_quiet_NaN ); + VERIFY( char_type::has_signaling_NaN == impl_type::has_signaling_NaN ); + VERIFY( char_type::has_denorm == impl_type::has_denorm ); + VERIFY( char_type::has_denorm_loss == impl_type::has_denorm_loss ); + VERIFY( char_type::infinity() == impl_type::infinity() ); + VERIFY( char_type::quiet_NaN() == impl_type::quiet_NaN() ); + VERIFY( char_type::signaling_NaN() == impl_type::signaling_NaN() ); + VERIFY( char_type::denorm_min() == impl_type::denorm_min() ); + VERIFY( char_type::is_iec559 == impl_type::is_iec559 ); + VERIFY( char_type::is_bounded == impl_type::is_bounded ); + VERIFY( char_type::is_modulo == impl_type::is_modulo ); + VERIFY( char_type::traps == impl_type::traps ); + VERIFY( char_type::tinyness_before == impl_type::tinyness_before ); + VERIFY( char_type::round_style == impl_type::round_style ); + } + +int main() +{ +#if _GLIBCXX_USE_C99_STDINT_TR1 + do_test<char16_t, uint_least16_t>(); + do_test<char32_t, uint_least32_t>(); +#endif + return 0; +} diff --git a/libstdc++-v3/testsuite/20_util/hash/requirements/explicit_instantiation.cc b/libstdc++-v3/testsuite/20_util/hash/requirements/explicit_instantiation.cc index 7b82eeeab2f..91b8db017ef 100644 --- a/libstdc++-v3/testsuite/20_util/hash/requirements/explicit_instantiation.cc +++ b/libstdc++-v3/testsuite/20_util/hash/requirements/explicit_instantiation.cc @@ -1,7 +1,7 @@ // { dg-options "-std=gnu++0x" } // { dg-do compile } -// Copyright (C) 2007 Free Software Foundation, Inc. +// Copyright (C) 2007, 2008 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 @@ -28,6 +28,8 @@ template class std::hash<bool>; template class std::hash<char>; template class std::hash<signed char>; template class std::hash<unsigned char>; +template class std::hash<char16_t>; +template class std::hash<char32_t>; template class std::hash<short>; template class std::hash<int>; template class std::hash<long>; diff --git a/libstdc++-v3/testsuite/20_util/is_integral/requirements/explicit_instantiation.cc b/libstdc++-v3/testsuite/20_util/is_integral/requirements/explicit_instantiation.cc new file mode 100644 index 00000000000..f3acb574369 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/is_integral/requirements/explicit_instantiation.cc @@ -0,0 +1,40 @@ +// { dg-options "-std=gnu++0x" } +// { dg-do compile } +// 2008-05-20 Paolo Carlini <paolo.carlini@oracle.com> + +// Copyright (C) 2008 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 2, 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 COPYING. If not, write to the Free +// Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +// USA. + +// As a special exception, you may use this file as part of a free software +// library without restriction. Specifically, if other files instantiate +// templates or use macros or inline functions from this file, or you compile +// this file and link it with other files to produce an executable, this +// file does not by itself cause the resulting executable to be covered by +// the GNU General Public License. This exception does not however +// invalidate any other reasons why the executable file might be covered by +// the GNU General Public License. + +// NB: This file is for testing type_traits with NO OTHER INCLUDES. + +#include <type_traits> + +namespace std +{ + typedef short test_type; + template struct is_integral<test_type>; +} diff --git a/libstdc++-v3/testsuite/20_util/is_integral/requirements/typedefs.cc b/libstdc++-v3/testsuite/20_util/is_integral/requirements/typedefs.cc new file mode 100644 index 00000000000..61ef22e5392 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/is_integral/requirements/typedefs.cc @@ -0,0 +1,37 @@ +// { dg-options "-std=gnu++0x" } +// 2008-05-20 Paolo Carlini <paolo.carlini@oracle.com> +// +// Copyright (C) 2008 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 2, 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 COPYING. If not, write to the Free +// Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +// USA. + +// +// NB: This file is for testing type_traits with NO OTHER INCLUDES. + +#include <type_traits> + +// { dg-do compile } + +void test01() +{ + // Check for required typedefs + typedef std::is_integral<int> test_type; + typedef test_type::value_type value_type; + typedef test_type::type type; + typedef test_type::type::value_type type_value_type; + typedef test_type::type::type type_type; +} diff --git a/libstdc++-v3/testsuite/20_util/is_integral/value.cc b/libstdc++-v3/testsuite/20_util/is_integral/value.cc new file mode 100644 index 00000000000..5ff12c8f2c0 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/is_integral/value.cc @@ -0,0 +1,63 @@ +// { dg-options "-std=gnu++0x" } +// 2008-05-20 Paolo Carlini <paolo.carlini@oracle.com> +// +// Copyright (C) 2008 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 2, 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 COPYING. If not, write to the Free +// Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +// USA. + +#include <type_traits> +#include <testsuite_hooks.h> +#include <testsuite_tr1.h> + +void test01() +{ + bool test __attribute__((unused)) = true; + using std::is_integral; + using namespace __gnu_test; + + VERIFY( (test_category<is_integral, void>(false)) ); + + VERIFY( (test_category<is_integral, char>(true)) ); + VERIFY( (test_category<is_integral, signed char>(true)) ); + VERIFY( (test_category<is_integral, unsigned char>(true)) ); +#ifdef _GLIBCXX_USE_WCHAR_T + VERIFY( (test_category<is_integral, wchar_t>(true)) ); +#endif + VERIFY( (test_category<is_integral, char16_t>(true)) ); + VERIFY( (test_category<is_integral, char32_t>(true)) ); + VERIFY( (test_category<is_integral, short>(true)) ); + VERIFY( (test_category<is_integral, unsigned short>(true)) ); + VERIFY( (test_category<is_integral, int>(true)) ); + VERIFY( (test_category<is_integral, unsigned int>(true)) ); + VERIFY( (test_category<is_integral, long>(true)) ); + VERIFY( (test_category<is_integral, unsigned long>(true)) ); + VERIFY( (test_category<is_integral, long long>(true)) ); + VERIFY( (test_category<is_integral, unsigned long long>(true)) ); + + VERIFY( (test_category<is_integral, float>(false)) ); + VERIFY( (test_category<is_integral, double>(false)) ); + VERIFY( (test_category<is_integral, long double>(false)) ); + + // Sanity check. + VERIFY( (test_category<is_integral, ClassType>(false)) ); +} + +int main() +{ + test01(); + return 0; +} |