diff options
| author | Rafael Espindola <espindola@google.com> | 2008-06-04 19:16:20 +0000 |
|---|---|---|
| committer | Rafael Espindola <espindola@google.com> | 2008-06-04 19:16:20 +0000 |
| commit | faad4c1b3447ed6550a540252f7e3e5f2cad220f (patch) | |
| tree | a3aebb83df142716f0bdec53666f934ba49a4a2b | |
| parent | 7b295708c1d8cd216c15aba31f4d1a38b16aa873 (diff) | |
2008-06-04 Rafael Espindola <espindola@google.com>
Mainline merge @136135
* configure.ac (ACX_PKGVERSION): Update revision merge string.
* configure: Regenerate.
git-svn-id: https://gcc.gnu.org/svn/gcc/branches/lto-streamer@136367 138bc75d-0d04-0410-961f-82ee72b054a4
374 files changed, 14432 insertions, 10711 deletions
diff --git a/gcc/ChangeLog b/gcc/ChangeLog index 6c0162f0f3e..9c10b88973f 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,431 @@ +2008-05-28 Seongbae Park <seongbae.park@gmail.com> + + * value-prof.c (tree_ic_transform): Use HOST_WIDEST_INT_PRINT_DEC + for printing gcov_type. + +2008-05-28 Seongbae Park <seongbae.park@gmail.com> + + * tree-ssa-propagate.c (set_rhs): Preserve the histogram + and the eh region information. + * value-prof.c (gimple_move_stmt_histograms): New function. + * value-prof.h (gimple_move_stmt_histograms): New function declaration. + +2008-05-28 Andreas Tobler <a.tobler@schweiz.org> + + * config/pa/pa.md: Remove extern frame_pointer_needed declaration. + +2008-05-28 Seongbae Park <seongbae.park@gmail.com> + + * value-prof.c (tree_ic_transform): Print counts. + * tree-profile.c (tree_gen_ic_func_profiler): + Clear __gcov_indreict_call_callee variable + to avoid misattribution of the profile. + +2008-05-28 Rafael Espindola <espindola@google.com> + + * see.c (see_def_extension_not_merged): Use copy_rtx_if_shared to avoid + invalid sharing. + +2008-05-28 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/36339 + * tree-ssa-alias.c (set_initial_properties): Move pt_anything + and clobbering code out of the loop. + +2008-05-28 Andreas Krebbel <krebbel1@de.ibm.com> + + * config/s390/constraints.md ('b', 'C', 'D', 'e'): New constraint + letters defined. + + * config/s390/s390.c (s390_compare_and_branch_condition_mask, + s390_contiguous_bitmask_p, s390_symref_operand_p, + s390_check_symref_alignment, s390_reload_larl_operand, + s390_reload_symref_address): New functions. + (s390_branch_condition_mnemonic): Support compare and branch + instructions. + (s390_mem_constraint): Avoid symrefs to accepted by the 'T' + and 'W' constraints. + (s390_secondary_reload): Add secondary reloads for unaligned + symbol refs or symbol refs to floating point or QI/TI mode + integer values. + (legitimate_address_p): Accept symbol references as addresses. + (s390_expand_insv): Use rotate and insert selected bits + instruction for insv when building for z10. + (print_operand_address): Handle symbol ref addresses. + (print_operand): Output modifier 'c' added for signed byte + values. + (s390_encode_section_info): Mark symbol refs with + SYMBOL_FLAG_NOT_NATURALLY_ALIGNED if appropriate. + + * config/s390/s390.md (SIL,RRS,RIS): New instruction formats added. + (length attribute): RRF, RRR have 4 byte length. + (FPALL, INTALL): New mode iterators added. + (*tstdi_sign, *cmpdi_ccs_sign, *cmpsi_ccs_sign, + *cmp<mode>_ccs, *cmpdi_ccu_zero, *cmpdi_ccu, *cmpsi_ccu, *cmphi_ccu, + *movdi_64, *movsi_zarch, *movhi, movmem<mode>, *movmem_short, + *extendsidi2, *extendhidi2_extimm, *extendhisi2_extimm, + *zero_extendsidi2, adddi3, *adddi3_31z, *adddi3_31, addsi3, + *add<mode>3, *add<mode>3_carry1_cc, *add<mode>3_carry2_cc, + *add<mode>3_cc, *add<mode>3_imm_cc, *muldi3_sign, muldi3, + *mulsi3_sign, mulsi3, mulsidi3): Patterns enhanced with z10 + instructions. + (*cmphi_ccs_z10, *cmpdi_ccs_signhi_rl, *cmpsi_ccu_zerohi_rlsi, + *cmp<GPR:mode>_ccu_zerohi_rldi, *cmp_and_br_signed_<mode>, + *cmp_and_br_unsigned_<mode>, reload<INTALL:mode><P:mode>_tomem_z10, + reload<INTALL:mode><P:mode>_toreg_z10, + reload<FPALL:mode><P:mode>_tomem_z10, + reload<FPALL:mode><P:mode>_toreg_z10, + reload<P:mode>_larl_odd_addend_z10, *execute_rl, *insv<mode>_z10, + *insv<mode>_z10_noshift, *insv<mode>_or_z10_noshift, + *zero_extendhi<mode>2_z10, *cmp_and_trap_signed_int<mode>, + *cmp_and_trap_unsigned_int<mode>, prefetch): New pattern or expander + definition. + (movmem, clrmem, cmpmem): New splitters added. + + * config/s390/predicates.md (larl_operand): Use + SYMBOL_REF_FLAGS (op) & SYMBOL_FLAG_ALIGN1 replaced with + SYMBOL_REF_ALIGN1_P. + (s390_signed_integer_comparison, + s390_unsigned_integer_comparison): New predicates. + + * config/s390/s390-protos.h (s390_check_symref_alignment, + s390_contiguous_bitmask_p, s390_reload_larl_operand, + s390_reload_symref_address, + s390_compare_and_branch_condition_mask): Prototypes added. + + * config/s390/s390.h (TARGET_MEM_CONSTRAINT, + SYMBOL_REF_ALIGN1_P, SYMBOL_FLAG_NOT_NATURALLY_ALIGNED, + SYMBOL_REF_NOT_NATURALLY_ALIGNED_P): Macro definition added. + +2008-05-28 Andreas Krebbel <krebbel1@de.ibm.com> + + * config/s390/s390.c (z10_cost): New cost function for z10. + (s390_handle_arch_option, override_options): Support + -march=z10 switch. + (s390_issue_rate): Adjust issue rate for z10. + * config/s390/s390.h (processor_type): Add PROCESSOR_2097_Z10. + (processor_flags): Add PF_Z10. + (TARGET_CPU_Z10, TARGET_Z10): New macro definitions. + * config/s390/s390.md (cpu, cpu_facility attributes): Add z10. + * gcc/config.gcc: Add z10. + +2008-05-28 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/36291 + * tree-flow. h (struct gimple_df): Remove var_anns member. + * tree-flow-inline.h (gimple_var_anns): Remove. + (var_ann): Simplify. + * tree-dfa.c (create_var_ann): Simplify. + (remove_referenced_var): Clear alias info from var_anns of globals. + * tree-ssa.c (init_tree_ssa): Do not allocate var_anns. + (delete_tree_ssa): Clear alias info from var_anns of globals. + Do not free var_anns. + (var_ann_eq): Remove. + (var_ann_hash): Likewise. + +2008-05-28 Mark Shinwell <shinwell@codesourcery.com> + + * config/mips/mips.c (mips_cpu_info_table): Add loongson2e + and loongson2f entries. + (mips_rtx_cost_data): Add entries for Loongson-2E/2F. + * config/mips/mips.h (processor_type): Add Loongson-2E + and Loongson-2F entries. + (TARGET_LOONGSON_2E, TARGET_LOONGSON_2F, TARGET_LOONGSON_2EF): New. + (MIPS_ISA_LEVEL_SPEC): Handle Loongson-2E/2F. + * config/mips/mips.md (define_attr cpu): Add loongson2e and loongson2f. + * doc/invoke.texi (MIPS Options): Document loongson2e + and loongson2f processor names. + +2008-05-27 H.J. Lu <hongjiu.lu@intel.com> + + PR target/35767 + PR target/35771 + * config/i386/i386.c (ix86_function_arg_boundary): Use + alignment of canonical type. + (ix86_expand_vector_move): Check unaligned memory access for + all SSE modes. + +2008-05-27 H.J. Lu <hongjiu.lu@intel.com> + + * dwarf2out.c (current_fde): Change return type to dw_fde_ref. + Moved to the front of file. + +2008-05-27 Xuepeng Guo <xuepeng.guo@intel.com> + H.J. Lu <hongjiu.lu@intel.com> + + * dwarf2out.c (current_fde): New. + (add_cfi): Use it. + (lookup_cfa:): Likewise. + (dwarf2out_end_epilogue): Likewise. + (dwarf2out_note_section_used): Likewise. + +2008-05-27 Michael Matz <matz@suse.de> + + PR c++/27975 + * c.opt (Wenum-compare): New warning option. + * doc/invoke.texi (Warning Options): Document -Wenum-compare. + +2008-05-27 Michael Matz <matz@suse.de> + + PR middle-end/36326 + * tree-gimple.c (is_gimple_mem_rhs): Remove work-around for + non-BLKmode types. + * tree-tailcall.c (find_tail_calls): Don't mark calls storing + into memory as tail calls. + +2008-05-27 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/36339 + * tree-ssa-alias.c (set_initial_properties): Escaped pt_anything + pointers cause all addressable variables to be call clobbered. + +2008-05-27 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/36245 + * tree-ssa-address.c (add_to_parts): Deal with non-pointer + bases. + +2008-05-27 Andreas Krebbel <krebbel1@de.ibm.com> + + * config/s390/s390.md: Replace all occurences of the 'm' + constraint with 'RT'. + +2008-05-27 Andreas Krebbel <krebbel1@de.ibm.com> + + * config/s390/s390.md ("cpu_facility", "enabled"): Attribute + definitions added. + ("*movdi_64dfp", "*movdi_64extimm", "*movdi_64"): Merged into + "*movdi_64". + ("*anddi3_extimm", "*anddi3"): Merged into "*anddi3". + ("*iordi3_extimm", "*iordi3"): Merged into "*iordi3". + ("*xordi3_extimm", "*xordi3"): Merged into "*xordi3". + +2008-05-27 Andreas Krebbel <krebbel1@de.ibm.com> + + * reload.c: (find_reloads): Skip alternatives according to the + "enabled" attribute. Constify the constraint variable. + * recog.c (get_attr_enabled): Add default implementation. + (extract_insn): Set the alternative_enabled_p array + in the recog_data struct. + (preprocess_constraints, constrain_operands): Skip + alternatives according to the "enabled" attribute + * recog.h (struct recog_data): New field alternative_enabled_p. + (skip_alternative): New inline function. + * regclass.c: (record_operand_costs): Check the "enabled" + attribute. + (record_reg_classes): Skip alternative according to the + "enabled" attribute. + + * doc/md.texi: Add documention for the "enabled" attribute. + +2008-05-27 Andreas Krebbel <krebbel1@de.ibm.com> + + * defaults.h (TARGET_MEM_CONSTRAINT): New target macro added. + * postreload.c (reload_cse_simplify_operands): Replace 'm' + constraint with TARGET_MEM_CONSTRAINT. + * recog.c (asm_operand_ok, preprocess_constraints, + constrain_operands): Likewise. + * regclass.c (record_reg_classes): Likewise. + * reload.c (find_reloads, alternative_allows_const_pool_ref): + Likewise. + * reload1.c (maybe_fix_stack_asms): Likewise. + * stmt.c (parse_output_constraint, parse_input_constraint): + Likewise. + * recog.h: Adjust comment. + * genpreds.c (generic_constraint_letters): Remove 'm' constraint. + * genoutput.c (note_constraint): Don't emit error for 'm' + constraint. + * doc/md.texi: Add a note to description of 'm' constraint. + * doc/tm.texi: Document the new TARGET_MEM_CONSTRAINT macro. + +2008-05-27 Eric Botcazou <ebotcazou@adacore.com> + + * tree-sra.c (sra_type_can_be_decomposed_p) <RECORD_TYPE>: Make sure + that the bitfield is of integral type before testing its precision. + +2008-05-27 Trevor Smigiel <trevor_smigiel@playstation.sony.com> + Sa Liu <saliu@de.ibm.com> + + * config/spu/spu.c (spu_init_libfuncs): Add __multi3, __divti3, + __modti3, __udivti3, __umodti3 and __udivmodti4. + * config/spu/t-spu-elf (LIB2FUNCS_STATIC_EXTRA): Add files + that implement TImode mul and div functions. + * config/spu/multi3.c: New. Implement __multi3. + * config/spu/divmodti4.c: New. Implement _udivmodti4 and others. + * testsuite/gcc.target/spu/muldivti3.c: New. Test TImode mul and div + functions on SPU. + +2008-05-26 Steven Bosscher <stevenb.gcc@gmail.com> + + * config/rs6000/rs6000.c (rs6000_legitimize_tls_address): Generate + new tls_gd_* and tls_ld_* insns instead of an insn sequence. + * config/rs6000/rs6000.md (TLSmode, tls_abi_suffix, tls_insn_suffix, + tls_sysv_suffix): New mode and mode attribute iterators. + (tls_gd_32, tls_gd_64, tls_ld_32, tls_ld_64): Remove. + (lts_gd_aix*, tls_gd_sysv*, tls_ld_aix*, tls_ld_sysv*): New patterns. + (tls_dtprel_*, tls_dtprel_ha_*, tls_dtprel_lo_*, tls_got_dtprel_*, + tls_tprel_*, tls_tprel_ha_*, tls_tprel_lo_*, tls_got_tprel_*, + tls_tls_*): Merge 32 bit and 64 bit variants using aforementioned + iterators. + +2008-05-26 Eric Botcazou <ebotcazou@adacore.com> + + PR tree-optimization/36329 + * tree.h (CALL_CANNOT_INLINE_P): Add access check. + * tree-gimple.h (CALL_STMT_CANNOT_INLINE_P): New macro. + * cgraphbuild.c (initialize_inline_failed): Use the latter + macro in lieu of the former. + * ipa-inline.c (cgraph_mark_inline): Likewise. + (cgraph_decide_inlining_of_small_function): Likewise. + (cgraph_decide_inlining): Likewise. + (cgraph_decide_inlining_incrementally): Likewise. + +2008-05-26 Tristan Gingold <gingold@adacore.com> + Anatoly Sokolov <aesok@post.ru> + + * config/avr/avr.md ("call_prologue_saves"): Use hi8(gs())/lo8(gs()) + instead of pm_lo8/pm_hi8 to makes this call working on avr6. + * config/avr/avr.c (expand_prologue): Tune "call_prologue" + optimization for 'avr6' architecture. + +2008-05-26 Andy Hutchinson <hutchinsonandy@aim.com> + + PR target/34932 + * config/avr/avr.md (*addhi3_zero_extend2): Remove. + +2008-05-26 Richard Guenther <rguenther@suse.de> + + * tree-ssa-sccvn.c (expr_has_constants): Declare. + (visit_reference_op_load): Initialize VN_INFO->has_constants + properly. + +2008-05-26 H.J. Lu <hongjiu.lu@intel.com> + + PR middle-end/36253 + * caller-save.c (insert_restore): Verify alignment of spill + space. + (insert_save): Likewise. + + * cfgexpand.c (LOCAL_ALIGNMENT): Removed. + + * defaults.h (LOCAL_ALIGNMENT): New. Provide default. + (STACK_SLOT_ALIGNMENT): Likewise. + + * function.c (LOCAL_ALIGNMENT): Removed. + (get_stack_local_alignment): New. + (assign_stack_local): Use it. Set alignment on stack slot. + (assign_stack_temp_for_type): Use get_stack_local_alignment. + + * config/i386/i386.h (LOCAL_ALIGNMENT): Updated. + (STACK_SLOT_ALIGNMENT): New. + + * config/i386/i386.c (ix86_local_alignment): Handle caller-save + stack slot in XFmode. + + * doc/tm.texi (STACK_SLOT_ALIGNMENT): New. + +2008-05-26 Kai Tietz <kai.tietz@onevision.com> + + PR/36321 + * config/i386/i386.md (allocate_stack_worker_64): Make sure + argument operand in rax isn't removed. + +2008-05-26 Richard Guenther <rguenther@suse.de> + + PR middle-end/36300 + * fold-const.c (extract_muldiv_1): Use TYPE_OVERFLOW_WRAPS, + not TYPE_UNSIGNED. Use TYPE_PRECISION instead of GET_MODE_SIZE. + +2008-05-26 Daniel Franke <franke.daniel@gmail.com> + + PR bootstrap/36331 + * c-cppbuiltin.c (define__GNUC__): Re-add definition of __GNUG__. + +2008-05-26 Dominique Dhumieres <dominiq@lps.ens.fr> + + * config/darwin-c.c: Include "incpath.h" instead of "c-incpath.h". + * config/t-darwin: Use "incpath.h" instead of "c-incpath.h". + +2008-05-25 Eric Botcazou <ebotcazou@adacore.com> + + * tree-nested.c (convert_tramp_reference) <ADDR_EXPR>: Do not + build a trampoline if we don't want one. + * varasm.c (initializer_constant_valid_p) <ADDR_EXPR>: Do not + return zero for nested functions if we don't want a trampoline. + +2008-05-26 Daniel Franke <franke.daniel@gmail.com> + + * doc/invoke.texi: Added f77, f77-cpp-input to list of file types. + +2008-05-26 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/18428 + * c.opt: Removed undocumented option '-lang-fortran'. + * c-common.h: Removed global variable 'lang_fortran'. + * c-opts.c (c_common_handle_option): Removed code to handle + option '-lang-fortran'. Updated includes. + * c-cppbuiltin.c (c_cpp_builtins): Removed conditional + definition of '__GFORTRAN__'. + (define__GNUC__): Reimplemented to use BASEVER and + cpp_define_formatted. + (builtin_define_with_value_n): Removed. + * c-incpath.h: Renamed to ... + * incpath.h: ... this. + * c-incpath.c: Renamed to ... + * incpath.c: ... this. Updated includes. + * fix-header.c: Updated includes. + * Makefile.in: Replaced c-incpath.[ch] by incpath.[ch]. + (c-cppbuiltin.o): Added dependency on and definition of BASEVER. + (OBJ-archive): Added cppdefault.o, incpath.o and prefix.o. + +2008-05-25 Eric Botcazou <ebotcazou@adacore.com> + + * tree.h: Update the table of flags used on tree nodes. + (TREE_NO_TRAMPOLINE): New accessor for static_flag. + (SAVE_EXPR_RESOLVED_P): Use automatically-built access check. + (FORCED_LABEL): Add access check. + (CALL_EXPR_RETURN_SLOT_OPT): Likewise. + (ASM_INPUT_P): Likewise. + (ASM_VOLATILE_P): Likewise. + (EH_FILTER_MUST_NOT_THROW): Access static_flag directly. + (OMP_SECTION_LAST): Access private_flag directly. + (OMP_RETURN_NOWAIT): Likewise. + (OMP_PARALLEL_COMBINED): Likewise. + (OMP_CLAUSE_PRIVATE_DEBUG): Access public_flag directly. + (OMP_CLAUSE_LASTPRIVATE_FIRSTPRIVATE): Likewise. + * tree-ssa-propagate.c (STMT_IN_SSA_EDGE_WORKLIST): Access + deprecated_flag directly. + +2008-05-25 H.J. Lu <hongjiu.lu@intel.com> + + * final.c (frame_pointer_needed): Removed. + * flags.h (frame_pointer_needed): Likewise. + + * function.h (rtl_data): Add frame_pointer_needed. + (frame_pointer_needed): New. + +2008-05-25 Arthur Loiret <arthur.loiret@u-psud.fr> + + * config.gcc (sh2[lbe]*-*-linux*): Allow target. + +2008-05-25 Steven Bosscher <stevenb.gcc@gmail.com> + + * gcse.c (hash_scan_set): Do not pick up a REG_EQUAL value if + SRC is a REG. + +2008-05-25 Alan Modra <amodra@bigpond.net.au> + + * c-common.c (strip_array_types): Move function to.. + * tree.c: ..here. + (get_inner_array_type): Delete. + * c-common.h (strip_array_types): Move declaration to.. + * tree.h: ..here. + (get_inner_array_type): Delete. + * config/i386/i386.c (x86_field_alignment): Use strip_array_types. + * config/rs6000/aix.h (ADJUST_FIELD_ALIGN): Likewise. + * config/rs6000/linux64.h (ADJUST_FIELD_ALIGN): Likewise. + * config/pa/pa.c (emit_move_sequence): Likewise. + 2008-05-24 H.J. Lu <hongjiu.lu@intel.com> * config/i386/i386.md (*sse_prologue_save_insn): Set length diff --git a/gcc/ChangeLog.lto b/gcc/ChangeLog.lto index 3e5ccaa7a3d..e780412c5b8 100644 --- a/gcc/ChangeLog.lto +++ b/gcc/ChangeLog.lto @@ -1,3 +1,10 @@ +2008-06-04 Rafael Espindola <espindola@google.com> + + Mainline merge @136135 + + * configure.ac (ACX_PKGVERSION): Update revision merge string. + * configure: Regenerate. + 2008-06-03 Bill Maddox <maddox@google.com> * lto-tree-flags.def: Add flags for LABEL_DECL. diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index 14b53ae536c..faad3478e9a 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20080524 +20080529 diff --git a/gcc/Makefile.in b/gcc/Makefile.in index b9d5f1d4563..5a29bddb244 100644 --- a/gcc/Makefile.in +++ b/gcc/Makefile.in @@ -979,7 +979,7 @@ GCC_OBJS = gcc.o opts-common.o gcc-options.o # Language-specific object files for C and Objective C. C_AND_OBJC_OBJS = attribs.o c-errors.o c-lex.o c-pragma.o c-decl.o c-typeck.o \ c-convert.o c-aux-info.o c-common.o c-opts.o c-format.o c-semantics.o \ - c-incpath.o cppdefault.o c-ppoutput.o c-cppbuiltin.o prefix.o \ + c-ppoutput.o c-cppbuiltin.o \ c-objc-common.o c-dump.o c-pch.o c-parser.o $(C_TARGET_OBJS) \ c-gimplify.o tree-mudflap.o c-pretty-print.o c-omp.o @@ -1244,6 +1244,8 @@ OBJS-archive = \ cgraph.o \ cgraphbuild.o \ cgraphunit.o \ + cppdefault.o \ + incpath.o \ ipa-cp.o \ ipa-inline.o \ ipa-prop.o \ @@ -1254,6 +1256,7 @@ OBJS-archive = \ ipa-utils.o \ ipa.o \ matrix-reorg.o \ + prefix.o \ tree-inline.o \ tree-nomudflap.o \ varpool.o @@ -1743,7 +1746,7 @@ srcextra: gcc.srcextra lang.srcextra gcc.srcextra: gengtype-lex.c -cp -p $^ $(srcdir) -c-incpath.o: c-incpath.c c-incpath.h $(CONFIG_H) $(SYSTEM_H) $(CPPLIB_H) \ +incpath.o: incpath.c incpath.h $(CONFIG_H) $(SYSTEM_H) $(CPPLIB_H) \ intl.h prefix.h coretypes.h $(TM_H) cppdefault.h $(TARGET_H) \ $(MACHMODE_H) @@ -1826,13 +1829,15 @@ c-pretty-print.o : c-pretty-print.c $(C_PRETTY_PRINT_H) \ c-opts.o : c-opts.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ $(TREE_H) $(C_PRAGMA_H) $(FLAGS_H) toplev.h langhooks.h \ $(TREE_INLINE_H) $(DIAGNOSTIC_H) intl.h debug.h $(C_COMMON_H) \ - opts.h options.h $(MKDEPS_H) c-incpath.h cppdefault.h $(TM_P_H) + opts.h options.h $(MKDEPS_H) incpath.h cppdefault.h $(TM_P_H) $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) \ $< $(OUTPUT_OPTION) @TARGET_SYSTEM_ROOT_DEFINE@ c-cppbuiltin.o : c-cppbuiltin.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ $(TREE_H) version.h $(C_COMMON_H) $(C_PRAGMA_H) $(FLAGS_H) toplev.h \ - output.h except.h $(REAL_H) $(TARGET_H) $(TM_P_H) + output.h except.h $(REAL_H) $(TARGET_H) $(TM_P_H) $(BASEVER) + $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) -DBASEVER=$(BASEVER_s) \ + $< $(OUTPUT_OPTION) # A file used by all variants of C and some other languages. @@ -3638,10 +3643,10 @@ xsys-protos.h: $(GCC_PASSES) $(srcdir)/sys-protos.h deduced.h \ # This is nominally a 'build' program, but it's run only when host==build, # so we can (indeed, must) use $(LIBDEPS) and $(LIBS). build/fix-header$(build_exeext): build/fix-header.o build/scan-decls.o \ - build/scan.o xsys-protos.h c-incpath.o cppdefault.o prefix.o \ + build/scan.o xsys-protos.h \ $(BUILD_ERRORS) $(LIBDEPS) $(CC_FOR_BUILD) $(BUILD_CFLAGS) $(BUILD_LDFLAGS) -o $@ \ - build/fix-header.o c-incpath.o cppdefault.o build/scan-decls.o prefix.o \ + build/fix-header.o incpath.o cppdefault.o build/scan-decls.o prefix.o \ build/scan.o $(BUILD_ERRORS) $(LIBS) build/fix-header.o: fix-header.c $(OBSTACK_H) scan.h errors.h \ diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f7305e8ef4f..280506de99e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,777 @@ +2008-05-28 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb (Analyze_Assignment): If the name is of a local anonymous + access type, wrap the expression in a conversion to force an + accessibility check. + + * sem_aggr.adb (Aggegate_Constraint_Checks): Apply conversion to force + accessibility checks even when expansion is disabled in order to + generate messages in the presence of previous errors or in + semantics-only mode. + +2008-05-28 Eric Botcazou <ebotcazou@adacore.com> + + * system-lynxos-ppc.ads (Always_Compatible_Rep): Set to False. + * system-lynxos-x86.ads (Always_Compatible_Rep): Set to False. + +2008-05-28 Vincent Celier <celier@adacore.com> + + PR ada/34446 + * gnat_ugn.texi: Document restriction introduced on 2007-04-20 in + preprocessing expressions + +2008-05-28 Vincent Celier <celier@adacore.com> + + * sinput-p.adb (Source_File_Is_Subunit): Allow special character used + for preprocessing + + * sinput-p.ads: Minor comment update and reformatting + +2008-05-28 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Valid_Conversion): An anonymous access_to_subprogram + type has a deeper level than any master only when it is the type of an + access parameter. + +2008-05-28 Javier Miranda <miranda@adacore.com> + + * sem_ch3.adb (Derive_Progenitor_Subprograms): Add documentation. + +2008-05-28 Javier Miranda <miranda@adacore.com> + + * sem_util.ads (Find_Overridden_Synchronized_Primitive): Removed. + * sem_util.adb (Find_Overridden_Synchronized_Primitive): Removed. + * sem_ch6.adb (Check_Synchronized_Overriding): Remove one formal. + Add code that was previously located in + Find_Overridden_Synchronized_Primitive because it is only used here. + +2008-05-28 Sergey Rybin <rybin@adacore.com> + + * sem_prag.adb (Process_Extended_Import_Export_Subprogram_Pragma): Set + Entity field for formal_parameter_NAME in MECHANISM_ASSOCIATION. + +2008-05-28 Robert Dewar <dewar@adacore.com> + + * restrict.ads: + Add missing restrictions, and properly label all GNAT defined ones + + * rtsfind.ads: + Add entry for Ada_Real_Time.Timing_Events.Timing_Event + Add entry for Ada.Task_Termination.Set_Specific_Handler + Add entry for Ada.Task_Termination.Specific_Handler + + * s-rident.ads: + Add missing restrictions and properly mark all gnat defined ones + + * sem_ch3.adb: + (Analyze_Object_Declaration): Check No_Local_Timing_Events restriction + + * sem_res.adb: + (Resolve_Call): Check violation of No_Specific_Termination_Handlers + + * gnat_rm.texi: Add missing restrictions, and properly label all + GNAT defined ones + +2008-05-28 Robert Dewar <dewar@adacore.com> + + * restrict.adb: + (Check_Restriction): violation of restriction No_Finalization is + treated as a serious error to stop expansion + +2008-05-28 Robert Dewar <dewar@adacore.com> + + * exp_util.adb: Minor reformatting + * exp_util.ads: Minor reformatting. + +2008-05-28 Arnaud Charlet <charlet@adacore.com> + + * Make-lang.in: Remove gprmake. + + * gprmake.adb, makegpr.ads, makegpr.adb: Removed. + +2008-05-28 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Diagnose_Interface): Cleanup error messages involving + improper progenitor names, and avoid cascaded errors. + +2008-05-28 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Add note on Old giving warning when applied to constant + + * sem_attr.adb (Analyze_Attribute, case Old): Give warning if prefix is + a constant + +2008-05-28 Robert Dewar <dewar@adacore.com> + + * exp_fixd.adb (Build_Multiply): Correct one-off error in computing + size + +2008-05-28 Robert Dewar <dewar@adacore.com> + + * exp_ch5.adb: + (Expand_Simple_Function_Return): Copy unaligned result into temporary + +2008-05-28 Javier Miranda <miranda@adacore.com> + + * sem_ch3.adb (Derive_Progenitor_Primitives): Add missing support + for user-defined predefined primitives. + + * sem_util.adb (Matches_Prefixed_View_Profile): Ditto. + (Find_Overridden_Synchronized_Primitive): Ditto. + + * sem_ch6.adb (Check_Synchronized_Overriding): Ditto. + +2008-05-27 Arnaud Charlet <charlet@adacore.com> + + * a-ststio.adb, s-direio.adb: + Further code clean up of previous change. + Update comments. + +2008-05-27 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb: Minor reformatting + +2008-05-27 Bob Duff <duff@adacore.com> + + * sem_ch3.adb (Build_Incomplete_Type_Declaration): In the case of an + untagged private type with a tagged full type, where the full type has + a self reference, create the corresponding class-wide type early, in + case the self reference is "access T'Class". + +2008-05-27 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Build_Array_Aggr_Code): If component type includes + tasks and context is an object declaration. create master entity before + expansion. + +2008-05-27 Robert Dewar <dewar@adacore.com> + + * mlib-prj.adb: Minor reformatting + + * prj-part.adb: Minor reformatting + + * prj.ads: Minor reformatting + + * exp_ch3.adb: Minor reformatting. + + * sem_ch3.ads: Minor reformatting + + * sem_eval.adb: Minor reformatting + +2008-05-27 Vincent Celier <celier@adacore.com> + + * gnatcmd.adb: + <prefix>-gnat stack spawns gnatstack, not <prefix>-gnatstack + +2008-05-27 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Expand_Array_Aggregate): If the aggregate contains + tasks, create an activation chain now, before the expansion into + assignments and build-in-place calls that require the presence of an + activation chain. + (Backend_Processing_Possible): If the component type is inherently + limited, the aggregate must be expanded into individual built-in-place + assignments. + + * sem_ch6.adb (Build_Extra_Formals): Use underlying type of result to + determine whether an allocation extra parameter must be built, to + handle case of a private type whose full type is a discriminated type + with defaults. + +2008-05-27 Bob Duff <duff@adacore.com> + + * gnat_rm.texi: + Document the new behavior regarding trampolines. + +2008-05-27 Arnaud Charlet <charlet@adacore.com> + + * a-direio.adb, a-sequio.adb: Replace address clause by + unrestricted_access, simpler and compatible with .NET. + +2008-05-27 Vincent Celier <celier@adacore.com> + + * prj-part.adb: + (Project_Path_Name_Of.Try_Path): Do not use Locate_Regular_File to find + a project file, so that symbolic links are not resolved. + +2008-05-27 Arnaud Charlet <charlet@adacore.com> + + * a-ztexio.adb, a-textio.adb, a-witeio.adb, s-direio.adb: + Replace heavy address clause by 'Unrestricted_Access, cleaner and more + portable across GNAT targets, since this kind of address clause is not + supported by VM back-ends (.NET/JGNAT). + +2008-05-27 Arnaud Charlet <charlet@adacore.com> + + * bindgen.adb: Update comments. + + * s-tasinf-mingw.adb: Add "with" of System.OS_Interface + +2008-05-27 Vincent Celier <celier@adacore.com> + + * gnatcmd.adb, prj-proc.adb, make.adb, mlib-prj.adb, prj.adb, + prj.ads, makegpr.adb, makeutl.adb, clean.adb, prj-nmsc.adb, + mlib-tgt.adb, prj-env.adb, prj-env.ads: + (Path_Information): New record type + Use component of type Path_Information when there are two paths, one in + canonical format and one in display format. + Update the project manager to these new components. + +2008-05-27 Robert Dewar <dewar@adacore.com> + + * makeutl.adb: Minor reformatting + * prj-nmsc.adb: Minor reformatting + * s-stausa.adb: Minor reformatting + * s-stausa.ads: Minor reformatting + * sem_ch6.adb: Minor reformatting + +2008-05-27 Thomas Quinot <quinot@adacore.com> + + * sem_res.adb: Minor comment fixes + +2008-05-27 Thomas Quinot <quinot@adacore.com> + + * makeutl.adb: Minor code reorganization + + * exp_aggr.adb: Add ??? comment + Fix typo + + * exp_ch6.adb: Minor reformatting + +2008-05-27 Quentin Ochem <ochem@adacore.com> + + * s-stausa.adb (Initialize): Updated result initialization, and + initialization of environment stack. + (Fill_Stack): Improved computation of the pattern zone, taking into + account already filled at the calling point. + (Get_Usage_Range): Now uses Min_Measure and Max_Measure instead of + Measure and Overflow_Guard. + (Report_Result): Fixed computation of the result using new fields of + Stack_Analyzer. + + * s-stausa.ads (Initialize_Analyzer): Replaced Size / Overflow_Guard + params by more explicit Stack_Size / Max_Pattern_Size params. + (Stack_Analyzer): Added distinct Stack_Size & Pattern_Size fields. + Added Stack_Used_When_Filling field. + (Task_Result): Replaced Measure / Overflow_Guard by more explicit + Min_Measure and Max_Measure fields. + + * s-tassta.adb (Task_Wrapper): Updated call to Initialize_Analyzer. + +2008-05-27 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb: + (Check_File): Make sure that a unit that replaces the same unit in a + project being extended is properly processed. + +2008-05-27 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb: + (Get_Discr_Value): Remove obsolete code that failed to find the value + of a discriminant for an inherited task component appearing in a type + extension. + +2008-05-27 Thomas Quinot <quinot@adacore.com> + + (System.File_IO.{Close, Delete, Reset}): + Change File parameter from "in out AFCB_Ptr" to "access AFCB_Ptr". + + (Ada.*_IO.{Close, Delete, Reset, Set_Mode}): + Pass File parameter by reference. + +2008-05-27 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb: + (Process_Sources_In_Multi_Language_Mode): Check that there are not two + sources of the same project that have the same object file name. + (Find_Explicit_Sources): Always remove a source exception that was not + found. + +2008-05-27 Thomas Quinot <quinot@adacore.com> + + * sem_ch3.adb: Minor reformatting + +2008-05-27 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb: + (Is_Interface_Conformant): Handle properly a primitive operation that + overrides an interface function with a controlling access result. + (Type_Conformance): If Skip_Controlling_Formals is true, when matching + inherited and overriding operations, omit as well the conformance check + on result types, to prevent spurious errors. + +2008-05-27 Vincent Celier <celier@adacore.com> + + * makeutl.ads, makeutl.adb: + (Set_Location): New procedure + (Get_Location): New function + (Update_Main): New procedure + +2008-05-27 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb: + (Check_Library): Allow standard project to be extended as a static + library project. + (Get_Mains): Do not inherit attribute Main in an extending library + project. + +2008-05-27 Eric Botcazou <ebotcazou@adacore.com> + + * system-darwin-ppc.ads (Always_Compatible_Rep): Set to False. + * system-darwin-x86.ads (Always_Compatible_Rep): Likewise. + * system-freebsd-x86.ads (Always_Compatible_Rep): Likewise. + * system-linux-ppc.ads (Always_Compatible_Rep): Likewise. + * system-linux-x86_64.ads (Always_Compatible_Rep): Likewise. + * system-linux-x86.ads (Always_Compatible_Rep): Likewise. + * system-mingw.ads (Always_Compatible_Rep): Likewise. + * system-solaris-sparc.ads (Always_Compatible_Rep): Likewise. + * system-solaris-sparcv9.ads (Always_Compatible_Rep): Likewise. + * system-solaris-x86.ads (Always_Compatible_Rep): Likewise. + +2008-05-27 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb: add guard to previous patch. + +2008-05-27 Ed Schonberg <schonberg@adacore.com> + + * exp_disp.adb (Build_Dispatch_Tables): For a private type completed by + a synchronized tagged type, do not attempt to build dispatch table for + full view. The table is built for the corresponding record type, which + has its own declaration. + +2008-05-27 Gary Dismukes <dismukes@adacore.com> + + * sem_ch3.adb (Fixup_Bad_Constraint): Set the Etype on the bad subtype + to the known type entity E, rather than setting it to Any_Type. Fixes + possible blowup in function Base_Init_Proc, as called from Freeze_Entity + for objects whose type had an illegal constraint. + +2008-05-27 Vincent Celier <celier@adacore.com> + + * gnat_ugn.texi: + Add succinct documentation for attribute Excluded_Source_List_File + +2008-05-27 Vincent Celier <celier@adacore.com> + + * prj-attr.adb: Add new project level attribute Map_File_Option + + * prj-nmsc.adb (Process_Linker): Process new attribute Map_File_Option + + * prj.ads: Minor reformatting and comment update + (Project_Configuration): New component Map_File_Option + + * snames.adb: New standard name Map_File_Option + + * snames.ads: New standard name Map_File_Option + +2008-05-27 Vincent Celier <celier@adacore.com> + + * xsnames.adb: Remove unused variable Oname + +2008-05-27 Doug Rupp <rupp@adacore.com> + + * exp_ch6.adb: + (Expand_N_Function_Call): Fix comments. Minor reformatting. + + * exp_vfpt.ads: + (Expand_Vax_Foreign_Return): Fix comments. + +2008-05-27 Thomas Quinot <quinot@adacore.com> + + * exp_dist.adb: Minor reformating + +2008-05-26 Gary Dismukes <dismukes@adacore.com> + + * exp_ch3.adb (Expand_N_Object_Declaration): Remove checks for + No_Default_Initialization, which is now delayed until the freeze point + of the object. Add a comment about deferral of the check. + + * freeze.adb (Freeze_Entity): The check for No_Default_Initialization + on objects is moved here. + +2008-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * s-casi16.adb (Uhalf): Rewrite it as integer with small alignment. + (Compare_Array_S16): Adjust for above change. + * s-casi32.adb (Uword): Likewise. + (Compare_Array_S32): Likewise. + * s-casi64.adb (Uword): Likewise. + (Compare_Array_S64): Likewise. + * s-caun16.adb (Uhalf): Likewise. + (Compare_Array_U16): Likewise. + * s-caun32.adb (Uword): Likewise. + (Compare_Array_U32): Likewise. + * s-caun64.adb (Uword): Likewise. + (Compare_Array_U64): Likewise. + +2008-05-26 Robert Dewar <dewar@adacore.com> + + * exp_ch6.adb: Add ??? comment for previous change + + * exp_vfpt.adb: Minor reformatting + + * exp_vfpt.ads: Add ??? comment for last change + + * sem_attr.adb: Add some ??? comments for previous change + + * s-vaflop.ads: Add comments for previous change + +2008-05-26 Doug Rupp <rupp@adacore.com> + + * s-vaflop-vms-alpha.adb: + Remove System.IO use clause, to prevent spurious ambiguities when + package is access through rtsfind. + +2008-05-26 Sergey Rybin <rybin@adacore.com> + + * tree_io.ads (ASIS_Version_Number): Update because of the changes + made in front-end + +2008-05-26 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb: + (Resolve_Attribute, case 'address): S (A .. B)' address can be safely + converted to S (A)'address only if A .. B is known to be a non-null + range. + +2008-05-26 Doug Rupp <rupp@adacore.com> + + * s-vaflop.adb: + (Return_D, Return_F, Return_G): New functions. + + * s-vaflop.ads: + (Return_D, Return_F, Return_G): New functions. + + * exp_vfpt.adb: + (Expand_Vax_Foreign_Return): New procedure + + * exp_vfpt.ads: + (Expand_Vax_Foreign_Return): New procedure + + * rtsfind.ads: + (RE_Return_D, RE_Return_F, RE_Return_G): New RE_Ids + (RE_Return_D, RE_Return_F, RE_Return_G): New RE_Unit_Table elements + + * exp_ch6.adb: + Import Exp_Vfpt + (Expand_N_Function_Call): Call Expand_Vax_Foreign_Return. + + * s-vaflop-vms-alpha.adb: + (Return_D, Return_F, Return_G): New functions. + +2008-05-26 Gary Dismukes <dismukes@adacore.com> + + * exp_ch3.adb (Build_Array_Init_Proc): Only set Init_Proc to a dummy + init proc entity when there is actual default initialization associated + with the component type, to avoid spurious errors on objects of scalar + array types that are marked Is_Public when No_Default_Initialization + applies. + +2008-05-26 Thomas Quinot <quinot@adacore.com> + + * rtsfind.ads, rtsfind.adb: + (RE_Get_RACW): New runtime library entity provided by PolyORB s-parint. + (Check_RPC): Support per-PCS-kind API versioning. + + exp_dist.ads, exp_dist.adb: + (Build_Stub_Tag, Get_Stub_Elements): New utility subprograms. + (PolyORB_Support.Add_RACW_From_Any): Offload common code to new runtime + library function Get_RACW. + (PolyORB_Support.Add_RACW_To_Any): Offload common code to new runtime + library function Get_Reference. + (PolyORB_Support.Add_RACW_Read_Attribute): Use Get_RACW instead of going + through an intermediate Any. + (PolyORB_Support.Add_RACW_Write_Attribute): Use Get_Reference instead of + going through an intermediate Any. + + * sem_dist.adb: Minor reformatting. + +2008-05-26 Javier Miranda <miranda@adacore.com> + + * einfo.ads (Abstract_Interface_Alias): Renamed as Interface_Alias. + (Set_Abstract_Interface_Alias): Renamed as Set_Interface_Alias. + (Is_Internal): Adding documentation on internal entities that have + attribute Interface_Alias (old attribute Abstract_Interface_Alias) + + * einfo.adb (Abstract_Interface_Alias): Renamed as Interface_Alias. + (Set_Abstract_Interface_Alias): Renamed as Set_Interface_Alias. + Added assertion to force entities with this attribute to have + attribute Is_Internal set to True. + (Next_Tag_Component): Simplify assertion using attribute Is_Tag. + + * sem_ch3.adb (Derive_Interface_Subprograms): This subprogram has been + renamed as Derive_Progenitor_Subprograms. In addition, its code is + a new implementation. + (Add_Interface_Tag_Components): Remove special management of + synchronized interfaces. + (Analyze_Interface_Declaration): Minor reformating + (Build_Derived_Record_Type): Minor reformating + (Check_Abstract_Overriding): Avoid reporting error in case of abstract + predefined primitive inherited from interface type because the body of + internally generated predefined primitives of tagged types are generated + later by Freeze_Type + (Derive_Subprogram): Avoid generating an internal name if the parent + subprogram overrides an interface primitive. + (Derive_Subprograms): New implementation that keeps separate the + management of tagged types not implementing interfaces, from tagged + types that implement interfaces. + (Is_Progenitor): New implementation. + (Process_Full_View): Add documentation + (Record_Type_Declaration): Replace call to Derive_Interface_Subprograms + by call to Derive_Progenitor_Subprograms. + + * sem_ch6.ads (Is_Interface_Conformant): New subprogram. + (Check_Subtype_Conformant, Subtype_Conformant): Adding new argument + Skip_Controlling_Formals. + + * sem_ch6.adb (Is_Interface_Conformant): New subprogram. + (Check_Conventions): New implementation. Remove local subprogram + Skip_Check. Remove formal Search_From of routine Check_Convention. + (Check_Subtype_Conformant, Subtype_Conformant): Adding new argument + Skip_Controlling_Formals. + (New_Overloaded_Entity): Enable addition of predefined dispatching + operations. + + * sem_disp.ads + (Find_Primitive_Covering_Interface): New subprogram. + + * sem_disp.adb (Check_Dispatching_Operation): Disable registering + the task body procedure as a primitive of the corresponding tagged + type. + (Check_Operation_From_Private_Type): Avoid adding twice an entity + to the list of primitives. + (Find_Primitive_Covering_Interface): New subprogram. + (Override_Dispatching_Operation): Add documentation. + + * sem_type.adb (Covers): Minor reformatings + + * sem_util.ads (Collect_Abstract_Interfaces): Renamed as + Collect_Interfaces. + Rename formal. + (Has_Abstract_Interfaces): Renamed as Has_Interfaces. + (Implements_Interface): New subprogram. + (Is_Parent): Removed. + (Primitive_Names_Match): New subprogram. + (Remove_Homonym): Moved here from Derive_Interface_Subprograms. + (Ultimate_Alias): New subprogram. + + * sem_util.adb (Collect_Abstract_Interfaces): Renamed as + Collect_Interfaces. + Remove special management for synchronized types. Rename formal. Remove + internal subprograms Interface_Present_In_Parent and Add_Interface. + (Has_Abstract_Interfaces): Renamed as Has_Interfaces. Replace assertion + on non-record types by code to return false in such case. + (Implements_Interface): New subprogram. + (Is_Parent): Removed. No special management is now required for + synchronized types covering interfaces. + (Primitive_Names_Match): New subprogram. + (Remove_Homonym): Moved here from Derive_Interface_Subprograms. + (Ultimate_Alias): New subprogram. + + * exp_ch3.adb (Add_Internal_Interface_Entities): New subprogram. + Add internal entities associated with secondary dispatch tables to + the list of tagged type primitives that are not interfaces. + (Freeze_Record_Type): Add new call to Add_Internal_Interface_Entities + (Make_Predefined_Primitive_Specs): Code reorganization to improve + the management of predefined equality operator. In addition, if + the type has an equality function corresponding with a primitive + defined in an interface type, the inherited equality is abstract + as well, and no body can be created for it. + + * exp_disp.ads (Is_Predefined_Dispatching_Operation): Moved from + exp_util to exp_disp. + (Is_Predefined_Interface_Primitive): New subprogram. Returns True if + an entity corresponds with one of the predefined primitives required + to implement interfaces. + Update copyright notice. + + * exp_disp.adb (Set_All_DT_Position): Add assertion. Exclude from the + final check on abstract subprograms all the primitives associated with + interface primitives because they must be visible in the public and + private part. + (Write_DT): Use Find_Dispatching_Type to locate the name of the + interface type. This allows the use of this routine, for debugging + purposes, when the tagged type is not fully decorated. + (Is_Predefined_Dispatching_Operation): Moved from exp_util to exp_disp. + Factorize code calling new subprogram Is_Predefined_Interface_Primitive. + (Is_Predefined_Interface_Primitive): New subprogram. Returns True if an + entity corresponds with one of the predefined primitives required to + implement interfaces. + + * exp_util.adb (Find_Interface_ADT): New implementation + (Find_Interface): Removed. + + * sprint.adb (Sprint_Node_Actual): Generate missing output for the + list of interfaces associated with nodes + N_Formal_Derived_Type_Definition and N_Private_Extension_Declaration. + +2008-05-26 Thomas Quinot <quinot@adacore.com> + + * exp_ch5.adb (Make_Tag_Ctrl_Assignment): Add missing guard on + condition for assignment to temporary. + +2008-05-26 Ed Schonberg <schonberg@adacore.com> + + * exp_ch4.adb (Expand_Concatenate_Other): Add explicit constraint + checks on the upper bound if the index type is a modular type, to + prevent wrap-around computations when size is close to upper bound of + type. + +2008-05-26 Robert Dewar <dewar@adacore.com> + + * sem_ch3.adb: Minor reformatting + +2008-05-26 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Remove_Parent): Use specification of instance + to retrieve generic parent, + to handle properly the case where the instance is a child unit. + Add guard to handle properly wrapper packages. + Minor reformatting + +2008-05-26 Thomas Quinot <quinot@adacore.com> + + * sinfo.ads: Minor reformatting + +2008-05-26 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch4.adb (Expand_N_Type_Conversion): Minor code reformatting. + Generate a tag check when the result subtype of a function, defined by + an access definition, designates a specific tagged type. + (Make_Tag_Check): New routine. + +2008-05-26 Arnaud Charlet <charlet@adacore.com> + + * ceinfo.adb, csinfo.adb: Remove warnings. Update headers. + +2008-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * gigi.h (gigi): Remove bogus ATTRIBUTE_UNUSED marker. + (builtin_decl_for): Likewise. + * trans.c (gigi): Likewise. + * utils.c (def_builtin_1): Fix formatting. + +2008-05-26 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch3.adb (Build_Init_Statements): Alphabetize local variables. + Create the statements which map a string name to protected or task + entry indix. + + * exp_ch9.adb: Add with and use clause for Stringt. + Minor code reformatting. + (Build_Entry_Names): New routine. + (Make_Initialize_Protection, Make_Task_Create_Call): Generate a value + for flag Build_Entry_Names which controls the allocation of the data + structure for the string names of entries. + + * exp_ch9.ads (Build_Entry_Names): New subprogram. + + * exp_util.adb (Entry_Names_OK): New function. + + * exp_util.ads (Entry_Names_OK): New function. + + * rtsfind.ads: Add RO_PE_Set_Entry_Name and RO_TS_Set_Entry_Name to + enumerations RE_Id and RE_Unit_Table. + + * s-taskin.adb Add with and use clause for Ada.Unchecked_Deallocation. + (Free_Entry_Names_Array): New routine. + + * s-taskin.ads: Comment reformatting. + Add types String_Access, Entry_Names_Array, Entry_Names_Array_Access. + Add component Entry_Names to record Ada_Task_Control_Block. + (Free_Entry_Names_Array): New routine. + + * s-tassta.adb (Create_Task): If flag Build_Entry_Names is set, + dynamically allocate an array + of string pointers. This structure holds string entry names. + (Free_Entry_Names): New routine. + (Free_Task, Vulnerable_Free_Task): Deallocate the entry names array. + (Set_Entry_Names): New routine. + + * s-tassta.ads: + (Create_Task): Add formal Build_Entry_Names. The flag is used to + control the allocation of the data structure which stores entry names. + (Set_Entry_Name): New routine. + + * s-tpoben.adb: + Add with and use clause for Ada.Unchecked_Conversion. + (Finalize): Deallocate the entry names array. + (Free_Entry_Names): New routine. + (Initialize_Protection_Entries): When flag Build_Entry_Names is set, + create an array of string pointers to hold the entry names. + (Set_Entry_Name): New routine. + + * s-tpoben.ads: + Add field Entry_Names to record Protection_Entries. + (Initialize_Protection_Entries): Add formal Build_Entry_Names. + (Set_Entry_Name): New routine. + +2008-05-26 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb: + (Process_Project_Level_Simple_Attributes): process attribute Library_GCC + + * prj.ads: + (Project_Configuration): New component Shared_Lib_Driver + +2008-05-26 Ed Schonberg <schonberg@adacore.com> + + * inline.adb: + (Cleanup_Scopes): For a protected operation, transfer finalization list + to protected body subprogram, to force cleanup actions when needed. + +2008-05-26 Robert Dewar <dewar@adacore.com> + + * sem_cat.adb: Minor reformatting + + * gnatname.adb: Minor reformatting + + * osint.ads: Minor reformatting + + * s-carun8.ads: Minor reformatting + + * g-heasor.ads: Minor comment fix (unit is now pure) + +2008-05-26 Robert Dewar <dewar@adacore.com> + + * exp_ch2.adb: + (Expand_Current_Value): Properly type generated integer literal + +2008-05-26 Sergey Rybin <rybin@adacore.com> + + * gnat_ugn.texi: Add description for the new gnatcheck rule - + Separate_Numeric_Error_Handlers. + +2008-05-26 Pascal Obry <obry@adacore.com> + + * sem_aggr.adb: Minor reformatting. + +2008-05-26 Jose Ruiz <ruiz@adacore.com> + + * s-osinte-aix.adb: + (To_Target_Priority): Setting the time slice value to 0 or greater sets + the scheduling policy to FIFO within priorities or round-robin + respectively. + Hence, the priority must be set in this case to the one selected by the + user. + +2008-05-26 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb: + (Remove_Parent): If the enclosing scope is an instance whose generic + parent is declared within some parent scope of the just completed + instance, make full views of the entities in that parent visible, when + applicable. + +2008-05-26 Kai Tietz <kai.tietz@onevision.com> + + * mingw32.h (STD_MINGW): Set to true for target w64. + +2008-05-25 Eric Botcazou <ebotcazou@adacore.com> + + * trans.c (Attribute_to_gnu) <Code_Address>: Set TREE_NO_TRAMPOLINE + instead of TREE_STATIC on the ADDR_EXPR. + 2008-05-24 Eric Botcazou <ebotcazou@adacore.com> * trans.c (gnat_to_gnu): Do not set source location info on NOP_EXPRs. diff --git a/gcc/ada/Make-lang.in b/gcc/ada/Make-lang.in index df7682c20b2..a7617ae3968 100644 --- a/gcc/ada/Make-lang.in +++ b/gcc/ada/Make-lang.in @@ -378,10 +378,6 @@ ada.all.cross: then \ $(MV) gnatsym$(exeext) gnatsym-cross$(exeext); \ fi - -if [ -f gprmake$(exeext) ] ; \ - then \ - $(MV) gprmake$(exeext) gprmake-cross$(exeext); \ - fi ada.start.encap: ada.rest.encap: @@ -497,7 +493,7 @@ doc/gnat-style.pdf: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi # and also as either gnatbind (if native) or $(tooldir)/bin/gnatbind # likewise for gnatf, gnatchop, and gnatlink, gnatkr, gnatmake, gnat, # gnatprep, gnatls, gnatxref, gnatfind, gnatname, gnatclean, -# gnatsym, gprmake +# gnatsym ada.install-common: $(MKDIR) $(DESTDIR)$(bindir) -if [ -f gnat1$(exeext) ] ; \ @@ -664,17 +660,6 @@ ada.install-common: $(INSTALL_PROGRAM) gnatclean$(exeext) $(DESTDIR)$(bindir)/gnatclean$(exeext); \ fi ; \ fi - -if [ -f gnat1$(exeext) ] ; \ - then \ - if [ -f gprmake-cross$(exeext) ] ; \ - then \ - $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gprmake$(exeext); \ - $(INSTALL_PROGRAM) gprmake-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gprmake$(exeext); \ - else \ - $(RM) $(bindir)/gprmake$(exeext); \ - $(INSTALL_PROGRAM) gprmake$(exeext) $(DESTDIR)$(bindir)/gprmake$(exeext); \ - fi ; \ - fi # # Gnatsym is only built on some platforms, including VMS # @@ -808,7 +793,6 @@ ada.distclean: -$(RM) gnatxref$(exeext) -$(RM) gnatclean$(exeext) -$(RM) gnatsym$(exeext) - -$(RM) gprmake$(exeext) # Gnatlbr is only used on VMS -$(RM) gnatlbr$(exeext) -$(RM) ada/rts/* diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 4d486f2e637..4fc101a6ffb 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -62,7 +62,7 @@ # Variables that exist for you to override. # See below for how to change them for certain systems. -# Various ways of specifying flags for compilations: +# Various ways of specifying flags for compilations: # CFLAGS is for the user to override to, e.g., do a bootstrap with -O2. # BOOT_CFLAGS is the value of CFLAGS to pass # to the stage2 and stage3 compilations @@ -139,7 +139,7 @@ shext = hyphen = - # Define this as & to perform parallel make on a Sequent. -# Note that this has some bugs, and it seems currently necessary +# Note that this has some bugs, and it seems currently necessary # to compile all the gen* files first by hand to avoid erroneous results. P = @@ -424,7 +424,7 @@ ifeq ($(strip $(filter-out m68k% wrs vx%,$(targ))),) s-tratas.adb<s-tratas-default.adb \ s-trafor.adb<s-trafor-default.adb \ s-trafor.ads<s-trafor-default.ads \ - s-tfsetr.adb<s-tfsetr-vxworks.adb + s-tfsetr.adb<s-tfsetr-vxworks.adb endif endif @@ -458,7 +458,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),) s-trafor.adb<s-trafor-default.adb \ s-trafor.ads<s-trafor-default.ads \ s-tratas.adb<s-tratas-default.adb \ - s-tfsetr.adb<s-tfsetr-vxworks.adb + s-tfsetr.adb<s-tfsetr-vxworks.adb endif ifeq ($(strip $(filter-out rtp,$(THREAD_KIND))),) @@ -761,7 +761,7 @@ ifeq ($(strip $(filter-out sparc% sun solaris%,$(targ))),) else LIBGNAT_TARGET_PAIRS = $(LIBGNAT_TARGET_PAIRS_64) endif - + TOOLS_TARGET_PAIRS=mlib-tgt-specific.adb<mlib-tgt-specific-solaris.adb EH_MECHANISM=-gcc @@ -1197,7 +1197,7 @@ LN_S = cp -p .SUFFIXES: .sym -.o.sym: +.o.sym: @ gnu:[bin]vmssymvec $< endif @@ -1752,9 +1752,9 @@ ADA_INCLUDE_SRCS =\ machcode.ads text_io.ads unchconv.ads unchdeal.ads \ sequenio.ads system.ads memtrack.adb \ a-[a-o]*.adb a-[p-z]*.adb a-[a-o]*.ads a-[p-z]*.ads g-*.ad? i-*.ad? \ - s-[a-o]*.adb s-[p-z]*.adb s-[a-o]*.ads s-[p-z]*.ads + s-[a-o]*.adb s-[p-z]*.adb s-[a-o]*.ads s-[p-z]*.ads -LIBGNAT=../rts/libgnat.a +LIBGNAT=../rts/libgnat.a GCC_LINK=$(CC) -static-libgcc $(ADA_INCLUDES) @@ -1767,7 +1767,7 @@ ifeq ($(TOOLSCASE),native) vpath %.h ../rts ../ endif -# in the cross tools case, everything is compiled with the native +# in the cross tools case, everything is compiled with the native # gnatmake/link. Therefore only -I needs to be modified in ADA_INCLUDES ifeq ($(TOOLSCASE),cross) vpath %.ads ../ @@ -1812,13 +1812,13 @@ common-tools: ../../vxaddr2line$(exeext): targext.o $(GNATMAKE) -c $(ADA_INCLUDES) vxaddr2line --GCC="$(CC) $(ALL_ADAFLAGS)" - $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) vxaddr2line + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) vxaddr2line $(GNATLINK) -v vxaddr2line -o $@ --GCC="$(GCC_LINK)" targext.o $(CLIB) gnatmake-re: link.o targext.o $(GNATMAKE) $(ADA_INCLUDES) -u sdefault --GCC="$(CC) $(MOST_ADA_FLAGS)" $(GNATMAKE) -c $(ADA_INCLUDES) gnatmake --GCC="$(CC) $(ALL_ADAFLAGS)" - $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatmake + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatmake $(GNATLINK) -v gnatmake -o ../../gnatmake$(exeext) \ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) @@ -1826,11 +1826,11 @@ gnatmake-re: link.o targext.o # with the former version of gnatlink itself which cannot override itself. gnatlink-re: link.o targext.o $(GNATMAKE) -c $(ADA_INCLUDES) gnatlink --GCC="$(CC) $(ALL_ADAFLAGS)" - $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatlink + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatlink $(GNATLINK) -v gnatlink -o ../../gnatlinknew$(exeext) \ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) $(MV) ../../gnatlinknew$(exeext) ../../gnatlink$(exeext) - + # Needs to be built with CC=gcc # Since the RTL should be built with the latest compiler, remove the # stamp target in the parent directory whenever gnat1 is rebuilt diff --git a/gcc/ada/a-direio.adb b/gcc/ada/a-direio.adb index 44479efedfd..9d315c88c5b 100644 --- a/gcc/ada/a-direio.adb +++ b/gcc/ada/a-direio.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- -- @@ -74,7 +74,7 @@ package body Ada.Direct_IO is procedure Close (File : in out File_Type) is begin - FIO.Close (AP (File)); + FIO.Close (AP (File)'Unrestricted_Access); end Close; ------------ @@ -98,7 +98,7 @@ package body Ada.Direct_IO is procedure Delete (File : in out File_Type) is begin - FIO.Delete (AP (File)); + FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- diff --git a/gcc/ada/a-direio.ads b/gcc/ada/a-direio.ads index 6ac1a8a95b6..70ff5ed3ca9 100644 --- a/gcc/ada/a-direio.ads +++ b/gcc/ada/a-direio.ads @@ -138,6 +138,32 @@ package Ada.Direct_IO is Data_Error : exception renames IO_Exceptions.Data_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + type File_Type is new System.Direct_IO.File_Type; Bytes : constant Interfaces.C_Streams.size_t := diff --git a/gcc/ada/a-sequio.adb b/gcc/ada/a-sequio.adb index eb9e989c65b..0c80b4062a7 100644 --- a/gcc/ada/a-sequio.adb +++ b/gcc/ada/a-sequio.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- -- @@ -67,7 +67,7 @@ package body Ada.Sequential_IO is procedure Close (File : in out File_Type) is begin - FIO.Close (AP (File)); + FIO.Close (AP (File)'Unrestricted_Access); end Close; ------------ @@ -90,7 +90,7 @@ package body Ada.Sequential_IO is procedure Delete (File : in out File_Type) is begin - FIO.Delete (AP (File)); + FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- @@ -240,12 +240,12 @@ package body Ada.Sequential_IO is procedure Reset (File : in out File_Type; Mode : File_Mode) is begin - FIO.Reset (AP (File), To_FCB (Mode)); + FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); end Reset; procedure Reset (File : in out File_Type) is begin - FIO.Reset (AP (File)); + FIO.Reset (AP (File)'Unrestricted_Access); end Reset; ----------- diff --git a/gcc/ada/a-sequio.ads b/gcc/ada/a-sequio.ads index ece3ee13ea6..bd685c22e48 100644 --- a/gcc/ada/a-sequio.ads +++ b/gcc/ada/a-sequio.ads @@ -114,6 +114,32 @@ package Ada.Sequential_IO is Data_Error : exception renames IO_Exceptions.Data_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + type File_Type is new System.Sequential_IO.File_Type; -- All subprograms are inlined diff --git a/gcc/ada/a-ststio.adb b/gcc/ada/a-ststio.adb index 6b8376489ad..9c3bd31af58 100644 --- a/gcc/ada/a-ststio.adb +++ b/gcc/ada/a-ststio.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- -- @@ -102,7 +102,7 @@ package body Ada.Streams.Stream_IO is procedure Close (File : in out File_Type) is begin - FIO.Close (AP (File)); + FIO.Close (AP (File)'Unrestricted_Access); end Close; ------------ @@ -138,7 +138,7 @@ package body Ada.Streams.Stream_IO is procedure Delete (File : in out File_Type) is begin - FIO.Delete (AP (File)); + FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- @@ -362,7 +362,7 @@ package body Ada.Streams.Stream_IO is if ((File.Mode = FCB.In_File) /= (Mode = In_File)) and then not File.Update_Mode then - FIO.Reset (AP (File), FCB.Inout_File); + FIO.Reset (AP (File)'Unrestricted_Access, FCB.Inout_File); File.Update_Mode := True; end if; diff --git a/gcc/ada/a-ststio.ads b/gcc/ada/a-ststio.ads index edcec9a139a..cc2a6d4e24a 100644 --- a/gcc/ada/a-ststio.ads +++ b/gcc/ada/a-ststio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, 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 -- @@ -144,6 +144,36 @@ package Ada.Streams.Stream_IO is Data_Error : exception renames IO_Exceptions.Data_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + pragma Export_Procedure + (Internal => Set_Mode, + External => "", + Mechanism => (File => Reference)); + package FCB renames System.File_Control_Block; ----------------------------- diff --git a/gcc/ada/a-textio.adb b/gcc/ada/a-textio.adb index 9247ba7f7aa..cc5a93bb076 100644 --- a/gcc/ada/a-textio.adb +++ b/gcc/ada/a-textio.adb @@ -148,7 +148,7 @@ package body Ada.Text_IO is procedure Close (File : in out File_Type) is begin - FIO.Close (AP (File)); + FIO.Close (AP (File)'Unrestricted_Access); end Close; --------- @@ -247,7 +247,7 @@ package body Ada.Text_IO is procedure Delete (File : in out File_Type) is begin - FIO.Delete (AP (File)); + FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- @@ -1585,7 +1585,7 @@ package body Ada.Text_IO is end if; Terminate_Line (File); - FIO.Reset (AP (File), To_FCB (Mode)); + FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); File.Page := 1; File.Line := 1; File.Col := 1; @@ -1598,7 +1598,7 @@ package body Ada.Text_IO is procedure Reset (File : in out File_Type) is begin Terminate_Line (File); - FIO.Reset (AP (File)); + FIO.Reset (AP (File)'Unrestricted_Access); File.Page := 1; File.Line := 1; File.Col := 1; diff --git a/gcc/ada/a-textio.ads b/gcc/ada/a-textio.ads index 45f422f7bf1..35cb5162f71 100644 --- a/gcc/ada/a-textio.ads +++ b/gcc/ada/a-textio.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. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -301,6 +301,32 @@ package Ada.Text_IO is Layout_Error : exception renames IO_Exceptions.Layout_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + ----------------------------------- -- Handling of Format Characters -- ----------------------------------- diff --git a/gcc/ada/a-witeio.adb b/gcc/ada/a-witeio.adb index 25d265c218e..1a4b0f5e0e7 100644 --- a/gcc/ada/a-witeio.adb +++ b/gcc/ada/a-witeio.adb @@ -134,7 +134,7 @@ package body Ada.Wide_Text_IO is procedure Close (File : in out File_Type) is begin - FIO.Close (AP (File)); + FIO.Close (AP (File)'Unrestricted_Access); end Close; --------- @@ -233,7 +233,7 @@ package body Ada.Wide_Text_IO is procedure Delete (File : in out File_Type) is begin - FIO.Delete (AP (File)); + FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- @@ -1320,7 +1320,7 @@ package body Ada.Wide_Text_IO is end if; Terminate_Line (File); - FIO.Reset (AP (File), To_FCB (Mode)); + FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); File.Page := 1; File.Line := 1; File.Col := 1; @@ -1333,7 +1333,7 @@ package body Ada.Wide_Text_IO is procedure Reset (File : in out File_Type) is begin Terminate_Line (File); - FIO.Reset (AP (File)); + FIO.Reset (AP (File)'Unrestricted_Access); File.Page := 1; File.Line := 1; File.Col := 1; diff --git a/gcc/ada/a-witeio.ads b/gcc/ada/a-witeio.ads index 0ea32ce2b0c..d35de1327d2 100644 --- a/gcc/ada/a-witeio.ads +++ b/gcc/ada/a-witeio.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. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -301,6 +301,32 @@ package Ada.Wide_Text_IO is Layout_Error : exception renames IO_Exceptions.Layout_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + package WCh_Con renames System.WCh_Con; ----------------------------------- diff --git a/gcc/ada/a-ztexio.adb b/gcc/ada/a-ztexio.adb index a85cdb30998..4bf70405c67 100644 --- a/gcc/ada/a-ztexio.adb +++ b/gcc/ada/a-ztexio.adb @@ -134,7 +134,7 @@ package body Ada.Wide_Wide_Text_IO is procedure Close (File : in out File_Type) is begin - FIO.Close (AP (File)); + FIO.Close (AP (File)'Unrestricted_Access); end Close; --------- @@ -233,7 +233,7 @@ package body Ada.Wide_Wide_Text_IO is procedure Delete (File : in out File_Type) is begin - FIO.Delete (AP (File)); + FIO.Delete (AP (File)'Unrestricted_Access); end Delete; ----------------- @@ -1320,7 +1320,7 @@ package body Ada.Wide_Wide_Text_IO is end if; Terminate_Line (File); - FIO.Reset (AP (File), To_FCB (Mode)); + FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); File.Page := 1; File.Line := 1; File.Col := 1; @@ -1333,7 +1333,7 @@ package body Ada.Wide_Wide_Text_IO is procedure Reset (File : in out File_Type) is begin Terminate_Line (File); - FIO.Reset (AP (File)); + FIO.Reset (AP (File)'Unrestricted_Access); File.Page := 1; File.Line := 1; File.Col := 1; diff --git a/gcc/ada/a-ztexio.ads b/gcc/ada/a-ztexio.ads index f91599295a4..b1b50fc59a7 100644 --- a/gcc/ada/a-ztexio.ads +++ b/gcc/ada/a-ztexio.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. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -301,6 +301,32 @@ package Ada.Wide_Wide_Text_IO is Layout_Error : exception renames IO_Exceptions.Layout_Error; private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + package WCh_Con renames System.WCh_Con; ----------------------------------- diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 475edd513f5..d29857fb5fc 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -3260,14 +3260,17 @@ package body Bindgen is for E in Elab_Order.First .. Elab_Order.Last loop Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); - -- The procedure of looking for specific packages and setting - -- flags is somewhat dubious, but there isn't a good alternative - -- at the current time ??? + -- This is not a perfect approach, but is the current protocol + -- between the run-time and the binder to indicate that tasking + -- is used: system.os_interface should always be used by any + -- tasking application. if Name_Buffer (1 .. 19) = "system.os_interface" then With_GNARL := True; end if; + -- Ditto for declib and the "dec" package + if OpenVMS_On_Target and then Name_Buffer (1 .. 5) = "dec%s" then With_DECGNAT := True; end if; diff --git a/gcc/ada/ceinfo.adb b/gcc/ada/ceinfo.adb index 494b9077c47..c88b642e444 100644 --- a/gcc/ada/ceinfo.adb +++ b/gcc/ada/ceinfo.adb @@ -6,18 +6,17 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -43,9 +42,6 @@ procedure CEinfo is Infil : File_Type; Lineno : Natural := 0; - Err : exception; - -- Raised on fatal error - Fieldnm : VString; Accessfunc : VString; Line : VString; @@ -53,25 +49,27 @@ procedure CEinfo is Fields : GNAT.Spitbol.Table_VString.Table (500); -- Maps field names to underlying field access name - UC : Pattern := Any ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); + UC : constant Pattern := Any ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); - Fnam : Pattern := (UC & Break (' ')) * Fieldnm; + Fnam : constant Pattern := (UC & Break (' ')) * Fieldnm; - Field_Def : Pattern := "-- " & Fnam & " (" & Break (')') * Accessfunc; + Field_Def : constant Pattern := + "-- " & Fnam & " (" & Break (')') * Accessfunc; - Field_Ref : Pattern := " -- " & Fnam & Break ('(') & Len (1) & - Break (')') * Accessfunc; + Field_Ref : constant Pattern := + " -- " & Fnam & Break ('(') & Len (1) & + Break (')') * Accessfunc; - Field_Com : Pattern := " -- " & Fnam & Span (' ') & - (Break (' ') or Rest) * Accessfunc; + Field_Com : constant Pattern := " -- " & Fnam & Span (' ') & + (Break (' ') or Rest) * Accessfunc; - Func_Hedr : Pattern := " function " & Fnam; + Func_Hedr : constant Pattern := " function " & Fnam; - Func_Retn : Pattern := " return " & Break (' ') * Accessfunc; + Func_Retn : constant Pattern := " return " & Break (' ') * Accessfunc; - Proc_Hedr : Pattern := " procedure " & Fnam; + Proc_Hedr : constant Pattern := " procedure " & Fnam; - Proc_Setf : Pattern := " Set_" & Break (' ') * Accessfunc; + Proc_Setf : constant Pattern := " Set_" & Break (' ') * Accessfunc; procedure Next_Line; -- Read next line trimmed from Infil into Line and bump Lineno diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 876ec5a19a3..5db4c4efc67 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -346,7 +346,7 @@ package body Clean is -- The name of the archive dependency file for this project Obj_Dir : constant String := - Get_Name_String (Data.Display_Object_Dir); + Get_Name_String (Data.Object_Directory.Display_Name); begin Change_Dir (Obj_Dir); @@ -551,10 +551,10 @@ package body Clean is Unit : Unit_Data; begin - if Data.Library and then Data.Library_Src_Dir /= No_Path then + if Data.Library and then Data.Library_Src_Dir /= No_Path_Information then declare Directory : constant String := - Get_Name_String (Data.Display_Library_Src_Dir); + Get_Name_String (Data.Library_Src_Dir.Display_Name); begin Change_Dir (Directory); @@ -663,10 +663,11 @@ package body Clean is declare Lib_Directory : constant String := - Get_Name_String (Data.Display_Library_Dir); + Get_Name_String + (Data.Library_Dir.Display_Name); Lib_ALI_Directory : constant String := Get_Name_String - (Data.Display_Library_ALI_Dir); + (Data.Library_ALI_Dir.Display_Name); begin Canonical_Case_File_Name (Archive_Name); @@ -863,10 +864,11 @@ package body Clean is Processed_Projects.Increment_Last; Processed_Projects.Table (Processed_Projects.Last) := Project; - if Data.Object_Directory /= No_Path then + if Data.Object_Directory /= No_Path_Information then declare Obj_Dir : constant String := - Get_Name_String (Data.Display_Object_Dir); + Get_Name_String + (Data.Object_Directory.Display_Name); begin Change_Dir (Obj_Dir); @@ -1089,16 +1091,16 @@ package body Clean is if not Compile_Only then Clean_Library_Directory (Project); - if Data.Library_Src_Dir /= No_Path then + if Data.Library_Src_Dir /= No_Path_Information then Clean_Interface_Copy_Directory (Project); end if; end if; if Data.Standalone_Library and then - Data.Object_Directory /= No_Path + Data.Object_Directory /= No_Path_Information then Delete_Binder_Generated_Files - (Get_Name_String (Data.Display_Object_Dir), + (Get_Name_String (Data.Object_Directory.Display_Name), File_Name_Type (Data.Library_Name)); end if; end if; @@ -1156,10 +1158,12 @@ package body Clean is -- The executables are deleted only if switch -c is not specified - if Project = Main_Project and then Data.Exec_Directory /= No_Path then + if Project = Main_Project + and then Data.Exec_Directory /= No_Path_Information + then declare Exec_Dir : constant String := - Get_Name_String (Data.Display_Exec_Dir); + Get_Name_String (Data.Exec_Directory.Display_Name); begin Change_Dir (Exec_Dir); @@ -1193,9 +1197,9 @@ package body Clean is end; end if; - if Data.Object_Directory /= No_Path then + if Data.Object_Directory /= No_Path_Information then Delete_Binder_Generated_Files - (Get_Name_String (Data.Display_Object_Dir), + (Get_Name_String (Data.Object_Directory.Display_Name), Strip_Suffix (Main_Source_File)); end if; end loop; diff --git a/gcc/ada/csinfo.adb b/gcc/ada/csinfo.adb index 47953e89ce2..9d8b16b572c 100644 --- a/gcc/ada/csinfo.adb +++ b/gcc/ada/csinfo.adb @@ -6,18 +6,17 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 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- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -55,7 +54,7 @@ procedure CSinfo is Done : exception; -- Raised after error is found to terminate run - WSP : Pattern := Span (' ' & ASCII.HT); + WSP : constant Pattern := Span (' ' & ASCII.HT); Fields : TV.Table (300); Fields1 : TV.Table (300); @@ -87,50 +86,56 @@ procedure CSinfo is Flags : TV.Table (20); -- Maps flag numbers to letters - N_Fields : Pattern := BreakX ("JL"); - E_Fields : Pattern := BreakX ("5EFGHIJLOP"); - U_Fields : Pattern := BreakX ("1345EFGHIJKLOPQ"); - B_Fields : Pattern := BreakX ("12345EFGHIJKLOPQ"); + N_Fields : constant Pattern := BreakX ("JL"); + E_Fields : constant Pattern := BreakX ("5EFGHIJLOP"); + U_Fields : constant Pattern := BreakX ("1345EFGHIJKLOPQ"); + B_Fields : constant Pattern := BreakX ("12345EFGHIJKLOPQ"); Line : VString; Bad : Boolean; - Field : VString := Nul; + Field : constant VString := Nul; Fields_Used : VString := Nul; - Name : VString := Nul; - Next : VString := Nul; + Name : constant VString := Nul; + Next : constant VString := Nul; Node : VString := Nul; Ref : VString := Nul; - Synonym : VString := Nul; - Nxtref : VString := Nul; + Synonym : constant VString := Nul; + Nxtref : constant VString := Nul; Which_Field : aliased VString := Nul; - Node_Search : Pattern := WSP & "-- N_" & Rest * Node; - Break_Punc : Pattern := Break (" .,"); - Plus_Binary : Pattern := WSP & "-- plus fields for binary operator"; - Plus_Unary : Pattern := WSP & "-- plus fields for unary operator"; - Plus_Expr : Pattern := WSP & "-- plus fields for expression"; - Break_Syn : Pattern := WSP & "-- " & Break (' ') * Synonym & - " (" & Break (')') * Field; - Break_Field : Pattern := BreakX ('-') * Field; - Get_Field : Pattern := BreakX (Decimal_Digit_Set) & - Span (Decimal_Digit_Set) * Which_Field; - Break_WFld : Pattern := Break (Which_Field'Access); - Get_Funcsyn : Pattern := WSP & "function " & Rest * Synonym; - Extr_Field : Pattern := BreakX ('-') & "-- " & Rest * Field; - Get_Procsyn : Pattern := WSP & "procedure Set_" & Rest * Synonym; - Get_Inline : Pattern := WSP & "pragma Inline (" & Break (')') * Name; - Set_Name : Pattern := "Set_" & Rest * Name; - Func_Rest : Pattern := " function " & Rest * Synonym; - Get_Nxtref : Pattern := Break (',') * Nxtref & ','; - Test_Syn : Pattern := Break ('=') & "= N_" & - (Break (" ,)") or Rest) * Next; - Chop_Comma : Pattern := BreakX (',') * Next; - Return_Fld : Pattern := WSP & "return " & Break (' ') * Field; - Set_Syn : Pattern := " procedure Set_" & Rest * Synonym; - Set_Fld : Pattern := WSP & "Set_" & Break (' ') * Field & " (N, Val)"; - Break_With : Pattern := Break ('_') ** Field & "_With_Parent"; + Node_Search : constant Pattern := WSP & "-- N_" & Rest * Node; + Break_Punc : constant Pattern := Break (" .,"); + Plus_Binary : constant Pattern := WSP + & "-- plus fields for binary operator"; + Plus_Unary : constant Pattern := WSP + & "-- plus fields for unary operator"; + Plus_Expr : constant Pattern := WSP + & "-- plus fields for expression"; + Break_Syn : constant Pattern := WSP & "-- " + & Break (' ') * Synonym + & " (" & Break (')') * Field; + Break_Field : constant Pattern := BreakX ('-') * Field; + Get_Field : constant Pattern := BreakX (Decimal_Digit_Set) + & Span (Decimal_Digit_Set) * Which_Field; + Break_WFld : constant Pattern := Break (Which_Field'Access); + Get_Funcsyn : constant Pattern := WSP & "function " & Rest * Synonym; + Extr_Field : constant Pattern := BreakX ('-') & "-- " & Rest * Field; + Get_Procsyn : constant Pattern := WSP & "procedure Set_" & Rest * Synonym; + Get_Inline : constant Pattern := WSP & "pragma Inline (" + & Break (')') * Name; + Set_Name : constant Pattern := "Set_" & Rest * Name; + Func_Rest : constant Pattern := " function " & Rest * Synonym; + Get_Nxtref : constant Pattern := Break (',') * Nxtref & ','; + Test_Syn : constant Pattern := Break ('=') & "= N_" + & (Break (" ,)") or Rest) * Next; + Chop_Comma : constant Pattern := BreakX (',') * Next; + Return_Fld : constant Pattern := WSP & "return " & Break (' ') * Field; + Set_Syn : constant Pattern := " procedure Set_" & Rest * Synonym; + Set_Fld : constant Pattern := WSP & "Set_" & Break (' ') * Field + & " (N, Val)"; + Break_With : constant Pattern := Break ('_') ** Field & "_With_Parent"; type VStringA is array (Natural range <>) of VString; @@ -187,9 +192,9 @@ begin Set (Flags, "17", V ("Q")); Set (Flags, "18", V ("R")); - -- Special fields table. The following fields are not recorded or checked - -- by Csinfo, since they are specially handled. This means that both the - -- field definitions, and the corresponding subprograms are ignored. + -- Special fields table. The following names are not recorded or checked + -- by Csinfo, since they are specially handled. This means that any field + -- definition or subprogram with a matching name is ignored. Set (Special, "Analyzed", True); Set (Special, "Assignment_OK", True); @@ -214,7 +219,9 @@ begin Set (Special, "Is_Static_Expression", True); Set (Special, "Left_Opnd", True); Set (Special, "Must_Not_Freeze", True); + Set (Special, "Nkind_In", True); Set (Special, "Parens", True); + Set (Special, "Pragma_Name", True); Set (Special, "Raises_Constraint_Error", True); Set (Special, "Right_Opnd", True); @@ -334,7 +341,7 @@ begin Put_Line ("Check for missing functions"); declare - List : TV.Table_Array := Convert_To_Array (Fields1); + List : constant TV.Table_Array := Convert_To_Array (Fields1); begin if List'Length > 0 then @@ -385,7 +392,7 @@ begin Put_Line ("Check for missing set procedures"); declare - List : TV.Table_Array := Convert_To_Array (Fields1); + List : constant TV.Table_Array := Convert_To_Array (Fields1); begin if List'Length > 0 then @@ -424,7 +431,7 @@ begin Put_Line ("Check no pragma Inlines were omitted"); declare - List : TV.Table_Array := Convert_To_Array (Fields); + List : constant TV.Table_Array := Convert_To_Array (Fields); Nxt : VString := Nul; begin @@ -523,7 +530,7 @@ begin Put_Line ("Check for missing functions in body"); declare - List : TV.Table_Array := Convert_To_Array (Refs); + List : constant TV.Table_Array := Convert_To_Array (Refs); begin if List'Length /= 0 then @@ -613,7 +620,7 @@ begin Put_Line ("Check for missing set procedures in body"); declare - List : TV.Table_Array := Convert_To_Array (Fields1); + List : constant TV.Table_Array := Convert_To_Array (Fields1); begin if List'Length /= 0 then diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 7d3fbdf57d7..fa212a76bed 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -208,8 +208,8 @@ package body Einfo is -- Spec_PPC_List Node24 - -- Abstract_Interface_Alias Node25 - -- Abstract_Interfaces Elist25 + -- Interface_Alias Node25 + -- Interfaces Elist25 -- Debug_Renaming_Link Node25 -- DT_Offset_To_Top_Func Node25 -- Task_Body_Procedure Node25 @@ -544,18 +544,6 @@ package body Einfo is -- Attribute Access Functions -- -------------------------------- - function Abstract_Interfaces (Id : E) return L is - begin - pragma Assert (Is_Record_Type (Id)); - return Elist25 (Id); - end Abstract_Interfaces; - - function Abstract_Interface_Alias (Id : E) return E is - begin - pragma Assert (Is_Subprogram (Id)); - return Node25 (Id); - end Abstract_Interface_Alias; - function Accept_Address (Id : E) return L is begin return Elist21 (Id); @@ -1538,6 +1526,18 @@ package body Einfo is return Flag232 (Id); end Implemented_By_Entry; + function Interfaces (Id : E) return L is + begin + pragma Assert (Is_Record_Type (Id)); + return Elist25 (Id); + end Interfaces; + + function Interface_Alias (Id : E) return E is + begin + pragma Assert (Is_Subprogram (Id)); + return Node25 (Id); + end Interface_Alias; + function In_Package_Body (Id : E) return B is begin return Flag48 (Id); @@ -2941,21 +2941,6 @@ package body Einfo is -- Attribute Set Procedures -- ------------------------------ - procedure Set_Abstract_Interfaces (Id : E; V : L) is - begin - pragma Assert (Is_Record_Type (Id)); - Set_Elist25 (Id, V); - end Set_Abstract_Interfaces; - - procedure Set_Abstract_Interface_Alias (Id : E; V : E) is - begin - pragma Assert - (Is_Hidden (Id) - and then - (Ekind (Id) = E_Procedure or else Ekind (Id) = E_Function)); - Set_Node25 (Id, V); - end Set_Abstract_Interface_Alias; - procedure Set_Accept_Address (Id : E; V : L) is begin Set_Elist21 (Id, V); @@ -3961,6 +3946,22 @@ package body Einfo is Set_Flag232 (Id, V); end Set_Implemented_By_Entry; + procedure Set_Interfaces (Id : E; V : L) is + begin + pragma Assert (Is_Record_Type (Id)); + Set_Elist25 (Id, V); + end Set_Interfaces; + + procedure Set_Interface_Alias (Id : E; V : E) is + begin + pragma Assert + (Is_Internal (Id) + and then Is_Hidden (Id) + and then (Ekind (Id) = E_Procedure + or else Ekind (Id) = E_Function)); + Set_Node25 (Id, V); + end Set_Interface_Alias; + procedure Set_In_Package_Body (Id : E; V : B := True) is begin Set_Flag48 (Id, V); @@ -7296,11 +7297,9 @@ package body Einfo is function Next_Tag_Component (Id : E) return E is Comp : Entity_Id; - Typ : constant Entity_Id := Scope (Id); begin - pragma Assert (Ekind (Id) = E_Component - and then Is_Tagged_Type (Typ)); + pragma Assert (Is_Tag (Id)); Comp := Next_Entity (Id); while Present (Comp) loop @@ -8600,13 +8599,13 @@ package body Einfo is when E_Procedure | E_Function => - Write_Str ("Abstract_Interface_Alias"); + Write_Str ("Interface_Alias"); when E_Record_Type | E_Record_Subtype | E_Record_Type_With_Private | E_Record_Subtype_With_Private => - Write_Str ("Abstract_Interfaces"); + Write_Str ("Interfaces"); when Task_Kind => Write_Str ("Task_Body_Procedure"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index e1623042b52..c0377a5430d 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -293,18 +293,6 @@ package Einfo is -- type, and if assertions are enabled, an attempt to set the attribute on a -- subtype will raise an assert error. --- Abstract_Interfaces (Elist25) --- Present in record types and subtypes. List of abstract interfaces --- implemented by a tagged type that are not already implemented by the --- ancestors (Ada 2005: AI-251). - --- Abstract_Interface_Alias (Node25) --- Present in subprograms that cover a primitive operation of an abstract --- interface type. Can be set only if the Is_Hidden flag is also set, --- since such entities are always hidden. Points to its associated --- interface subprogram. It is used to register the subprogram in --- secondary dispatch table of the interface (Ada 2005: AI-251). - -- Accept_Address (Elist21) -- Present in entries. If an accept has a statement sequence, then an -- address variable is created, which is used to hold the address of the @@ -364,12 +352,12 @@ package Einfo is -- Alias (Node18) -- Present in overloaded entities (literals, subprograms, entries) and -- subprograms that cover a primitive operation of an abstract interface --- (that is, subprograms with the Abstract_Interface_Alias attribute). --- In case of overloaded entities it points to the parent subprogram of --- a derived subprogram. In case of abstract interface subprograms it --- points to the subprogram that covers the abstract interface primitive. --- Also used for a subprogram renaming, where it points to the renamed --- subprogram. Always empty for entries. +-- (that is, subprograms with the Interface_Alias attribute). In case of +-- overloaded entities it points to the parent subprogram of a derived +-- subprogram. In case of abstract interface subprograms it points to the +-- subprogram that covers the abstract interface primitive. Also used for +-- a subprogram renaming, where it points to the renamed subprogram. +-- Always empty for entries. -- Alignment (Uint14) -- Present in entities for types and also in constants, variables @@ -1837,6 +1825,18 @@ package Einfo is -- Applies to functions and procedures. Set if pragma Implemented_By_ -- Entry is applied on the subprogram entity. +-- Interfaces (Elist25) +-- Present in record types and subtypes. List of abstract interfaces +-- implemented by a tagged type that are not already implemented by the +-- ancestors (Ada 2005: AI-251). + +-- Interface_Alias (Node25) +-- Present in subprograms that cover a primitive operation of an abstract +-- interface type. Can be set only if the Is_Hidden flag is also set, +-- since such entities are always hidden. Points to its associated +-- interface subprogram. It is used to register the subprogram in +-- secondary dispatch table of the interface (Ada 2005: AI-251). + -- In_Package_Body (Flag48) -- Present in package entities. Set on the entity that denotes the -- package (the defining occurrence of the package declaration) while @@ -2259,6 +2259,10 @@ package Einfo is -- 3) Object declarations generated by the expander that are implicitly -- imported or exported so that they can be marked in Sprint output. -- +-- 4) Internal entities in the list of primitives of tagged types that +-- are used to handle secondary dispatch tables. These entities have +-- also the attribute Interface_Alias. +-- -- Is_Interrupt_Handler (Flag89) -- Present in procedures. Set if a pragma Interrupt_Handler applies -- to the procedure. The procedure must be parameterless, and on all @@ -5018,7 +5022,7 @@ package Einfo is -- Generic_Renamings (Elist23) (for an instance) -- Inner_Instances (Elist23) (generic function only) -- Protection_Object (Node23) (for concurrent kind) - -- Abstract_Interface_Alias (Node25) + -- Interface_Alias (Node25) -- Overridden_Operation (Node26) -- Extra_Formals (Node28) -- Body_Needed_For_SAL (Flag40) @@ -5279,7 +5283,7 @@ package Einfo is -- Inner_Instances (Elist23) (for generic proc) -- Protection_Object (Node23) (for concurrent kind) -- Spec_PPC_List (Node24) (non-generic case only) - -- Abstract_Interface_Alias (Node25) + -- Interface_Alias (Node25) -- Static_Initialization (Node26) (init_proc only) -- Overridden_Operation (Node26) -- Wrapped_Entity (Node27) (non-generic case only) @@ -5363,7 +5367,7 @@ package Einfo is -- Discriminant_Constraint (Elist21) -- Corresponding_Remote_Type (Node22) -- Stored_Constraint (Elist23) - -- Abstract_Interfaces (Elist25) + -- Interfaces (Elist25) -- Component_Alignment (special) (base type only) -- C_Pass_By_Copy (Flag125) (base type only) -- Has_Dispatch_Table (Flag220) (base tagged type only) @@ -5397,7 +5401,7 @@ package Einfo is -- Discriminant_Constraint (Elist21) -- Private_View (Node22) -- Stored_Constraint (Elist23) - -- Abstract_Interfaces (Elist25) + -- Interfaces (Elist25) -- Has_Completion (Flag26) -- Has_Record_Rep_Clause (Flag65) (base type only) -- Has_External_Tag_Rep_Clause (Flag110) @@ -5746,13 +5750,11 @@ package Einfo is -- section contains the functions used to obtain attribute values which -- correspond to values in fields or flags in the entity itself. - function Abstract_Interfaces (Id : E) return L; function Accept_Address (Id : E) return L; function Access_Disp_Table (Id : E) return L; function Actual_Subtype (Id : E) return E; function Address_Taken (Id : E) return B; function Alias (Id : E) return E; - function Abstract_Interface_Alias (Id : E) return E; function Alignment (Id : E) return U; function Associated_Final_Chain (Id : E) return E; function Associated_Formal_Package (Id : E) return E; @@ -5920,6 +5922,8 @@ package Einfo is function In_Private_Part (Id : E) return B; function In_Use (Id : E) return B; function Inner_Instances (Id : E) return L; + function Interfaces (Id : E) return L; + function Interface_Alias (Id : E) return E; function Interface_Name (Id : E) return N; function Is_AST_Entry (Id : E) return B; function Is_Abstract_Subprogram (Id : E) return B; @@ -6305,14 +6309,12 @@ package Einfo is -- Attribute Set Procedures -- ------------------------------ - procedure Set_Abstract_Interfaces (Id : E; V : L); procedure Set_Accept_Address (Id : E; V : L); procedure Set_Access_Disp_Table (Id : E; V : L); procedure Set_Dispatch_Table_Wrapper (Id : E; V : E); procedure Set_Actual_Subtype (Id : E; V : E); procedure Set_Address_Taken (Id : E; V : B := True); procedure Set_Alias (Id : E; V : E); - procedure Set_Abstract_Interface_Alias (Id : E; V : E); procedure Set_Alignment (Id : E; V : U); procedure Set_Associated_Final_Chain (Id : E; V : E); procedure Set_Associated_Formal_Package (Id : E; V : E); @@ -6474,10 +6476,12 @@ package Einfo is procedure Set_Hiding_Loop_Variable (Id : E; V : E); procedure Set_Homonym (Id : E; V : E); procedure Set_Implemented_By_Entry (Id : E; V : B := True); + procedure Set_Interfaces (Id : E; V : L); procedure Set_In_Package_Body (Id : E; V : B := True); procedure Set_In_Private_Part (Id : E; V : B := True); procedure Set_In_Use (Id : E; V : B := True); procedure Set_Inner_Instances (Id : E; V : L); + procedure Set_Interface_Alias (Id : E; V : E); procedure Set_Interface_Name (Id : E; V : N); procedure Set_Is_AST_Entry (Id : E; V : B := True); procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True); @@ -6954,12 +6958,10 @@ package Einfo is -- subprograms meeting the requirements documented in the section on -- XEINFO may be referenced in this section. - pragma Inline (Abstract_Interfaces); pragma Inline (Accept_Address); pragma Inline (Access_Disp_Table); pragma Inline (Actual_Subtype); pragma Inline (Address_Taken); - pragma Inline (Abstract_Interface_Alias); pragma Inline (Alias); pragma Inline (Alignment); pragma Inline (Associated_Final_Chain); @@ -7122,10 +7124,12 @@ package Einfo is pragma Inline (Hiding_Loop_Variable); pragma Inline (Homonym); pragma Inline (Implemented_By_Entry); + pragma Inline (Interfaces); pragma Inline (In_Package_Body); pragma Inline (In_Private_Part); pragma Inline (In_Use); pragma Inline (Inner_Instances); + pragma Inline (Interface_Alias); pragma Inline (Interface_Name); pragma Inline (Is_AST_Entry); pragma Inline (Is_Abstract_Subprogram); @@ -7380,12 +7384,10 @@ package Einfo is pragma Inline (Init_Esize); pragma Inline (Init_RM_Size); - pragma Inline (Set_Abstract_Interfaces); pragma Inline (Set_Accept_Address); pragma Inline (Set_Access_Disp_Table); pragma Inline (Set_Actual_Subtype); pragma Inline (Set_Address_Taken); - pragma Inline (Set_Abstract_Interface_Alias); pragma Inline (Set_Alias); pragma Inline (Set_Alignment); pragma Inline (Set_Associated_Final_Chain); @@ -7547,10 +7549,12 @@ package Einfo is pragma Inline (Set_Hiding_Loop_Variable); pragma Inline (Set_Homonym); pragma Inline (Set_Implemented_By_Entry); + pragma Inline (Set_Interfaces); pragma Inline (Set_In_Package_Body); pragma Inline (Set_In_Private_Part); pragma Inline (Set_In_Use); pragma Inline (Set_Inner_Instances); + pragma Inline (Set_Interface_Alias); pragma Inline (Set_Interface_Name); pragma Inline (Set_Is_AST_Entry); pragma Inline (Set_Is_Abstract_Subprogram); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index af531ab6ed0..40ff3796671 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -544,6 +544,13 @@ package body Exp_Aggr is return False; end if; + -- If component is limited, aggregate must be expanded because each + -- component assignment must be built in place. + + if Is_Inherently_Limited_Type (Component_Type (Typ)) then + return False; + end if; + -- Checks 4 (array must not be multi-dimensional Fortran case) if Convention (Typ) = Convention_Fortran @@ -1514,6 +1521,16 @@ package body Exp_Aggr is Make_Integer_Literal (Loc, Uint_0)))); end if; + -- If the component type contains tasks, we need to build a Master + -- entity in the current scope, because it will be needed if build- + -- in-place functions are called in the expanded code. + + if Nkind (Parent (N)) = N_Object_Declaration + and then Has_Task (Typ) + then + Build_Master_Entity (Defining_Identifier (Parent (N))); + end if; + -- STEP 1: Process component associations -- For those associations that may generate a loop, initialize @@ -2573,7 +2590,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 Has_Abstract_Interfaces (Base_Type (Typ)) then + if Has_Interfaces (Base_Type (Typ)) then Init_Secondary_Tags (Typ => Base_Type (Typ), Target => Target, @@ -3080,7 +3097,7 @@ package body Exp_Aggr is -- abstract interfaces we must also initialize the tags of the -- secondary dispatch tables. - if Has_Abstract_Interfaces (Base_Type (Typ)) then + if Has_Interfaces (Base_Type (Typ)) then Init_Secondary_Tags (Typ => Base_Type (Typ), Target => Target, @@ -4041,7 +4058,7 @@ package body Exp_Aggr is -- Aggr_Lo <= Aggr_Hi and then -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)] - -- As an optimization try to see if some tests are trivially vacuos + -- As an optimization try to see if some tests are trivially vacuous -- because we are comparing an expression against itself. if Aggr_Lo = Ind_Lo and then Aggr_Hi = Ind_Hi then @@ -4672,6 +4689,8 @@ package body Exp_Aggr is Make_Raise_Constraint_Error (Loc, Condition => Cond, Reason => CE_Length_Check_Failed)); + -- Questionable reason code, shouldn't that be a + -- CE_Range_Check_Failed ??? end if; -- Now look inside the sub-aggregate to see if there is more work @@ -4953,6 +4972,13 @@ package body Exp_Aggr is and then In_Place_Assign_OK); end if; + -- If this is an array of tasks, it will be expanded into build-in- + -- -place assignments. Build an activation chain for the tasks now + + if Has_Task (Etype (N)) then + Build_Activation_Chain_Entity (N); + end if; + if not Has_Default_Init_Comps (N) and then Comes_From_Source (Parent (N)) and then Nkind (Parent (N)) = N_Object_Declaration @@ -5369,7 +5395,7 @@ package body Exp_Aggr is -- If the tagged types covers interface types we need to initialize all -- hidden components containing pointers to secondary dispatch tables. - elsif Is_Tagged_Type (Typ) and then Has_Abstract_Interfaces (Typ) then + elsif Is_Tagged_Type (Typ) and then Has_Interfaces (Typ) then Convert_To_Assignments (N, Typ); -- If some components are mutable, the size of the aggregate component diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 3ba47ec4446..4d2967bbf0f 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -299,7 +299,7 @@ package body Exp_Ch13 is -- its secondary dispatch table and therefore the code generator -- has nothing else to do with this freezing node. - Delete := Present (Abstract_Interface_Alias (E)); + Delete := Present (Interface_Alias (E)); end if; -- Analyze actions generated by freezing. The init_proc contains source diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index 6093f2a7333..3825405dccf 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -193,13 +193,21 @@ package body Exp_Ch2 is Unchecked_Convert_To (T, New_Occurrence_Of (Entity (Val), Loc))); - -- Otherwise get the value, and convert to appropriate type + -- If constant is of an integer type, just make an appropriately + -- integer literal, which will get the proper type. + + elsif Is_Integer_Type (T) then + Rewrite (N, + Make_Integer_Literal (Loc, + Intval => Expr_Rep_Value (Val))); + + -- Otherwise do unchecked conversion of value to right type else Rewrite (N, Unchecked_Convert_To (T, - Make_Integer_Literal (Loc, - Intval => Expr_Rep_Value (Val)))); + Make_Integer_Literal (Loc, + Intval => Expr_Rep_Value (Val)))); end if; Analyze_And_Resolve (N, T); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 1ed0703f251..b110121bc5e 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -57,6 +57,7 @@ with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Stand; use Stand; @@ -532,11 +533,12 @@ package body Exp_Ch3 is --------------------------- procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is - Loc : constant Source_Ptr := Sloc (Nod); - Comp_Type : constant Entity_Id := Component_Type (A_Type); - Index_List : List_Id; - Proc_Id : Entity_Id; - Body_Stmts : List_Id; + Loc : constant Source_Ptr := Sloc (Nod); + Comp_Type : constant Entity_Id := Component_Type (A_Type); + Index_List : List_Id; + Proc_Id : Entity_Id; + Body_Stmts : List_Id; + Has_Default_Init : Boolean; function Init_Component return List_Id; -- Create one statement to initialize one array component, designated @@ -670,14 +672,16 @@ package body Exp_Ch3 is -- the issue arises) in a special manner anyway which does not need an -- init_proc. - if Has_Non_Null_Base_Init_Proc (Comp_Type) - or else Needs_Simple_Initialization (Comp_Type) - or else Has_Task (Comp_Type) + Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type) + or else Needs_Simple_Initialization (Comp_Type) + or else Has_Task (Comp_Type); + + if Has_Default_Init or else (not Restriction_Active (No_Initialize_Scalars) - and then Is_Public (A_Type) - and then Root_Type (A_Type) /= Standard_String - and then Root_Type (A_Type) /= Standard_Wide_String - and then Root_Type (A_Type) /= Standard_Wide_Wide_String) + and then Is_Public (A_Type) + and then Root_Type (A_Type) /= Standard_String + and then Root_Type (A_Type) /= Standard_Wide_String + and then Root_Type (A_Type) /= Standard_Wide_Wide_String) then Proc_Id := Make_Defining_Identifier (Loc, @@ -687,9 +691,16 @@ package body Exp_Ch3 is -- want to build an init_proc, but we need to mark that an init_proc -- would be needed if this restriction was not active (so that we can -- detect attempts to call it), so set a dummy init_proc in place. + -- This is only done though when actual default initialization is + -- needed, so we exclude the setting in the Is_Public case, such + -- as for arrays of scalars, since otherwise such objects would be + -- wrongly flagged as violating the restriction. if Restriction_Active (No_Default_Initialization) then - Set_Init_Proc (A_Type, Proc_Id); + if Has_Default_Init then + Set_Init_Proc (A_Type, Proc_Id); + end if; + return; end if; @@ -2166,7 +2177,7 @@ package body Exp_Ch3 is -- If the interface is a parent of Rec_Type it shares the primary -- dispatch table and hence there is no need to build the function - if not Is_Parent (Node (Iface_Elmt), Rec_Type) then + if not Is_Ancestor (Node (Iface_Elmt), Rec_Type) then Build_Offset_To_Top_Function (Iface_Comp => Node (Comp_Elmt)); end if; @@ -2304,7 +2315,7 @@ package body Exp_Ch3 is if Ada_Version >= Ada_05 and then not Is_Interface (Rec_Type) - and then Has_Abstract_Interfaces (Rec_Type) + and then Has_Interfaces (Rec_Type) then Init_Secondary_Tags (Typ => Rec_Type, @@ -2398,8 +2409,7 @@ package body Exp_Ch3 is if not Is_Imported (Prim) and then Convention (Prim) = Convention_CPP - and then not Present (Abstract_Interface_Alias - (Prim)) + and then not Present (Interface_Alias (Prim)) then Register_Primitive (Loc, Prim => Prim, @@ -2421,7 +2431,7 @@ package body Exp_Ch3 is if Ada_Version >= Ada_05 and then not Is_Interface (Rec_Type) - and then Has_Abstract_Interfaces (Rec_Type) + and then Has_Interfaces (Rec_Type) and then Has_Discriminants (Etype (Rec_Type)) and then Is_Variable_Size_Record (Etype (Rec_Type)) then @@ -2477,17 +2487,16 @@ package body Exp_Ch3 is function Build_Init_Statements (Comp_List : Node_Id) return List_Id is Check_List : constant List_Id := New_List; Alt_List : List_Id; + Decl : Node_Id; + Id : Entity_Id; + Names : Node_Id; Statement_List : List_Id; Stmts : List_Id; + Typ : Entity_Id; + Variant : Node_Id; Per_Object_Constraint_Components : Boolean; - Decl : Node_Id; - Variant : Node_Id; - - Id : Entity_Id; - Typ : Entity_Id; - function Has_Access_Constraint (E : Entity_Id) return Boolean; -- Components with access discriminants that depend on the current -- instance must be initialized after all other components. @@ -2711,6 +2720,17 @@ package body Exp_Ch3 is Append_To (Statement_List, Make_Task_Create_Call (Rec_Type)); + -- Generate the statements which map a string entry name to a + -- task entry index. Note that the task may not have entries. + + if Entry_Names_OK then + Names := Build_Entry_Names (Rec_Type); + + if Present (Names) then + Append_To (Statement_List, Names); + end if; + end if; + declare Task_Type : constant Entity_Id := Corresponding_Concurrent_Type (Rec_Type); @@ -2761,6 +2781,18 @@ package body Exp_Ch3 is if Is_Protected_Record_Type (Rec_Type) then Append_List_To (Statement_List, Make_Initialize_Protection (Rec_Type)); + + -- Generate the statements which map a string entry name to a + -- protected entry index. Note that the protected type may not + -- have entries. + + if Entry_Names_OK then + Names := Build_Entry_Names (Rec_Type); + + if Present (Names) then + Append_To (Statement_List, Names); + end if; + end if; end if; -- If no initializations when generated for component declarations @@ -4246,7 +4278,11 @@ package body Exp_Ch3 is and then not Suppress_Init_Proc (Typ) then - Check_Restriction (No_Default_Initialization, N); + -- Return without initializing when No_Default_Initialization + -- applies. Note that the actual restriction check occurs later, + -- when the object is frozen, because we don't know yet whether + -- the object is imported, which is a case where the check does + -- not apply. if Restriction_Active (No_Default_Initialization) then return; @@ -4292,7 +4328,6 @@ package body Exp_Ch3 is and then not Is_Internal (Def_Id) and then not Has_Init_Expression (N) then - Check_Restriction (No_Default_Initialization, N); Set_No_Initialization (N, False); Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id))); Analyze_And_Resolve (Expression (N), Typ); @@ -4399,7 +4434,7 @@ package body Exp_Ch3 is and then (Is_Class_Wide_Type (Etype (Expr)) or else - not Is_Parent (Root_Type (Typ), Etype (Expr))) + not Is_Ancestor (Root_Type (Typ), Etype (Expr))) and then Comes_From_Source (Def_Id) and then VM_Target = No_VM then @@ -4494,15 +4529,16 @@ package body Exp_Ch3 is end; end if; - -- If the type is controlled and not limited then the target is - -- adjusted after the copy and attached to the finalization list. - -- However, no adjustment is done in the case where the object was - -- initialized by a call to a function whose result is built in - -- place, since no copy occurred. (We eventually plan to support - -- in-place function results for some nonlimited types. ???) + -- If the type is controlled and not inherently limited, then + -- the target is adjusted after the copy and attached to the + -- finalization list. However, no adjustment is done in the case + -- where the object was initialized by a call to a function whose + -- result is built in place, since no copy occurred. (Eventually + -- we plan to support in-place function results for some cases + -- of nonlimited types. ???) if Controlled_Type (Typ) - and then not Is_Limited_Type (Typ) + and then not Is_Inherently_Limited_Type (Typ) and then not BIP_Call then Insert_Actions_After (Init_After, @@ -5298,6 +5334,105 @@ package body Exp_Ch3 is ------------------------ procedure Freeze_Record_Type (N : Node_Id) is + + procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id); + -- Add to the list of primitives of Tagged_Types the internal entities + -- associated with interface primitives that are located in secondary + -- dispatch tables. + + ------------------------------------- + -- Add_Internal_Interface_Entities -- + ------------------------------------- + + procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is + Elmt : Elmt_Id; + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + Iface_Prim : Entity_Id; + Ifaces_List : Elist_Id; + New_Subp : Entity_Id := Empty; + Prim : Entity_Id; + + begin + pragma Assert (Ada_Version >= Ada_05 + and then Is_Record_Type (Tagged_Type) + and then Is_Tagged_Type (Tagged_Type) + and then Has_Interfaces (Tagged_Type) + and then not Is_Interface (Tagged_Type)); + + Collect_Interfaces (Tagged_Type, Ifaces_List); + + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); + + -- Exclude from this processing interfaces that are parents + -- of Tagged_Type because their primitives are located in the + -- primary dispatch table (and hence no auxiliary internal + -- entities are required to handle secondary dispatch tables + -- in such case). + + if not Is_Ancestor (Iface, Tagged_Type) then + Elmt := First_Elmt (Primitive_Operations (Iface)); + while Present (Elmt) loop + Iface_Prim := Node (Elmt); + + if not Is_Predefined_Dispatching_Operation (Iface_Prim) then + Prim := + Find_Primitive_Covering_Interface + (Tagged_Type => Tagged_Type, + Iface_Prim => Iface_Prim); + + pragma Assert (Present (Prim)); + + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Iface_Prim, + Derived_Type => Tagged_Type, + Parent_Type => Iface); + + -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp + -- associated with interface types. These entities are + -- only registered in the list of primitives of its + -- corresponding tagged type because they are only used + -- to fill the contents of the secondary dispatch tables. + -- Therefore they are removed from the homonym chains. + + Set_Is_Hidden (New_Subp); + Set_Is_Internal (New_Subp); + Set_Alias (New_Subp, Prim); + Set_Is_Abstract_Subprogram (New_Subp, + Is_Abstract_Subprogram (Prim)); + Set_Interface_Alias (New_Subp, Iface_Prim); + + -- Internal entities associated with interface types are + -- only registered in the list of primitives of the + -- tagged type. They are only used to fill the contents + -- of the secondary dispatch tables. Therefore they are + -- not needed in the homonym chains. + + Remove_Homonym (New_Subp); + + -- Hidden entities associated with interfaces must have + -- set the Has_Delay_Freeze attribute to ensure that, in + -- case of locally defined tagged types (or compiling + -- with static dispatch tables generation disabled) the + -- corresponding entry of the secondary dispatch table is + -- filled when such entity is frozen. + + Set_Has_Delayed_Freeze (New_Subp); + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + Next_Elmt (Iface_Elmt); + end loop; + end Add_Internal_Interface_Entities; + + -- Local variables + Def_Id : constant Node_Id := Entity (N); Type_Decl : constant Node_Id := Parent (Def_Id); Comp : Entity_Id; @@ -5320,6 +5455,8 @@ package body Exp_Ch3 is Wrapper_Body_List : List_Id := No_List; Null_Proc_Decl_List : List_Id := No_List; + -- Start of processing for Freeze_Record_Type + begin -- Build discriminant checking functions if not a derived type (for -- derived types that are not tagged types, always use the discriminant @@ -5522,6 +5659,17 @@ package body Exp_Ch3 is Insert_Actions (N, Null_Proc_Decl_List); end if; + -- Ada 2005 (AI-251): Add internal entities associated with + -- secondary dispatch tables to the list of primitives of tagged + -- types that are not interfaces + + if Ada_Version >= Ada_05 + and then not Is_Interface (Def_Id) + and then Has_Interfaces (Def_Id) + then + Add_Internal_Interface_Entities (Def_Id); + end if; + Set_Is_Frozen (Def_Id); Set_All_DT_Position (Def_Id); @@ -6655,7 +6803,7 @@ package body Exp_Ch3 is -- Initialize the pointer to the secondary DT associated with the -- interface. - if not Is_Parent (Iface, Typ) then + if not Is_Ancestor (Iface, Typ) then Append_To (Stmts_List, Make_Assignment_Statement (Loc, Name => @@ -6753,7 +6901,7 @@ package body Exp_Ch3 is -- Don't need to set any value if this interface shares -- the primary dispatch table. - if not Is_Parent (Iface, Typ) then + if not Is_Ancestor (Iface, Typ) then Append_To (Stmts_List, Build_Set_Static_Offset_To_Top (Loc, Iface_Tag => New_Reference_To (Iface_Tag, Loc), @@ -7212,7 +7360,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; @@ -7476,27 +7624,42 @@ package body Exp_Ch3 is -- User-defined equality elsif Chars (Node (Prim)) = Name_Op_Eq - and then (No (Alias (Node (Prim))) - or else Nkind (Unit_Declaration_Node (Node (Prim))) = - N_Subprogram_Renaming_Declaration) and then Etype (First_Formal (Node (Prim))) = Etype (Next_Formal (First_Formal (Node (Prim)))) and then Base_Type (Etype (Node (Prim))) = Standard_Boolean then - Eq_Needed := False; - exit; + if No (Alias (Node (Prim))) + or else Nkind (Unit_Declaration_Node (Node (Prim))) = + N_Subprogram_Renaming_Declaration + then + Eq_Needed := False; + exit; - -- If the parent is not an interface type and has an abstract - -- equality function, the inherited equality is abstract as well, - -- and no body can be created for it. + -- If the parent is not an interface type and has an abstract + -- equality function, the inherited equality is abstract as + -- well, and no body can be created for it. - elsif Chars (Node (Prim)) = Name_Op_Eq - and then not Is_Interface (Etype (Tag_Typ)) - and then Present (Alias (Node (Prim))) - and then Is_Abstract_Subprogram (Alias (Node (Prim))) - then - Eq_Needed := False; - exit; + elsif not Is_Interface (Etype (Tag_Typ)) + and then Present (Alias (Node (Prim))) + and then Is_Abstract_Subprogram (Alias (Node (Prim))) + then + Eq_Needed := False; + exit; + + -- If the type has an equality function corresponding with + -- a primitive defined in an interface type, the inherited + -- equality is abstract as well, and no body can be created + -- for it. + + elsif Present (Alias (Node (Prim))) + and then Comes_From_Source (Ultimate_Alias (Node (Prim))) + and then + Is_Interface + (Find_Dispatching_Type (Ultimate_Alias (Node (Prim)))) + then + Eq_Needed := False; + exit; + end if; end if; Next_Elmt (Prim); @@ -7640,7 +7803,7 @@ package body Exp_Ch3 is and then Is_Limited_Record (Etype (Tag_Typ))) or else (Is_Concurrent_Record_Type (Tag_Typ) - and then Has_Abstract_Interfaces (Tag_Typ)) + and then Has_Interfaces (Tag_Typ)) then Append_To (Res, Make_Subprogram_Declaration (Loc, @@ -8093,7 +8256,7 @@ package body Exp_Ch3 is ((Is_Interface (Etype (Tag_Typ)) and then Is_Limited_Record (Etype (Tag_Typ))) or else (Is_Concurrent_Record_Type (Tag_Typ) - and then Has_Abstract_Interfaces (Tag_Typ))) + and then Has_Interfaces (Tag_Typ))) and then RTE_Available (RE_Select_Specific_Data) then Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ)); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 0246516fcbf..2d275a9bc80 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -2230,6 +2230,7 @@ package body Exp_Ch4 is Declare_Stmts : List_Id; H_Decl : Node_Id; + I_Decl : Node_Id; H_Init : Node_Id; P_Decl : Node_Id; R_Decl : Node_Id; @@ -2427,6 +2428,7 @@ package body Exp_Ch4 is or else Root_Type (Ind_Typ) = Standard_Integer or else Root_Type (Ind_Typ) = Standard_Short_Integer or else Root_Type (Ind_Typ) = Standard_Short_Short_Integer + or else Is_Modular_Integer_Type (Ind_Typ) then Target_Type := Standard_Integer; else @@ -2609,7 +2611,37 @@ package body Exp_Ch4 is for I in 2 .. Nb_Opnds loop H_Init := Make_Op_Add (Loc, H_Init, S_Length (I)); end loop; - H_Init := Ind_Val (Make_Op_Add (Loc, H_Init, L_Pos)); + + -- If the index type is small modular type, we need to perform an + -- additional check that the upper bound fits in the index type. + -- Otherwise the computation of the upper bound can wrap around + -- and yield meaningless results. The constraint check has to be + -- explicit in the code, because the generated function is compiled + -- with checks disabled, for efficiency. + + if Is_Modular_Integer_Type (Ind_Typ) + and then Esize (Ind_Typ) < Esize (Standard_Integer) + then + I_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI), + Object_Definition => New_Reference_To (Standard_Integer, Loc), + Expression => + Make_Type_Conversion (Loc, + New_Reference_To (Standard_Integer, Loc), + Make_Op_Add (Loc, H_Init, L_Pos))); + + H_Init := + Ind_Val ( + Make_Type_Conversion (Loc, + New_Reference_To (Ind_Typ, Loc), + New_Reference_To (Defining_Identifier (I_Decl), Loc))); + + -- For other index types, computation is safe. + + else + H_Init := Ind_Val (Make_Op_Add (Loc, H_Init, L_Pos)); + end if; H_Decl := Make_Object_Declaration (Loc, @@ -2636,6 +2668,28 @@ package body Exp_Ch4 is Declare_Decls := New_List (P_Decl, H_Decl, R_Decl); + -- Add constraint check for the modular index case. + + if Is_Modular_Integer_Type (Ind_Typ) + and then Esize (Ind_Typ) < Esize (Standard_Integer) + then + Insert_After (P_Decl, I_Decl); + + Insert_After (I_Decl, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => + New_Reference_To (Defining_Identifier (I_Decl), Loc), + Right_Opnd => + Make_Type_Conversion (Loc, + New_Reference_To (Standard_Integer, Loc), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ind_Typ, Loc), + Attribute_Name => Name_Last))), + Reason => CE_Range_Check_Failed)); + end if; + -- Construct list of statements for the declare block Declare_Stmts := New_List; @@ -7583,79 +7637,151 @@ package body Exp_Ch4 is -- Otherwise, proceed with processing tagged conversion declare - Actual_Operand_Type : Entity_Id; - Actual_Target_Type : Entity_Id; + Actual_Op_Typ : Entity_Id; + Actual_Targ_Typ : Entity_Id; + Make_Conversion : Boolean := False; + Root_Op_Typ : Entity_Id; + + procedure Make_Tag_Check (Targ_Typ : Entity_Id); + -- Create a membership check to test whether Operand is a member + -- of Targ_Typ. If the original Target_Type is an access, include + -- a test for null value. The check is inserted at N. + + -------------------- + -- Make_Tag_Check -- + -------------------- + + procedure Make_Tag_Check (Targ_Typ : Entity_Id) is + Cond : Node_Id; + + begin + -- Generate: + -- [Constraint_Error + -- when Operand /= null + -- and then Operand.all not in Targ_Typ] + + if Is_Access_Type (Target_Type) then + Cond := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), + Right_Opnd => Make_Null (Loc)), + + Right_Opnd => + Make_Not_In (Loc, + Left_Opnd => + Make_Explicit_Dereference (Loc, + Prefix => Duplicate_Subexpr_No_Checks (Operand)), + Right_Opnd => New_Reference_To (Targ_Typ, Loc))); + + -- Generate: + -- [Constraint_Error when Operand not in Targ_Typ] + + else + Cond := + Make_Not_In (Loc, + Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), + Right_Opnd => New_Reference_To (Targ_Typ, Loc)); + end if; + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Tag_Check_Failed)); + end Make_Tag_Check; - Cond : Node_Id; + -- Start of processing begin if Is_Access_Type (Target_Type) then - Actual_Operand_Type := Designated_Type (Operand_Type); - Actual_Target_Type := Designated_Type (Target_Type); + Actual_Op_Typ := Designated_Type (Operand_Type); + Actual_Targ_Typ := Designated_Type (Target_Type); else - Actual_Operand_Type := Operand_Type; - Actual_Target_Type := Target_Type; + Actual_Op_Typ := Operand_Type; + Actual_Targ_Typ := Target_Type; end if; + Root_Op_Typ := Root_Type (Actual_Op_Typ); + -- Ada 2005 (AI-251): Handle interface type conversion - if Is_Interface (Actual_Operand_Type) then + if Is_Interface (Actual_Op_Typ) then Expand_Interface_Conversion (N, Is_Static => False); return; end if; - if Is_Class_Wide_Type (Actual_Operand_Type) - and then Root_Type (Actual_Operand_Type) /= Actual_Target_Type - and then Is_Ancestor - (Root_Type (Actual_Operand_Type), - Actual_Target_Type) - and then not Tag_Checks_Suppressed (Actual_Target_Type) - then - -- Conversion is valid for any descendant of the target type + if not Tag_Checks_Suppressed (Actual_Targ_Typ) then - Actual_Target_Type := Class_Wide_Type (Actual_Target_Type); + -- Create a runtime tag check for a downward class-wide type + -- conversion. - if Is_Access_Type (Target_Type) then - Cond := - Make_And_Then (Loc, - Left_Opnd => - Make_Op_Ne (Loc, - Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), - Right_Opnd => Make_Null (Loc)), + if Is_Class_Wide_Type (Actual_Op_Typ) + and then Root_Op_Typ /= Actual_Targ_Typ + and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ) + then + Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ)); + Make_Conversion := True; + end if; - Right_Opnd => - Make_Not_In (Loc, - Left_Opnd => - Make_Explicit_Dereference (Loc, - Prefix => - Duplicate_Subexpr_No_Checks (Operand)), - Right_Opnd => - New_Reference_To (Actual_Target_Type, Loc))); + -- AI05-0073: If the result subtype of the function is defined + -- by an access_definition designating a specific tagged type + -- T, a check is made that the result value is null or the tag + -- of the object designated by the result value identifies T. + -- Constraint_Error is raised if this check fails. - else - Cond := - Make_Not_In (Loc, - Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), - Right_Opnd => - New_Reference_To (Actual_Target_Type, Loc)); + if Nkind (Parent (N)) = Sinfo.N_Return_Statement then + declare + Func : Entity_Id; + Func_Typ : Entity_Id; + + begin + -- Climb scope stack looking for the enclosing function + + Func := Current_Scope; + while Present (Func) + and then Ekind (Func) /= E_Function + loop + Func := Scope (Func); + end loop; + + -- The function's return subtype must be defined using + -- an access definition. + + if Nkind (Result_Definition (Parent (Func))) = + N_Access_Definition + then + Func_Typ := Directly_Designated_Type (Etype (Func)); + + -- The return subtype denotes a specific tagged type, + -- in other words, a non class-wide type. + + if Is_Tagged_Type (Func_Typ) + and then not Is_Class_Wide_Type (Func_Typ) + then + Make_Tag_Check (Actual_Targ_Typ); + Make_Conversion := True; + end if; + end if; + end; end if; - Insert_Action (N, - Make_Raise_Constraint_Error (Loc, - Condition => Cond, - Reason => CE_Tag_Check_Failed)); + -- We have generated a tag check for either a class-wide type + -- conversion or for AI05-0073. - declare - Conv : Node_Id; - begin - Conv := - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), - Expression => Relocate_Node (Expression (N))); - Rewrite (N, Conv); - Analyze_And_Resolve (N, Target_Type); - end; + if Make_Conversion then + declare + Conv : Node_Id; + begin + Conv := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), + Expression => Relocate_Node (Expression (N))); + Rewrite (N, Conv); + Analyze_And_Resolve (N, Target_Type); + end; + end if; end if; end; @@ -9084,7 +9210,7 @@ package body Exp_Ch4 is -- Obj1 in Iface'Class; -- Compile time error if not Is_Class_Wide_Type (Left_Type) - and then (Is_Parent (Etype (Right_Type), Left_Type) + and then (Is_Ancestor (Etype (Right_Type), Left_Type) or else (Is_Interface (Etype (Right_Type)) and then Interface_Present_In_Ancestor (Typ => Left_Type, diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 00ab0d6fa9d..18ea8fe44db 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -734,8 +734,8 @@ package body Exp_Ch5 is and then not No_Ctrl_Actions (N) then declare - Proc : constant Entity_Id := - TSS (Base_Type (L_Type), TSS_Slice_Assign); + Proc : constant Entity_Id := + TSS (Base_Type (L_Type), TSS_Slice_Assign); Actuals : List_Id; begin @@ -872,7 +872,7 @@ package body Exp_Ch5 is -- explicit bounds of right and left hand sides. declare - Proc : constant Node_Id := + Proc : constant Entity_Id := TSS (Base_Type (L_Type), TSS_Slice_Assign); Actuals : List_Id; @@ -4032,6 +4032,28 @@ package body Exp_Ch5 is end; end if; + -- If we are returning an object that may not be bit-aligned, then + -- copy the value into a temporary first. This copy may need to expand + -- to a loop of component operations.. + + if Is_Possibly_Unaligned_Slice (Exp) + or else Is_Possibly_Unaligned_Object (Exp) + then + declare + Tnn : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + begin + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (R_Type, Loc), + Expression => Relocate_Node (Exp)), + Suppress => All_Checks); + Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); + end; + end if; + -- Generate call to postcondition checks if they are present if Ekind (Scope_Id) = E_Function @@ -4061,8 +4083,7 @@ package body Exp_Ch5 is else declare Tnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('T')); + Make_Defining_Identifier (Loc, New_Internal_Name ('T')); begin -- For a complex expression of an elementary type, capture @@ -4186,13 +4207,16 @@ package body Exp_Ch5 is if not Ctrl_Act then null; - -- The left hand side is an uninitialized temporary + -- The left hand side is an uninitialized temporary object elsif Nkind (L) = N_Type_Conversion and then Is_Entity_Name (Expression (L)) + and then Nkind (Parent (Entity (Expression (L)))) + = N_Object_Declaration and then No_Initialization (Parent (Entity (Expression (L)))) then null; + else Append_List_To (Res, Make_Final_Call ( diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 8791fcf6958..3afb7696770 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -41,6 +41,7 @@ with Exp_Intr; use Exp_Intr; with Exp_Pakd; use Exp_Pakd; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; +with Exp_VFpt; use Exp_VFpt; with Fname; use Fname; with Freeze; use Freeze; with Inline; use Inline; @@ -3963,6 +3964,21 @@ package body Exp_Ch6 is procedure Expand_N_Function_Call (N : Node_Id) is begin Expand_Call (N); + + -- If the return value of a foreign compiled function is + -- VAX Float then expand the return (adjusts the location + -- of the return value on Alpha/VMS, noop everywere else). + -- Comes_From_Source intercepts recursive expansion. + + if Vax_Float (Etype (N)) + and then Nkind (N) = N_Function_Call + and then Present (Name (N)) + and then Present (Entity (Name (N))) + and then Has_Foreign_Convention (Entity (Name (N))) + and then Comes_From_Source (Parent (N)) + then + Expand_Vax_Foreign_Return (N); + end if; end Expand_N_Function_Call; --------------------------------------- @@ -4728,7 +4744,7 @@ package body Exp_Ch6 is Tagged_Typ := Find_Dispatching_Type (Prim); if No (Access_Disp_Table (Tagged_Typ)) - or else not Has_Abstract_Interfaces (Tagged_Typ) + or else not Has_Interfaces (Tagged_Typ) or else not RTE_Available (RE_Interface_Tag) or else Restriction_Active (No_Dispatching_Calls) then @@ -4856,7 +4872,7 @@ package body Exp_Ch6 is -- table slot. if not Is_Interface (Typ) - or else Present (Abstract_Interface_Alias (Subp)) + or else Present (Interface_Alias (Subp)) then if Is_Predefined_Dispatching_Operation (Subp) then Register_Predefined_DT_Entry (Subp); @@ -5166,9 +5182,9 @@ package body Exp_Ch6 is end if; end Make_Build_In_Place_Call_In_Anonymous_Context; - --------------------------------------------------- + -------------------------------------------- -- Make_Build_In_Place_Call_In_Assignment -- - --------------------------------------------------- + -------------------------------------------- procedure Make_Build_In_Place_Call_In_Assignment (Assign : Node_Id; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index ca4d70b2c02..572dae04ea0 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -32,6 +32,7 @@ with Exp_Ch3; use Exp_Ch3; with Exp_Ch11; use Exp_Ch11; with Exp_Ch6; use Exp_Ch6; with Exp_Dbug; use Exp_Dbug; +with Exp_Disp; use Exp_Disp; with Exp_Sel; use Exp_Sel; with Exp_Smem; use Exp_Smem; with Exp_Tss; use Exp_Tss; @@ -56,6 +57,7 @@ with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; +with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -1106,6 +1108,334 @@ package body Exp_Ch9 is return Ecount; end Build_Entry_Count_Expression; + ----------------------- + -- Build_Entry_Names -- + ----------------------- + + function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (Conc_Typ); + B_Decls : List_Id; + B_Stmts : List_Id; + Comp : Node_Id; + Index : Entity_Id; + Index_Typ : RE_Id; + Typ : Entity_Id := Conc_Typ; + + procedure Build_Entry_Family_Name (Id : Entity_Id); + -- Generate: + -- for Lnn in Family_Low .. Family_High loop + -- Inn := Inn + 1; + -- Set_Entry_Name + -- (_init._object, Inn, new String ("<Entry name> " & Lnn'Img)); + -- _init._task_id + -- end loop; + -- Note that the bounds of the range may reference discriminants. The + -- above construct is added directly to the statements of the block. + + procedure Build_Entry_Name (Id : Entity_Id); + -- Generate: + -- Inn := Inn + 1; + -- Set_Entry_Name (_init._task_id, Inn, new String ("<Entry name>"); + -- _init._object + -- The above construct is added directly to the statements of the block. + + function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id; + -- Generate the call to the runtime routine Set_Entry_Name with actuals + -- _init._task_id or _init._object, Inn and Arg3. + + function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id; + -- Given a protected type or its corresponding record, find the type of + -- field _object. + + procedure Increment_Index (Stmts : List_Id); + -- Generate the following and add it to Stmts + -- Inn := Inn + 1; + + ----------------------------- + -- Build_Entry_Family_Name -- + ----------------------------- + + procedure Build_Entry_Family_Name (Id : Entity_Id) is + Def : constant Node_Id := + Discrete_Subtype_Definition (Parent (Id)); + L_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('L')); + L_Stmts : constant List_Id := New_List; + Val : Node_Id; + + function Build_Range (Def : Node_Id) return Node_Id; + -- Given a discrete subtype definition of an entry family, generate a + -- range node which covers the range of Def's type. + + ----------------- + -- Build_Range -- + ----------------- + + function Build_Range (Def : Node_Id) return Node_Id is + High : Node_Id := Type_High_Bound (Etype (Def)); + Low : Node_Id := Type_Low_Bound (Etype (Def)); + + begin + -- If a bound references a discriminant, generate an identifier + -- with the same name. Resolution will map it to the formals of + -- the init proc. + + if Is_Entity_Name (Low) + and then Ekind (Entity (Low)) = E_Discriminant + then + Low := Make_Identifier (Loc, Chars (Low)); + else + Low := New_Copy_Tree (Low); + end if; + + if Is_Entity_Name (High) + and then Ekind (Entity (High)) = E_Discriminant + then + High := Make_Identifier (Loc, Chars (High)); + else + High := New_Copy_Tree (High); + end if; + + return + Make_Range (Loc, + Low_Bound => Low, + High_Bound => High); + end Build_Range; + + -- Start of processing for Build_Entry_Family_Name + + begin + Get_Name_String (Chars (Id)); + + if Is_Enumeration_Type (Etype (Def)) then + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ' '; + end if; + + -- Generate: + -- new String'("<Entry name>" & Lnn'Img); + + Val := + Make_Allocator (Loc, + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Reference_To (Standard_String, Loc), + Expression => + Make_Op_Concat (Loc, + Left_Opnd => + Make_String_Literal (Loc, + String_From_Name_Buffer), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (L_Id, Loc), + Attribute_Name => Name_Img)))); + + Increment_Index (L_Stmts); + Append_To (L_Stmts, Build_Set_Entry_Name_Call (Val)); + + -- Generate: + -- for Lnn in Family_Low .. Family_High loop + -- Inn := Inn + 1; + -- Set_Entry_Name (_init._task_id, Inn, <Val>); + -- end loop; + + Append_To (B_Stmts, + Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => L_Id, + Discrete_Subtype_Definition => + Build_Range (Def))), + Statements => L_Stmts, + End_Label => Empty)); + end Build_Entry_Family_Name; + + ---------------------- + -- Build_Entry_Name -- + ---------------------- + + procedure Build_Entry_Name (Id : Entity_Id) is + Val : Node_Id; + + begin + Get_Name_String (Chars (Id)); + Val := + Make_Allocator (Loc, + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Reference_To (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, + String_From_Name_Buffer))); + + Increment_Index (B_Stmts); + Append_To (B_Stmts, Build_Set_Entry_Name_Call (Val)); + end Build_Entry_Name; + + ------------------------------- + -- Build_Set_Entry_Name_Call -- + ------------------------------- + + function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id is + Arg1 : Name_Id; + Proc : RE_Id; + + begin + -- Determine the proper name for the first argument and the RTS + -- routine to call. + + if Is_Protected_Type (Typ) then + Arg1 := Name_uObject; + Proc := RO_PE_Set_Entry_Name; + + else pragma Assert (Is_Task_Type (Typ)); + Arg1 := Name_uTask_Id; + Proc := RO_TS_Set_Entry_Name; + end if; + + -- Generate: + -- Set_Entry_Name (_init.Arg1, Inn, Arg3); + + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (Proc), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, -- _init._object + Prefix => -- _init._task_id + Make_Identifier (Loc, Name_uInit), + Selector_Name => + Make_Identifier (Loc, Arg1)), + New_Reference_To (Index, Loc), -- Inn + Arg3)); -- Val + end Build_Set_Entry_Name_Call; + + -------------------------- + -- Find_Protection_Type -- + -------------------------- + + function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is + Comp : Entity_Id; + Typ : Entity_Id := Conc_Typ; + + begin + if Is_Concurrent_Type (Typ) then + Typ := Corresponding_Record_Type (Typ); + end if; + + Comp := First_Component (Typ); + while Present (Comp) loop + if Chars (Comp) = Name_uObject then + return Base_Type (Etype (Comp)); + end if; + + Next_Component (Comp); + end loop; + + -- The corresponding record of a protected type should always have an + -- _object field. + + raise Program_Error; + end Find_Protection_Type; + + --------------------- + -- Increment_Index -- + --------------------- + + procedure Increment_Index (Stmts : List_Id) is + begin + -- Generate: + -- Inn := Inn + 1; + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Index, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => + New_Reference_To (Index, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, 1)))); + end Increment_Index; + + -- Start of processing for Build_Entry_Names + + begin + -- Retrieve the original concurrent type + + if Is_Concurrent_Record_Type (Typ) then + Typ := Corresponding_Concurrent_Type (Typ); + end if; + + pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ)); + + -- Nothing to do if the type has no entries + + if not Has_Entries (Typ) then + return Empty; + end if; + + -- Avoid generating entry names for a protected type with only one entry + + if Is_Protected_Type (Typ) + and then Find_Protection_Type (Typ) /= RTE (RE_Protection_Entries) + then + return Empty; + end if; + + Index := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + + -- Step 1: Generate the declaration of the index variable: + -- Inn : Protected_Entry_Index := 0; + -- or + -- Inn : Task_Entry_Index := 0; + + if Is_Protected_Type (Typ) then + Index_Typ := RE_Protected_Entry_Index; + else + Index_Typ := RE_Task_Entry_Index; + end if; + + B_Decls := New_List; + Append_To (B_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Index, + Object_Definition => + New_Reference_To (RTE (Index_Typ), Loc), + Expression => + Make_Integer_Literal (Loc, 0))); + + B_Stmts := New_List; + + -- Step 2: Generate a call to Set_Entry_Name for each entry and entry + -- family member. + + Comp := First_Entity (Typ); + while Present (Comp) loop + if Ekind (Comp) = E_Entry then + Build_Entry_Name (Comp); + + elsif Ekind (Comp) = E_Entry_Family then + Build_Entry_Family_Name (Comp); + end if; + + Next_Entity (Comp); + end loop; + + -- Step 3: Wrap the statements in a block + + return + Make_Block_Statement (Loc, + Declarations => B_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => B_Stmts)); + end Build_Entry_Names; + --------------------------- -- Build_Parameter_Block -- --------------------------- @@ -1551,11 +1881,11 @@ package body Exp_Ch9 is Iface := Etype (Iface); end loop Examine_Parents; - if Present (Abstract_Interfaces + if Present (Interfaces (Corresponding_Record_Type (Scope (Proc_Nam)))) then Iface_Elmt := First_Elmt - (Abstract_Interfaces + (Interfaces (Corresponding_Record_Type (Scope (Proc_Nam)))); Examine_Interfaces : while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); @@ -6762,7 +7092,7 @@ package body Exp_Ch9 is -- an interface. if Ada_Version >= Ada_05 - and then Present (Abstract_Interfaces ( + and then Present (Interfaces ( Corresponding_Record_Type (Pid))) then Disp_Op_Body := @@ -6849,8 +7179,7 @@ package body Exp_Ch9 is if Ada_Version >= Ada_05 and then Present (Protected_Definition (Parent (Pid))) - and then Present (Abstract_Interfaces - (Corresponding_Record_Type (Pid))) + and then Present (Interfaces (Corresponding_Record_Type (Pid))) then declare Vis_Decl : Node_Id := @@ -7301,10 +7630,10 @@ package body Exp_Ch9 is if Ada_Version >= Ada_05 and then Present (Visible_Declarations (Pdef)) and then Present (Corresponding_Record_Type - (Defining_Identifier (Parent (Pdef)))) - and then Present (Abstract_Interfaces - (Corresponding_Record_Type - (Defining_Identifier (Parent (Pdef))))) + (Defining_Identifier (Parent (Pdef)))) + and then Present (Interfaces + (Corresponding_Record_Type + (Defining_Identifier (Parent (Pdef))))) then declare Current_Node : Node_Id := Rec_Decl; @@ -7421,8 +7750,7 @@ package body Exp_Ch9 is if Ada_Version >= Ada_05 and then - Present (Abstract_Interfaces - (Corresponding_Record_Type (Prot_Typ))) + Present (Interfaces (Corresponding_Record_Type (Prot_Typ))) then Sub := Make_Subprogram_Declaration (Loc, @@ -9206,8 +9534,7 @@ package body Exp_Ch9 is if Ada_Version >= Ada_05 and then Present (Task_Definition (Parent (Ttyp))) - and then Present (Abstract_Interfaces - (Corresponding_Record_Type (Ttyp))) + and then Present (Interfaces (Corresponding_Record_Type (Ttyp))) then declare Current_Node : Node_Id; @@ -9701,10 +10028,10 @@ package body Exp_Ch9 is if Ada_Version >= Ada_05 and then Present (Taskdef) and then Present (Corresponding_Record_Type - (Defining_Identifier (Parent (Taskdef)))) - and then Present (Abstract_Interfaces - (Corresponding_Record_Type - (Defining_Identifier (Parent (Taskdef))))) + (Defining_Identifier (Parent (Taskdef)))) + and then Present (Interfaces + (Corresponding_Record_Type + (Defining_Identifier (Parent (Taskdef))))) then declare Current_Node : Node_Id := Rec_Decl; @@ -9758,7 +10085,6 @@ package body Exp_Ch9 is declare L : constant List_Id := Freeze_Entity (Rec_Ent, Loc); - begin if Is_Non_Empty_List (L) then Insert_List_After (Body_Decl, L); @@ -11247,11 +11573,11 @@ package body Exp_Ch9 is if Has_Entry or else Has_Interrupt_Handler (Ptyp) or else Has_Attach_Handler (Ptyp) - or else Has_Abstract_Interfaces (Protect_Rec) + or else Has_Interfaces (Protect_Rec) then declare - Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp); - + Pkg_Id : constant RTU_Id := + Corresponding_Runtime_Package (Ptyp); Called_Subp : RE_Id; begin @@ -11302,6 +11628,20 @@ package body Exp_Ch9 is Prefix => New_Reference_To (P_Arr, Loc), Attribute_Name => Name_Unrestricted_Access)); + + -- Build_Entry_Names generation flag. When set to true, the + -- runtime will allocate an array to hold the string names + -- of protected entries. + + if not Restricted_Profile then + if Entry_Names_OK then + Append_To (Args, + New_Reference_To (Standard_True, Loc)); + else + Append_To (Args, + New_Reference_To (Standard_False, Loc)); + end if; + end if; end if; elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then @@ -11310,6 +11650,7 @@ package body Exp_Ch9 is elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then Append_To (Args, Make_Null (Loc)); Append_To (Args, Make_Null (Loc)); + Append_To (Args, New_Reference_To (Standard_False, Loc)); end if; Append_To (L, @@ -11422,13 +11763,13 @@ package body Exp_Ch9 is function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Task_Rec); + Args : List_Id; + Ecount : Node_Id; Name : Node_Id; - Tdef : Node_Id; Tdec : Node_Id; - Ttyp : Node_Id; + Tdef : Node_Id; Tnam : Name_Id; - Args : List_Id; - Ecount : Node_Id; + Ttyp : Node_Id; begin Ttyp := Corresponding_Concurrent_Type (Task_Rec); @@ -11682,14 +12023,29 @@ package body Exp_Ch9 is Prefix => Make_Identifier (Loc, Name_uInit), Selector_Name => Make_Identifier (Loc, Name_uTask_Id))); + -- Build_Entry_Names generation flag. When set to true, the runtime + -- will allocate an array to hold the string names of task entries. + + if not Restricted_Profile then + if Has_Entries (Ttyp) + and then Entry_Names_OK + then + Append_To (Args, New_Reference_To (Standard_True, Loc)); + else + Append_To (Args, New_Reference_To (Standard_False, Loc)); + end if; + end if; + if Restricted_Profile then Name := New_Reference_To (RTE (RE_Create_Restricted_Task), Loc); else Name := New_Reference_To (RTE (RE_Create_Task), Loc); end if; - return Make_Procedure_Call_Statement (Loc, - Name => Name, Parameter_Associations => Args); + return + Make_Procedure_Call_Statement (Loc, + Name => Name, + Parameter_Associations => Args); end Make_Task_Create_Call; ------------------------------ diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 0e9715dde0d..a4c618a61cb 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -58,6 +58,11 @@ package Exp_Ch9 is -- build record declaration. N is the type declaration, Ctyp is the -- concurrent entity (task type or protected type). + function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id; + -- Create the statements which populate the entry names array of a task or + -- protected type. The statements are wrapped inside a block due to a local + -- declaration. + procedure Build_Master_Entity (E : Entity_Id); -- Given an entity E for the declaration of an object containing tasks -- or of a type declaration for an allocator whose designated type is a diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 58bd28b2d72..864206951f6 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -173,25 +173,28 @@ package body Exp_Disp is -- Handle private types of library level tagged types. We must -- exchange the private and full-view to ensure the correct - -- expansion. + -- expansion. If the full view is a synchronized type ignore + -- the type because the table will be built for the corresponding + -- record type, that has its own declaration. elsif (Nkind (D) = N_Private_Type_Declaration or else Nkind (D) = N_Private_Extension_Declaration) and then Present (Full_View (Defining_Entity (D))) - and then Is_Library_Level_Tagged_Type - (Full_View (Defining_Entity (D))) - and then Ekind (Full_View (Defining_Entity (D))) - /= E_Record_Subtype then declare E1 : constant Entity_Id := Defining_Entity (D); - E2 : constant Entity_Id := Full_View (Defining_Entity (D)); + E2 : constant Entity_Id := Full_View (E1); begin - Exchange_Declarations (E1); - Insert_List_After_And_Analyze (Last (Target_List), - Make_DT (E1)); - Exchange_Declarations (E2); + if Is_Library_Level_Tagged_Type (E2) + and then Ekind (E2) /= E_Record_Subtype + and then not Is_Concurrent_Type (E2) + then + Exchange_Declarations (E1); + Insert_List_After_And_Analyze (Last (Target_List), + Make_DT (E1)); + Exchange_Declarations (E2); + end if; end; end if; @@ -1080,7 +1083,7 @@ package body Exp_Disp is -- a parent of the type of the actual because in this case the -- interface primitives are located in the primary dispatch table. - elsif Is_Parent (Formal_Typ, Actual_Typ) then + elsif Is_Ancestor (Formal_Typ, Actual_Typ) then null; -- Implicit conversion to the class-wide formal type to force @@ -1126,7 +1129,7 @@ package body Exp_Disp is -- a parent of the type of the actual because in this case the -- interface primitives are located in the primary dispatch table. - elsif Is_Parent (Formal_DDT, Actual_DDT) then + elsif Is_Ancestor (Formal_DDT, Actual_DDT) then null; else @@ -1450,6 +1453,50 @@ package body Exp_Disp is and then not Restriction_Active (No_Dispatching_Calls); end Has_DT; + ----------------------------------------- + -- Is_Predefined_Dispatching_Operation -- + ----------------------------------------- + + function Is_Predefined_Dispatching_Operation + (E : Entity_Id) return Boolean + is + TSS_Name : TSS_Name_Type; + + begin + if not Is_Dispatching_Operation (E) then + return False; + end if; + + Get_Name_String (Chars (E)); + + -- Most predefined primitives have internally generated names. Equality + -- must be treated differently; the predefined operation is recognized + -- as a homogeneous binary operator that returns Boolean. + + if Name_Len > TSS_Name_Type'Last then + TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 + .. Name_Len)); + if Chars (E) = Name_uSize + or else Chars (E) = Name_uAlignment + or else TSS_Name = TSS_Stream_Read + or else TSS_Name = TSS_Stream_Write + or else TSS_Name = TSS_Stream_Input + or else TSS_Name = TSS_Stream_Output + or else + (Chars (E) = Name_Op_Eq + and then Etype (First_Entity (E)) = Etype (Last_Entity (E))) + or else Chars (E) = Name_uAssign + or else TSS_Name = TSS_Deep_Adjust + or else TSS_Name = TSS_Deep_Finalize + or else Is_Predefined_Interface_Primitive (E) + then + return True; + end if; + end if; + + return False; + end Is_Predefined_Dispatching_Operation; + ------------------------------------- -- Is_Predefined_Dispatching_Alias -- ------------------------------------- @@ -1475,6 +1522,21 @@ package body Exp_Disp is return False; end Is_Predefined_Dispatching_Alias; + --------------------------------------- + -- Is_Predefined_Interface_Primitive -- + --------------------------------------- + + function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is + begin + return Ada_Version >= Ada_05 + and then (Chars (E) = Name_uDisp_Asynchronous_Select or else + Chars (E) = Name_uDisp_Conditional_Select or else + Chars (E) = Name_uDisp_Get_Prim_Op_Kind or else + Chars (E) = Name_uDisp_Get_Task_Id or else + Chars (E) = Name_uDisp_Requeue or else + Chars (E) = Name_uDisp_Timed_Select); + end Is_Predefined_Interface_Primitive; + ---------------------------------------- -- Make_Disp_Asynchronous_Select_Body -- ---------------------------------------- @@ -3401,7 +3463,7 @@ package body Exp_Disp is or else Is_Controlled (Typ) or else Restriction_Active (No_Dispatching_Calls) or else not Is_Limited_Type (Typ) - or else not Has_Abstract_Interfaces (Typ) + or else not Has_Interfaces (Typ) or else not Build_Thunks then -- No OSD table required @@ -3429,11 +3491,11 @@ package body Exp_Disp is while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); - if Present (Abstract_Interface_Alias (Prim)) + if Present (Interface_Alias (Prim)) and then Find_Dispatching_Type - (Abstract_Interface_Alias (Prim)) = Iface + (Interface_Alias (Prim)) = Iface then - Prim_Alias := Abstract_Interface_Alias (Prim); + Prim_Alias := Interface_Alias (Prim); E := Prim; while Present (Alias (E)) loop @@ -3544,31 +3606,29 @@ package body Exp_Disp is Prim := Node (Prim_Elmt); if not Is_Predefined_Dispatching_Operation (Prim) - and then Present (Abstract_Interface_Alias (Prim)) + and then Present (Interface_Alias (Prim)) and then not Is_Abstract_Subprogram (Alias (Prim)) and then not Is_Imported (Alias (Prim)) and then Find_Dispatching_Type - (Abstract_Interface_Alias (Prim)) = Iface + (Interface_Alias (Prim)) = Iface -- Generate the code of the thunk only if the abstract -- interface type is not an immediate ancestor of -- Tagged_Type; otherwise the DT associated with the -- interface is the primary DT. - and then not Is_Parent (Iface, Typ) + and then not Is_Ancestor (Iface, Typ) then if not Build_Thunks then Pos := - UI_To_Int - (DT_Position (Abstract_Interface_Alias (Prim))); + UI_To_Int (DT_Position (Interface_Alias (Prim))); Prim_Table (Pos) := Alias (Prim); else Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); if Present (Thunk_Id) then Pos := - UI_To_Int - (DT_Position (Abstract_Interface_Alias (Prim))); + UI_To_Int (DT_Position (Interface_Alias (Prim))); Prim_Table (Pos) := Thunk_Id; Append_To (Result, Thunk_Code); @@ -3843,7 +3903,7 @@ package body Exp_Disp is -- Ada 2005 (AI-251): Build the secondary dispatch tables - if Has_Abstract_Interfaces (Typ) then + if Has_Interfaces (Typ) then Collect_Interface_Components (Typ, Typ_Comps); Suffix_Index := 0; @@ -4438,7 +4498,7 @@ package body Exp_Disp is -- Count the number of interface types implemented by Typ - Collect_Abstract_Interfaces (Typ, Typ_Ifaces); + Collect_Interfaces (Typ, Typ_Ifaces); AI := First_Elmt (Typ_Ifaces); while Present (AI) loop @@ -4460,7 +4520,7 @@ package body Exp_Disp is begin AI := First_Elmt (Typ_Ifaces); while Present (AI) loop - if Is_Parent (Node (AI), Typ) then + if Is_Ancestor (Node (AI), Typ) then Sec_DT_Tag := New_Reference_To (DT_Ptr, Loc); else @@ -4471,7 +4531,7 @@ package body Exp_Disp is while Ekind (Node (Elmt)) = E_Constant and then not - Is_Parent (Node (AI), Related_Type (Node (Elmt))) + Is_Ancestor (Node (AI), Related_Type (Node (Elmt))) loop pragma Assert (Has_Thunks (Node (Elmt))); Next_Elmt (Elmt); @@ -4582,7 +4642,7 @@ package body Exp_Disp is if Ada_Version >= Ada_05 and then Has_DT (Typ) and then Is_Concurrent_Record_Type (Typ) - and then Has_Abstract_Interfaces (Typ) + and then Has_Interfaces (Typ) and then Nb_Prim > 0 and then not Is_Abstract_Type (Typ) and then not Is_Controlled (Typ) @@ -4999,7 +5059,7 @@ package body Exp_Disp is Prim := Node (Prim_Elmt); if Is_Imported (Prim) - or else Present (Abstract_Interface_Alias (Prim)) + or else Present (Interface_Alias (Prim)) or else Is_Predefined_Dispatching_Operation (Prim) then null; @@ -5015,7 +5075,7 @@ package body Exp_Disp is if not Is_Predefined_Dispatching_Operation (E) and then not Is_Abstract_Subprogram (E) - and then not Present (Abstract_Interface_Alias (E)) + and then not Present (Interface_Alias (E)) then pragma Assert (UI_To_Int (DT_Position (Prim)) <= Nb_Prim); @@ -5225,11 +5285,10 @@ package body Exp_Disp is Copy_Secondary_DTs (Etype (Typ)); end if; - if Present (Abstract_Interfaces (Typ)) - and then not Is_Empty_Elmt_List - (Abstract_Interfaces (Typ)) + if Present (Interfaces (Typ)) + and then not Is_Empty_Elmt_List (Interfaces (Typ)) then - Iface := First_Elmt (Abstract_Interfaces (Typ)); + Iface := First_Elmt (Interfaces (Typ)); E := First_Entity (Typ); while Present (E) and then Present (Node (Sec_DT_Ancestor)) @@ -5392,7 +5451,7 @@ package body Exp_Disp is if Ada_Version >= Ada_05 and then Is_Concurrent_Record_Type (Typ) - and then Has_Abstract_Interfaces (Typ) + and then Has_Interfaces (Typ) then Append_List_To (Result, Make_Select_Specific_Data_Table (Typ)); @@ -5547,7 +5606,7 @@ package body Exp_Disp is -- Look for primitive overriding an abstract interface subprogram - if Present (Abstract_Interface_Alias (Prim)) + if Present (Interface_Alias (Prim)) and then not Examined (UI_To_Int (DT_Position (Alias (Prim)))) then Prim_Pos := DT_Position (Alias (Prim)); @@ -5626,7 +5685,7 @@ package body Exp_Disp is -- Collect the components associated with secondary dispatch tables - if Has_Abstract_Interfaces (Typ) then + if Has_Interfaces (Typ) then Collect_Interface_Components (Typ, Typ_Comps); end if; @@ -5777,7 +5836,7 @@ package body Exp_Disp is -- 2) Generate the secondary tag entities - if Has_Abstract_Interfaces (Typ) then + if Has_Interfaces (Typ) then Suffix_Index := 0; -- For each interface type we build an unique external name @@ -6071,7 +6130,7 @@ package body Exp_Disp is return; end if; - if not Present (Abstract_Interface_Alias (Prim)) then + if not Present (Interface_Alias (Prim)) then Tag_Typ := Scope (DTC_Entity (Prim)); Pos := DT_Position (Prim); Tag := First_Tag_Component (Tag_Typ); @@ -6128,13 +6187,13 @@ package body Exp_Disp is else Tag_Typ := Find_Dispatching_Type (Alias (Prim)); - Iface_Typ := Find_Dispatching_Type (Abstract_Interface_Alias (Prim)); + Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim)); pragma Assert (Is_Interface (Iface_Typ)); Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); - if not Is_Parent (Iface_Typ, Tag_Typ) + if not Is_Ancestor (Iface_Typ, Tag_Typ) and then Present (Thunk_Code) then -- Comment needed on why checks are suppressed. This is not just @@ -6151,7 +6210,7 @@ package body Exp_Disp is Iface_DT_Ptr := Node (Iface_DT_Elmt); pragma Assert (Has_Thunks (Iface_DT_Ptr)); - Iface_Prim := Abstract_Interface_Alias (Prim); + Iface_Prim := Interface_Alias (Prim); Pos := DT_Position (Iface_Prim); Tag := First_Tag_Component (Iface_Typ); L := New_List; @@ -6263,7 +6322,7 @@ package body Exp_Disp is -- Primitive operations covering abstract interfaces are -- allocated later - elsif Present (Abstract_Interface_Alias (Op)) then + elsif Present (Interface_Alias (Op)) then null; -- Predefined dispatching operations are completely safe. They @@ -6343,6 +6402,8 @@ package body Exp_Disp is -- Start of processing for Set_All_DT_Position begin + pragma Assert (Present (First_Tag_Component (Typ))); + -- Set the DT_Position for each primitive operation. Perform some -- sanity checks to avoid to build completely inconsistent dispatch -- tables. @@ -6498,17 +6559,14 @@ package body Exp_Disp is -- Overriding primitives of ancestor abstract interfaces - elsif Present (Abstract_Interface_Alias (Prim)) - and then Is_Parent - (Find_Dispatching_Type - (Abstract_Interface_Alias (Prim)), - Typ) + elsif Present (Interface_Alias (Prim)) + and then Is_Ancestor + (Find_Dispatching_Type (Interface_Alias (Prim)), Typ) then pragma Assert (DT_Position (Prim) = No_Uint - and then Present (DTC_Entity - (Abstract_Interface_Alias (Prim)))); + and then Present (DTC_Entity (Interface_Alias (Prim)))); - E := Abstract_Interface_Alias (Prim); + E := Interface_Alias (Prim); Set_DT_Position (Prim, DT_Position (E)); pragma Assert @@ -6520,11 +6578,11 @@ package body Exp_Disp is -- Overriding primitives must use the same entry as the -- overridden primitive. - elsif not Present (Abstract_Interface_Alias (Prim)) + elsif not Present (Interface_Alias (Prim)) and then Present (Alias (Prim)) and then Chars (Prim) = Chars (Alias (Prim)) and then Find_Dispatching_Type (Alias (Prim)) /= Typ - and then Is_Parent + and then Is_Ancestor (Find_Dispatching_Type (Alias (Prim)), Typ) and then Present (DTC_Entity (Alias (Prim))) then @@ -6554,7 +6612,7 @@ package body Exp_Disp is -- Primitives covering interface primitives are handled later - elsif Present (Abstract_Interface_Alias (Prim)) then + elsif Present (Interface_Alias (Prim)) then null; else @@ -6583,16 +6641,15 @@ package body Exp_Disp is Prim := Node (Prim_Elmt); if DT_Position (Prim) = No_Uint - and then Present (Abstract_Interface_Alias (Prim)) + and then Present (Interface_Alias (Prim)) then pragma Assert (Present (Alias (Prim)) and then Find_Dispatching_Type (Alias (Prim)) = Typ); -- Check if this entry will be placed in the primary DT - if Is_Parent (Find_Dispatching_Type - (Abstract_Interface_Alias (Prim)), - Typ) + if Is_Ancestor + (Find_Dispatching_Type (Interface_Alias (Prim)), Typ) then pragma Assert (DT_Position (Alias (Prim)) /= No_Uint); Set_DT_Position (Prim, DT_Position (Alias (Prim))); @@ -6601,9 +6658,9 @@ package body Exp_Disp is else pragma Assert - (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint); + (DT_Position (Interface_Alias (Prim)) /= No_Uint); Set_DT_Position (Prim, - DT_Position (Abstract_Interface_Alias (Prim))); + DT_Position (Interface_Alias (Prim))); end if; end if; @@ -6666,14 +6723,16 @@ package body Exp_Disp is -- point of declaration, but for inherited operations it must -- be done when building the dispatch table. - -- Ada 2005 (AI-251): Hidden entities associated with abstract - -- interface primitives are not taken into account because the - -- check is done with the aliased primitive. + -- Ada 2005 (AI-251): Primitives associated with interfaces are + -- excluded from this check because interfaces must be visible in + -- the public and private part (RM 7.3 (7.3/2)) if Is_Abstract_Type (Typ) and then Is_Abstract_Subprogram (Prim) and then Present (Alias (Prim)) - and then not Present (Abstract_Interface_Alias (Prim)) + and then not Is_Interface + (Find_Dispatching_Type (Ultimate_Alias (Prim))) + and then not Present (Interface_Alias (Prim)) and then Is_Derived_Type (Typ) and then In_Private_Part (Current_Scope) and then @@ -6789,16 +6848,14 @@ package body Exp_Disp is Prim : Entity_Id) is begin - if Present (Abstract_Interface_Alias (Prim)) + if Present (Interface_Alias (Prim)) and then Is_Interface - (Find_Dispatching_Type - (Abstract_Interface_Alias (Prim))) + (Find_Dispatching_Type (Interface_Alias (Prim))) then Set_DTC_Entity (Prim, Find_Interface_Tag (T => Tagged_Type, - Iface => Find_Dispatching_Type - (Abstract_Interface_Alias (Prim)))); + Iface => Find_Dispatching_Type (Interface_Alias (Prim)))); else Set_DTC_Entity (Prim, First_Tag_Component (Tagged_Type)); @@ -6927,12 +6984,12 @@ package body Exp_Disp is Write_Name (Chars (Scope (DTC_Entity (Alias (Prim))))); end if; - if Present (Abstract_Interface_Alias (Prim)) then + if Present (Interface_Alias (Prim)) then Write_Str (", AI_Alias of "); - Write_Name (Chars (Scope (DTC_Entity - (Abstract_Interface_Alias (Prim))))); + Write_Name + (Chars (Find_Dispatching_Type (Interface_Alias (Prim)))); Write_Char (':'); - Write_Int (Int (Abstract_Interface_Alias (Prim))); + Write_Int (Int (Interface_Alias (Prim))); end if; Write_Str (")"); diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 5bf2b6c30a4..abdc949855e 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.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- -- @@ -212,6 +212,13 @@ package Exp_Disp is -- Otherwise they are set to the defining identifier and the subprogram -- body of the generated thunk. + function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean; + -- Ada 2005 (AI-251): Determines if E is a predefined primitive operation + + function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean; + -- Ada 2005 (AI-345): Returns True if E is one of the predefined primitives + -- required to implement interfaces. + function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id; -- Expand the declarations for the Dispatch Table. The node N is the -- declaration that forces the generation of the table. It is used to place diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 47e193fb8bc..973948c4287 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -43,7 +43,6 @@ with Sem_Dist; use Sem_Dist; with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; -with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with Tbuild; use Tbuild; @@ -184,6 +183,12 @@ package body Exp_Dist is -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type). + function Build_Stub_Tag + (Loc : Source_Ptr; + RACW_Type : Entity_Id) return Node_Id; + -- Return an expression denoting the tag of the stub type associated with + -- RACW_Type. + function Build_Subprogram_Calling_Stubs (Vis_Decl : Node_Id; Subp_Id : Node_Id; @@ -382,6 +387,9 @@ package body Exp_Dist is Equal => "="); -- Mapping between a RCI subprogram and the corresponding calling stubs + function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure; + -- Return the stub information associated with the given RACW type + procedure Add_Stub_Type (Designated_Type : Entity_Id; RACW_Type : Entity_Id; @@ -1247,6 +1255,7 @@ package body Exp_Dist is RPC_Receiver := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('P')); + Specific_Build_RPC_Receiver_Body (RPC_Receiver => RPC_Receiver, Request => RPC_Receiver_Request, @@ -1388,13 +1397,14 @@ package body Exp_Dist is Parameter_Associations => New_List ( New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc), Make_String_Literal (Loc, Subp_Str))), + Then_Statements => New_List ( Make_Assignment_Statement (Loc, Name => New_Occurrence_Of ( RPC_Receiver_Subp_Index, Loc), Expression => Make_Integer_Literal (Loc, - Current_Primitive_Number))))); + Intval => Current_Primitive_Number))))); end if; Append_To (RPC_Receiver_Case_Alternatives, @@ -1465,10 +1475,6 @@ package body Exp_Dist is RAS_Type : constant Entity_Id := Defining_Identifier (N); Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type); RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type); - Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type)); - - Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); - pragma Assert (Stub_Elements /= Empty_Stub_Structure); RACW_Primitive_Name : Node_Id; @@ -1642,17 +1648,16 @@ package body Exp_Dist is Subp_Name : constant Entity_Id := Defining_Unit_Name (Specification (Vis_Decl)); - Pkg_Name : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => - New_External_Name (Chars (Subp_Name), 'P', -1)); + Pkg_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Subp_Name), 'P', -1)); Proxy_Type : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => - New_External_Name ( - Related_Id => Chars (Subp_Name), - Suffix => 'P')); + New_External_Name + (Related_Id => Chars (Subp_Name), + Suffix => 'P')); Proxy_Type_Full_View : constant Entity_Id := Make_Defining_Identifier (Loc, @@ -1698,12 +1703,9 @@ package body Exp_Dist is Append_To (Vis_Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Proxy_Object_Addr, - Constant_Present => - True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Address), Loc))); + Defining_Identifier => Proxy_Object_Addr, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc))); -- private @@ -1714,8 +1716,7 @@ package body Exp_Dist is Append_To (Pvt_Decls, Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Proxy_Type_Full_View, + Defining_Identifier => Proxy_Type_Full_View, Type_Definition => Build_Remote_Subprogram_Proxy_Type (Loc, New_Occurrence_Of (All_Calls_Remote_E, Loc)))); @@ -1743,19 +1744,15 @@ package body Exp_Dist is if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then Perform_Call := Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Subp_Name, Loc), - Parameter_Associations => - Actuals); + Name => New_Occurrence_Of (Subp_Name, Loc), + Parameter_Associations => Actuals); else Perform_Call := Make_Simple_Return_Statement (Loc, Expression => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (Subp_Name, Loc), - Parameter_Associations => - Actuals)); + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Subp_Name, Loc), + Parameter_Associations => Actuals)); end if; Formal := First (Parameter_Specifications (Subp_Decl_Spec)); @@ -1771,31 +1768,23 @@ package body Exp_Dist is Append_To (Pvt_Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Name_uO), - Aliased_Present => - True, - Object_Definition => - New_Occurrence_Of (Proxy_Type, Loc))); + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (Proxy_Type, Loc))); -- A : constant System.Address := O'Address; Append_To (Pvt_Decls, Make_Object_Declaration (Loc, Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars (Proxy_Object_Addr)), - Constant_Present => - True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Address), Loc), + Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)), + Constant_Present => True, + Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc), Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of ( Defining_Identifier (Last (Pvt_Decls)), Loc), - Attribute_Name => - Name_Address))); + Attribute_Name => Name_Address))); Append_To (Decls, Make_Package_Declaration (Loc, @@ -1809,12 +1798,10 @@ package body Exp_Dist is Append_To (Decls, Make_Package_Body (Loc, Defining_Unit_Name => - Make_Defining_Identifier (Loc, - Chars (Pkg_Name)), + Make_Defining_Identifier (Loc, Chars (Pkg_Name)), Declarations => New_List ( Make_Subprogram_Body (Loc, - Specification => - Subp_Body_Spec, + Specification => Subp_Body_Spec, Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, @@ -2058,10 +2045,8 @@ package body Exp_Dist is Chars => Name_Address, Expression => Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Constant_Object, Loc), - Attribute_Name => - Name_Address))); + Prefix => New_Occurrence_Of (Constant_Object, Loc), + Attribute_Name => Name_Address))); end; end if; @@ -2077,8 +2062,7 @@ package body Exp_Dist is Make_Object_Declaration (Loc, Defining_Identifier => Object, Constant_Present => Present (Expr) and then not Variable, - Object_Definition => - New_Occurrence_Of (Etyp, Loc), + Object_Definition => New_Occurrence_Of (Etyp, Loc), Expression => Expr)); if Constant_Present (Last (Decls)) then @@ -2110,17 +2094,14 @@ package body Exp_Dist is Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Pointer, Loc), + Prefix => New_Occurrence_Of (Pointer, Loc), Selector_Name => New_Occurrence_Of (First_Tag_Component (Designated_Type (Etype (Pointer))), Loc)), Expression => Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Stub_Type, Loc), - Attribute_Name => - Name_Tag))); + Prefix => New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => Name_Tag))); -- Note: The assignment to Pointer._Tag is safe here because -- we carefully ensured that Stub_Type has exactly the same layout @@ -2227,8 +2208,7 @@ package body Exp_Dist is Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), - Attribute_Name => - Name_Version))); + Attribute_Name => Name_Version))); Append_To (L, Reg); Analyze (Reg); end Build_Passive_Partition_Stub; @@ -2302,6 +2282,22 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)))))); end Build_Remote_Subprogram_Proxy_Type; + -------------------- + -- Build_Stub_Tag -- + -------------------- + + function Build_Stub_Tag + (Loc : Source_Ptr; + RACW_Type : Entity_Id) return Node_Id + is + Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type); + begin + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => Name_Tag); + end Build_Stub_Tag; + ------------------------------------ -- Build_Subprogram_Calling_Stubs -- ------------------------------------ @@ -2689,8 +2685,7 @@ package body Exp_Dist is Append_To (Stmts, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_NVList_Create), Loc), + Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (NVList, Loc)))); end Declare_Create_NVList; @@ -2818,7 +2813,9 @@ package body Exp_Dist is declare HSS_Stmts : constant List_Id := Statements (Handled_Statement_Sequence (Unit_Node)); + First_HSS_Stmt : constant Node_Id := First (HSS_Stmts); + begin if No (First_HSS_Stmt) then Append_List_To (HSS_Stmts, Stubs_Stmts); @@ -2878,7 +2875,8 @@ package body Exp_Dist is (Loc : Source_Ptr; Decls : List_Id; RPC_Receiver : Entity_Id; - Stub_Elements : Stub_Structure) is + Stub_Elements : Stub_Structure) + is begin -- The RPC receiver body should not be the completion of the -- declaration recorded in the stub structure, because then the @@ -2931,18 +2929,18 @@ package body Exp_Dist is Attribute_Name => Name_Address); end if; - Add_RACW_Write_Attribute ( - RACW_Type, - Stub_Type, - Stub_Type_Access, - RPC_Receiver, - Body_Decls); - - Add_RACW_Read_Attribute ( - RACW_Type, - Stub_Type, - Stub_Type_Access, - Body_Decls); + Add_RACW_Write_Attribute + (RACW_Type, + Stub_Type, + Stub_Type_Access, + RPC_Receiver, + Body_Decls); + + Add_RACW_Read_Attribute + (RACW_Type, + Stub_Type, + Stub_Type_Access, + Body_Decls); end Add_RACW_Features; ----------------------------- @@ -3001,6 +2999,7 @@ package body Exp_Dist is Insert_After (Proc_Decl, Attr_Decl); if No (Body_Decls) then + -- Case of processing an RACW type from another unit than the -- main one: do not generate a body. @@ -3273,35 +3272,31 @@ package body Exp_Dist is -- a remote object. Remote_Statements := New_List ( - Pack_Node_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => + Stream => Stream_Parameter, + Object => Make_Selected_Component (Loc, - Prefix => Unchecked_Convert_To (Stub_Type_Access, - Object), - Selector_Name => - Make_Identifier (Loc, Name_Origin)), - Etyp => RTE (RE_Partition_ID)), + Prefix => + Unchecked_Convert_To (Stub_Type_Access, Object), + Selector_Name => Make_Identifier (Loc, Name_Origin)), + Etyp => RTE (RE_Partition_ID)), Pack_Node_Into_Stream_Access (Loc, Stream => Stream_Parameter, Object => Make_Selected_Component (Loc, - Prefix => Unchecked_Convert_To (Stub_Type_Access, - Object), - Selector_Name => - Make_Identifier (Loc, Name_Receiver)), + Prefix => + Unchecked_Convert_To (Stub_Type_Access, Object), + Selector_Name => Make_Identifier (Loc, Name_Receiver)), Etyp => RTE (RE_Unsigned_64)), Pack_Node_Into_Stream_Access (Loc, Stream => Stream_Parameter, Object => Make_Selected_Component (Loc, - Prefix => Unchecked_Convert_To (Stub_Type_Access, - Object), - Selector_Name => - Make_Identifier (Loc, Name_Addr)), + Prefix => + Unchecked_Convert_To (Stub_Type_Access, Object), + Selector_Name => Make_Identifier (Loc, Name_Addr)), Etyp => RTE (RE_Unsigned_64))); -- Build code fragment corresponding to marshalling of a null object @@ -3328,7 +3323,9 @@ package body Exp_Dist is Make_Op_Eq (Loc, Left_Opnd => Object, Right_Opnd => Make_Null (Loc)), + Then_Statements => Null_Statements, + Elsif_Parts => New_List ( Make_Elsif_Part (Loc, Condition => @@ -3337,6 +3334,7 @@ package body Exp_Dist is Make_Attribute_Reference (Loc, Prefix => Object, Attribute_Name => Name_Tag), + Right_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Stub_Type, Loc), @@ -3451,7 +3449,7 @@ package body Exp_Dist is begin Proc_Decls := New_List ( - -- Common declarations + -- Common declarations Make_Object_Declaration (Loc, Defining_Identifier => Origin, @@ -3465,15 +3463,15 @@ package body Exp_Dist is Parameter_Associations => New_List ( New_Occurrence_Of (Package_Name, Loc)))), - -- Declaration use only in the local case: proxy address + -- Declaration use only in the local case: proxy address Make_Object_Declaration (Loc, Defining_Identifier => Proxy_Addr, Object_Definition => New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), - -- Declarations used only in the remote case: stub object and - -- stub pointer. + -- Declarations used only in the remote case: stub object and + -- stub pointer. Make_Object_Declaration (Loc, Defining_Identifier => Local_Stub, @@ -3492,7 +3490,8 @@ package body Exp_Dist is Attribute_Name => Name_Unchecked_Access))); Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); - -- Build_Get_Unique_RP_Call needs this information + + -- Build_Get_Unique_RP_Call needs above information -- Note: Here we assume that the Fat_Type is a record -- containing just a pointer to a proxy or stub object. @@ -3509,8 +3508,7 @@ package body Exp_Dist is -- end if; Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), + Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Package_Name, Loc), New_Occurrence_Of (Subp_Id, Loc), @@ -3527,9 +3525,11 @@ package body Exp_Dist is Make_Function_Call (Loc, New_Occurrence_Of ( RTE (RE_Get_Local_Partition_Id), Loc))), + Right_Opnd => Make_Op_Not (Loc, New_Occurrence_Of (All_Calls_Remote, Loc))), + Then_Statements => New_List ( Make_Simple_Return_Statement (Loc, Unchecked_Convert_To (Fat_Type, @@ -3548,12 +3548,12 @@ package body Exp_Dist is Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)), - -- E.4.1(9) A remote call is asynchronous if it is a call to - -- a procedure, or a call through a value of an access-to-procedure - -- type, to which a pragma Asynchronous applies. + -- E.4.1(9) A remote call is asynchronous if it is a call to + -- a procedure or a call through a value of an access-to-procedure + -- type to which a pragma Asynchronous applies. - -- Parameter Asynch_P is true when the procedure is asynchronous; - -- Expression Asynch_T is true when the type is asynchronous. + -- Asynch_P is true when the procedure is asynchronous; + -- Asynch_T is true when the type is asynchronous. Set_Field (Name_Asynchronous, Make_Or_Else (Loc, @@ -3704,8 +3704,7 @@ package body Exp_Dist is New_List ( Make_Procedure_Call_Statement (Loc, Name => - New_Occurrence_Of ( - Defining_Entity (Stubs), Loc), + New_Occurrence_Of (Defining_Entity (Stubs), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Request_Parameter, Loc)))))); end Append_Stubs_To; @@ -3748,10 +3747,12 @@ package body Exp_Dist is Make_Op_Eq (Loc, New_Occurrence_Of (Subp_Id, Loc), Make_Integer_Literal (Loc, 0)), + Then_Statements => New_List ( Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Subp_Id, Loc), + Expression => Make_Selected_Component (Loc, Prefix => @@ -3766,6 +3767,7 @@ package body Exp_Dist is Make_Selected_Component (Loc, Prefix => Request_Parameter, Selector_Name => Name_Params))))), + Selector_Name => Make_Identifier (Loc, Name_Subp_Id)))))); @@ -3787,6 +3789,7 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))), Result_Definition => New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))); + Append_To (Decls, Current_Declaration); Analyze (Current_Declaration); @@ -3869,6 +3872,7 @@ package body Exp_Dist is Choices => New_List ( Make_Integer_Literal (Loc, Current_Subprogram_Number)), + Expression => Make_Aggregate (Loc, Component_Associations => New_List ( @@ -3880,10 +3884,8 @@ package body Exp_Dist is Proxy_Object_Addr, Loc)))))); Append_Stubs_To (Pkg_RPC_Receiver_Cases, - Stubs => - Current_Stubs, - Subprogram_Number => - Current_Subprogram_Number); + Stubs => Current_Stubs, + Subprogram_Number => Current_Subprogram_Number); end; Current_Subprogram_Number := Current_Subprogram_Number + 1; @@ -3902,15 +3904,12 @@ package body Exp_Dist is Append_To (Pkg_RPC_Receiver_Cases, Make_Case_Statement_Alternative (Loc, - Discrete_Choices => - New_List (Make_Others_Choice (Loc)), - Statements => - New_List (Make_Null_Statement (Loc)))); + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); Append_To (Pkg_RPC_Receiver_Statements, Make_Case_Statement (Loc, - Expression => - New_Occurrence_Of (Subp_Id, Loc), + Expression => New_Occurrence_Of (Subp_Id, Loc), Alternatives => Pkg_RPC_Receiver_Cases)); Append_To (Decls, @@ -3930,8 +3929,9 @@ package body Exp_Dist is First_RCI_Subprogram_Id), High_Bound => Make_Integer_Literal (Loc, - First_RCI_Subprogram_Id - + List_Length (Subp_Info_List) - 1))))))); + Intval => + First_RCI_Subprogram_Id + + List_Length (Subp_Info_List) - 1))))))); -- For a degenerate RCI with no visible subprograms, Subp_Info_List -- has zero length, and the declaration is for an empty array, in @@ -3962,13 +3962,11 @@ package body Exp_Dist is Make_Selected_Component (Loc, Prefix => Make_Indexed_Component (Loc, - Prefix => - New_Occurrence_Of (Subp_Info_Array, Loc), + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), Expressions => New_List ( Convert_To (Standard_Integer, Make_Identifier (Loc, Name_Subp_Id)))), - Selector_Name => - Make_Identifier (Loc, Name_Addr)); + Selector_Name => Make_Identifier (Loc, Name_Addr)); -- Case of no visible subprogram: just raise Constraint_Error, we -- know for sure we got junk from a remote partition. @@ -3984,15 +3982,14 @@ package body Exp_Dist is Make_Subprogram_Body (Loc, Specification => Copy_Specification (Loc, Parent (Lookup_RAS_Info)), - Declarations => - No_List, + Declarations => No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Simple_Return_Statement (Loc, Expression => - OK_Convert_To (RTE (RE_Unsigned_64), - Subp_Info_Addr)))))); + OK_Convert_To + (RTE (RE_Unsigned_64), Subp_Info_Addr)))))); end; Analyze (Last (Decls)); @@ -4012,10 +4009,8 @@ package body Exp_Dist is Append_To (Register_Pkg_Actuals, Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Pkg_RPC_Receiver, Loc), - Attribute_Name => - Name_Unrestricted_Access)); + Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc), + Attribute_Name => Name_Unrestricted_Access)); -- Version @@ -4023,26 +4018,21 @@ package body Exp_Dist is Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), - Attribute_Name => - Name_Version)); + Attribute_Name => Name_Version)); -- Subp_Info Append_To (Register_Pkg_Actuals, Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Info_Array, Loc), - Attribute_Name => - Name_Address)); + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => Name_Address)); -- Subp_Info_Len Append_To (Register_Pkg_Actuals, Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Info_Array, Loc), - Attribute_Name => - Name_Length)); + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => Name_Length)); -- Generate the call @@ -4180,10 +4170,8 @@ package body Exp_Dist is Attribute_Name => Name_Write, Expressions => New_List ( Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => - Name_Access), + Prefix => New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), Target_RPC_Receiver))); -- Then put the Subprogram_Id of the subprogram we want to call in @@ -4191,14 +4179,11 @@ package body Exp_Dist is Append_To (Statements, Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), - Attribute_Name => - Name_Write, + Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => Name_Write, Expressions => New_List ( Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Stream_Parameter, Loc), + Prefix => New_Occurrence_Of (Stream_Parameter, Loc), Attribute_Name => Name_Access), Subprogram_Id))); @@ -4214,7 +4199,7 @@ package body Exp_Dist is begin if Is_RACW_Controlling_Formal - (Current_Parameter, Stub_Type) + (Current_Parameter, Stub_Type) then -- In the case of a controlling formal argument, we marshall -- its addr field rather than the local stub. @@ -4230,8 +4215,9 @@ package body Exp_Dist is Etyp => RTE (RE_Unsigned_64))); else - Value := New_Occurrence_Of - (Defining_Identifier (Current_Parameter), Loc); + Value := + New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc); -- Access type parameters are transmitted as in out -- parameters. However, a dereference is needed so that @@ -4255,8 +4241,7 @@ package body Exp_Dist is then Append_To (Statements, Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Etyp, Loc), + Prefix => New_Occurrence_Of (Etyp, Loc), Attribute_Name => Output_From_Constrained (Constrained), Expressions => New_List ( @@ -4302,13 +4287,12 @@ package body Exp_Dist is Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Standard_Boolean, Loc), - Attribute_Name => - Name_Write, + Attribute_Name => Name_Write, Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => - New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => + New_Occurrence_Of + (Stream_Parameter, Loc), Attribute_Name => Name_Access), New_Occurrence_Of (Extra_Parameter, Loc)))); end if; @@ -4334,8 +4318,7 @@ package body Exp_Dist is Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => - Name_Access)))); + Attribute_Name => Name_Access)))); else Asynchronous_Statements := No_List; end if; @@ -4354,14 +4337,12 @@ package body Exp_Dist is Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => - Name_Access), + Attribute_Name => Name_Access), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Result_Parameter, Loc), - Attribute_Name => - Name_Access)))); + Attribute_Name => Name_Access)))); -- Read the exception occurrence from the result stream and -- reraise it. It does no harm if this is a Null_Occurrence since @@ -4372,15 +4353,13 @@ package body Exp_Dist is Prefix => New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), - Attribute_Name => - Name_Read, + Attribute_Name => Name_Read, Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Result_Parameter, Loc), - Attribute_Name => - Name_Access), + Attribute_Name => Name_Access), New_Occurrence_Of (Exception_Return_Parameter, Loc)))); Append_To (Non_Asynchronous_Statements, @@ -4453,8 +4432,7 @@ package body Exp_Dist is Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Result_Parameter, Loc), - Attribute_Name => - Name_Access), + Attribute_Name => Name_Access), Value))); end if; end; @@ -4545,9 +4523,9 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), Attribute_Name => Name_Input, Expressions => New_List ( - Make_Selected_Component (Loc, - Prefix => Request, - Selector_Name => Name_Params))))); + Make_Selected_Component (Loc, + Prefix => Request, + Selector_Name => Name_Params))))); Stmts := New_List; @@ -4785,9 +4763,9 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), Attribute_Name => Name_Write, Expressions => New_List ( - Make_Selected_Component (Loc, - Prefix => Request_Parameter, - Selector_Name => Name_Result), + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Result), New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); if Dynamically_Asynchronous then @@ -4870,15 +4848,19 @@ package body Exp_Dist is Append_To (Decls, Input_With_Tag_Check (Loc, Var_Type => Etyp, - Stream => Make_Selected_Component (Loc, - Prefix => Request_Parameter, - Selector_Name => Name_Params))); + Stream => + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Params))); -- Prepare function call expression - Expr := Make_Function_Call (Loc, - New_Occurrence_Of (Defining_Unit_Name - (Specification (Last (Decls))), Loc)); + Expr := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (Defining_Unit_Name + (Specification (Last (Decls))), Loc)); end if; end if; @@ -5217,6 +5199,19 @@ package body Exp_Dist is end Get_And_Reset_RACW_Bodies; ----------------------- + -- Get_Stub_Elements -- + ----------------------- + + function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); + Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); + begin + pragma Assert (Stub_Elements /= Empty_Stub_Structure); + return Stub_Elements; + end Get_Stub_Elements; + + ----------------------- -- Get_Subprogram_Id -- ----------------------- @@ -5502,16 +5497,11 @@ package body Exp_Dist is procedure Add_RACW_From_Any (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; Body_Decls : List_Id); -- Add the From_Any TSS for this RACW type procedure Add_RACW_To_Any - (Designated_Type : Entity_Id; - RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; + (RACW_Type : Entity_Id; Body_Decls : List_Id); -- Add the To_Any TSS for this RACW type @@ -5598,21 +5588,12 @@ package body Exp_Dist is begin Add_RACW_From_Any (RACW_Type => RACW_Type, - Stub_Type => Stub_Type, - Stub_Type_Access => Stub_Type_Access, Body_Decls => Body_Decls); Add_RACW_To_Any - (Designated_Type => Desig, - RACW_Type => RACW_Type, - Stub_Type => Stub_Type, - Stub_Type_Access => Stub_Type_Access, + (RACW_Type => RACW_Type, Body_Decls => Body_Decls); - -- In the PolyORB case, the RACW 'Read and 'Write attributes are - -- implemented in terms of the From_Any and To_Any TSSs, so these - -- TSSs must be expanded before 'Read and 'Write. - Add_RACW_Write_Attribute (RACW_Type => RACW_Type, Stub_Type => Stub_Type, @@ -5637,8 +5618,6 @@ package body Exp_Dist is procedure Add_RACW_From_Any (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; Body_Decls : List_Id) is Loc : constant Source_Ptr := Sloc (RACW_Type); @@ -5652,28 +5631,12 @@ package body Exp_Dist is Func_Decl : Node_Id; Func_Body : Node_Id; - Decls : List_Id; Statements : List_Id; - Stub_Statements : List_Id; - Local_Statements : List_Id; -- Various parts of the subprogram Any_Parameter : constant Entity_Id := Make_Defining_Identifier (Loc, Name_A); - Reference : Entity_Id; - Is_Local : Entity_Id; - Addr : Entity_Id; - Local_Stub : Entity_Id; - Stubbed_Result : Entity_Id; - - Stub_Condition : Node_Id; - -- An expression that determines whether we create a stub for the - -- newly-unpacked RACW. Normally we create a stub only for remote - -- objects, but in the case of an RACW used to implement a RAS, we - -- also create a stub for local subprograms if a pragma - -- All_Calls_Remote applies. - Asynchronous_Flag : constant Entity_Id := Asynchronous_Flags_Table.Get (RACW_Type); -- The flag object declared in Add_RACW_Asynchronous_Flag @@ -5702,119 +5665,6 @@ package body Exp_Dist is return; end if; - -- Object declarations - - Reference := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - Is_Local := - Make_Defining_Identifier (Loc, New_Internal_Name ('L')); - Addr := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); - Local_Stub := - Make_Defining_Identifier (Loc, New_Internal_Name ('L')); - Stubbed_Result := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - - Decls := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => - Reference, - Object_Definition => - New_Occurrence_Of (RTE (RE_Object_Ref), Loc), - Expression => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Any_Parameter, Loc)))), - - Make_Object_Declaration (Loc, - Defining_Identifier => Local_Stub, - Aliased_Present => True, - Object_Definition => New_Occurrence_Of (Stub_Type, Loc)), - - Make_Object_Declaration (Loc, - Defining_Identifier => Stubbed_Result, - Object_Definition => - New_Occurrence_Of (Stub_Type_Access, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Local_Stub, Loc), - Attribute_Name => - Name_Unchecked_Access)), - - Make_Object_Declaration (Loc, - Defining_Identifier => Is_Local, - Object_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)), - - Make_Object_Declaration (Loc, - Defining_Identifier => Addr, - Object_Definition => - New_Occurrence_Of (RTE (RE_Address), Loc))); - - -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result - - Set_Etype (Stubbed_Result, Stub_Type_Access); - - -- If the ref Is_Nil, return a null pointer - - Statements := New_List ( - Make_Implicit_If_Statement (RACW_Type, - Condition => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Is_Nil), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Reference, Loc))), - Then_Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => - Make_Null (Loc))))); - - Append_To (Statements, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Reference, Loc), - New_Occurrence_Of (Is_Local, Loc), - New_Occurrence_Of (Addr, Loc)))); - - -- If the object is located on another partition, then a stub object - -- will be created with all the information needed to rebuild the - -- real object at the other end. This stanza is always used in the - -- case of RAS types, for which a stub is required even for local - -- subprograms. - - Stub_Statements := New_List ( - Make_Assignment_Statement (Loc, - Name => Make_Selected_Component (Loc, - Prefix => Stubbed_Result, - Selector_Name => Name_Target), - Expression => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Entity_Of), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Reference, Loc)))), - - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), - Parameter_Associations => New_List ( - Make_Selected_Component (Loc, - Prefix => Stubbed_Result, - Selector_Name => Name_Target))), - - Make_Assignment_Statement (Loc, - Name => Make_Selected_Component (Loc, - Prefix => Stubbed_Result, - Selector_Name => Name_Asynchronous), - Expression => - New_Occurrence_Of (Asynchronous_Flag, Loc))); - -- ??? Issue with asynchronous calls here: the Asynchronous flag is -- set on the stub type if, and only if, the RACW type has a pragma -- Asynchronous. This is incorrect for RACWs that implement RAS @@ -5825,52 +5675,24 @@ package body Exp_Dist is -- the Asynchronous component in the stub type in the RAS's _From_Any -- TSS. - Append_List_To (Stub_Statements, - Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type)); - - -- Distinguish between the local and remote cases, and execute the - -- appropriate piece of code. - - Stub_Condition := New_Occurrence_Of (Is_Local, Loc); - - if Is_RAS then - Stub_Condition := Make_And_Then (Loc, - Left_Opnd => - Stub_Condition, - Right_Opnd => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To ( - RTE (RE_RAS_Proxy_Type_Access), - New_Occurrence_Of (Addr, Loc)), - Selector_Name => - Make_Identifier (Loc, - Name_All_Calls_Remote))); - end if; - - Local_Statements := New_List ( - Make_Simple_Return_Statement (Loc, - Expression => - Unchecked_Convert_To (RACW_Type, - New_Occurrence_Of (Addr, Loc)))); - - Append_To (Statements, - Make_Implicit_If_Statement (RACW_Type, - Condition => - Stub_Condition, - Then_Statements => Local_Statements, - Else_Statements => Stub_Statements)); - - Append_To (Statements, + Statements := New_List ( Make_Simple_Return_Statement (Loc, Expression => Unchecked_Convert_To (RACW_Type, - New_Occurrence_Of (Stubbed_Result, Loc)))); + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc), + Parameter_Associations => New_List ( + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any_Parameter, Loc))), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + New_Occurrence_Of (Asynchronous_Flag, Loc)))))); Func_Body := Make_Subprogram_Body (Loc, - Specification => - Copy_Specification (Loc, Func_Spec), - Declarations => Decls, + Specification => Copy_Specification (Loc, Func_Spec), + Declarations => No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Statements)); @@ -5898,21 +5720,24 @@ package body Exp_Dist is Body_Node : Node_Id; - Decls : List_Id; - Statements : constant List_Id := New_List; + Decls : constant List_Id := New_List; + Statements : constant List_Id := New_List; + Reference : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_R); -- Various parts of the procedure - Pnam : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Pnam : constant Entity_Id := Make_Defining_Identifier (Loc, + New_Internal_Name ('R')); + + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); - Source_Ref : Entity_Id; Asynchronous_Flag : constant Entity_Id := Asynchronous_Flags_Table.Get (RACW_Type); pragma Assert (Present (Asynchronous_Flag)); function Stream_Parameter return Node_Id; function Result return Node_Id; + -- Functions to create occurrences of the formal parameter names ------------ @@ -5957,15 +5782,11 @@ package body Exp_Dist is return; end if; - Source_Ref := Make_Defining_Identifier - (Loc, New_Internal_Name ('R')); - - -- Generate object declarations - - Decls := New_List ( + Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => Source_Ref, - Object_Definition => + Defining_Identifier => + Reference, + Object_Definition => New_Occurrence_Of (RTE (RE_Object_Ref), Loc))); Append_List_To (Statements, New_List ( @@ -5975,19 +5796,21 @@ package body Exp_Dist is Attribute_Name => Name_Read, Expressions => New_List ( Stream_Parameter, - New_Occurrence_Of (Source_Ref, Loc))), + New_Occurrence_Of (Reference, Loc))), + Make_Assignment_Statement (Loc, - Name => + Name => Result, Expression => - PolyORB_Support.Helpers.Build_From_Any_Call ( - RACW_Type, + Unchecked_Convert_To (RACW_Type, Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc), + Name => + New_Occurrence_Of (RTE (RE_Get_RACW), Loc), Parameter_Associations => New_List ( - New_Occurrence_Of (Source_Ref, Loc))), - Decls)))); + New_Occurrence_Of (Reference, Loc), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + New_Occurrence_Of (Asynchronous_Flag, Loc))))))); Set_Declarations (Body_Node, Decls); Append_To (Body_Decls, Body_Node); @@ -5998,23 +5821,19 @@ package body Exp_Dist is --------------------- procedure Add_RACW_To_Any - (Designated_Type : Entity_Id; - RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; + (RACW_Type : Entity_Id; Body_Decls : List_Id) is Loc : constant Source_Ptr := Sloc (RACW_Type); - Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); - Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (RACW_Type), 'T')); + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + Stub_Elements : constant Stub_Structure := - Stubs_Table.Get (Designated_Type); - pragma Assert (Stub_Elements /= Empty_Stub_Structure); + Get_Stub_Elements (RACW_Type); Func_Spec : Node_Id; Func_Decl : Node_Id; @@ -6022,10 +5841,6 @@ package body Exp_Dist is Decls : List_Id; Statements : List_Id; - Null_Statements : List_Id; - Local_Statements : List_Id := No_List; - Stub_Statements : List_Id; - If_Node : Node_Id; -- Various parts of the subprogram RACW_Parameter : constant Entity_Id := @@ -6063,120 +5878,62 @@ package body Exp_Dist is return; end if; - -- Object declarations + -- Generate: + + -- R : constant Object_Ref := + -- Get_Reference + -- (Address!(RACW), + -- "typ", + -- Stub_Type'Tag, + -- Is_RAS, + -- RPC_Receiver'Access); + -- A : Any; Decls := New_List ( Make_Object_Declaration (Loc, - Defining_Identifier => - Reference, - Object_Definition => - New_Occurrence_Of (RTE (RE_Object_Ref), Loc)), - Make_Object_Declaration (Loc, - Defining_Identifier => - Any, - Object_Definition => - New_Occurrence_Of (RTE (RE_Any), Loc))); - - -- If the object is null, nothing to do (Reference is already - -- a Nil ref.) - - Null_Statements := New_List (Make_Null_Statement (Loc)); - - if Is_RAS then - - -- If the object is a RAS designating a local subprogram, we - -- already have a target reference. - - Local_Statements := New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_Ref), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Reference, Loc), - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), - New_Occurrence_Of (RACW_Parameter, Loc)), - Selector_Name => Make_Identifier (Loc, Name_Target))))); - - else - -- If the object is a local RACW object, use Get_Reference now to - -- obtain a reference. - - Local_Statements := New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_Reference), Loc), - Parameter_Associations => New_List ( - Unchecked_Convert_To ( - RTE (RE_Address), - New_Occurrence_Of (RACW_Parameter, Loc)), - Make_String_Literal (Loc, - Full_Qualified_Name (Designated_Type)), - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of ( - Defining_Identifier ( - Stub_Elements.RPC_Receiver_Decl), Loc), - Attribute_Name => - Name_Access), - New_Occurrence_Of (Reference, Loc)))); - end if; - - -- If the object is located on another partition, use the target from - -- the stub. + Defining_Identifier => Reference, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), + New_Occurrence_Of (RACW_Parameter, Loc)), + Make_String_Literal (Loc, + Strval => Full_Qualified_Name + (Etype (Designated_Type (RACW_Type)))), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Defining_Identifier + (Stub_Elements.RPC_Receiver_Decl), Loc), + Attribute_Name => Name_Access)))), - Stub_Statements := New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_Ref), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Reference, Loc), - Make_Selected_Component (Loc, - Prefix => Unchecked_Convert_To (Stub_Type_Access, - New_Occurrence_Of (RACW_Parameter, Loc)), - Selector_Name => - Make_Identifier (Loc, Name_Target))))); + Make_Object_Declaration (Loc, + Defining_Identifier => Any, + Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc))); - -- Distinguish between the null, local and remote cases, and execute - -- the appropriate piece of code. + -- Generate: - If_Node := - Make_Implicit_If_Statement (RACW_Type, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => New_Occurrence_Of (RACW_Parameter, Loc), - Right_Opnd => Make_Null (Loc)), - Then_Statements => Null_Statements, - Elsif_Parts => New_List ( - Make_Elsif_Part (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RACW_Parameter, Loc), - Attribute_Name => Name_Tag), - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Stub_Type, Loc), - Attribute_Name => Name_Tag)), - Then_Statements => Local_Statements)), - Else_Statements => Stub_Statements); + -- Any := TA_ObjRef (Reference); + -- Set_TC (Any, RPC_Receiver.Obj_TypeCode); + -- return Any; Statements := New_List ( - If_Node, Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of (Any, Loc), + Name => New_Occurrence_Of (Any, Loc), Expression => Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Reference, Loc)))), + Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_TC), Loc), + Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc), Make_Selected_Component (Loc, @@ -6184,14 +5941,13 @@ package body Exp_Dist is Defining_Identifier ( Stub_Elements.RPC_Receiver_Decl), Selector_Name => Name_Obj_TypeCode))), + Make_Simple_Return_Statement (Loc, - Expression => - New_Occurrence_Of (Any, Loc))); + Expression => New_Occurrence_Of (Any, Loc))); Func_Body := Make_Subprogram_Body (Loc, - Specification => - Copy_Specification (Loc, Func_Spec), + Specification => Copy_Specification (Loc, Func_Spec), Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, @@ -6229,9 +5985,8 @@ package body Exp_Dist is Func_Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => - Fnam, - Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); + Defining_Unit_Name => Fnam, + Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); -- NOTE: The usage occurrences of RACW_Parameter must refer to the -- entity in the declaration spec, not those of the body spec. @@ -6246,8 +6001,7 @@ package body Exp_Dist is Func_Body := Make_Subprogram_Body (Loc, - Specification => - Copy_Specification (Loc, Func_Spec), + Specification => Copy_Specification (Loc, Func_Spec), Declarations => Empty_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, @@ -6256,8 +6010,8 @@ package body Exp_Dist is Expression => Make_Selected_Component (Loc, Prefix => - Defining_Identifier ( - Stub_Elements.RPC_Receiver_Decl), + Defining_Identifier + (Stub_Elements.RPC_Receiver_Decl), Selector_Name => Name_Obj_TypeCode))))); Append_To (Body_Decls, Func_Body); @@ -6279,11 +6033,16 @@ package body Exp_Dist is Loc : constant Source_Ptr := Sloc (RACW_Type); + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + + Stub_Elements : constant Stub_Structure := + Get_Stub_Elements (RACW_Type); + Body_Node : Node_Id; Proc_Decl : Node_Id; Attr_Decl : Node_Id; - Statements : constant List_Id := New_List; + Statements : constant List_Id := New_List; Pnam : constant Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); @@ -6296,15 +6055,8 @@ package body Exp_Dist is ------------ function Object return Node_Id is - Object_Ref : constant Node_Id := - Make_Identifier (Loc, Name_V); - begin - -- Etype must be set for Build_To_Any_Call - - Set_Etype (Object_Ref, RACW_Type); - - return Object_Ref; + return Make_Identifier (Loc, Name_V); end Object; ---------------------- @@ -6346,11 +6098,21 @@ package body Exp_Dist is Stream => Stream_Parameter, Object => Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc), + Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), Parameter_Associations => New_List ( - PolyORB_Support.Helpers.Build_To_Any_Call - (Object, Body_Decls))), + Unchecked_Convert_To (RTE (RE_Address), Object), + Make_String_Literal (Loc, + Strval => Full_Qualified_Name + (Etype (Designated_Type (RACW_Type)))), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Defining_Identifier + (Stub_Elements.RPC_Receiver_Decl), Loc), + Attribute_Name => Name_Access))), + Etyp => RTE (RE_Object_Ref))); Append_To (Body_Decls, Body_Node); @@ -6388,13 +6150,10 @@ package body Exp_Dist is -- corresponding record type. RACW_Type : constant Entity_Id := - Underlying_RACW_Type (Ras_Type); - Desig : constant Entity_Id := - Etype (Designated_Type (RACW_Type)); + Underlying_RACW_Type (Ras_Type); Stub_Elements : constant Stub_Structure := - Stubs_Table.Get (Desig); - pragma Assert (Stub_Elements /= Empty_Stub_Structure); + Get_Stub_Elements (RACW_Type); Proc : constant Entity_Id := Make_Defining_Identifier (Loc, @@ -6506,8 +6265,7 @@ package body Exp_Dist is New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), Make_Object_Declaration (Loc, - Defining_Identifier => - Stub_Ptr, + Defining_Identifier => Stub_Ptr, Object_Definition => New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), Expression => @@ -6523,8 +6281,7 @@ package body Exp_Dist is Proc_Statements := New_List ( Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), + Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Package_Name, Loc), New_Occurrence_Of (Subp_Id, Loc), @@ -6535,8 +6292,7 @@ package body Exp_Dist is -- obtain the local address of its proxy (A). Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), + Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Ref, Loc), New_Occurrence_Of (Is_Local, Loc), @@ -6550,8 +6306,7 @@ package body Exp_Dist is -- if L then Make_Implicit_If_Statement (N, - Condition => - New_Occurrence_Of (Is_Local, Loc), + Condition => New_Occurrence_Of (Is_Local, Loc), Then_Statements => New_List ( @@ -6561,12 +6316,11 @@ package body Exp_Dist is Condition => Make_Op_Eq (Loc, Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To ( - RTE (RE_RAS_Proxy_Type_Access), - New_Occurrence_Of (Local_Addr, Loc)), - Selector_Name => - Make_Identifier (Loc, Name_Target)), + Prefix => + Unchecked_Convert_To + (RTE (RE_RAS_Proxy_Type_Access), + New_Occurrence_Of (Local_Addr, Loc)), + Selector_Name => Make_Identifier (Loc, Name_Target)), Make_Null (Loc)), Then_Statements => New_List ( @@ -6576,32 +6330,29 @@ package body Exp_Dist is Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To ( - RTE (RE_RAS_Proxy_Type_Access), - New_Occurrence_Of (Local_Addr, Loc)), - Selector_Name => - Make_Identifier (Loc, Name_Target)), + Prefix => + Unchecked_Convert_To + (RTE (RE_RAS_Proxy_Type_Access), + New_Occurrence_Of (Local_Addr, Loc)), + Selector_Name => Make_Identifier (Loc, Name_Target)), Expression => Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Entity_Of), Loc), + Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Ref, Loc)))), -- Inc_Usage (A.Target); Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), + Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => - Unchecked_Convert_To ( - RTE (RE_RAS_Proxy_Type_Access), - New_Occurrence_Of (Local_Addr, Loc)), - Selector_Name => Make_Identifier (Loc, - Name_Target)))))), + Unchecked_Convert_To + (RTE (RE_RAS_Proxy_Type_Access), + New_Occurrence_Of (Local_Addr, Loc)), + Selector_Name => + Make_Identifier (Loc, Name_Target)))))), -- end if; -- if not All_Calls_Remote then @@ -6611,12 +6362,14 @@ package body Exp_Dist is Make_Implicit_If_Statement (N, Condition => Make_Op_Not (Loc, - New_Occurrence_Of (All_Calls_Remote, Loc)), + Right_Opnd => + New_Occurrence_Of (All_Calls_Remote, Loc)), Then_Statements => New_List ( Make_Simple_Return_Statement (Loc, - Unchecked_Convert_To (Fat_Type, - New_Occurrence_Of (Local_Addr, Loc)))))))); + Expression => + Unchecked_Convert_To + (Fat_Type, New_Occurrence_Of (Local_Addr, Loc)))))))); Append_List_To (Proc_Statements, New_List ( @@ -6624,16 +6377,14 @@ package body Exp_Dist is Set_Field (Name_Target, Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Entity_Of), Loc), + Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Ref, Loc)))), -- Inc_Usage (Stub.Target); Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), + Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => Stub_Ptr, @@ -6648,13 +6399,13 @@ package body Exp_Dist is Set_Field (Name_Asynchronous, Make_Or_Else (Loc, - New_Occurrence_Of (Asynch_P, Loc), - New_Occurrence_Of (Boolean_Literals ( - Is_Asynchronous (Ras_Type)), Loc))))); + Left_Opnd => New_Occurrence_Of (Asynch_P, Loc), + Right_Opnd => + New_Occurrence_Of + (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc))))); Append_List_To (Proc_Statements, - Build_Get_Unique_RP_Call (Loc, - Stub_Ptr, Stub_Elements.Stub_Type)); + Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); Append_To (Proc_Statements, Make_Simple_Return_Statement (Loc, @@ -6740,14 +6491,11 @@ package body Exp_Dist is Func_Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => - Fnam, + Defining_Unit_Name => Fnam, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => - Any_Parameter, - Parameter_Type => - New_Occurrence_Of (RTE (RE_Any), Loc))), + Defining_Identifier => Any_Parameter, + Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))), Result_Definition => New_Occurrence_Of (RAS_Type, Loc)); Discard_Node ( @@ -6792,36 +6540,30 @@ package body Exp_Dist is Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type)); Decls := New_List ( Make_Object_Declaration (Loc, - Defining_Identifier => - Any, - Object_Definition => - New_Occurrence_Of (RTE (RE_Any), Loc), - Expression => + Defining_Identifier => Any, + Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => PolyORB_Support.Helpers.Build_To_Any_Call (RACW_Parameter, No_List))); Statements := New_List ( Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_TC), Loc), + Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc), PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, RAS_Type, Decls))), + Make_Simple_Return_Statement (Loc, - Expression => - New_Occurrence_Of (Any, Loc))); + Expression => New_Occurrence_Of (Any, Loc))); Func_Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => - Fnam, + Defining_Unit_Name => Fnam, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => - RAS_Parameter, - Parameter_Type => - New_Occurrence_Of (RAS_Type, Loc))), + Defining_Identifier => RAS_Parameter, + Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))), Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); Discard_Node ( @@ -6844,17 +6586,16 @@ package body Exp_Dist is Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, Make_TSS_Name (RAS_Type, TSS_TypeCode)); - Func_Spec : Node_Id; - - Decls : constant List_Id := New_List; - Name_String, Repo_Id_String : String_Id; + Func_Spec : Node_Id; + Decls : constant List_Id := New_List; + Name_String : String_Id; + Repo_Id_String : String_Id; begin Func_Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => - Fnam, - Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); + Defining_Unit_Name => Fnam, + Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); PolyORB_Support.Helpers.Build_Name_And_Repository_Id (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String); @@ -6869,24 +6610,25 @@ package body Exp_Dist is Make_Simple_Return_Statement (Loc, Expression => Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_TC_Build), Loc), + Name => New_Occurrence_Of (RTE (RE_TC_Build), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (RTE (RE_TC_Object), Loc), Make_Aggregate (Loc, Expressions => New_List ( Make_Function_Call (Loc, - Name => New_Occurrence_Of ( - RTE (RE_TA_String), Loc), + Name => + New_Occurrence_Of + (RTE (RE_TA_String), Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, Name_String))), Make_Function_Call (Loc, - Name => New_Occurrence_Of ( - RTE (RE_TA_String), Loc), + Name => + New_Occurrence_Of + (RTE (RE_TA_String), Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, - Repo_Id_String)))))))))))); + Strval => Repo_Id_String)))))))))))); Set_TSS (RAS_Type, Fnam); end Add_RAS_TypeCode; @@ -6905,14 +6647,14 @@ package body Exp_Dist is Make_Defining_Identifier (Loc, New_Internal_Name ('H')); Pkg_RPC_Receiver_Object : Node_Id; - Pkg_RPC_Receiver_Body : Node_Id; Pkg_RPC_Receiver_Decls : List_Id; Pkg_RPC_Receiver_Statements : List_Id; - Pkg_RPC_Receiver_Cases : constant List_Id := New_List; + + Pkg_RPC_Receiver_Cases : constant List_Id := New_List; -- A Pkg_RPC_Receiver is built to decode the request - Request : Node_Id; + Request : Node_Id; -- Request object received from neutral layer Subp_Id : Entity_Id; @@ -6920,16 +6662,19 @@ package body Exp_Dist is -- distribution core. Subp_Index : Entity_Id; - -- Internal index as determined by matching either the - -- method name from the request structure, or the local - -- subprogram address (in case of a RAS). + -- Internal index as determined by matching either the method name + -- from the request structure, or the local subprogram address (in + -- case of a RAS). Is_Local : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('L')); + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('L')); + Local_Address : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); - -- Address of a local subprogram designated by a - -- reference corresponding to a RAS. + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('A')); + -- Address of a local subprogram designated by a reference + -- corresponding to a RAS. Dispatch_On_Address : constant List_Id := New_List; Dispatch_On_Name : constant List_Id := New_List; @@ -6984,8 +6729,8 @@ package body Exp_Dist is Defining_Entity (Stubs), Loc), Parameter_Associations => New_List (New_Occurrence_Of (Request, Loc)))); - if Nkind (Specification (Declaration)) - = N_Function_Specification + + if Nkind (Specification (Declaration)) = N_Function_Specification or else not Is_Asynchronous (Defining_Entity (Specification (Declaration))) then @@ -6996,8 +6741,7 @@ package body Exp_Dist is Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List (Make_Integer_Literal (Loc, Subp_Number)), - Statements => - Case_Stmts)); + Statements => Case_Stmts)); Append_To (Dispatch_On_Name, Make_Elsif_Part (Loc, @@ -7008,25 +6752,23 @@ package body Exp_Dist is Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Id, Loc), New_Occurrence_Of (Subp_Dist_Name, Loc))), + Then_Statements => New_List ( Make_Assignment_Statement (Loc, New_Occurrence_Of (Subp_Index, Loc), - Make_Integer_Literal (Loc, - Subp_Number))))); + Make_Integer_Literal (Loc, Subp_Number))))); Append_To (Dispatch_On_Address, Make_Elsif_Part (Loc, Condition => Make_Op_Eq (Loc, - Left_Opnd => - New_Occurrence_Of (Local_Address, Loc), - Right_Opnd => - New_Occurrence_Of (Subp_Proxy_Addr, Loc)), + Left_Opnd => New_Occurrence_Of (Local_Address, Loc), + Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)), + Then_Statements => New_List ( Make_Assignment_Statement (Loc, New_Occurrence_Of (Subp_Index, Loc), - Make_Integer_Literal (Loc, - Subp_Number))))); + Make_Integer_Literal (Loc, Subp_Number))))); end Append_Stubs_To; -- Start of processing for Add_Receiving_Stubs_To_Declarations @@ -7064,20 +6806,19 @@ package body Exp_Dist is Append_To (Pkg_RPC_Receiver_Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Is_Local, + Defining_Identifier => Is_Local, Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc))); + Append_To (Pkg_RPC_Receiver_Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Local_Address, + Defining_Identifier => Local_Address, Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc))); + Append_To (Pkg_RPC_Receiver_Statements, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), + Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => Request, @@ -7112,11 +6853,12 @@ package body Exp_Dist is Subp_Val : String_Id; Subp_Dist_Name : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_External_Name ( - Related_Id => Chars (Subp_Def), - Suffix => 'D', - Suffix_Index => -1)); + Make_Defining_Identifier (Loc, + Chars => + New_External_Name + (Related_Id => Chars (Subp_Def), + Suffix => 'D', + Suffix_Index => -1)); Proxy_Object_Addr : Entity_Id; @@ -7137,29 +6879,26 @@ package body Exp_Dist is -- Build RAS proxy Add_RAS_Proxy_And_Analyze (Decls, - Vis_Decl => - Current_Declaration, - All_Calls_Remote_E => - All_Calls_Remote_E, - Proxy_Object_Addr => - Proxy_Object_Addr); + Vis_Decl => Current_Declaration, + All_Calls_Remote_E => All_Calls_Remote_E, + Proxy_Object_Addr => Proxy_Object_Addr); -- Compute distribution identifier - Assign_Subprogram_Identifier ( - Subp_Def, - Current_Subprogram_Number, - Subp_Val); + Assign_Subprogram_Identifier + (Subp_Def, + Current_Subprogram_Number, + Subp_Val); - pragma Assert (Current_Subprogram_Number = - Get_Subprogram_Id (Subp_Def)); + pragma Assert + (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def)); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Subp_Dist_Name, Constant_Present => True, - Object_Definition => New_Occurrence_Of ( - Standard_String, Loc), + Object_Definition => + New_Occurrence_Of (Standard_String, Loc), Expression => Make_String_Literal (Loc, Subp_Val))); Analyze (Last (Decls)); @@ -7172,21 +6911,21 @@ package body Exp_Dist is Append_To (Subp_Info_List, Make_Component_Association (Loc, Choices => New_List ( - Make_Integer_Literal (Loc, - Current_Subprogram_Number)), + Make_Integer_Literal (Loc, Current_Subprogram_Number)), + Expression => Make_Aggregate (Loc, Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => - New_Occurrence_Of ( - Subp_Dist_Name, Loc), + New_Occurrence_Of (Subp_Dist_Name, Loc), Attribute_Name => Name_Address), + Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of ( - Subp_Dist_Name, Loc), + Prefix => + New_Occurrence_Of (Subp_Dist_Name, Loc), Attribute_Name => Name_Length), + New_Occurrence_Of (Proxy_Object_Addr, Loc))))); Append_Stubs_To (Pkg_RPC_Receiver_Cases, @@ -7216,12 +6955,14 @@ package body Exp_Dist is Make_Index_Or_Discriminant_Constraint (Loc, New_List ( Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, - First_RCI_Subprogram_Id), + Low_Bound => + Make_Integer_Literal (Loc, + Intval => First_RCI_Subprogram_Id), High_Bound => Make_Integer_Literal (Loc, - First_RCI_Subprogram_Id - + List_Length (Subp_Info_List) - 1))))))); + Intval => + First_RCI_Subprogram_Id + + List_Length (Subp_Info_List) - 1))))))); if Present (First (Subp_Info_List)) then Set_Expression (Last (Decls), @@ -7247,27 +6988,22 @@ package body Exp_Dist is Make_Implicit_If_Statement (Pkg_Spec, Condition => Make_Op_Ne (Loc, - Left_Opnd => New_Occurrence_Of - (Local_Address, Loc), + Left_Opnd => New_Occurrence_Of (Local_Address, Loc), Right_Opnd => New_Occurrence_Of (RTE (RE_Null_Address), Loc)), + Then_Statements => New_List ( Make_Implicit_If_Statement (Pkg_Spec, - Condition => - New_Occurrence_Of (Standard_False, Loc), + Condition => New_Occurrence_Of (Standard_False, Loc), Then_Statements => New_List ( Make_Null_Statement (Loc)), - Elsif_Parts => - Dispatch_On_Address)), + Elsif_Parts => Dispatch_On_Address)), Else_Statements => New_List ( Make_Implicit_If_Statement (Pkg_Spec, - Condition => - New_Occurrence_Of (Standard_False, Loc), - Then_Statements => New_List ( - Make_Null_Statement (Loc)), - Elsif_Parts => - Dispatch_On_Name)))); + Condition => New_Occurrence_Of (Standard_False, Loc), + Then_Statements => New_List (Make_Null_Statement (Loc)), + Elsif_Parts => Dispatch_On_Name)))); else -- For a degenerate RCI with no visible subprograms, @@ -7295,15 +7031,12 @@ package body Exp_Dist is Append_To (Pkg_RPC_Receiver_Cases, Make_Case_Statement_Alternative (Loc, - Discrete_Choices => - New_List (Make_Others_Choice (Loc)), - Statements => - New_List (Make_Null_Statement (Loc)))); + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); Append_To (Pkg_RPC_Receiver_Statements, Make_Case_Statement (Loc, - Expression => - New_Occurrence_Of (Subp_Index, Loc), + Expression => New_Occurrence_Of (Subp_Index, Loc), Alternatives => Pkg_RPC_Receiver_Cases)); -- Pkg_RPC_Receiver body is now complete: insert it into the tree and @@ -7317,70 +7050,71 @@ package body Exp_Dist is Defining_Identifier => Make_Defining_Identifier (Loc, New_Internal_Name ('R')), Aliased_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Servant), Loc)); + Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); Append_To (Decls, Pkg_RPC_Receiver_Object); Analyze (Last (Decls)); Get_Library_Unit_Name_String (Pkg_Spec); + + -- Name + Append_To (Register_Pkg_Actuals, - -- Name Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); + -- Version + Append_To (Register_Pkg_Actuals, - -- Version Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), - Attribute_Name => - Name_Version)); + Attribute_Name => Name_Version)); + + -- Handler Append_To (Register_Pkg_Actuals, - -- Handler Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc), Attribute_Name => Name_Access)); + -- Receiver + Append_To (Register_Pkg_Actuals, - -- Receiver Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of ( - Defining_Identifier ( - Pkg_RPC_Receiver_Object), Loc), - Attribute_Name => - Name_Access)); + Defining_Identifier (Pkg_RPC_Receiver_Object), Loc), + Attribute_Name => Name_Access)); + + -- Subp_Info Append_To (Register_Pkg_Actuals, - -- Subp_Info Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Info_Array, Loc), - Attribute_Name => - Name_Address)); + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => Name_Address)); + + -- Subp_Info_Len Append_To (Register_Pkg_Actuals, - -- Subp_Info_Len Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Info_Array, Loc), - Attribute_Name => - Name_Length)); + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => Name_Length)); + + -- Is_All_Calls_Remote Append_To (Register_Pkg_Actuals, - -- Is_All_Calls_Remote New_Occurrence_Of (All_Calls_Remote_E, Loc)); + -- ??? + Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc), Parameter_Associations => Register_Pkg_Actuals)); Analyze (Last (Stmts)); - end Add_Receiving_Stubs_To_Declarations; --------------------------------- @@ -7455,8 +7189,7 @@ package body Exp_Dist is begin -- ??? document general form of stub subprograms for the PolyORB case - Request := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Request := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); Append_To (Decls, Make_Object_Declaration (Loc, @@ -7466,11 +7199,13 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Request_Access), Loc))); Result := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('R')); if Is_Function then - Result_TC := PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, - Etype (Result_Definition (Spec)), Decls); + Result_TC := + PolyORB_Support.Helpers.Build_TypeCode_Call + (Loc, Etype (Result_Definition (Spec)), Decls); else Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc); end if; @@ -7485,8 +7220,7 @@ package body Exp_Dist is Make_Aggregate (Loc, Component_Associations => New_List ( Make_Component_Association (Loc, - Choices => New_List ( - Make_Identifier (Loc, Name_Name)), + Choices => New_List (Make_Identifier (Loc, Name_Name)), Expression => New_Occurrence_Of (RTE (RE_Result_Name), Loc)), Make_Component_Association (Loc, @@ -7494,15 +7228,12 @@ package body Exp_Dist is Make_Identifier (Loc, Name_Argument)), Expression => Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Create_Any), Loc), - Parameter_Associations => New_List ( - Result_TC))), + Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List (Result_TC))), Make_Component_Association (Loc, - Choices => New_List ( + Choices => New_List ( Make_Identifier (Loc, Name_Arg_Modes)), - Expression => - Make_Integer_Literal (Loc, 0)))))); + Expression => Make_Integer_Literal (Loc, 0)))))); if not Is_Known_Asynchronous then Exception_Return_Parameter := @@ -7531,6 +7262,7 @@ package body Exp_Dist is Is_First_Controlling_Formal := not First_Controlling_Formal_Seen; First_Controlling_Formal_Seen := True; + else Is_Controlling_Formal := False; Is_First_Controlling_Formal := False; @@ -7538,8 +7270,7 @@ package body Exp_Dist is if Is_Controlling_Formal then - -- In the case of a controlling formal argument, we send its - -- reference. + -- For a controlling formal argument, we send its reference Etyp := RACW_Type; @@ -7547,11 +7278,10 @@ package body Exp_Dist is Etyp := Etype (Parameter_Type (Current_Parameter)); end if; - -- The first controlling formal parameter is treated specially: it - -- is used to set the target object of the call. + -- The first controlling formal parameter is treated specially: + -- it is used to set the target object of the call. if not Is_First_Controlling_Formal then - declare Constrained : constant Boolean := Is_Constrained (Etyp) @@ -7584,10 +7314,8 @@ package body Exp_Dist is else Actual_Parameter := OK_Convert_To (Etyp, Make_Attribute_Reference (Loc, - Prefix => - Actual_Parameter, - Attribute_Name => - Name_Unrestricted_Access)); + Prefix => Actual_Parameter, + Attribute_Name => Name_Unrestricted_Access)); end if; end if; @@ -7602,26 +7330,24 @@ package body Exp_Dist is -- parameter (always passed as a reference) other than -- the first one. - Expr := PolyORB_Support.Helpers.Build_To_Any_Call ( - Actual_Parameter, Decls); + Expr := PolyORB_Support.Helpers.Build_To_Any_Call + (Actual_Parameter, Decls); + else Expr := Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), Parameter_Associations => New_List ( - PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, - Etyp, Decls))); + PolyORB_Support.Helpers.Build_TypeCode_Call + (Loc, Etyp, Decls))); end if; Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Any, + Defining_Identifier => Any, Aliased_Present => False, Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), - Expression => - Expr)); + Expression => Expr)); Append_To (Statements, Add_Parameter_To_NVList (Loc, @@ -7639,10 +7365,10 @@ package body Exp_Dist is New_Occurrence_Of ( Defining_Identifier (Current_Parameter), Loc), Expression => - PolyORB_Support.Helpers.Build_From_Any_Call ( - Etype (Parameter_Type (Current_Parameter)), - New_Occurrence_Of (Any, Loc), - Decls))); + PolyORB_Support.Helpers.Build_From_Any_Call + (Etype (Parameter_Type (Current_Parameter)), + New_Occurrence_Of (Any, Loc), + Decls))); end if; end; @@ -7652,8 +7378,8 @@ package body Exp_Dist is -- this status is transmitted as well. -- This should be done for accessibility as well ??? - if Nkind (Parameter_Type (Current_Parameter)) - /= N_Access_Definition + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition and then Need_Extra_Constrained (Current_Parameter) then -- In this block, we do not use the extra formal that has been @@ -7664,28 +7390,27 @@ package body Exp_Dist is declare Extra_Any_Parameter : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('P')); + Make_Defining_Identifier + (Loc, New_Internal_Name ('P')); Parameter_Exp : constant Node_Id := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of ( Defining_Identifier (Current_Parameter), Loc), Attribute_Name => Name_Constrained); + begin Set_Etype (Parameter_Exp, Etype (Standard_Boolean)); Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Extra_Any_Parameter, + Defining_Identifier => Extra_Any_Parameter, Aliased_Present => False, Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), Expression => - PolyORB_Support.Helpers.Build_To_Any_Call ( - Parameter_Exp, - Decls))); + PolyORB_Support.Helpers.Build_To_Any_Call + (Parameter_Exp, Decls))); Append_To (Extra_Formal_Statements, Add_Parameter_To_NVList (Loc, @@ -7707,6 +7432,7 @@ package body Exp_Dist is Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Request_Create), Loc), + Parameter_Associations => New_List ( Target_Object, Subprogram_Id, @@ -7717,14 +7443,18 @@ package body Exp_Dist is Append_To (Parameter_Associations (Last (Statements)), New_Occurrence_Of (Request, Loc)); - pragma Assert ( - not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous)); + pragma Assert + (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous)); + if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then - Asynchronous_P := New_Occurrence_Of ( - Boolean_Literals (Is_Known_Asynchronous), Loc); + Asynchronous_P := + New_Occurrence_Of + (Boolean_Literals (Is_Known_Asynchronous), Loc); + else pragma Assert (Present (Asynchronous)); Asynchronous_P := New_Copy_Tree (Asynchronous); + -- The expression node Asynchronous will be used to build an 'if' -- statement at the end of Build_General_Calling_Stubs: we need to -- make a copy here. @@ -7766,17 +7496,16 @@ package body Exp_Dist is Append_To (Non_Asynchronous_Statements, Make_Tag_Check (Loc, Make_Simple_Return_Statement (Loc, - PolyORB_Support.Helpers.Build_From_Any_Call ( - Etype (Result_Definition (Spec)), - Make_Selected_Component (Loc, - Prefix => Result, - Selector_Name => Name_Argument), - Decls)))); + PolyORB_Support.Helpers.Build_From_Any_Call + (Etype (Result_Definition (Spec)), + Make_Selected_Component (Loc, + Prefix => Result, + Selector_Name => Name_Argument), + Decls)))); end if; end if; - Append_List_To (Non_Asynchronous_Statements, - After_Statements); + Append_List_To (Non_Asynchronous_Statements, After_Statements); if Is_Known_Asynchronous then Append_List_To (Statements, Asynchronous_Statements); @@ -7813,8 +7542,10 @@ package body Exp_Dist is Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Target_Reference, + Object_Definition => New_Occurrence_Of (RTE (RE_Object_Ref), Loc), + Expression => Make_Function_Call (Loc, Name => @@ -7823,7 +7554,8 @@ package body Exp_Dist is Make_Selected_Component (Loc, Prefix => Controlling_Parameter, Selector_Name => Name_Target))))); - -- Controlling_Parameter has the same components as + + -- Note: Controlling_Parameter has the same components as -- System.Partition_Interface.RACW_Stub_Type. Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc); @@ -7831,11 +7563,11 @@ package body Exp_Dist is else Target_Info.Object := Make_Selected_Component (Loc, - Prefix => - Make_Identifier (Loc, Chars (RCI_Locator)), + Prefix => Make_Identifier (Loc, Chars (RCI_Locator)), Selector_Name => Make_Identifier (Loc, Name_Get_RCI_Package_Ref)); end if; + return Target_Info; end Build_Stub_Target; @@ -7871,20 +7603,19 @@ package body Exp_Dist is Make_Defining_Identifier (Loc, Name_Target), Component_Definition => Make_Component_Definition (Loc, - Aliased_Present => - False, + Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))), Make_Component_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_Asynchronous), + Component_Definition => Make_Component_Definition (Loc, Aliased_Present => False, Subtype_Indication => - New_Occurrence_Of ( - Standard_Boolean, Loc))))))); + New_Occurrence_Of (Standard_Boolean, Loc))))))); RPC_Receiver_Decl := Make_Object_Declaration (Loc, @@ -8032,8 +7763,8 @@ package body Exp_Dist is New_Occurrence_Of (Parent_Primitive, Loc); else Called_Subprogram := - New_Occurrence_Of ( - Defining_Unit_Name (Specification (Vis_Decl)), Loc); + New_Occurrence_Of + (Defining_Unit_Name (Specification (Vis_Decl)), Loc); end if; Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements); @@ -8050,11 +7781,12 @@ package body Exp_Dist is Any : Entity_Id := Empty; Object : constant Entity_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('P')); + Chars => New_Internal_Name ('P')); Expr : Node_Id := Empty; - Is_Controlling_Formal : constant Boolean - := Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type); + Is_Controlling_Formal : constant Boolean := + Is_RACW_Controlling_Formal + (Current_Parameter, Stub_Type); Is_First_Controlling_Formal : Boolean := False; @@ -8075,30 +7807,30 @@ package body Exp_Dist is Is_First_Controlling_Formal := not First_Controlling_Formal_Seen; First_Controlling_Formal_Seen := True; + else Etyp := Etype (Parameter_Type (Current_Parameter)); end if; Constrained := - Is_Constrained (Etyp) - or else Is_Elementary_Type (Etyp); + Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); if not Is_First_Controlling_Formal then - Any := Make_Defining_Identifier (Loc, - New_Internal_Name ('A')); + Any := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('A')); + Append_To (Outer_Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Any, + Defining_Identifier => Any, Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), Expression => Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), Parameter_Associations => New_List ( - PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, - Etyp, Outer_Decls))))); + PolyORB_Support.Helpers.Build_TypeCode_Call + (Loc, Etyp, Outer_Decls))))); Append_To (Outer_Statements, Add_Parameter_To_NVList (Loc, @@ -8111,34 +7843,34 @@ package body Exp_Dist is if Is_First_Controlling_Formal then declare Addr : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('A')); + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('A')); + Is_Local : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('L')); - begin + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('L')); + begin -- Special case: obtain the first controlling formal -- from the target of the remote call, instead of the -- argument list. Append_To (Outer_Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Addr, + Defining_Identifier => Addr, Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc))); + Append_To (Outer_Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Is_Local, + Defining_Identifier => Is_Local, Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc))); + Append_To (Outer_Statements, Make_Procedure_Call_Statement (Loc, Name => - New_Occurrence_Of ( - RTE (RE_Get_Local_Address), Loc), + New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => @@ -8169,13 +7901,12 @@ package body Exp_Dist is if Constrained then Append_To (Statements, Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of (Object, Loc), - Expression => - Expr)); + Name => New_Occurrence_Of (Object, Loc), + Expression => Expr)); Expr := Empty; else null; + -- Expr will be used to initialize (and constrain) the -- parameter when it is declared. end if; @@ -8216,13 +7947,11 @@ package body Exp_Dist is then Append_To (After_Statements, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc), + Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc), - PolyORB_Support.Helpers.Build_To_Any_Call ( - New_Occurrence_Of (Object, Loc), - Decls)))); + PolyORB_Support.Helpers.Build_To_Any_Call + (New_Occurrence_Of (Object, Loc), Decls)))); end if; -- For RACW controlling formals, the Etyp of Object is always @@ -8231,25 +7960,27 @@ package body Exp_Dist is if Is_Controlling_Formal then if Nkind (Parameter_Type (Current_Parameter)) /= - N_Access_Definition + N_Access_Definition then Append_To (Parameter_List, Make_Parameter_Association (Loc, Selector_Name => - New_Occurrence_Of ( - Defining_Identifier (Current_Parameter), Loc), + New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc), Explicit_Actual_Parameter => Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RACW_Type, - OK_Convert_To (RTE (RE_Address), - New_Occurrence_Of (Object, Loc)))))); + Prefix => + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc)))))); else Append_To (Parameter_List, Make_Parameter_Association (Loc, Selector_Name => - New_Occurrence_Of ( - Defining_Identifier (Current_Parameter), Loc), + New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => Unchecked_Convert_To (RACW_Type, OK_Convert_To (RTE (RE_Address), @@ -8280,21 +8011,22 @@ package body Exp_Dist is Extra_Constrained (Defining_Identifier (Current_Parameter)); + Extra_Any : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('A')); + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('A')); Formal_Entity : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars (Extra_Parameter)); + Make_Defining_Identifier (Loc, + Chars => Chars (Extra_Parameter)); Formal_Type : constant Entity_Id := Etype (Extra_Parameter); + begin Append_To (Outer_Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Extra_Any, + Defining_Identifier => Extra_Any, Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), Expression => @@ -8320,13 +8052,12 @@ package body Exp_Dist is Append_To (Statements, Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of (Formal_Entity, Loc), + Name => New_Occurrence_Of (Formal_Entity, Loc), Expression => - PolyORB_Support.Helpers.Build_From_Any_Call ( - Formal_Type, - New_Occurrence_Of (Extra_Any, Loc), - Decls))); + PolyORB_Support.Helpers.Build_From_Any_Call + (Formal_Type, + New_Occurrence_Of (Extra_Any, Loc), + Decls))); Set_Extra_Constrained (Object, Formal_Entity); end; end if; @@ -8341,24 +8072,23 @@ package body Exp_Dist is Append_To (Outer_Statements, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Request_Arguments), Loc), + Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Request_Parameter, Loc), New_Occurrence_Of (Arguments, Loc)))); if Nkind (Specification (Vis_Decl)) = N_Function_Specification then - -- The remote subprogram is a function. We build an inner block to - -- be able to hold a potentially unconstrained result in a - -- variable. + -- The remote subprogram is a function: Build an inner block to be + -- able to hold a potentially unconstrained result in a variable. declare Etyp : constant Entity_Id := Etype (Result_Definition (Specification (Vis_Decl))); Result : constant Node_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Chars => New_Internal_Name ('R')); + begin Inner_Decls := New_List ( Make_Object_Declaration (Loc, @@ -8374,7 +8104,7 @@ package body Exp_Dist is -- For a remote call to a function with a class-wide type, -- check that the returned value satisfies the requirements - -- of E.4(18). + -- of (RM E.4(18)). Append_To (Inner_Decls, Make_Transportable_Check (Loc, @@ -8385,13 +8115,12 @@ package body Exp_Dist is Set_Etype (Result, Etyp); Append_To (After_Statements, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_Result), Loc), + Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Request_Parameter, Loc), - PolyORB_Support.Helpers.Build_To_Any_Call ( - New_Occurrence_Of (Result, Loc), - Decls)))); + PolyORB_Support.Helpers.Build_To_Any_Call + (New_Occurrence_Of (Result, Loc), Decls)))); + -- A DSA function does not have out or inout arguments end; @@ -8412,8 +8141,7 @@ package body Exp_Dist is Append_To (After_Statements, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc), + Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Request_Parameter, Loc)))); @@ -8451,7 +8179,6 @@ package body Exp_Dist is Statements => New_List (Make_Null_Statement (Loc)))); else - -- In the other cases, if an exception is raised, then the -- exception occurrence is propagated. @@ -8460,8 +8187,7 @@ package body Exp_Dist is Append_To (Outer_Statements, Make_Block_Statement (Loc, - Declarations => - Decls, + Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Statements))); @@ -8622,8 +8348,8 @@ package body Exp_Dist is Fnam : Entity_Id := Empty; Lib_RE : RE_Id := RE_Null; Result : Node_Id; - begin + begin -- First simple case where the From_Any function is present -- in the type's TSS. @@ -8761,24 +8487,22 @@ package body Exp_Dist is if Is_Itype (Typ) then Build_From_Any_Function (Loc => Loc, - Typ => Etype (Typ), - Decl => Decl, - Fnam => Fnam); + Typ => Etype (Typ), + Decl => Decl, + Fnam => Fnam); return; end if; - Fnam := Make_Stream_Procedure_Function_Name (Loc, - Typ, Name_uFrom_Any); + Fnam := + Make_Stream_Procedure_Function_Name (Loc, Typ, Name_uFrom_Any); Spec := Make_Function_Specification (Loc, Defining_Unit_Name => Fnam, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => - Any_Parameter, - Parameter_Type => - New_Occurrence_Of (RTE (RE_Any), Loc))), + Defining_Identifier => Any_Parameter, + Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))), Result_Definition => New_Occurrence_Of (Typ, Loc)); -- The following is taken care of by Exp_Dist.Add_RACW_From_Any @@ -8790,7 +8514,7 @@ package body Exp_Dist is if Has_Stream_Attribute_Definition (Typ, TSS_Stream_Output, At_Any_Place => True) - or else + or else Has_Stream_Attribute_Definition (Typ, TSS_Stream_Write, At_Any_Place => True) then @@ -8804,12 +8528,11 @@ package body Exp_Dist is Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => - OK_Convert_To ( - Typ, - Build_From_Any_Call ( - Root_Type (Typ), - New_Occurrence_Of (Any_Parameter, Loc), - Decls)))); + OK_Convert_To (Typ, + Build_From_Any_Call + (Root_Type (Typ), + New_Occurrence_Of (Any_Parameter, Loc), + Decls)))); elsif Is_Record_Type (Typ) and then not Is_Derived_Type (Typ) @@ -8819,19 +8542,20 @@ package body Exp_Dist is Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => - OK_Convert_To ( - Typ, - Build_From_Any_Call ( - Etype (Typ), - New_Occurrence_Of (Any_Parameter, Loc), - Decls)))); + OK_Convert_To (Typ, + Build_From_Any_Call + (Etype (Typ), + New_Occurrence_Of (Any_Parameter, Loc), + Decls)))); + else declare - Disc : Entity_Id := Empty; + Disc : Entity_Id := Empty; Discriminant_Associations : List_Id; - Rdef : constant Node_Id := - Type_Definition (Declaration_Node (Typ)); - Component_Counter : Int := 0; + Rdef : constant Node_Id := + Type_Definition + (Declaration_Node (Typ)); + Component_Counter : Int := 0; -- The returned object @@ -8850,8 +8574,8 @@ package body Exp_Dist is procedure FA_Append_Record_Traversal is new Append_Record_Traversal - (Rec => Res, - Add_Process_Element => FA_Rec_Add_Process_Element); + (Rec => Res, + Add_Process_Element => FA_Rec_Add_Process_Element); -------------------------------- -- FA_Rec_Add_Process_Element -- @@ -8890,7 +8614,7 @@ package body Exp_Dist is -- A variant part declare - Variant : Node_Id; + Variant : Node_Id; Struct_Counter : Int := 0; Block_Decls : constant List_Id := New_List; @@ -8907,16 +8631,16 @@ package body Exp_Dist is begin Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Struct_Any, - Constant_Present => - True, - Object_Definition => + Defining_Identifier => Struct_Any, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), - Expression => + Expression => Make_Function_Call (Loc, - Name => New_Occurrence_Of ( - RTE (RE_Extract_Union_Value), Loc), + Name => + New_Occurrence_Of + (RTE (RE_Extract_Union_Value), Loc), + Parameter_Associations => New_List ( Build_Get_Aggregate_Element (Loc, Any => Any, @@ -8935,8 +8659,7 @@ package body Exp_Dist is Append_To (Stmts, Make_Block_Statement (Loc, - Declarations => - Block_Decls, + Declarations => Block_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Block_Stmts))); @@ -8946,15 +8669,14 @@ package body Exp_Dist is Expression => Make_Selected_Component (Loc, Prefix => Rec, - Selector_Name => - Chars (Name (Field))), - Alternatives => - Alt_List)); + Selector_Name => Chars (Name (Field))), + Alternatives => Alt_List)); Variant := First_Non_Pragma (Variants (Field)); while Present (Variant) loop - Choice_List := New_Copy_List_Tree - (Discrete_Choices (Variant)); + Choice_List := + New_Copy_List_Tree + (Discrete_Choices (Variant)); VP_Stmts := New_List; @@ -8975,12 +8697,12 @@ package body Exp_Dist is Append_To (Alt_List, Make_Case_Statement_Alternative (Loc, Discrete_Choices => Choice_List, - Statements => - VP_Stmts)); + Statements => VP_Stmts)); Next_Non_Pragma (Variant); end loop; end; end if; + Counter := Counter + 1; end FA_Rec_Add_Process_Element; @@ -9002,11 +8724,11 @@ package body Exp_Dist is begin Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Disc_Var_Name, - Constant_Present => True, - Object_Definition => + Defining_Identifier => Disc_Var_Name, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Disc_Type, Loc), + Expression => Build_From_Any_Call (Disc_Type, Build_Get_Aggregate_Element (Loc, @@ -9016,6 +8738,7 @@ package body Exp_Dist is Idx => Make_Integer_Literal (Loc, Intval => Component_Counter)), Decls))); + Component_Counter := Component_Counter + 1; Append_To (Discriminant_Associations, @@ -9045,10 +8768,8 @@ package body Exp_Dist is Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Res, - Object_Definition => - Res_Definition)); + Defining_Identifier => Res, + Object_Definition => Res_Definition)); -- ... then all components @@ -9105,6 +8826,7 @@ package body Exp_Dist is -- sufficient to determine the typecode of Datum -- (which can be a TC_SEQUENCE or TC_ARRAY -- depending on the value of Constrained). + -- Therefore we retrieve the typecode which has -- been constructed in Append_Array_Traversal with -- a call to Get_Any_Type. @@ -9139,10 +8861,8 @@ package body Exp_Dist is New_Occurrence_Of (Counter, Loc), Expression => Make_Op_Add (Loc, - Left_Opnd => - New_Occurrence_Of (Counter, Loc), - Right_Opnd => - Make_Integer_Literal (Loc, 1)))); + Left_Opnd => New_Occurrence_Of (Counter, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1)))); if Nkind (Datum) /= N_Attribute_Reference then @@ -9152,10 +8872,8 @@ package body Exp_Dist is if Etype (Datum) /= RTE (RE_Any) then Set_Expression (Assignment, - Build_From_Any_Call ( - Component_Type (Typ), - Element_Any, - Decls)); + Build_From_Any_Call + (Component_Type (Typ), Element_Any, Decls)); else Set_Expression (Assignment, Element_Any); end if; @@ -9210,32 +8928,36 @@ package body Exp_Dist is Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Lnam), - Constant_Present => - True, + Constant_Present => True, Object_Definition => New_Occurrence_Of (Indt, Loc), Expression => - Build_From_Any_Call ( - Indt, - Build_Get_Aggregate_Element (Loc, - Any => Any_Parameter, - TC => Build_TypeCode_Call (Loc, - Indt, Decls), - Idx => Make_Integer_Literal (Loc, J - 1)), + Build_From_Any_Call + (Indt, + Build_Get_Aggregate_Element (Loc, + Any => Any_Parameter, + TC => Build_TypeCode_Call + (Loc, Indt, Decls), + Idx => + Make_Integer_Literal (Loc, J - 1)), Decls))); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Hnam), - Constant_Present => - True, + + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Indt, Loc), + Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Indt, Loc), + Attribute_Name => Name_Val, + Expressions => New_List ( Make_Op_Subtract (Loc, Left_Opnd => @@ -9244,6 +8966,7 @@ package body Exp_Dist is OK_Convert_To ( Standard_Long_Integer, Make_Identifier (Loc, Lnam)), + Right_Opnd => OK_Convert_To ( Standard_Long_Integer, @@ -9257,7 +8980,8 @@ package body Exp_Dist is New_Occurrence_Of ( Any_Parameter, Loc), Make_Integer_Literal (Loc, - J))))), + Intval => J))))), + Right_Opnd => Make_Integer_Literal (Loc, 1)))))); @@ -9275,8 +8999,7 @@ package body Exp_Dist is Initial_Counter_Value := Ndim; Res_Subtype_Indication := Make_Subtype_Indication (Loc, - Subtype_Mark => - Res_Subtype_Indication, + Subtype_Mark => Res_Subtype_Indication, Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Ranges)); @@ -9300,15 +9023,15 @@ package body Exp_Dist is Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Component_TC, - Constant_Present => True, - Object_Definition => + Constant_Present => True, + Object_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc), - Expression => + Expression => Build_TypeCode_Call (Loc, Component_Type (Typ), Decls))); - Append_From_Any_Array_Iterator (Stms, - Any_Parameter, Counter); + Append_From_Any_Array_Iterator + (Stms, Any_Parameter, Counter); Append_To (Stms, Make_Simple_Return_Statement (Loc, @@ -9319,12 +9042,11 @@ package body Exp_Dist is Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => - Unchecked_Convert_To ( - Typ, - Build_From_Any_Call ( - Find_Numeric_Representation (Typ), - New_Occurrence_Of (Any_Parameter, Loc), - Decls)))); + Unchecked_Convert_To (Typ, + Build_From_Any_Call + (Find_Numeric_Representation (Typ), + New_Occurrence_Of (Any_Parameter, Loc), + Decls)))); else Use_Opaque_Representation := True; @@ -9347,10 +9069,8 @@ package body Exp_Dist is Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Strm, - Aliased_Present => - True, + Defining_Identifier => Strm, + Aliased_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); @@ -9367,8 +9087,7 @@ package body Exp_Dist is Append_To (Stms, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Any_To_BS), Loc), + Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any_Parameter, Loc), New_Occurrence_Of (Strm, Loc)))); @@ -9385,8 +9104,7 @@ package body Exp_Dist is Make_Object_Declaration (Loc, Defining_Identifier => Res, Constant_Present => True, - Object_Definition => - New_Occurrence_Of (Typ, Loc), + Object_Definition => New_Occurrence_Of (Typ, Loc), Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Typ, Loc), @@ -9403,8 +9121,7 @@ package body Exp_Dist is Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), Parameter_Associations => - New_List ( - New_Occurrence_Of (Strm, Loc))), + New_List (New_Occurrence_Of (Strm, Loc))), Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (Res, Loc)))))); @@ -9433,8 +9150,7 @@ package body Exp_Dist is begin return Make_Function_Call (Loc, Name => - New_Occurrence_Of ( - RTE (RE_Get_Aggregate_Element), Loc), + New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc), TC, @@ -9650,19 +9366,15 @@ package body Exp_Dist is Defining_Unit_Name => Fnam, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => - Expr_Parameter, - Parameter_Type => - New_Occurrence_Of (Typ, Loc))), - Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); + Defining_Identifier => Expr_Parameter, + Parameter_Type => New_Occurrence_Of (Typ, Loc))), + Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); Set_Etype (Expr_Parameter, Typ); Any_Decl := Make_Object_Declaration (Loc, - Defining_Identifier => - Any, - Object_Definition => - New_Occurrence_Of (RTE (RE_Any), Loc)); + Defining_Identifier => Any, + Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); Use_Opaque_Representation := False; @@ -9704,8 +9416,8 @@ package body Exp_Dist is New_Occurrence_Of (Expr_Parameter, Loc)); begin - Set_Expression (Any_Decl, - Build_To_Any_Call (Expr, Decls)); + Set_Expression + (Any_Decl, Build_To_Any_Call (Expr, Decls)); end; -- Comment needed here (and label on declare block ???) @@ -9868,10 +9580,8 @@ package body Exp_Dist is Append_To (Block_Stmts, Make_Case_Statement (Loc, - Expression => - Make_Discriminant_Reference, - Alternatives => - Alt_List)); + Expression => Make_Discriminant_Reference, + Alternatives => Alt_List)); Variant := First_Non_Pragma (Variants (Field)); while Present (Variant) loop @@ -9889,9 +9599,9 @@ package body Exp_Dist is RTE (RE_Add_Aggregate_Element), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Union_Any, Loc), - Build_To_Any_Call ( - Make_Discriminant_Reference, - Block_Decls)))); + Build_To_Any_Call + (Make_Discriminant_Reference, + Block_Decls)))); -- Populate inner struct aggregate @@ -9935,7 +9645,7 @@ package body Exp_Dist is Append_To (Alt_List, Make_Case_Statement_Alternative (Loc, Discrete_Choices => Choice_List, - Statements => VP_Stmts)); + Statements => VP_Stmts)); Next_Non_Pragma (Variant); end loop; @@ -10204,8 +9914,7 @@ package body Exp_Dist is Append_To (Stms, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_BS_To_Any), Loc), + Name => New_Occurrence_Of (RTE (RE_BS_To_Any), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Strm, Loc), New_Occurrence_Of (Any, Loc)))); @@ -10215,8 +9924,7 @@ package body Exp_Dist is Append_To (Stms, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), + Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Strm, Loc)))); end; @@ -10239,8 +9947,8 @@ package body Exp_Dist is Decl := Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Decls, + Specification => Spec, + Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stms)); @@ -10442,8 +10150,7 @@ package body Exp_Dist is begin Append_To (Parameter_List, Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_TA_String), Loc), + Name => New_Occurrence_Of (RTE (RE_TA_String), Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, S)))); end Add_String_Parameter; @@ -10459,10 +10166,8 @@ package body Exp_Dist is begin Append_To (Parameter_List, Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_TA_TC), Loc), - Parameter_Associations => New_List ( - TC_Node))); + Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc), + Parameter_Associations => New_List (TC_Node))); end Add_TypeCode_Parameter; ------------------------ @@ -10476,8 +10181,7 @@ package body Exp_Dist is begin Append_To (Parameter_List, Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_TA_LI), Loc), + Name => New_Occurrence_Of (RTE (RE_TA_LI), Loc), Parameter_Associations => New_List (Expr_Node))); end Add_Long_Parameter; @@ -10538,7 +10242,7 @@ package body Exp_Dist is Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => - Make_Constructed_TypeCode (Kind, Parameters))); + Make_Constructed_TypeCode (Kind, Parameters))); end Return_Constructed_TypeCode; ------------------ @@ -10577,8 +10281,8 @@ package body Exp_Dist is -- A regular component - Add_TypeCode_Parameter ( - Build_TypeCode_Call (Loc, Etype (Field), Decls), Params); + Add_TypeCode_Parameter + (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params); Get_Name_String (Chars (Field)); Add_String_Parameter (String_From_Name_Buffer, Params); @@ -10718,7 +10422,7 @@ package body Exp_Dist is declare Default_Node : constant Node_Id := - Pick (Union_TC_Params, 4); + Pick (Union_TC_Params, 4); New_Default_Node : constant Node_Id := Make_Function_Call (Loc, @@ -10761,7 +10465,7 @@ package body Exp_Dist is declare Exp : constant Node_Id := - New_Copy_Tree (Choice); + New_Copy_Tree (Choice); begin Append_To (Union_TC_Params, Build_To_Any_Call (Exp, Decls)); @@ -10769,14 +10473,13 @@ package body Exp_Dist is Add_Params_For_Variant_Components; end case; + Next (Choice); Choice_Index := Choice_Index + 1; - end loop; Next_Non_Pragma (Variant); end loop; - end; end if; end TC_Rec_Add_Process_Element; @@ -10798,19 +10501,20 @@ package body Exp_Dist is Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => Fnam, + Defining_Unit_Name => Fnam, Parameter_Specifications => Empty_List, - Result_Definition => + Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); Build_Name_And_Repository_Id (Typ, Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str); + Initialize_Parameter_List (Type_Name_Str, Type_Repo_Id_Str, Parameters); if Has_Stream_Attribute_Definition (Typ, TSS_Stream_Output, At_Any_Place => True) - or else + or else Has_Stream_Attribute_Definition (Typ, TSS_Stream_Write, At_Any_Place => True) then @@ -10875,20 +10579,23 @@ package body Exp_Dist is -- | [VP Name] if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then - Return_Alias_TypeCode ( - Build_TypeCode_Call (Loc, Etype (Typ), Decls)); + Return_Alias_TypeCode + (Build_TypeCode_Call (Loc, Etype (Typ), Decls)); + else declare Disc : Entity_Id := Empty; Rdef : constant Node_Id := - Type_Definition (Declaration_Node (Typ)); + Type_Definition (Declaration_Node (Typ)); Dummy_Counter : Int := 0; + begin -- Construct the discriminants typecodes if Has_Discriminants (Typ) then Disc := First_Discriminant (Typ); end if; + while Present (Disc) loop Add_TypeCode_Parameter ( Build_TypeCode_Call (Loc, Etype (Disc), Decls), @@ -10917,9 +10624,8 @@ package body Exp_Dist is Indx : Node_Id := First_Index (Typ); begin - Inner_TypeCode := Build_TypeCode_Call (Loc, - Component_Type (Typ), - Decls); + Inner_TypeCode := + Build_TypeCode_Call (Loc, Component_Type (Typ), Decls); for J in 1 .. Ndim loop if Constrained then @@ -10928,13 +10634,11 @@ package body Exp_Dist is Build_To_Any_Call ( OK_Convert_To (RTE (RE_Long_Unsigned), Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Typ, Loc), - Attribute_Name => - Name_Length, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Length, Expressions => New_List ( Make_Integer_Literal (Loc, - Ndim - J + 1)))), + Intval => Ndim - J + 1)))), Decls), Build_To_Any_Call (Inner_TypeCode, Decls))); @@ -10981,8 +10685,8 @@ package body Exp_Dist is Decl := Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Decls, + Specification => Spec, + Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stms)); @@ -11086,7 +10790,6 @@ package body Exp_Dist is Make_Indexed_Component (Loc, New_Occurrence_Of (Arry, Loc), Indices); - begin Set_Etype (Element_Expr, Component_Type (Typ)); Add_Process_Element (Stmts, @@ -11118,8 +10821,8 @@ package body Exp_Dist is declare Loop_Any : Node_Id := Inner_Any; - begin + begin -- For the first dimension of a constrained array, we add -- elements directly in the corresponding Any; there is no -- intervening inner Any. @@ -11169,8 +10872,7 @@ package body Exp_Dist is if Constrained then Inner_Any_TypeCode_Expr := Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_TC), Loc), + Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc))); else @@ -11185,11 +10887,10 @@ package body Exp_Dist is else Inner_Any_TypeCode_Expr := Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Content_Type), Loc), + Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc), Parameter_Associations => New_List ( Make_Identifier (Loc, - New_External_Name ('T', Depth - 1)))); + Chars => New_External_Name ('T', Depth - 1)))); end if; Append_To (Decls, @@ -11281,7 +10982,8 @@ package body Exp_Dist is if Is_Tagged_Type (Typ) then return Make_Defining_Identifier (Loc, Nam); else - return Make_Defining_Identifier (Loc, + return + Make_Defining_Identifier (Loc, Chars => New_External_Name (Nam, ' ', Increment_Serial_Number)); end if; @@ -11457,7 +11159,8 @@ package body Exp_Dist is (Loc : Source_Ptr; Decls : List_Id; RPC_Receiver : Entity_Id; - Stub_Elements : Stub_Structure) is + Stub_Elements : Stub_Structure) + is begin case Get_PCS_Name is when Name_PolyORB_DSA => @@ -11479,25 +11182,26 @@ package body Exp_Dist is Stub_Type : Entity_Id; Stub_Type_Access : Entity_Id; RPC_Receiver_Decl : Node_Id; - Body_Decls : List_Id) is + Body_Decls : List_Id) + is begin case Get_PCS_Name is when Name_PolyORB_DSA => - PolyORB_Support.Add_RACW_Features ( - RACW_Type, - Desig, - Stub_Type, - Stub_Type_Access, - RPC_Receiver_Decl, - Body_Decls); + PolyORB_Support.Add_RACW_Features + (RACW_Type, + Desig, + Stub_Type, + Stub_Type_Access, + RPC_Receiver_Decl, + Body_Decls); when others => - GARLIC_Support.Add_RACW_Features ( - RACW_Type, - Stub_Type, - Stub_Type_Access, - RPC_Receiver_Decl, - Body_Decls); + GARLIC_Support.Add_RACW_Features + (RACW_Type, + Stub_Type, + Stub_Type_Access, + RPC_Receiver_Decl, + Body_Decls); end case; end Specific_Add_RACW_Features; @@ -11507,7 +11211,8 @@ package body Exp_Dist is procedure Specific_Add_RAST_Features (Vis_Decl : Node_Id; - RAS_Type : Entity_Id) is + RAS_Type : Entity_Id) + is begin case Get_PCS_Name is when Name_PolyORB_DSA => @@ -11529,11 +11234,11 @@ package body Exp_Dist is begin case Get_PCS_Name is when Name_PolyORB_DSA => - PolyORB_Support.Add_Receiving_Stubs_To_Declarations ( - Pkg_Spec, Decls, Stmts); + PolyORB_Support.Add_Receiving_Stubs_To_Declarations + (Pkg_Spec, Decls, Stmts); when others => - GARLIC_Support.Add_Receiving_Stubs_To_Declarations ( - Pkg_Spec, Decls, Stmts); + GARLIC_Support.Add_Receiving_Stubs_To_Declarations + (Pkg_Spec, Decls, Stmts); end case; end Specific_Add_Receiving_Stubs_To_Declarations; @@ -11558,34 +11263,35 @@ package body Exp_Dist is begin case Get_PCS_Name is when Name_PolyORB_DSA => - PolyORB_Support.Build_General_Calling_Stubs ( - Decls, - Statements, - Target.Object, - Subprogram_Id, - Asynchronous, - Is_Known_Asynchronous, - Is_Known_Non_Asynchronous, - Is_Function, - Spec, - Stub_Type, - RACW_Type, - Nod); + PolyORB_Support.Build_General_Calling_Stubs + (Decls, + Statements, + Target.Object, + Subprogram_Id, + Asynchronous, + Is_Known_Asynchronous, + Is_Known_Non_Asynchronous, + Is_Function, + Spec, + Stub_Type, + RACW_Type, + Nod); + when others => - GARLIC_Support.Build_General_Calling_Stubs ( - Decls, - Statements, - Target.Partition, - Target.RPC_Receiver, - Subprogram_Id, - Asynchronous, - Is_Known_Asynchronous, - Is_Known_Non_Asynchronous, - Is_Function, - Spec, - Stub_Type, - RACW_Type, - Nod); + GARLIC_Support.Build_General_Calling_Stubs + (Decls, + Statements, + Target.Partition, + Target.RPC_Receiver, + Subprogram_Id, + Asynchronous, + Is_Known_Asynchronous, + Is_Known_Non_Asynchronous, + Is_Function, + Spec, + Stub_Type, + RACW_Type, + Nod); end case; end Specific_Build_General_Calling_Stubs; @@ -11611,6 +11317,7 @@ package body Exp_Dist is Subp_Index, Stmts, Decl); + when others => GARLIC_Support.Build_RPC_Receiver_Body (RPC_Receiver, @@ -11637,6 +11344,7 @@ package body Exp_Dist is when Name_PolyORB_DSA => return PolyORB_Support.Build_Stub_Target (Loc, Decls, RCI_Locator, Controlling_Parameter); + when others => return GARLIC_Support.Build_Stub_Target (Loc, Decls, RCI_Locator, Controlling_Parameter); @@ -11659,6 +11367,7 @@ package body Exp_Dist is PolyORB_Support.Build_Stub_Type ( RACW_Type, Stub_Type, Stub_Type_Decl, RPC_Receiver_Decl); + when others => GARLIC_Support.Build_Stub_Type ( RACW_Type, Stub_Type, @@ -11677,21 +11386,22 @@ package body Exp_Dist is begin case Get_PCS_Name is when Name_PolyORB_DSA => - return PolyORB_Support.Build_Subprogram_Receiving_Stubs ( - Vis_Decl, - Asynchronous, - Dynamically_Asynchronous, - Stub_Type, - RACW_Type, - Parent_Primitive); + return PolyORB_Support.Build_Subprogram_Receiving_Stubs + (Vis_Decl, + Asynchronous, + Dynamically_Asynchronous, + Stub_Type, + RACW_Type, + Parent_Primitive); + when others => - return GARLIC_Support.Build_Subprogram_Receiving_Stubs ( - Vis_Decl, - Asynchronous, - Dynamically_Asynchronous, - Stub_Type, - RACW_Type, - Parent_Primitive); + return GARLIC_Support.Build_Subprogram_Receiving_Stubs + (Vis_Decl, + Asynchronous, + Dynamically_Asynchronous, + Stub_Type, + RACW_Type, + Parent_Primitive); end case; end Specific_Build_Subprogram_Receiving_Stubs; @@ -11722,10 +11432,12 @@ package body Exp_Dist is end if; return - Etype (Subtype_Indication ( - Component_Definition ( - First (Component_Items (Component_List ( - Type_Definition (Declaration_Node (Record_Type)))))))); + Etype (Subtype_Indication + (Component_Definition + (First (Component_Items + (Component_List + (Type_Definition + (Declaration_Node (Record_Type)))))))); end Underlying_RACW_Type; end Exp_Dist; diff --git a/gcc/ada/exp_dist.ads b/gcc/ada/exp_dist.ads index cc2323f26c0..a1418d3f6bb 100644 --- a/gcc/ada/exp_dist.ads +++ b/gcc/ada/exp_dist.ads @@ -26,12 +26,16 @@ -- This package contains utility routines used for the generation of the -- stubs relevant to the distribution annex. -with Namet; use Namet; -with Types; use Types; +with Namet; use Namet; +with Snames; use Snames; +with Types; use Types; package Exp_Dist is - PCS_Version_Number : constant := 1; + PCS_Version_Number : constant array (PCS_Names) of Int := + (Name_No_DSA => 1, + Name_GARLIC_DSA => 1, + Name_PolyORB_DSA => 2); -- PCS interface version. This is used to check for consistency between the -- compiler used to generate distribution stubs and the PCS implementation. -- It must be incremented whenever a change is made to the generated code diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb index 162e5d2ee40..b2e05c3c43d 100644 --- a/gcc/ada/exp_fixd.adb +++ b/gcc/ada/exp_fixd.adb @@ -103,7 +103,7 @@ package body Exp_Fixd is function Build_Multiply (N : Node_Id; L, R : Node_Id) return Node_Id; -- Builds an N_Op_Multiply node from the given left and right operand -- expressions, using the source location from Sloc (N). The operands are - -- either both Universal_Real, in which case Build_Divide differs from + -- either both Universal_Real, in which case Build_Multiply differs from -- Make_Op_Multiply only in that the Etype of the resulting node is set (to -- Universal_Real), or they can be integer types. In this case the integer -- types need not be the same, and Build_Multiply chooses a type long @@ -623,25 +623,17 @@ package body Exp_Fixd is -- the effective size of an operand is the RM_Size of the operand. -- But a special case arises with operands whose size is known at -- compile time. In this case, we can use the actual value of the - -- operand to get its size if it would fit in 8 or 16 bits. - - -- Note: if both operands are known at compile time (can that - -- happen?) and both were equal to the power of 2, then we would - -- be one bit off in this test, so for the left operand, we only - -- go up to the power of 2 - 1. This ensures that we do not get - -- this anomalous case, and in practice the right operand is by - -- far the more likely one to be the constant. + -- operand to get its size if it would fit signed in 8 or 16 bits. Left_Size := UI_To_Int (RM_Size (Left_Type)); if Compile_Time_Known_Value (L) then declare Val : constant Uint := Expr_Value (L); - begin - if Val < Int'(2 ** 8) then + if Val < Int'(2 ** 7) then Left_Size := 8; - elsif Val < Int'(2 ** 16) then + elsif Val < Int'(2 ** 15) then Left_Size := 16; end if; end; @@ -652,11 +644,10 @@ package body Exp_Fixd is if Compile_Time_Known_Value (R) then declare Val : constant Uint := Expr_Value (R); - begin - if Val <= Int'(2 ** 8) then + if Val <= Int'(2 ** 7) then Right_Size := 8; - elsif Val <= Int'(2 ** 16) then + elsif Val <= Int'(2 ** 15) then Right_Size := 16; end if; end; diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 6f29b37b3ba..a33bf0472a2 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -45,6 +45,7 @@ with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinput; use Sinput; @@ -165,7 +166,7 @@ package body Exp_Intr is -- If the result type is not parent of Tag_Arg then we need to -- locate the tag of the secondary dispatch table. - if not Is_Parent (Etype (Result_Typ), Etype (Tag_Arg)) then + if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg)) then pragma Assert (not Is_Interface (Etype (Tag_Arg))); Iface_Tag := diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index fd9fe26dd15..d41a6bc383c 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -908,9 +908,9 @@ package body Exp_Util is function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is begin - -- If no component clause, then everything is fine, since the - -- back end never bit-misaligns by default, even if there is - -- a pragma Packed for the record. + -- If no component clause, then everything is fine, since the back end + -- never bit-misaligns by default, even if there is a pragma Packed for + -- the record. if No (Component_Clause (Comp)) then return False; @@ -933,8 +933,8 @@ package body Exp_Util is then return False; - -- Otherwise if the component is not byte aligned, we - -- know we have the nasty unaligned case. + -- Otherwise if the component is not byte aligned, we know we have the + -- nasty unaligned case. elsif Normalized_First_Bit (Comp) /= Uint_0 or else Esize (Comp) mod System_Storage_Unit /= Uint_0 @@ -1116,6 +1116,19 @@ package body Exp_Util is end if; end Ensure_Defined; + -------------------- + -- Entry_Names_OK -- + -------------------- + + function Entry_Names_OK return Boolean is + begin + return + not Restricted_Profile + and then not Global_Discard_Names + and then not Restriction_Active (No_Implicit_Heap_Allocations) + and then not Restriction_Active (No_Local_Allocators); + end Entry_Names_OK; + --------------------- -- Evolve_And_Then -- --------------------- @@ -1373,73 +1386,8 @@ package body Exp_Util is (T : Entity_Id; Iface : Entity_Id) return Elmt_Id is - ADT : Elmt_Id; - Found : Boolean := False; - Typ : Entity_Id := T; - - procedure Find_Secondary_Table (Typ : Entity_Id); - -- Internal subprogram used to recursively climb to the ancestors - - -------------------------- - -- Find_Secondary_Table -- - -------------------------- - - procedure Find_Secondary_Table (Typ : Entity_Id) is - AI_Elmt : Elmt_Id; - AI : Node_Id; - - begin - pragma Assert (Typ /= Iface); - - -- Climb to the ancestor (if any) handling synchronized interface - -- derivations and private types - - if Is_Concurrent_Record_Type (Typ) then - declare - Iface_List : constant List_Id := Abstract_Interface_List (Typ); - - begin - if Is_Non_Empty_List (Iface_List) then - Find_Secondary_Table (Etype (First (Iface_List))); - end if; - end; - - elsif Present (Full_View (Etype (Typ))) then - if Full_View (Etype (Typ)) /= Typ then - Find_Secondary_Table (Full_View (Etype (Typ))); - end if; - - elsif Etype (Typ) /= Typ then - Find_Secondary_Table (Etype (Typ)); - end if; - - -- Traverse the list of interfaces implemented by the type - - if not Found - and then Present (Abstract_Interfaces (Typ)) - and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) - then - AI_Elmt := First_Elmt (Abstract_Interfaces (Typ)); - while Present (AI_Elmt) loop - AI := Node (AI_Elmt); - - if AI = Iface or else Is_Ancestor (Iface, AI) then - Found := True; - return; - end if; - - -- Document what is going on here, why four Next's??? - - Next_Elmt (ADT); - Next_Elmt (ADT); - Next_Elmt (ADT); - Next_Elmt (ADT); - Next_Elmt (AI_Elmt); - end loop; - end if; - end Find_Secondary_Table; - - -- Start of processing for Find_Interface_ADT + ADT : Elmt_Id; + Typ : Entity_Id := T; begin pragma Assert (Is_Interface (Iface)); @@ -1468,11 +1416,23 @@ package body Exp_Util is (not Is_Class_Wide_Type (Typ) and then Ekind (Typ) /= E_Incomplete_Type); - ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); - pragma Assert (Present (Node (ADT))); - Find_Secondary_Table (Typ); - pragma Assert (Found); - return ADT; + if Is_Ancestor (Iface, Typ) then + return First_Elmt (Access_Disp_Table (Typ)); + + else + ADT := + Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); + while Present (ADT) + and then Present (Related_Type (Node (ADT))) + and then Related_Type (Node (ADT)) /= Iface + and then not Is_Ancestor (Iface, Related_Type (Node (ADT))) + loop + Next_Elmt (ADT); + end loop; + + pragma Assert (Present (Related_Type (Node (ADT)))); + return ADT; + end if; end Find_Interface_ADT; ------------------------ @@ -1487,14 +1447,6 @@ package body Exp_Util is Found : Boolean := False; Typ : Entity_Id := T; - Is_Primary_Tag : Boolean := False; - - Is_Sync_Typ : Boolean := False; - -- In case of non concurrent-record-types each parent-type has the - -- tags associated with the interface types that are not implemented - -- by the ancestors; concurrent-record-types have their whole list of - -- interface tags (and this case requires some special management). - procedure Find_Tag (Typ : Entity_Id); -- Internal subprogram used to recursively climb to the ancestors @@ -1511,32 +1463,15 @@ package body Exp_Util is -- therefore shares the main tag. if Typ = Iface then - if Is_Sync_Typ then - Is_Primary_Tag := True; - else - pragma Assert - (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); - AI_Tag := First_Tag_Component (Typ); - end if; - + pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); + AI_Tag := First_Tag_Component (Typ); Found := True; return; end if; - -- Handle synchronized interface derivations - - if Is_Concurrent_Record_Type (Typ) then - declare - Iface_List : constant List_Id := Abstract_Interface_List (Typ); - begin - if Is_Non_Empty_List (Iface_List) then - Find_Tag (Etype (First (Iface_List))); - end if; - end; - -- Climb to the root type handling private types - elsif Present (Full_View (Etype (Typ))) then + if Present (Full_View (Etype (Typ))) then if Full_View (Etype (Typ)) /= Typ then Find_Tag (Full_View (Etype (Typ))); end if; @@ -1548,19 +1483,16 @@ package body Exp_Util is -- Traverse the list of interfaces implemented by the type if not Found - and then Present (Abstract_Interfaces (Typ)) - and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ))) + and then Present (Interfaces (Typ)) + and then not (Is_Empty_Elmt_List (Interfaces (Typ))) then -- Skip the tag associated with the primary table - if not Is_Sync_Typ then - pragma Assert - (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); - AI_Tag := Next_Tag_Component (First_Tag_Component (Typ)); - pragma Assert (Present (AI_Tag)); - end if; + pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); + AI_Tag := Next_Tag_Component (First_Tag_Component (Typ)); + pragma Assert (Present (AI_Tag)); - AI_Elmt := First_Elmt (Abstract_Interfaces (Typ)); + AI_Elmt := First_Elmt (Interfaces (Typ)); while Present (AI_Elmt) loop AI := Node (AI_Elmt); @@ -1611,149 +1543,10 @@ package body Exp_Util is Typ := Non_Limited_View (Typ); end if; - if not Is_Concurrent_Record_Type (Typ) then - Find_Tag (Typ); - pragma Assert (Found); - return AI_Tag; - - -- Concurrent record types - - else - Is_Sync_Typ := True; - AI_Tag := Next_Tag_Component (First_Tag_Component (Typ)); - Find_Tag (Typ); - pragma Assert (Found); - - if Is_Primary_Tag then - return First_Tag_Component (Typ); - else - return AI_Tag; - end if; - end if; - end Find_Interface_Tag; - - -------------------- - -- Find_Interface -- - -------------------- - - function Find_Interface - (T : Entity_Id; - Comp : Entity_Id) return Entity_Id - is - AI_Tag : Entity_Id; - Found : Boolean := False; - Iface : Entity_Id; - Typ : Entity_Id := T; - - Is_Sync_Typ : Boolean := False; - -- In case of non concurrent-record-types each parent-type has the - -- tags associated with the interface types that are not implemented - -- by the ancestors; concurrent-record-types have their whole list of - -- interface tags (and this case requires some special management). - - procedure Find_Iface (Typ : Entity_Id); - -- Internal subprogram used to recursively climb to the ancestors - - ---------------- - -- Find_Iface -- - ---------------- - - procedure Find_Iface (Typ : Entity_Id) is - AI_Elmt : Elmt_Id; - - begin - -- Climb to the root type - - -- Handle synchronized interface derivations - - if Is_Concurrent_Record_Type (Typ) then - declare - Iface_List : constant List_Id := Abstract_Interface_List (Typ); - begin - if Is_Non_Empty_List (Iface_List) then - Find_Iface (Etype (First (Iface_List))); - end if; - end; - - -- Handle the common case - - elsif Etype (Typ) /= Typ then - pragma Assert (not Present (Full_View (Etype (Typ)))); - Find_Iface (Etype (Typ)); - end if; - - -- Traverse the list of interfaces implemented by the type - - if not Found - and then Present (Abstract_Interfaces (Typ)) - and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ))) - then - -- Skip the tag associated with the primary table - - if not Is_Sync_Typ then - pragma Assert - (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); - AI_Tag := Next_Tag_Component (First_Tag_Component (Typ)); - pragma Assert (Present (AI_Tag)); - end if; - - AI_Elmt := First_Elmt (Abstract_Interfaces (Typ)); - while Present (AI_Elmt) loop - if AI_Tag = Comp then - Iface := Node (AI_Elmt); - Found := True; - return; - end if; - - AI_Tag := Next_Tag_Component (AI_Tag); - Next_Elmt (AI_Elmt); - end loop; - end if; - end Find_Iface; - - -- Start of processing for Find_Interface - - begin - -- Handle private types - - if Has_Private_Declaration (Typ) - and then Present (Full_View (Typ)) - then - Typ := Full_View (Typ); - end if; - - -- Handle access types - - if Is_Access_Type (Typ) then - Typ := Directly_Designated_Type (Typ); - end if; - - -- Handle task and protected types implementing interfaces - - if Is_Concurrent_Type (Typ) then - Typ := Corresponding_Record_Type (Typ); - end if; - - if Is_Class_Wide_Type (Typ) then - Typ := Etype (Typ); - end if; - - -- Handle entities from the limited view - - if Ekind (Typ) = E_Incomplete_Type then - pragma Assert (Present (Non_Limited_View (Typ))); - Typ := Non_Limited_View (Typ); - end if; - - if Is_Concurrent_Record_Type (Typ) then - Is_Sync_Typ := True; - AI_Tag := Next_Tag_Component (First_Tag_Component (Typ)); - end if; - - Find_Iface (Typ); + Find_Tag (Typ); pragma Assert (Found); - return Iface; - end Find_Interface; + return AI_Tag; + end Find_Interface_Tag; ------------------ -- Find_Prim_Op -- @@ -3049,55 +2842,6 @@ package body Exp_Util is and then Is_Library_Level_Entity (Typ); end Is_Library_Level_Tagged_Type; - ----------------------------------------- - -- Is_Predefined_Dispatching_Operation -- - ----------------------------------------- - - function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean - is - TSS_Name : TSS_Name_Type; - - begin - if not Is_Dispatching_Operation (E) then - return False; - end if; - - Get_Name_String (Chars (E)); - - -- Most predefined primitives have internally generated names. Equality - -- must be treated differently; the predefined operation is recognized - -- as a homogeneous binary operator that returns Boolean. - - if Name_Len > TSS_Name_Type'Last then - TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 - .. Name_Len)); - if Chars (E) = Name_uSize - or else Chars (E) = Name_uAlignment - or else TSS_Name = TSS_Stream_Read - or else TSS_Name = TSS_Stream_Write - or else TSS_Name = TSS_Stream_Input - or else TSS_Name = TSS_Stream_Output - or else - (Chars (E) = Name_Op_Eq - and then Etype (First_Entity (E)) = Etype (Last_Entity (E))) - or else Chars (E) = Name_uAssign - or else TSS_Name = TSS_Deep_Adjust - or else TSS_Name = TSS_Deep_Finalize - or else (Ada_Version >= Ada_05 - and then (Chars (E) = Name_uDisp_Asynchronous_Select - or else Chars (E) = Name_uDisp_Conditional_Select - or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind - or else Chars (E) = Name_uDisp_Get_Task_Id - or else Chars (E) = Name_uDisp_Requeue - or else Chars (E) = Name_uDisp_Timed_Select)) - then - return True; - end if; - end if; - - return False; - end Is_Predefined_Dispatching_Operation; - ---------------------------------- -- Is_Possibly_Unaligned_Object -- ---------------------------------- @@ -4295,8 +4039,8 @@ package body Exp_Util is begin -- If we know the component size and it is less than 64, then - -- we are definitely OK. The back end always does assignment - -- of misaligned small objects correctly. + -- we are definitely OK. The back end always does assignment of + -- misaligned small objects correctly. if Known_Static_Component_Size (Ptyp) and then Component_Size (Ptyp) <= 64 diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 73277afe16b..5e57147b720 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -205,6 +205,7 @@ package Exp_Util is -- index values. For composite types, the result includes two declarations: -- one for a generated function that computes the image without using -- concatenation, and one for the variable that holds the result. + -- -- If In_Init_Proc is true, the call is part of the initialization of -- a component of a composite type, and the enclosing initialization -- procedure must be flagged as using the secondary stack. If In_Init_Proc @@ -314,6 +315,11 @@ package Exp_Util is -- used to ensure that an Itype is properly defined outside a conditional -- construct when it is referenced in more than one branch. + function Entry_Names_OK return Boolean; + -- Determine whether it is appropriate to dynamically allocate strings + -- which represent entry [family member] names. These strings are created + -- by the compiler and used by GDB. + procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id); -- Rewrites Cond with the expression: Cond and then Cond1. If Cond is -- Empty, then simply returns Cond1 (this allows the use of Empty to @@ -337,13 +343,6 @@ package Exp_Util is -- declarations and/or allocations when the type is indefinite (including -- class-wide). - function Find_Interface - (T : Entity_Id; - Comp : Entity_Id) return Entity_Id; - -- Ada 2005 (AI-251): Given a tagged type and one of its components - -- associated with the secondary dispatch table of an abstract interface - -- type, return the associated abstract interface type. - function Find_Interface_ADT (T : Entity_Id; Iface : Entity_Id) return Elmt_Id; @@ -384,7 +383,7 @@ package Exp_Util is Name_Req : Boolean := False); -- Force the evaluation of the expression right away. Similar behavior -- to Remove_Side_Effects when Variable_Ref is set to TRUE. That is to - -- say, it removes the side-effects and capture the values of the + -- say, it removes the side-effects and captures the values of the -- variables. Remove_Side_Effects guarantees that multiple evaluations -- of the same expression won't generate multiple side effects, whereas -- Force_Evaluation further guarantees that all evaluations will yield @@ -457,9 +456,6 @@ package Exp_Util is -- Return True if Typ is a library level tagged type. Currently we use -- this information to build statically allocated dispatch tables. - function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean; - -- Ada 2005 (AI-251): Determines if E is a predefined primitive operation - function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean; -- Determine whether the node P is a reference to a bit packed array, i.e. -- whether the designated object is a component of a bit packed array, or a @@ -481,7 +477,7 @@ package Exp_Util is -- Node N is an object reference. This function returns True if it is -- possible that the object may not be aligned according to the normal -- default alignment requirement for its type (e.g. if it appears in a - -- packed record, or as part of a component that has a component clause. + -- packed record, or as part of a component that has a component clause.) function Is_Renamed_Object (N : Node_Id) return Boolean; -- Returns True if the node N is a renamed object. An expression is @@ -569,12 +565,12 @@ package Exp_Util is -- returned only if the replacement is safe. function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean; - -- This function is used in processing the assignment of a record or - -- indexed component. The argument N is either the left hand or right - -- hand side of an assignment, and this function determines if there - -- is a record component reference where the record may be bit aligned - -- in a manner that causes trouble for the back end (see description - -- of Exp_Util.Component_May_Be_Bit_Aligned for further details). + -- This function is used during processing the assignment of a record or + -- indexed component. The argument N is either the left hand or right hand + -- side of an assignment, and this function determines if there is a record + -- component reference where the record may be bit aligned in a manner that + -- causes trouble for the back end (see Component_May_Be_Bit_Aligned for + -- further details). procedure Remove_Side_Effects (Exp : Node_Id; diff --git a/gcc/ada/exp_vfpt.adb b/gcc/ada/exp_vfpt.adb index 0537cf089d0..9f172566cf5 100644 --- a/gcc/ada/exp_vfpt.adb +++ b/gcc/ada/exp_vfpt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-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- -- @@ -443,6 +443,41 @@ package body Exp_VFpt is Analyze_And_Resolve (N, T_Typ, Suppress => All_Checks); end Expand_Vax_Conversion; + ------------------------------- + -- Expand_Vax_Foreign_Return -- + ------------------------------- + + procedure Expand_Vax_Foreign_Return (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Base_Type (Etype (N)); + Func : RE_Id; + Args : List_Id; + Atyp : Entity_Id; + Rtyp : constant Entity_Id := Etype (N); + + begin + if Digits_Value (Typ) = VAXFF_Digits then + Func := RE_Return_F; + Atyp := RTE (RE_F); + elsif Digits_Value (Typ) = VAXDF_Digits then + Func := RE_Return_D; + Atyp := RTE (RE_D); + else pragma Assert (Digits_Value (Typ) = VAXGF_Digits); + Func := RE_Return_G; + Atyp := RTE (RE_G); + end if; + + Args := New_List (Convert_To (Atyp, N)); + + Rewrite (N, + Convert_To (Rtyp, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Func), Loc), + Parameter_Associations => Args))); + + Analyze_And_Resolve (N, Typ, Suppress => All_Checks); + end Expand_Vax_Foreign_Return; + ----------------------------- -- Expand_Vax_Real_Literal -- ----------------------------- diff --git a/gcc/ada/exp_vfpt.ads b/gcc/ada/exp_vfpt.ads index 1652ad84ab5..fdca701cfb1 100644 --- a/gcc/ada/exp_vfpt.ads +++ b/gcc/ada/exp_vfpt.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- -- @@ -45,6 +45,12 @@ package Exp_VFpt is -- The node N is a type conversion node where either the source or the -- target type, or both, are Vax floating-point type. + procedure Expand_Vax_Foreign_Return (N : Node_Id); + -- The node N is a call to a foreign function that returns a Vax float + -- value in a floating point register. Wraps the call in an asm stub + -- that moves the return value to an integer location on Alpha/VMS, + -- noop everywhere else. + procedure Expand_Vax_Real_Literal (N : Node_Id); -- The node N is a real literal node where the type is a Vax floating-point -- type. This procedure rewrites the node to eliminate the occurrence of diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 21b1ad5884c..31f93985c44 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -29,7 +29,9 @@ with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; +with Exp_Ch3; use Exp_Ch3; with Exp_Ch7; use Exp_Ch7; +with Exp_Disp; use Exp_Disp; with Exp_Pakd; use Exp_Pakd; with Exp_Util; use Exp_Util; with Exp_Tss; use Exp_Tss; @@ -2650,10 +2652,31 @@ package body Freeze is Validate_Object_Declaration (Declaration_Node (E)); - -- If there is an address clause, check it is valid + -- If there is an address clause, check that it is valid Check_Address_Clause (E); + -- If the object needs any kind of default initialization, an + -- error must be issued if No_Default_Initialization applies. + -- The check doesn't apply to imported objects, which are not + -- ever default initialized, and is why the check is deferred + -- until freezing, at which point we know if Import applies. + + if not Is_Imported (E) + and then not Has_Init_Expression (Declaration_Node (E)) + and then + ((Has_Non_Null_Base_Init_Proc (Etype (E)) + and then not No_Initialization (Declaration_Node (E)) + and then not Is_Value_Type (Etype (E)) + and then not Suppress_Init_Proc (Etype (E))) + or else + (Needs_Simple_Initialization (Etype (E)) + and then not Is_Internal (E))) + then + Check_Restriction + (No_Default_Initialization, Declaration_Node (E)); + end if; + -- For imported objects, set Is_Public unless there is also an -- address clause, which means that there is no external symbol -- needed for the Import (Is_Public may still be set for other diff --git a/gcc/ada/g-heasor.ads b/gcc/ada/g-heasor.ads index a30d0b6325b..177f40ce770 100644 --- a/gcc/ada/g-heasor.ads +++ b/gcc/ada/g-heasor.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2006, AdaCore -- +-- Copyright (C) 1995-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- -- @@ -43,9 +43,7 @@ -- See also GNAT.Heap_Sort_G which is a generic version that will be faster -- since the overhead of the indirect calls is avoided, at the expense of --- generic code duplication and less convenient interface. The generic version --- also has the advantage of being Pure, while this unit can only be --- Preelaborate, because of the access types. +-- generic code duplication and less convenient interface. -- Note: GNAT.Heap_Sort replaces and obsoletes GNAT.Heap_Sort_A, which is -- retained in the GNAT library for backwards compatibility. diff --git a/gcc/ada/gigi.h b/gcc/ada/gigi.h index 9b0c2bec8d5..68e5ebf141e 100644 --- a/gcc/ada/gigi.h +++ b/gcc/ada/gigi.h @@ -104,7 +104,7 @@ extern void add_decl_expr (tree gnu_decl, Entity_Id gnat_entity); /* Mark nodes rooted at *TP with TREE_VISITED and types as having their sized gimplified. We use this to indicate all variable sizes and - positions in global types may not be shared by any subprograms. */ + positions in global types may not be shared by any subprogram. */ extern void mark_visited (tree *); /* Finalize any From_With_Type incomplete types. We do this after processing @@ -217,7 +217,7 @@ extern void gigi (Node_Id gnat_root, int max_gnat_node, int number_name, Char_Code *strings_chars_ptr, struct List_Header *list_headers_ptr, Nat number_file, - struct File_Info_Type *file_info_ptr ATTRIBUTE_UNUSED, + struct File_Info_Type *file_info_ptr, Entity_Id standard_integer, Entity_Id standard_long_long_float, Entity_Id standard_exception_type, @@ -852,7 +852,7 @@ extern tree gnat_builtin_function (tree decl); /* Search the chain of currently reachable declarations for a builtin FUNCTION_DECL node corresponding to function NAME (an IDENTIFIER_NODE). Return the first node found, if any, or NULL_TREE otherwise. */ -extern tree builtin_decl_for (tree name ATTRIBUTE_UNUSED); +extern tree builtin_decl_for (tree name); /* This function is called by the front end to enumerate all the supported modes for the machine. We pass a function which is called back with diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index c048581d662..5046cc56c73 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -3897,7 +3897,7 @@ the Profile (Ravenscar), the value of Max_Task_Entries is always no calls to Task_Identification.Abort_Task. @item No_Asynchronous_Control -[RM D.7] There are no semantic dependences on the package +There are no semantic dependences on the package Asynchronous_Task_Control. @item No_Calendar @@ -3918,6 +3918,10 @@ Detach_Handler, and Reference). Protected objects and access types that designate such objects shall be declared only at library level. +@item No_Local_Timing_Events +[RM D.7] All objects of type Ada.Timing_Events.Timing_Event are +declared at the library level. + @item No_Protected_Type_Allocators There are no allocators for protected types or types containing protected subcomponents. @@ -3931,6 +3935,10 @@ Requeue statements are not allowed. @item No_Select_Statements There are no select_statements. +@item No_Specific_Termination_Handlers +[RM D.7] There are no calls to Ada.Task_Termination.Set_Specific_Handler +or to Ada.Task_Termination.Specific_Handler. + @item No_Task_Allocators [RM D.7] There are no allocators for task types or types containing task subcomponents. @@ -3945,6 +3953,12 @@ directly on the environment task of the partition. @item No_Task_Termination Tasks which terminate are erroneous. +@item No_Unchecked_Conversion +There are no semantic dependencies on the Ada.Unchecked_Conversion package. + +@item No_Unchecked_Deallocation +There are no semantic dependencies on the Ada.Unchecked_Deallocation package. + @item Simple_Barriers Entry barrier condition expressions shall be either static boolean expressions or boolean objects which are declared in @@ -5803,6 +5817,10 @@ package body Old_Pkg is end Old_Pkg; @end smallexample +@noindent +Note that it is allowed to apply 'Old to a constant entity, but this will +result in a warning, since the old and new values will always be the same. + @node Passed_By_Reference @unnumberedsec Passed_By_Reference @cindex Parameters, when passed by reference @@ -8370,6 +8388,7 @@ of composite objects and the Max/Min attributes. @item No_Implicit_Dynamic_Code @findex No_Implicit_Dynamic_Code +@cindex trampoline This restriction prevents the compiler from building ``trampolines''. This is a structure that is built on the stack and contains dynamic code to be executed at run time. On some targets, a trampoline is @@ -8379,6 +8398,17 @@ nested task bodies; primitive operations of nested tagged types. Trampolines do not work on machines that prevent execution of stack data. For example, on windows systems, enabling DEP (data execution protection) will cause trampolines to raise an exception. +Trampolines are also quite slow at run time. + +On many targets, trampolines have been largely eliminated. Look at the +version of system.ads for your target --- if it has +Always_Compatible_Rep equal to False, then trampolines are largely +eliminated. In particular, a trampoline is built for the following +features: @code{Address} of a nested subprogram; +@code{Access} or @code{Unrestricted_Access} of a nested subprogram, +but only if pragma Favor_Top_Level applies, or the access type has a +foreign-language convention; primitive operations of nested tagged +types. @item No_Implicit_Loops @findex No_Implicit_Loops diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index ed5cec7d049..d40d0e86199 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -12072,7 +12072,9 @@ the inherited body is not part of the sources of the project, otherwise there will be a compilation error when compiling the spec. For that purpose, the attribute @code{Excluded_Source_Files} is used. -Its value is a string list: a list of file names. +Its value is a string list: a list of file names. It is also possible to use +attribute @code{Excluded_Source_List_File}. Its value is a single string: +the file name of a text file containing a list of file names, one per line. @smallexample @c @projectfile project B extends "a" is @@ -12495,6 +12497,8 @@ The following attributes are defined on projects (all are simple attributes): @tab string list @item @code{Excluded_Source_Files} @tab string list +@item @code{Excluded_Source_List_File} +@tab string @item @code{Languages} @tab string list @item @code{Main} @@ -17833,6 +17837,21 @@ In this example, @i{expression} is defined by the following grammar: @i{expression} ::= ( @i{expression} ) @end smallexample +The following restriction exists: it is not allowed to have "and" or "or" +following "not" in the same expression without parentheses. For example, this +is not allowed: + +@smallexample + not X or Y +@end smallexample + +This should be one of the following: + +@smallexample + (not X) or Y + not (X or Y) +@end smallexample + @noindent For the first test (@i{expression} ::= <symbol>) the symbol must have either the value true or false, that is to say the right-hand of the @@ -20513,6 +20532,7 @@ used as a parameter of the @option{+R} or @option{-R} options. * Predefined_Numeric_Types:: * Raising_External_Exceptions:: * Raising_Predefined_Exceptions:: +* Separate_Numeric_Error_Handlers:: @ignore * Recursion:: * Side_Effect_Functions:: @@ -21707,6 +21727,18 @@ Flag each @code{raise} statement that raises a predefined exception This rule has no parameters. +@node Separate_Numeric_Error_Handlers +@subsection @code{Separate_Numeric_Error_Handlers} +@cindex @code{Separate_Numeric_Error_Handlers} rule (for @command{gnatcheck}) + +@noindent +Flags each exception handler that contains a choice for +the predefined @code{Constraint_Error} exception, but does not contain +the choice for the predefined @code{Numeric_Error} exception, or +that contains the choice for @code{Numeric_Error}, but does not contain the +choice for @code{Constraint_Error}. + +This rule has no parameters. @ignore @node Recursion diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 8135bfc8a4d..2b0c6c4add2 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -349,9 +349,9 @@ procedure GNATCmd is while Main /= Nil_String loop File := new String' - (Get_Name_String (Data.Object_Directory) & - Directory_Separator & - B_Start.all & + (Get_Name_String (Data.Object_Directory.Name) & + Directory_Separator & + B_Start.all & MLib.Fil.Ext_To (Get_Name_String (Project_Tree.String_Elements.Table @@ -375,10 +375,10 @@ procedure GNATCmd is File := new String' - (Get_Name_String (Data.Object_Directory) & - Directory_Separator & - B_Start.all & - Get_Name_String (Data.Library_Name) & + (Get_Name_String (Data.Object_Directory.Name) & + Directory_Separator & + B_Start.all & + Get_Name_String (Data.Library_Name) & ".ci"); if Is_Regular_File (File.all) then @@ -403,7 +403,7 @@ procedure GNATCmd is if Unit_Data.File_Names (Body_Part).Name /= No_File and then - Unit_Data.File_Names (Body_Part).Path /= Slash + Unit_Data.File_Names (Body_Part).Path.Name /= Slash then -- There is a body, check if it is for this project @@ -415,7 +415,8 @@ procedure GNATCmd is if Unit_Data.File_Names (Specification).Name = No_File or else - Unit_Data.File_Names (Specification).Path = Slash + Unit_Data.File_Names + (Specification).Path.Name = Slash then -- We have a body with no spec: we need to check if -- this is a subunit, because gnatls will complain @@ -428,7 +429,7 @@ procedure GNATCmd is Src_Ind := Sinput.P.Load_Project_File (Get_Name_String (Unit_Data.File_Names - (Body_Part).Path)); + (Body_Part).Path.Name)); Subunit := Sinput.P.Source_File_Is_Subunit @@ -449,7 +450,7 @@ procedure GNATCmd is elsif Unit_Data.File_Names (Specification).Name /= No_File and then - Unit_Data.File_Names (Specification).Path /= Slash + Unit_Data.File_Names (Specification).Path.Name /= Slash then -- We have a spec with no body; check if it is for this -- project. @@ -475,7 +476,7 @@ procedure GNATCmd is if Unit_Data.File_Names (Body_Part).Name /= No_File and then - Unit_Data.File_Names (Body_Part).Path /= Slash + Unit_Data.File_Names (Body_Part).Path.Name /= Slash then -- There is a body. Check if .ci files for this project -- must be added. @@ -489,7 +490,8 @@ procedure GNATCmd is if Unit_Data.File_Names (Specification).Name = No_File or else - Unit_Data.File_Names (Specification).Path = Slash + Unit_Data.File_Names + (Specification).Path.Name = Slash then -- We have a body with no spec: we need to check -- if this is a subunit, because .ci files are not @@ -501,7 +503,8 @@ procedure GNATCmd is begin Src_Ind := Sinput.P.Load_Project_File (Get_Name_String - (Unit_Data.File_Names (Body_Part).Path)); + (Unit_Data.File_Names + (Body_Part).Path.Name)); Subunit := Sinput.P.Source_File_Is_Subunit (Src_Ind); @@ -516,7 +519,7 @@ procedure GNATCmd is (Project_Tree.Projects.Table (Unit_Data.File_Names (Body_Part).Project). - Object_Directory) & + Object_Directory.Name) & Directory_Separator & MLib.Fil.Ext_To (Get_Name_String @@ -529,7 +532,7 @@ procedure GNATCmd is elsif Unit_Data.File_Names (Specification).Name /= No_File and then - Unit_Data.File_Names (Specification).Path /= Slash + Unit_Data.File_Names (Specification).Path.Name /= Slash then -- We have a spec with no body. Check if it is for this -- project. @@ -546,7 +549,7 @@ procedure GNATCmd is (Project_Tree.Projects.Table (Unit_Data.File_Names (Specification).Project). - Object_Directory) & + Object_Directory.Name) & Dir_Separator & MLib.Fil.Ext_To (Get_Name_String @@ -565,14 +568,14 @@ procedure GNATCmd is if Check_Project (Unit_Data.File_Names (Kind).Project, Project) and then Unit_Data.File_Names (Kind).Name /= No_File - and then Unit_Data.File_Names (Kind).Path /= Slash + and then Unit_Data.File_Names (Kind).Path.Name /= Slash then Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String' (Get_Name_String (Unit_Data.File_Names - (Kind).Display_Path)); + (Kind).Path.Display_Name)); end if; end loop; end if; @@ -688,7 +691,7 @@ procedure GNATCmd is end loop; Get_Name_String (Project_Tree.Projects.Table - (Project).Exec_Directory); + (Project).Exec_Directory.Name); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; @@ -870,7 +873,7 @@ procedure GNATCmd is Get_Name_String (Udata.File_Names (Specification).Name) = Line (1 .. Last) then - Path := Udata.File_Names (Specification).Path; + Path := Udata.File_Names (Specification).Path.Name; exit; elsif Udata.File_Names (Body_Part).Name /= No_File @@ -878,7 +881,7 @@ procedure GNATCmd is Get_Name_String (Udata.File_Names (Body_Part).Name) = Line (1 .. Last) then - Path := Udata.File_Names (Body_Part).Path; + Path := Udata.File_Names (Body_Part).Path.Name; exit; end if; end loop; @@ -1103,7 +1106,7 @@ procedure GNATCmd is Dir : constant String := Get_Name_String (Project_Tree.Projects.Table - (Prj).Object_Directory); + (Prj).Object_Directory.Name); begin if Is_Regular_File (Dir & @@ -1184,7 +1187,7 @@ procedure GNATCmd is new String'("-o"); Get_Name_String (Project_Tree.Projects.Table - (Project).Exec_Directory); + (Project).Exec_Directory.Name); Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String'(Name_Buffer (1 .. Name_Len) & @@ -1222,7 +1225,7 @@ procedure GNATCmd is new String'("-L" & Get_Name_String (Project_Tree.Projects.Table - (Project).Library_Dir)); + (Project).Library_Dir.Name)); -- Add the -l switch @@ -1244,7 +1247,7 @@ procedure GNATCmd is Library_Paths.Table (Library_Paths.Last) := new String'(Get_Name_String (Project_Tree.Projects.Table - (Project).Library_Dir)); + (Project).Library_Dir.Name)); end if; end if; end Set_Library_For; @@ -1336,7 +1339,14 @@ procedure GNATCmd is Put (To_Lower (Command_List (C).Cname.all)); Set_Col (25); - Put (Program_Name (Command_List (C).Unixcmd.all).all); + + -- Never call gnatstack with a prefix + + if C = Stack then + Put (Command_List (C).Unixcmd.all); + else + Put (Program_Name (Command_List (C).Unixcmd.all).all); + end if; declare Sws : Argument_List_Access renames Command_List (C).Unixsws; @@ -1560,18 +1570,26 @@ begin end if; declare - Program : constant String := - Program_Name (Command_List (The_Command).Unixcmd.all).all; - + Program : String_Access; Exec_Path : String_Access; begin + if The_Command = Stack then + -- Never call gnatstack with a prefix + + Program := new String'(Command_List (The_Command).Unixcmd.all); + + else + Program := + Program_Name (Command_List (The_Command).Unixcmd.all); + end if; + -- Locate the executable for the command - Exec_Path := Locate_Exec_On_Path (Program); + Exec_Path := Locate_Exec_On_Path (Program.all); if Exec_Path = null then - Put_Line (Standard_Error, "could not locate " & Program); + Put_Line (Standard_Error, "could not locate " & Program.all); raise Error_Exit; end if; @@ -1978,7 +1996,7 @@ begin Change_Dir (Get_Name_String (Project_Tree.Projects.Table - (Project).Object_Directory)); + (Project).Object_Directory.Name)); end if; -- Set up the env vars for project path files @@ -2191,7 +2209,7 @@ begin end loop; Get_Name_String - (Project_Tree.Projects.Table (Project).Directory); + (Project_Tree.Projects.Table (Project).Directory.Name); declare Project_Dir : constant String := Name_Buffer (1 .. Name_Len); @@ -2291,7 +2309,8 @@ begin if The_Command = Metric and then - Project_Tree.Projects.Table (Project).Object_Directory /= No_Path + Project_Tree.Projects.Table (Project).Object_Directory /= + No_Path_Information then First_Switches.Increment_Last; First_Switches.Table (2 .. First_Switches.Last) := @@ -2300,7 +2319,7 @@ begin new String'("-d=" & Get_Name_String (Project_Tree.Projects.Table - (Project).Object_Directory)); + (Project).Object_Directory.Name)); end if; -- For gnat check, -rules and the following switches need to be the diff --git a/gcc/ada/gnatname.adb b/gcc/ada/gnatname.adb index dbd7f509312..d684551ed91 100644 --- a/gcc/ada/gnatname.adb +++ b/gcc/ada/gnatname.adb @@ -201,6 +201,9 @@ procedure Gnatname is when Error_In_Regexp => Fail ("invalid regular expression """, S, """"); end Check_Regular_Expression; + + -- Start of processing for Scan_Args + begin -- First check for --version or --help @@ -214,6 +217,7 @@ procedure Gnatname is 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); @@ -221,9 +225,10 @@ procedure Gnatname is begin if Arg'Length > 0 then - if Project_File_Name_Expected then - -- -P xxx + -- -P xxx + + if Project_File_Name_Expected then if Arg (1) = '-' then Fail ("project file name missing"); @@ -233,48 +238,50 @@ procedure Gnatname is Project_File_Name_Expected := False; end if; - elsif Pragmas_File_Expected then - -- -c file + -- -c file + elsif Pragmas_File_Expected then File_Set := True; File_Path := new String'(Arg); Create_Project := False; Pragmas_File_Expected := False; - elsif Directory_Expected then - -- -d xxx + -- -d xxx + elsif Directory_Expected then Add_Source_Directory (Arg); Directory_Expected := False; - elsif Dir_File_Name_Expected then - -- -D xxx + -- -D xxx + elsif Dir_File_Name_Expected then Get_Directories (Arg); Dir_File_Name_Expected := False; - elsif Foreign_Pattern_Expected then - -- -f xxx + -- -f xxx + elsif Foreign_Pattern_Expected then 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 + -- -x xxx + elsif Excluded_Pattern_Expected then 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. - -- There must be at least one Ada pattern or one foreign - -- pattern for the previous section. + -- --and + + elsif Arg = "--and" then if Patterns.Last (Arguments.Table (Arguments.Last).Name_Patterns) = 0 @@ -297,8 +304,7 @@ procedure Gnatname is new String'(".")); end if; - -- Add another component in table Arguments and initialize - -- it. + -- Add and initialize another component to Arguments table Arguments.Increment_Last; @@ -319,12 +325,16 @@ procedure Gnatname is Patterns.Set_Last (Arguments.Table (Arguments.Last).Foreign_Patterns, 0); + -- Subdirectory switch + 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)); + -- -c + 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"); @@ -343,6 +353,8 @@ procedure Gnatname is Create_Project := False; end if; + -- -d + elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-d" then if Arg'Length = 2 then Directory_Expected := True; @@ -355,6 +367,8 @@ procedure Gnatname is Add_Source_Directory (Arg (3 .. Arg'Last)); end if; + -- -D + elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-D" then if Arg'Length = 2 then Dir_File_Name_Expected := True; @@ -367,9 +381,13 @@ procedure Gnatname is Get_Directories (Arg (3 .. Arg'Last)); end if; + -- -eL + elsif Arg = "-eL" then Opt.Follow_Links_For_Files := True; + -- -f + elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-f" then if Arg'Length = 2 then Foreign_Pattern_Expected := True; @@ -385,15 +403,20 @@ procedure Gnatname is Check_Regular_Expression (Arg (3 .. Arg'Last)); end if; + -- -gnatep or -gnateD + elsif Arg'Length > 7 and then (Arg (1 .. 7) = "-gnatep" or else Arg (1 .. 7) = "-gnateD") then - Preprocessor_Switches.Append (new String'(Arg)); + -- -h + elsif Arg = "-h" then Usage_Needed := True; + -- -p + 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"); @@ -414,6 +437,8 @@ procedure Gnatname is Create_Project := True; + -- -v + elsif Arg = "-v" then if Opt.Verbose_Mode then Very_Verbose := True; @@ -421,6 +446,8 @@ procedure Gnatname is Opt.Verbose_Mode := True; end if; + -- -x + elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-x" then if Arg'Length = 2 then Excluded_Pattern_Expected := True; @@ -436,9 +463,13 @@ procedure Gnatname is Check_Regular_Expression (Arg (3 .. Arg'Last)); end if; + -- Junk switch starting with minus + elsif Arg (1) = '-' then Fail ("wrong switch: " & Arg); + -- Not a recognized switch, assume file name + else Canonical_Case_File_Name (Arg); Patterns.Append diff --git a/gcc/ada/gprmake.adb b/gcc/ada/gprmake.adb deleted file mode 100644 index 61bef3c9098..00000000000 --- a/gcc/ada/gprmake.adb +++ /dev/null @@ -1,35 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G P R M A K E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- The driver for the gprmake tool - -with Makegpr; - -procedure Gprmake is -begin - -- The code is in Makegpr - - Makegpr.Gprmake; -end Gprmake; diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 332994ea285..296ff6b1df5 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -847,11 +847,15 @@ package body Inline is -- cleanup operations have been delayed, and the subprogram -- has been rewritten in the expansion of the enclosing -- protected body. It is the corresponding subprogram that - -- may require the cleanup operations. + -- may require the cleanup operations, so propagate the + -- information that triggers cleanup activity. Set_Uses_Sec_Stack (Protected_Body_Subprogram (Scop), Uses_Sec_Stack (Scop)); + Set_Finalization_Chain_Entity + (Protected_Body_Subprogram (Scop), + Finalization_Chain_Entity (Scop)); Scop := Protected_Body_Subprogram (Scop); end if; diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index a7cc61a06e1..8af553fef59 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -1150,16 +1150,14 @@ package body Lib.Xref is New_Entry (Tref); if Is_Record_Type (Ent) - and then Present (Abstract_Interfaces (Ent)) + and then Present (Interfaces (Ent)) then -- Add an entry for each one of the given interfaces -- implemented by type Ent. declare - Elmt : Elmt_Id; - + Elmt : Elmt_Id := First_Elmt (Interfaces (Ent)); begin - Elmt := First_Elmt (Abstract_Interfaces (Ent)); while Present (Elmt) loop New_Entry (Node (Elmt)); Next_Elmt (Elmt); @@ -2032,13 +2030,11 @@ package body Lib.Xref is -- Additional information for types with progenitors if Is_Record_Type (XE.Ent) - and then Present (Abstract_Interfaces (XE.Ent)) + and then Present (Interfaces (XE.Ent)) then declare - Elmt : Elmt_Id; - + Elmt : Elmt_Id := First_Elmt (Interfaces (XE.Ent)); begin - Elmt := First_Elmt (Abstract_Interfaces (XE.Ent)); while Present (Elmt) loop Check_Type_Reference (Node (Elmt), True); Next_Elmt (Elmt); diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 304f15556ca..c1737b7ed47 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -1068,7 +1068,7 @@ package body Make is else Get_Name_String - (Project_Tree.Projects.Table (Main_Project).Display_Directory); + (Project_Tree.Projects.Table (Main_Project).Directory.Display_Name); Add_Lib_Search_Dir (Normalize_Pathname (Path, Name_Buffer (1 .. Name_Len))); end if; @@ -1120,7 +1120,7 @@ package body Make is else Get_Name_String - (Project_Tree.Projects.Table (Main_Project).Display_Directory); + (Project_Tree.Projects.Table (Main_Project).Directory.Display_Name); Add_Src_Search_Dir (Normalize_Pathname (Path, Name_Buffer (1 .. Name_Len))); end if; @@ -1391,7 +1391,7 @@ package body Make is if Project_Of_Current_Object_Directory /= Actual_Project then Project_Of_Current_Object_Directory := Actual_Project; Object_Directory := - Project_Tree.Projects.Table (Actual_Project).Object_Directory; + Project_Tree.Projects.Table (Actual_Project).Object_Directory.Name; -- Set the working directory to the object directory of the actual -- project. @@ -1415,7 +1415,7 @@ package body Make is Make_Failed ("unable to change to object directory """ & Path_Or_File_Name (Project_Tree.Projects.Table - (Actual_Project).Object_Directory) & + (Actual_Project).Object_Directory.Name) & """ of project " & Get_Name_String (Project_Tree.Projects.Table (Actual_Project).Display_Name)); @@ -1938,7 +1938,7 @@ package body Make is while ALI_Project /= No_Project and then Obj_Dir /= Project_Tree.Projects.Table - (ALI_Project).Object_Directory + (ALI_Project).Object_Directory.Name loop ALI_Project := Project_Tree.Projects.Table (ALI_Project).Extended_By; @@ -2330,7 +2330,7 @@ package body Make is if Data.Dir_Path = null then Data.Dir_Path := - new String'(Get_Name_String (Data.Display_Directory)); + new String'(Get_Name_String (Data.Directory.Display_Name)); Project_Tree.Projects.Table (Arguments_Project) := Data; end if; @@ -3580,7 +3580,8 @@ package body Make is Udata.File_Names (Body_Part).Name /= No_File and then - Udata.File_Names (Body_Part).Path /= Slash + Udata.File_Names (Body_Part).Path.Name /= + Slash then Sfile := Udata.File_Names (Body_Part).Name; Source_Index := @@ -3590,8 +3591,8 @@ package body Make is Udata.File_Names (Specification).Name /= No_File and then - Udata.File_Names (Specification).Path /= - Slash + Udata.File_Names + (Specification).Path.Name /= Slash then Sfile := Udata.File_Names (Specification).Name; @@ -3796,7 +3797,7 @@ package body Make is Parent_Directory : constant String := Get_Name_String (Project_Tree.Projects.Table - (Project).Display_Directory); + (Project).Directory.Display_Name); begin if Parent_Directory (Parent_Directory'Last) = @@ -4538,9 +4539,9 @@ package body Make is -- for other projects, use the object directory. if PD.Library then - Get_Name_String (PD.Library_Dir); + Get_Name_String (PD.Library_Dir.Name); else - Get_Name_String (PD.Object_Directory); + Get_Name_String (PD.Object_Directory.Name); end if; if Name_Buffer (Name_Len) /= @@ -4987,7 +4988,7 @@ package body Make is if Main_Project /= No_Project then if Project_Tree.Projects.Table - (Main_Project).Object_Directory /= No_Path + (Main_Project).Object_Directory /= No_Path_Information then -- Change current directory to object directory of main project @@ -5264,7 +5265,7 @@ package body Make is -- impossible to build the library. So fail immediately. if Project_Tree.Projects.Table (Proj).Object_Directory = - No_Path + No_Path_Information then Make_Failed ("no object files to build library for project """, @@ -5308,7 +5309,7 @@ package body Make is if not Is_Absolute_Path (Exec_File_Name) then Get_Name_String (Project_Tree.Projects.Table - (Main_Project).Exec_Directory); + (Main_Project).Exec_Directory.Name); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; @@ -5337,7 +5338,7 @@ package body Make is Dir_Path : constant String_Access := new String'(Get_Name_String (Project_Tree.Projects.Table - (Main_Project).Directory)); + (Main_Project).Directory.Name)); begin for J in 1 .. Binder_Switches.Last loop Test_If_Relative_Path @@ -5554,8 +5555,9 @@ package body Make is begin if not Is_Absolute_Path (Exec_File_Name) then - Get_Name_String (Project_Tree.Projects.Table - (Main_Project).Display_Exec_Dir); + Get_Name_String + (Project_Tree.Projects.Table + (Main_Project).Exec_Directory.Display_Name); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; @@ -6141,7 +6143,7 @@ package body Make is new String' (Get_Name_String (Project_Tree.Projects.Table - (Proj1).Display_Library_Dir)); + (Proj1).Library_Dir.Display_Name)); end if; end if; end loop; @@ -6156,7 +6158,7 @@ package body Make is Get_Name_String (Project_Tree.Projects.Table (Library_Projs.Table (Index)). - Display_Library_Dir)); + Library_Dir.Display_Name)); -- Add the -l switch @@ -6462,7 +6464,7 @@ package body Make is Dir_Path : constant String_Access := new String'(Get_Name_String (Project_Tree.Projects.Table - (Main_Project).Directory)); + (Main_Project).Directory.Name)); begin for J in Last_Binder_Switch + 1 .. Binder_Switches.Last @@ -6961,7 +6963,7 @@ package body Make is -- locally removed, if Unit.File_Names (Body_Part).Name /= No_File - and then Unit.File_Names (Body_Part).Path /= Slash + and then Unit.File_Names (Body_Part).Path.Name /= Slash then -- And it is a source for the specified project @@ -6988,7 +6990,7 @@ package body Make is begin Src_Ind := Sinput.P.Load_Project_File (Get_Name_String - (Unit.File_Names (Body_Part).Path)); + (Unit.File_Names (Body_Part).Path.Name)); -- If it is a subunit, discard it @@ -7008,7 +7010,7 @@ package body Make is end if; elsif Unit.File_Names (Specification).Name /= No_File - and then Unit.File_Names (Specification).Path /= Slash + and then Unit.File_Names (Specification).Path.Name /= Slash and then Check_Project (Unit.File_Names (Specification).Project) then -- If there is no source for the body, but there is a source @@ -7184,8 +7186,8 @@ package body Make is declare Object_Directory : constant String := Normalize_Pathname - (Get_Name_String - (Data.Display_Object_Dir)); + (Get_Name_String + (Data.Object_Directory.Display_Name)); Olast : Natural := Object_Directory'Last; @@ -7380,7 +7382,7 @@ package body Make is (Dir, Get_Name_String (Project_Tree.Projects.Table - (Main_Project).Display_Directory)); + (Main_Project).Directory.Display_Name)); begin if Real_Path'Length = 0 then diff --git a/gcc/ada/makegpr.adb b/gcc/ada/makegpr.adb deleted file mode 100644 index 684cae99eb8..00000000000 --- a/gcc/ada/makegpr.adb +++ /dev/null @@ -1,4469 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M A K E G P R -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-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 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Csets; -with Gnatvsn; -with Hostparm; use Hostparm; -with Makeutl; use Makeutl; -with MLib.Tgt; use MLib.Tgt; -with Namet; use Namet; -with Output; use Output; -with Opt; use Opt; -with Osint; use Osint; -with Prj; use Prj; -with Prj.Ext; use Prj.Ext; -with Prj.Pars; -with Prj.Util; use Prj.Util; -with Snames; use Snames; -with Table; -with Types; use Types; - -with Ada.Command_Line; use Ada.Command_Line; -with Ada.Strings.Fixed; use Ada.Strings.Fixed; -with Ada.Text_IO; use Ada.Text_IO; -with Ada.Unchecked_Deallocation; - -with GNAT.Directory_Operations; use GNAT.Directory_Operations; -with GNAT.Dynamic_Tables; -with GNAT.Expect; use GNAT.Expect; -with GNAT.HTable; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with GNAT.Regpat; use GNAT.Regpat; - -with System; -with System.Case_Util; use System.Case_Util; - -package body Makegpr is - - On_Windows : constant Boolean := Directory_Separator = '\'; - -- True when on Windows. Used in Check_Compilation_Needed when processing - -- C/C++ dependency files for backslash handling. - - Max_In_Archives : constant := 50; - -- The maximum number of arguments for a single invocation of the - -- Archive Indexer (ar). - - No_Argument : aliased Argument_List := (1 .. 0 => null); - -- Null argument list representing case of no arguments - - FD : Process_Descriptor; - -- The process descriptor used when invoking a non GNU compiler with -M - -- and getting the output with GNAT.Expect. - - Line_Matcher : constant Pattern_Matcher := Compile ("^.*?\n", Single_Line); - -- Pattern for GNAT.Expect for the invocation of a non GNU compiler with -M - - Name_Ide : Name_Id; - Name_Compiler_Command : Name_Id; - -- Names of package IDE and its attribute Compiler_Command. - -- Set up by Initialize. - - Unique_Compile : Boolean := False; - -- True when switch -u is used on the command line - - type Source_Index_Rec is record - Project : Project_Id; - Id : Other_Source_Id; - Found : Boolean := False; - end record; - -- Used as Source_Indexes component to check if archive needs to be rebuilt - - type Source_Index_Array is array (Positive range <>) of Source_Index_Rec; - type Source_Indexes_Ref is access Source_Index_Array; - - procedure Free is new Ada.Unchecked_Deallocation - (Source_Index_Array, Source_Indexes_Ref); - - Initial_Source_Index_Count : constant Positive := 20; - Source_Indexes : Source_Indexes_Ref := - new Source_Index_Array (1 .. Initial_Source_Index_Count); - -- A list of the Other_Source_Ids of a project file, with an indication - -- that they have been found in the archive dependency file. - - Last_Source : Natural := 0; - -- The index of the last valid component of Source_Indexes - - Compiler_Names : array (First_Language_Indexes) of String_Access; - -- The names of the compilers to be used. Set up by Get_Compiler. - -- Used to display the commands spawned. - - Gnatmake_String : constant String_Access := new String'("gnatmake"); - GCC_String : constant String_Access := new String'("gcc"); - G_Plus_Plus_String : constant String_Access := new String'("g++"); - - Default_Compiler_Names : constant array - (First_Language_Indexes range - Ada_Language_Index .. C_Plus_Plus_Language_Index) - of String_Access := - (Ada_Language_Index => Gnatmake_String, - C_Language_Index => GCC_String, - C_Plus_Plus_Language_Index => G_Plus_Plus_String); - - Compiler_Paths : array (First_Language_Indexes) of String_Access; - -- The path names of the compiler to be used. Set up by Get_Compiler. - -- Used to spawn compiling/linking processes. - - Compiler_Is_Gcc : array (First_Language_Indexes) of Boolean; - -- An indication that a compiler is a GCC compiler, to be able to use - -- specific GCC switches. - - Archive_Builder_Path : String_Access := null; - -- The path name of the archive builder (ar). To be used when spawning - -- ar commands. - - Archive_Indexer_Path : String_Access := null; - -- The path name of the archive indexer (ranlib), if it exists - - Copyright_Output : Boolean := False; - Usage_Output : Boolean := False; - -- Flags to avoid multiple displays of Copyright notice and of Usage - - Output_File_Name : String_Access := null; - -- The name given after a switch -o - - Output_File_Name_Expected : Boolean := False; - -- True when last switch was -o - - Project_File_Name : String_Access := null; - -- The name of the project file specified with switch -P - - Project_File_Name_Expected : Boolean := False; - -- True when last switch was -P - - Naming_String : aliased String := "naming"; - Builder_String : aliased String := "builder"; - Compiler_String : aliased String := "compiler"; - Binder_String : aliased String := "binder"; - Linker_String : aliased String := "linker"; - -- Name of packages to be checked when parsing/processing project files - - List_Of_Packages : aliased String_List := - (Naming_String 'Access, - Builder_String 'Access, - Compiler_String 'Access, - Binder_String 'Access, - Linker_String 'Access); - Packages_To_Check : constant String_List_Access := List_Of_Packages'Access; - -- List of the packages to be checked when parsing/processing project files - - Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data; - - Main_Project : Project_Id; - -- The project id of the main project - - type Processor is (None, Linker, Compiler); - Current_Processor : Processor := None; - -- This variable changes when switches -*args are used - - Current_Language : Language_Index := Ada_Language_Index; - -- The compiler language to consider when Processor is Compiler - - package Comp_Opts is new GNAT.Dynamic_Tables - (Table_Component_Type => String_Access, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 20, - Table_Increment => 100); - Options : array (First_Language_Indexes) of Comp_Opts.Instance; - -- Tables to store compiling options for the different compilers - - package Linker_Options is new Table.Table - (Table_Component_Type => String_Access, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 20, - Table_Increment => 100, - Table_Name => "Makegpr.Linker_Options"); - -- Table to store the linking options - - package Library_Opts is new Table.Table - (Table_Component_Type => String_Access, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 20, - Table_Increment => 100, - Table_Name => "Makegpr.Library_Opts"); - -- Table to store the linking options - - package Ada_Mains is new Table.Table - (Table_Component_Type => String_Access, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 20, - Table_Increment => 100, - Table_Name => "Makegpr.Ada_Mains"); - -- Table to store the Ada mains, either specified on the command line - -- or found in attribute Main of the main project file. - - package Other_Mains is new Table.Table - (Table_Component_Type => Other_Source, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 20, - Table_Increment => 100, - Table_Name => "Makegpr.Other_Mains"); - -- Table to store the mains of languages other than Ada, either specified - -- on the command line or found in attribute Main of the main project file. - - package Sources_Compiled is new GNAT.HTable.Simple_HTable - (Header_Num => Header_Num, - Element => Boolean, - No_Element => False, - Key => File_Name_Type, - Hash => Hash, - Equal => "="); - - package Saved_Switches is new Table.Table - (Table_Component_Type => String_Access, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 10, - Table_Increment => 100, - Table_Name => "Makegpr.Saved_Switches"); - -- Table to store the switches to be passed to gnatmake - - Initial_Argument_Count : constant Positive := 20; - type Boolean_Array is array (Positive range <>) of Boolean; - type Booleans is access Boolean_Array; - - procedure Free is new Ada.Unchecked_Deallocation (Boolean_Array, Booleans); - - Arguments : Argument_List_Access := - new Argument_List (1 .. Initial_Argument_Count); - -- Used to store lists of arguments to be used when spawning a process - - Arguments_Displayed : Booleans := - new Boolean_Array (1 .. Initial_Argument_Count); - -- For each argument in Arguments, indicate if the argument should be - -- displayed when procedure Display_Command is called. - - Last_Argument : Natural := 0; - -- Index of the last valid argument in Arguments - - package Cache_Args is new Table.Table - (Table_Component_Type => String_Access, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 200, - Table_Increment => 100, - Table_Name => "Makegpr.Cache_Args"); - -- A table to cache arguments, to avoid multiple allocation of the same - -- strings. It is not possible to use a hash table, because String is - -- an unconstrained type. - - -- Various switches used when spawning processes: - - Dash_B_String : aliased String := "-B"; - Dash_B : constant String_Access := Dash_B_String'Access; - Dash_c_String : aliased String := "-c"; - Dash_c : constant String_Access := Dash_c_String'Access; - Dash_cargs_String : aliased String := "-cargs"; - Dash_cargs : constant String_Access := Dash_cargs_String'Access; - Dash_d_String : aliased String := "-d"; - Dash_d : constant String_Access := Dash_d_String'Access; - Dash_eL_String : aliased String := "-eL"; - Dash_eL : constant String_Access := Dash_eL_String'Access; - Dash_f_String : aliased String := "-f"; - Dash_f : constant String_Access := Dash_f_String'Access; - Dash_k_String : aliased String := "-k"; - Dash_k : constant String_Access := Dash_k_String'Access; - Dash_largs_String : aliased String := "-largs"; - Dash_largs : constant String_Access := Dash_largs_String'Access; - Dash_M_String : aliased String := "-M"; - Dash_M : constant String_Access := Dash_M_String'Access; - Dash_margs_String : aliased String := "-margs"; - Dash_margs : constant String_Access := Dash_margs_String'Access; - Dash_o_String : aliased String := "-o"; - Dash_o : constant String_Access := Dash_o_String'Access; - Dash_P_String : aliased String := "-P"; - Dash_P : constant String_Access := Dash_P_String'Access; - Dash_q_String : aliased String := "-q"; - Dash_q : constant String_Access := Dash_q_String'Access; - Dash_u_String : aliased String := "-u"; - Dash_u : constant String_Access := Dash_u_String'Access; - Dash_v_String : aliased String := "-v"; - Dash_v : constant String_Access := Dash_v_String'Access; - Dash_vP1_String : aliased String := "-vP1"; - Dash_vP1 : constant String_Access := Dash_vP1_String'Access; - Dash_vP2_String : aliased String := "-vP2"; - Dash_vP2 : constant String_Access := Dash_vP2_String'Access; - Dash_x_String : aliased String := "-x"; - Dash_x : constant String_Access := Dash_x_String'Access; - r_String : aliased String := "r"; - r : constant String_Access := r_String'Access; - - CPATH : constant String := "CPATH"; - -- The environment variable to set when compiler is a GCC compiler - -- to indicate the include directory path. - - Current_Include_Paths : array (First_Language_Indexes) of String_Access; - -- A cache for the paths of included directories, to avoid setting - -- env var CPATH unnecessarily. - - C_Plus_Plus_Is_Used : Boolean := False; - -- True when there are sources in C++ - - Link_Options_Switches : Argument_List_Access := null; - -- The link options coming from the attributes Linker'Linker_Options in - -- project files imported, directly or indirectly, by the main project. - - Total_Number_Of_Errors : Natural := 0; - -- Used when Keep_Going is True (switch -k) to keep the total number - -- of compilation/linking errors, to report at the end of execution. - - Need_To_Rebuild_Global_Archive : Boolean := False; - - Error_Header : constant String := "*** ERROR: "; - -- The beginning of error message, when Keep_Going is True - - Need_To_Relink : Boolean := False; - -- True when an executable of a language other than Ada need to be linked - - Global_Archive_Exists : Boolean := False; - -- True if there is a non empty global archive, to prevent creation - -- of such archives. - - Path_Option : String_Access; - -- The path option switch, when supported - - Project_Of_Current_Object_Directory : Project_Id := No_Project; - -- The object directory of the project for the last compilation. Avoid - -- calling Change_Dir if the current working directory is already this - -- directory. - - package Lib_Path is new Table.Table - (Table_Component_Type => Character, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 200, - Table_Increment => 100, - Table_Name => "Makegpr.Lib_Path"); - -- A table to compute the path to put in the path option switch, when it - -- is supported. - - procedure Add_Archives (For_Gnatmake : Boolean); - -- Add to Arguments the list of archives for linking an executable - - procedure Add_Argument (Arg : String_Access; Display : Boolean); - procedure Add_Argument (Arg : String; Display : Boolean); - -- Add an argument to Arguments. Reallocate if necessary - - procedure Add_Arguments (Args : Argument_List; Display : Boolean); - -- Add a list of arguments to Arguments. Reallocate if necessary - - procedure Add_Option (Arg : String); - -- Add a switch for the Ada, C or C++ compiler, or for the linker. - -- The table where this option is stored depends on the values of - -- Current_Processor and Current_Language. - - procedure Add_Search_Directories - (Data : Project_Data; - Language : First_Language_Indexes); - -- Either add to the Arguments the necessary -I switches needed to - -- compile, or, when compiler is gcc/g++, set up the C*INCLUDE_PATH - -- environment variable, if necessary. - - procedure Add_Source_Id (Project : Project_Id; Id : Other_Source_Id); - -- Add a source id to Source_Indexes, with Found set to False - - procedure Add_Switches - (Data : Project_Data; - Proc : Processor; - Language : Language_Index; - File_Name : File_Name_Type); - -- Add to Arguments the switches, if any, for a source (attribute Switches) - -- or language (attribute Default_Switches), coming from package Compiler - -- or Linker (depending on Proc) of a specified project file. - - procedure Build_Global_Archive; - -- Build the archive for the main project - - procedure Build_Library (Project : Project_Id; Unconditionally : Boolean); - -- Build the library for a library project. If Unconditionally is - -- False, first check if the library is up to date, and build it only - -- if it is not. - - procedure Check (Option : String); - -- Check that a switch coming from a project file is not the concatenation - -- of several valid switch, for example "-g -v". If it is, issue a warning. - - procedure Check_Archive_Builder; - -- Check if the archive builder (ar) is there - - procedure Check_Compilation_Needed - (Source : Other_Source; - Need_To_Compile : out Boolean); - -- Check if a source of a language other than Ada needs to be compiled or - -- recompiled. - - procedure Check_For_C_Plus_Plus; - -- Check if C++ is used in at least one project - - procedure Compile - (Source_Id : Other_Source_Id; - Data : Project_Data; - Local_Errors : in out Boolean); - -- Compile one non-Ada source - - procedure Compile_Individual_Sources; - -- Compile the sources specified on the command line, when in - -- Unique_Compile mode. - - procedure Compile_Link_With_Gnatmake (Mains_Specified : Boolean); - -- Compile/Link with gnatmake when there are Ada sources in the main - -- project. Arguments may already contain options to be used by - -- gnatmake. Used for both Ada mains and mains of other languages. - -- When Compile_Only is True, do not use the linking options - - procedure Compile_Sources; - -- Compile the sources of languages other than Ada, if necessary - - procedure Copyright; - -- Output the Copyright notice - - procedure Create_Archive_Dependency_File - (Name : String; - First_Source : Other_Source_Id); - -- Create the archive dependency file for a library project - - procedure Create_Global_Archive_Dependency_File (Name : String); - -- Create the archive dependency file for the main project - - procedure Display_Command - (Name : String; - Path : String_Access; - CPATH : String_Access := null; - Ellipse : Boolean := False); - -- Display the command for a spawned process, if in Verbose_Mode or not in - -- Quiet_Output. In non verbose mode, when Ellipse is True, display "..." - -- in place of the first argument that has Display set to False. - - procedure Get_Compiler (For_Language : First_Language_Indexes); - -- Find the compiler name and path name for a specified programming - -- language, if not already done. Results are in the corresponding elements - -- of arrays Compiler_Names and Compiler_Paths. Name of compiler is found - -- in package IDE of the main project, or defaulted. Fail if compiler - -- cannot be found on the path. For the Ada language, gnatmake, rather than - -- the Ada compiler is returned. - - procedure Get_Imported_Directories - (Project : Project_Id; - Data : in out Project_Data); - -- Find the necessary switches -I to be used when compiling sources of - -- languages other than Ada, in a specified project file. Cache the result - -- in component Imported_Directories_Switches of the project data. For - -- gcc/g++ compilers, get the value of the C*_INCLUDE_PATH, instead. - - procedure Initialize; - -- Do the necessary package initialization and process the command line - -- arguments. - - function Is_Included_In_Global_Archive - (Object_Name : File_Name_Type; - Project : Project_Id) return Boolean; - -- Return True if the object Object_Name is not overridden by a source - -- in a project extending project Project. - - procedure Link_Executables; - -- Link executables - - procedure Report_Error (S1 : String; S2 : String := ""; S3 : String := ""); - -- Report an error. If Keep_Going is False, just call Osint.Fail. If - -- Keep_Going is True, display the error and increase the total number of - -- errors. - - procedure Report_Total_Errors (Kind : String); - -- If Total_Number_Of_Errors is not zero, report it, and fail - - procedure Scan_Arg (Arg : String); - -- Process one command line argument - - function Strip_CR_LF (Text : String) return String; - -- Remove characters ASCII.CR and ASCII.LF from a String - - procedure Usage; - -- Display the usage - - ------------------ - -- Add_Archives -- - ------------------ - - procedure Add_Archives (For_Gnatmake : Boolean) is - Last_Arg : constant Natural := Last_Argument; - -- The position of the last argument before adding the archives. Used to - -- reverse the order of the arguments added when processing the - -- archives. - - procedure Recursive_Add_Archives (Project : Project_Id); - -- Recursive procedure to add the archive of a project file, if any, - -- then call itself for the project imported. - - ---------------------------- - -- Recursive_Add_Archives -- - ---------------------------- - - procedure Recursive_Add_Archives (Project : Project_Id) is - Data : Project_Data; - Imported : Project_List; - Prj : Project_Id; - - procedure Add_Archive_Path; - -- For a library project or the main project, add the archive - -- path to the arguments. - - ---------------------- - -- Add_Archive_Path -- - ---------------------- - - procedure Add_Archive_Path is - Increment : Positive; - Prev_Last : Positive; - - begin - if Data.Library then - - -- If it is a library project file, nothing to do if gnatmake - -- will be invoked, because gnatmake will take care of it, even - -- if the library is not an Ada library. - - if not For_Gnatmake then - if Data.Library_Kind = Static then - Add_Argument - (Get_Name_String (Data.Display_Library_Dir) & - Directory_Separator & - "lib" & Get_Name_String (Data.Library_Name) & - '.' & Archive_Ext, - Verbose_Mode); - - else - -- As we first insert in the reverse order, - -- -L<dir> is put after -l<lib> - - Add_Argument - ("-l" & Get_Name_String (Data.Library_Name), - Verbose_Mode); - - Get_Name_String (Data.Display_Library_Dir); - - Add_Argument - ("-L" & Name_Buffer (1 .. Name_Len), - Verbose_Mode); - - -- If there is a run path option, prepend this directory - -- to the library path. It is probable that the order of - -- the directories in the path option is not important, - -- but just in case put the directories in the same order - -- as the libraries. - - if Path_Option /= null then - - -- If it is not the first directory, make room at the - -- beginning of the table, including for a path - -- separator. - - if Lib_Path.Last > 0 then - Increment := Name_Len + 1; - Prev_Last := Lib_Path.Last; - Lib_Path.Set_Last (Prev_Last + Increment); - - for Index in reverse 1 .. Prev_Last loop - Lib_Path.Table (Index + Increment) := - Lib_Path.Table (Index); - end loop; - - Lib_Path.Table (Increment) := Path_Separator; - - else - -- If it is the first directory, just set - -- Last to the length of the directory. - - Lib_Path.Set_Last (Name_Len); - end if; - - -- Put the directory at the beginning of the - -- table. - - for Index in 1 .. Name_Len loop - Lib_Path.Table (Index) := Name_Buffer (Index); - end loop; - end if; - end if; - end if; - - -- For a non-library project, the only archive needed is the one - -- for the main project, if there is one. - - elsif Project = Main_Project and then Global_Archive_Exists then - Add_Argument - (Get_Name_String (Data.Display_Object_Dir) & - Directory_Separator & - "lib" & Get_Name_String (Data.Display_Name) - & '.' & Archive_Ext, - Verbose_Mode); - end if; - end Add_Archive_Path; - - begin - -- Nothing to do when there is no project specified - - if Project /= No_Project then - Data := Project_Tree.Projects.Table (Project); - - -- Nothing to do if the project has already been processed - - if not Data.Seen then - - -- Mark the project as processed, to avoid processing it again - - Project_Tree.Projects.Table (Project).Seen := True; - - Recursive_Add_Archives (Data.Extends); - - Imported := Data.Imported_Projects; - - -- Call itself recursively for all imported projects - - while Imported /= Empty_Project_List loop - Prj := Project_Tree.Project_Lists.Table - (Imported).Project; - - if Prj /= No_Project then - while Project_Tree.Projects.Table - (Prj).Extended_By /= No_Project - loop - Prj := Project_Tree.Projects.Table - (Prj).Extended_By; - end loop; - - Recursive_Add_Archives (Prj); - end if; - - Imported := Project_Tree.Project_Lists.Table - (Imported).Next; - end loop; - - -- If there is sources of language other than Ada in this - -- project, add the path of the archive to Arguments. - - if Project = Main_Project - or else Data.Other_Sources_Present - then - Add_Archive_Path; - end if; - end if; - end if; - end Recursive_Add_Archives; - - -- Start of processing for Add_Archives - - begin - -- First, mark all projects as not processed - - for Project in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - Project_Tree.Projects.Table (Project).Seen := False; - end loop; - - -- Take care of the run path option - - if Path_Option = null then - Path_Option := MLib.Linker_Library_Path_Option; - end if; - - Lib_Path.Set_Last (0); - - -- Add archives in the reverse order - - Recursive_Add_Archives (Main_Project); - - -- And reverse the order - - declare - First : Positive; - Last : Natural; - Temp : String_Access; - - begin - First := Last_Arg + 1; - Last := Last_Argument; - while First < Last loop - Temp := Arguments (First); - Arguments (First) := Arguments (Last); - Arguments (Last) := Temp; - First := First + 1; - Last := Last - 1; - end loop; - end; - end Add_Archives; - - ------------------ - -- Add_Argument -- - ------------------ - - procedure Add_Argument (Arg : String_Access; Display : Boolean) is - begin - -- Nothing to do if no argument is specified or if argument is empty - - if Arg /= null or else Arg'Length = 0 then - - -- Reallocate arrays if necessary - - if Last_Argument = Arguments'Last then - declare - New_Arguments : constant Argument_List_Access := - new Argument_List - (1 .. Last_Argument + - Initial_Argument_Count); - - New_Arguments_Displayed : constant Booleans := - new Boolean_Array - (1 .. Last_Argument + - Initial_Argument_Count); - - begin - New_Arguments (Arguments'Range) := Arguments.all; - - -- To avoid deallocating the strings, nullify all components - -- of Arguments before calling Free. - - Arguments.all := (others => null); - - Free (Arguments); - Arguments := New_Arguments; - - New_Arguments_Displayed (Arguments_Displayed'Range) := - Arguments_Displayed.all; - Free (Arguments_Displayed); - Arguments_Displayed := New_Arguments_Displayed; - end; - end if; - - -- Add the argument and its display indication - - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := Arg; - Arguments_Displayed (Last_Argument) := Display; - end if; - end Add_Argument; - - procedure Add_Argument (Arg : String; Display : Boolean) is - Argument : String_Access := null; - - begin - -- Nothing to do if argument is empty - - if Arg'Length > 0 then - - -- Check if the argument is already in the Cache_Args table. - -- If it is already there, reuse the allocated value. - - for Index in 1 .. Cache_Args.Last loop - if Cache_Args.Table (Index).all = Arg then - Argument := Cache_Args.Table (Index); - exit; - end if; - end loop; - - -- If the argument is not in the cache, create a new entry in the - -- cache. - - if Argument = null then - Argument := new String'(Arg); - Cache_Args.Increment_Last; - Cache_Args.Table (Cache_Args.Last) := Argument; - end if; - - -- And add the argument - - Add_Argument (Argument, Display); - end if; - end Add_Argument; - - ------------------- - -- Add_Arguments -- - ------------------- - - procedure Add_Arguments (Args : Argument_List; Display : Boolean) is - begin - -- Reallocate the arrays, if necessary - - if Last_Argument + Args'Length > Arguments'Last then - declare - New_Arguments : constant Argument_List_Access := - new Argument_List - (1 .. Last_Argument + Args'Length + - Initial_Argument_Count); - - New_Arguments_Displayed : constant Booleans := - new Boolean_Array - (1 .. Last_Argument + - Args'Length + - Initial_Argument_Count); - - begin - New_Arguments (1 .. Last_Argument) := - Arguments (1 .. Last_Argument); - - -- To avoid deallocating the strings, nullify all components - -- of Arguments before calling Free. - - Arguments.all := (others => null); - Free (Arguments); - - Arguments := New_Arguments; - New_Arguments_Displayed (1 .. Last_Argument) := - Arguments_Displayed (1 .. Last_Argument); - Free (Arguments_Displayed); - Arguments_Displayed := New_Arguments_Displayed; - end; - end if; - - -- Add the new arguments and the display indications - - Arguments (Last_Argument + 1 .. Last_Argument + Args'Length) := Args; - Arguments_Displayed (Last_Argument + 1 .. Last_Argument + Args'Length) := - (others => Display); - Last_Argument := Last_Argument + Args'Length; - end Add_Arguments; - - ---------------- - -- Add_Option -- - ---------------- - - procedure Add_Option (Arg : String) is - Option : constant String_Access := new String'(Arg); - - begin - case Current_Processor is - when None => - null; - - when Linker => - - -- Add option to the linker table - - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := Option; - - when Compiler => - - -- Add option to the compiler option table, depending on the - -- value of Current_Language. - - Comp_Opts.Increment_Last (Options (Current_Language)); - Options (Current_Language).Table - (Comp_Opts.Last (Options (Current_Language))) := Option; - - end case; - end Add_Option; - - ------------------- - -- Add_Source_Id -- - ------------------- - - procedure Add_Source_Id (Project : Project_Id; Id : Other_Source_Id) is - begin - -- Reallocate the array, if necessary - - if Last_Source = Source_Indexes'Last then - declare - New_Indexes : constant Source_Indexes_Ref := - new Source_Index_Array - (1 .. Source_Indexes'Last + - Initial_Source_Index_Count); - begin - New_Indexes (Source_Indexes'Range) := Source_Indexes.all; - Free (Source_Indexes); - Source_Indexes := New_Indexes; - end; - end if; - - Last_Source := Last_Source + 1; - Source_Indexes (Last_Source) := (Project, Id, False); - end Add_Source_Id; - - ---------------------------- - -- Add_Search_Directories -- - ---------------------------- - - procedure Add_Search_Directories - (Data : Project_Data; - Language : First_Language_Indexes) - is - begin - -- If a GNU compiler is used, set the CPATH environment variable, - -- if it does not already has the correct value. - - if Compiler_Is_Gcc (Language) then - if Current_Include_Paths (Language) /= Data.Include_Path then - Current_Include_Paths (Language) := Data.Include_Path; - Setenv (CPATH, Data.Include_Path.all); - end if; - - else - Add_Arguments (Data.Imported_Directories_Switches.all, Verbose_Mode); - end if; - end Add_Search_Directories; - - ------------------ - -- Add_Switches -- - ------------------ - - procedure Add_Switches - (Data : Project_Data; - Proc : Processor; - Language : Language_Index; - File_Name : File_Name_Type) - is - Switches : Variable_Value; - -- The switches, if any, for the file/language - - Pkg : Package_Id; - -- The id of the package where to look for the switches - - Defaults : Array_Element_Id; - -- The Default_Switches associative array - - Switches_Array : Array_Element_Id; - -- The Switches associative array - - Element_Id : String_List_Id; - Element : String_Element; - - begin - -- First, choose the proper package - - case Proc is - when None => - raise Program_Error; - - when Linker => - Pkg := Value_Of (Name_Linker, Data.Decl.Packages, Project_Tree); - - when Compiler => - Pkg := Value_Of (Name_Compiler, Data.Decl.Packages, Project_Tree); - end case; - - if Pkg /= No_Package then - - -- Get the Switches ("file name"), if they exist - - Switches_Array := Prj.Util.Value_Of - (Name => Name_Switches, - In_Arrays => Project_Tree.Packages.Table - (Pkg).Decl.Arrays, - In_Tree => Project_Tree); - - Switches := - Prj.Util.Value_Of - (Index => Name_Id (File_Name), - Src_Index => 0, - In_Array => Switches_Array, - In_Tree => Project_Tree); - - -- Otherwise, get the Default_Switches ("language"), if they exist - - if Switches = Nil_Variable_Value then - Defaults := Prj.Util.Value_Of - (Name => Name_Default_Switches, - In_Arrays => Project_Tree.Packages.Table - (Pkg).Decl.Arrays, - In_Tree => Project_Tree); - Switches := Prj.Util.Value_Of - (Index => Language_Names.Table (Language), - Src_Index => 0, - In_Array => Defaults, - In_Tree => Project_Tree); - end if; - - -- If there are switches, add them to Arguments - - if Switches /= Nil_Variable_Value then - Element_Id := Switches.Values; - while Element_Id /= Nil_String loop - Element := Project_Tree.String_Elements.Table - (Element_Id); - - if Element.Value /= No_Name then - Get_Name_String (Element.Value); - - if not Quiet_Output then - - -- When not in quiet output (no -q), check that the - -- switch is not the concatenation of several valid - -- switches, such as "-g -v". If it is, issue a warning. - - Check (Option => Name_Buffer (1 .. Name_Len)); - end if; - - Add_Argument (Name_Buffer (1 .. Name_Len), True); - end if; - - Element_Id := Element.Next; - end loop; - end if; - end if; - end Add_Switches; - - -------------------------- - -- Build_Global_Archive -- - -------------------------- - - procedure Build_Global_Archive is - Data : Project_Data := Project_Tree.Projects.Table (Main_Project); - Source_Id : Other_Source_Id; - S_Id : Other_Source_Id; - Source : Other_Source; - Success : Boolean; - - Archive_Name : constant String := - "lib" - & Get_Name_String (Data.Display_Name) - & '.' - & Archive_Ext; - -- The name of the archive file for this project - - Archive_Dep_Name : constant String := - "lib" - & Get_Name_String (Data.Display_Name) - & ".deps"; - -- The name of the archive dependency file for this project - - Need_To_Rebuild : Boolean := Need_To_Rebuild_Global_Archive; - -- When True, archive will be rebuilt - - File : Prj.Util.Text_File; - Object_Path : Path_Name_Type; - Time_Stamp : Time_Stamp_Type; - Saved_Last_Argument : Natural; - First_Object : Natural; - - Discard : Boolean; - pragma Warnings (Off, Discard); - - begin - Check_Archive_Builder; - - if Project_Of_Current_Object_Directory /= Main_Project then - Project_Of_Current_Object_Directory := Main_Project; - Change_Dir (Get_Name_String (Data.Object_Directory)); - - if Verbose_Mode then - Write_Str ("Changing to object directory of """); - Write_Name (Data.Display_Name); - Write_Str (""": """); - Write_Name (Data.Display_Object_Dir); - Write_Line (""""); - end if; - end if; - - if not Need_To_Rebuild then - if Verbose_Mode then - Write_Str (" Checking "); - Write_Line (Archive_Name); - end if; - - -- If the archive does not exist, of course it needs to be built - - if not Is_Regular_File (Archive_Name) then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Line (" -> archive does not exist"); - end if; - - -- Archive does exist - - else - -- Check the archive dependency file - - Open (File, Archive_Dep_Name); - - -- If the archive dependency file does not exist, we need to - -- rebuild the archive and to create its dependency file. - - if not Is_Valid (File) then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> archive dependency file "); - Write_Str (Archive_Dep_Name); - Write_Line (" does not exist"); - end if; - - else - -- Put all sources of language other than Ada in Source_Indexes - - declare - Local_Data : Project_Data; - - begin - Last_Source := 0; - - for Proj in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - Local_Data := Project_Tree.Projects.Table (Proj); - - if not Local_Data.Library then - Source_Id := Local_Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Add_Source_Id (Proj, Source_Id); - Source_Id := Project_Tree.Other_Sources.Table - (Source_Id).Next; - end loop; - end if; - end loop; - end; - - -- Read the dependency file, line by line - - while not End_Of_File (File) loop - Get_Line (File, Name_Buffer, Name_Len); - - -- First line is the path of the object file - - Object_Path := Name_Find; - Source_Id := No_Other_Source; - - -- Check if this object file is for a source of this project - - for S in 1 .. Last_Source loop - S_Id := Source_Indexes (S).Id; - Source := Project_Tree.Other_Sources.Table (S_Id); - - if (not Source_Indexes (S).Found) - and then Source.Object_Path = Object_Path - then - -- We have found the object file: get the source data, - -- and mark it as found. - - Source_Id := S_Id; - Source_Indexes (S).Found := True; - exit; - end if; - end loop; - - -- If it is not for a source of this project, then the - -- archive needs to be rebuilt. - - if Source_Id = No_Other_Source then - Need_To_Rebuild := True; - if Verbose_Mode then - Write_Str (" -> "); - Write_Str (Get_Name_String (Object_Path)); - Write_Line (" is not an object of any project"); - end if; - - exit; - end if; - - -- The second line is the time stamp of the object file. If - -- there is no next line, then the dependency file is - -- truncated, and the archive need to be rebuilt. - - if End_Of_File (File) then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> archive dependency file "); - Write_Line (" is truncated"); - end if; - - exit; - end if; - - Get_Line (File, Name_Buffer, Name_Len); - - -- If the line has the wrong number of characters, then - -- the dependency file is incorrectly formatted, and the - -- archive needs to be rebuilt. - - if Name_Len /= Time_Stamp_Length then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> archive dependency file "); - Write_Line (" is incorrectly formatted (time stamp)"); - end if; - - exit; - end if; - - Time_Stamp := Time_Stamp_Type (Name_Buffer (1 .. Name_Len)); - - -- If the time stamp in the dependency file is different - -- from the time stamp of the object file, then the archive - -- needs to be rebuilt. - - if Time_Stamp /= Source.Object_TS then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> time stamp of "); - Write_Str (Get_Name_String (Object_Path)); - Write_Str (" is incorrect in the archive"); - Write_Line (" dependency file"); - end if; - - exit; - end if; - end loop; - - Close (File); - end if; - end if; - end if; - - if not Need_To_Rebuild then - if Verbose_Mode then - Write_Line (" -> up to date"); - end if; - - -- No need to create a global archive, if there is no object - -- file to put into. - - Global_Archive_Exists := Last_Source /= 0; - - -- Archive needs to be rebuilt - - else - -- If archive already exists, first delete it - - -- Comment needed on why we discard result??? - - if Is_Regular_File (Archive_Name) then - Delete_File (Archive_Name, Discard); - end if; - - Last_Argument := 0; - - -- Start with the options found in MLib.Tgt (usually just "rc") - - Add_Arguments (Archive_Builder_Options.all, True); - - -- Followed by the archive name - - Add_Argument (Archive_Name, True); - - First_Object := Last_Argument; - - -- Followed by all the object files of the non library projects - - for Proj in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - Data := Project_Tree.Projects.Table (Proj); - - if not Data.Library then - Source_Id := Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Source := - Project_Tree.Other_Sources.Table (Source_Id); - - -- Only include object file name that have not been - -- overridden in extending projects. - - if Is_Included_In_Global_Archive - (Source.Object_Name, Proj) - then - Add_Argument - (Get_Name_String (Source.Object_Path), - Verbose_Mode or (First_Object = Last_Argument)); - end if; - - Source_Id := Source.Next; - end loop; - end if; - end loop; - - -- No need to create a global archive, if there is no object - -- file to put into. - - Global_Archive_Exists := Last_Argument > First_Object; - - if Global_Archive_Exists then - - -- If the archive is built, then linking will need to occur - -- unconditionally. - - Need_To_Relink := True; - - -- Spawn the archive builder (ar) - - Saved_Last_Argument := Last_Argument; - Last_Argument := First_Object + Max_In_Archives; - loop - if Last_Argument > Saved_Last_Argument then - Last_Argument := Saved_Last_Argument; - end if; - - Display_Command - (Archive_Builder, - Archive_Builder_Path, - Ellipse => True); - - Spawn - (Archive_Builder_Path.all, - Arguments (1 .. Last_Argument), - Success); - - exit when not Success - or else Last_Argument = Saved_Last_Argument; - - Arguments (1) := r; - Arguments (3 .. Saved_Last_Argument - Last_Argument + 2) := - Arguments (Last_Argument + 1 .. Saved_Last_Argument); - Saved_Last_Argument := Saved_Last_Argument - Last_Argument + 2; - end loop; - - -- If the archive was built, run the archive indexer (ranlib) - -- if there is one. - - if Success then - - if Archive_Indexer_Path /= null then - Last_Argument := 0; - Add_Argument (Archive_Name, True); - - Display_Command (Archive_Indexer, Archive_Indexer_Path); - - Spawn - (Archive_Indexer_Path.all, Arguments (1 .. 1), Success); - - if not Success then - - -- Running ranlib failed, delete the dependency file, - -- if it exists. - - if Is_Regular_File (Archive_Dep_Name) then - Delete_File (Archive_Dep_Name, Success); - end if; - - -- And report the error - - Report_Error - ("running" & Archive_Indexer & " for project """, - Get_Name_String (Data.Display_Name), - """ failed"); - return; - end if; - end if; - - -- The archive was correctly built, create its dependency file - - Create_Global_Archive_Dependency_File (Archive_Dep_Name); - - -- Building the archive failed, delete dependency file if one - -- exists. - - else - if Is_Regular_File (Archive_Dep_Name) then - Delete_File (Archive_Dep_Name, Success); - end if; - - -- And report the error - - Report_Error - ("building archive for project """, - Get_Name_String (Data.Display_Name), - """ failed"); - end if; - end if; - end if; - end Build_Global_Archive; - - ------------------- - -- Build_Library -- - ------------------- - - procedure Build_Library (Project : Project_Id; Unconditionally : Boolean) is - Data : constant Project_Data := - Project_Tree.Projects.Table (Project); - Source_Id : Other_Source_Id; - Source : Other_Source; - - Archive_Name : constant String := - "lib" & Get_Name_String (Data.Library_Name) - & '.' & Archive_Ext; - -- The name of the archive file for this project - - Archive_Dep_Name : constant String := - "lib" & Get_Name_String (Data.Library_Name) - & ".deps"; - -- The name of the archive dependency file for this project - - Need_To_Rebuild : Boolean := Unconditionally; - -- When True, archive will be rebuilt - - File : Prj.Util.Text_File; - - Object_Name : File_Name_Type; - Time_Stamp : Time_Stamp_Type; - Driver_Name : Name_Id := No_Name; - - Lib_Opts : Argument_List_Access := No_Argument'Access; - - begin - -- Nothing to do if the project is externally built - - if Data.Externally_Built then - return; - end if; - - Check_Archive_Builder; - - -- If Unconditionally is False, check if the archive need to be built - - if not Need_To_Rebuild then - if Verbose_Mode then - Write_Str (" Checking "); - Write_Line (Archive_Name); - end if; - - -- If the archive does not exist, of course it needs to be built - - if not Is_Regular_File (Archive_Name) then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Line (" -> archive does not exist"); - end if; - - -- Archive does exist - - else - -- Check the archive dependency file - - Open (File, Archive_Dep_Name); - - -- If the archive dependency file does not exist, we need to - -- rebuild the archive and to create its dependency file. - - if not Is_Valid (File) then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> archive dependency file "); - Write_Str (Archive_Dep_Name); - Write_Line (" does not exist"); - end if; - - else - -- Put all sources of language other than Ada in Source_Indexes - - Last_Source := 0; - - Source_Id := Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Add_Source_Id (Project, Source_Id); - Source_Id := - Project_Tree.Other_Sources.Table (Source_Id).Next; - end loop; - - -- Read the dependency file, line by line - - while not End_Of_File (File) loop - Get_Line (File, Name_Buffer, Name_Len); - - -- First line is the name of an object file - - Object_Name := Name_Find; - Source_Id := No_Other_Source; - - -- Check if this object file is for a source of this project - - for S in 1 .. Last_Source loop - if (not Source_Indexes (S).Found) - and then - Project_Tree.Other_Sources.Table - (Source_Indexes (S).Id).Object_Name = Object_Name - then - -- We have found the object file: get the source - -- data, and mark it as found. - - Source_Id := Source_Indexes (S).Id; - Source := Project_Tree.Other_Sources.Table - (Source_Id); - Source_Indexes (S).Found := True; - exit; - end if; - end loop; - - -- If it is not for a source of this project, then the - -- archive needs to be rebuilt. - - if Source_Id = No_Other_Source then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> "); - Write_Str (Get_Name_String (Object_Name)); - Write_Line (" is not an object of the project"); - end if; - - exit; - end if; - - -- The second line is the time stamp of the object file. - -- If there is no next line, then the dependency file is - -- truncated, and the archive need to be rebuilt. - - if End_Of_File (File) then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> archive dependency file "); - Write_Line (" is truncated"); - end if; - - exit; - end if; - - Get_Line (File, Name_Buffer, Name_Len); - - -- If the line has the wrong number of character, then - -- the dependency file is incorrectly formatted, and the - -- archive needs to be rebuilt. - - if Name_Len /= Time_Stamp_Length then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> archive dependency file "); - Write_Line (" is incorrectly formatted (time stamp)"); - end if; - - exit; - end if; - - Time_Stamp := Time_Stamp_Type (Name_Buffer (1 .. Name_Len)); - - -- If the time stamp in the dependency file is different - -- from the time stamp of the object file, then the archive - -- needs to be rebuilt. - - if Time_Stamp /= Source.Object_TS then - Need_To_Rebuild := True; - - if Verbose_Mode then - Write_Str (" -> time stamp of "); - Write_Str (Get_Name_String (Object_Name)); - Write_Str (" is incorrect in the archive"); - Write_Line (" dependency file"); - end if; - - exit; - end if; - end loop; - - Close (File); - - if not Need_To_Rebuild then - - -- Now, check if all object files of the project have been - -- accounted for. If any of them is not in the dependency - -- file, the archive needs to be rebuilt. - - for Index in 1 .. Last_Source loop - if not Source_Indexes (Index).Found then - Need_To_Rebuild := True; - - if Verbose_Mode then - Source_Id := Source_Indexes (Index).Id; - Source := Project_Tree.Other_Sources.Table - (Source_Id); - Write_Str (" -> "); - Write_Str (Get_Name_String (Source.Object_Name)); - Write_Str (" is not in the archive "); - Write_Line ("dependency file"); - end if; - - exit; - end if; - end loop; - end if; - - if (not Need_To_Rebuild) and Verbose_Mode then - Write_Line (" -> up to date"); - end if; - end if; - end if; - end if; - - -- Build the library if necessary - - if Need_To_Rebuild then - - -- If a library is built, then linking will need to occur - -- unconditionally. - - Need_To_Relink := True; - - Last_Argument := 0; - - -- If there are sources in Ada, then gnatmake will build the library, - -- so nothing to do. - - if not Data.Langs (Ada_Language_Index) then - - -- Get all the object files of the project - - Source_Id := Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Source := Project_Tree.Other_Sources.Table (Source_Id); - Add_Argument - (Get_Name_String (Source.Object_Name), Verbose_Mode); - Source_Id := Source.Next; - end loop; - - -- If it is a library, it need to be built it the same way Ada - -- libraries are built. - - if Data.Library_Kind = Static then - MLib.Build_Library - (Ofiles => Arguments (1 .. Last_Argument), - Output_File => Get_Name_String (Data.Library_Name), - Output_Dir => Get_Name_String (Data.Display_Library_Dir)); - - else - -- Link with g++ if C++ is one of the languages, otherwise - -- building the library may fail with unresolved symbols. - - if C_Plus_Plus_Is_Used then - if Compiler_Names (C_Plus_Plus_Language_Index) = null then - Get_Compiler (C_Plus_Plus_Language_Index); - end if; - - if Compiler_Is_Gcc (C_Plus_Plus_Language_Index) then - Name_Len := 0; - Add_Str_To_Name_Buffer - (Compiler_Names (C_Plus_Plus_Language_Index).all); - Driver_Name := Name_Find; - end if; - end if; - - -- If Library_Options is specified, add these options - - declare - Library_Options : constant Variable_Value := - Value_Of - (Name_Library_Options, - Data.Decl.Attributes, - Project_Tree); - - begin - if not Library_Options.Default then - declare - Current : String_List_Id; - Element : String_Element; - - begin - Current := Library_Options.Values; - while Current /= Nil_String loop - Element := - Project_Tree.String_Elements.Table (Current); - Get_Name_String (Element.Value); - - if Name_Len /= 0 then - Library_Opts.Increment_Last; - Library_Opts.Table (Library_Opts.Last) := - new String'(Name_Buffer (1 .. Name_Len)); - end if; - - Current := Element.Next; - end loop; - end; - end if; - - Lib_Opts := - new Argument_List'(Argument_List - (Library_Opts.Table (1 .. Library_Opts.Last))); - end; - - MLib.Tgt.Build_Dynamic_Library - (Ofiles => Arguments (1 .. Last_Argument), - Options => Lib_Opts.all, - Interfaces => No_Argument, - Lib_Filename => Get_Name_String (Data.Library_Name), - Lib_Dir => Get_Name_String (Data.Library_Dir), - Symbol_Data => No_Symbols, - Driver_Name => Driver_Name, - Lib_Version => "", - Auto_Init => False); - end if; - end if; - - -- Create fake empty archive, so we can check its time stamp later - - declare - Archive : Ada.Text_IO.File_Type; - begin - Create (Archive, Out_File, Archive_Name); - Close (Archive); - end; - - Create_Archive_Dependency_File - (Archive_Dep_Name, Data.First_Other_Source); - end if; - end Build_Library; - - ----------- - -- Check -- - ----------- - - procedure Check (Option : String) is - First : Positive := Option'First; - Last : Natural; - - begin - for Index in Option'First + 1 .. Option'Last - 1 loop - if Option (Index) = ' ' and then Option (Index + 1) = '-' then - Write_Str ("warning: switch """); - Write_Str (Option); - Write_Str (""" is suspicious; consider using "); - - Last := First; - while Last <= Option'Last loop - if Option (Last) = ' ' then - if First /= Option'First then - Write_Str (", "); - end if; - - Write_Char ('"'); - Write_Str (Option (First .. Last - 1)); - Write_Char ('"'); - - while Last <= Option'Last and then Option (Last) = ' ' loop - Last := Last + 1; - end loop; - - First := Last; - - else - if Last = Option'Last then - if First /= Option'First then - Write_Str (", "); - end if; - - Write_Char ('"'); - Write_Str (Option (First .. Last)); - Write_Char ('"'); - end if; - - Last := Last + 1; - end if; - end loop; - - Write_Line (" instead"); - exit; - end if; - end loop; - end Check; - - --------------------------- - -- Check_Archive_Builder -- - --------------------------- - - procedure Check_Archive_Builder is - begin - -- First, make sure that the archive builder (ar) is on the path - - if Archive_Builder_Path = null then - Archive_Builder_Path := Locate_Exec_On_Path (Archive_Builder); - - if Archive_Builder_Path = null then - Osint.Fail - ("unable to locate archive builder """, - Archive_Builder, - """"); - end if; - - -- If there is an archive indexer (ranlib), try to locate it on the - -- path. Don't fail if it is not found. - - if Archive_Indexer /= "" then - Archive_Indexer_Path := Locate_Exec_On_Path (Archive_Indexer); - end if; - end if; - end Check_Archive_Builder; - - ------------------------------ - -- Check_Compilation_Needed -- - ------------------------------ - - procedure Check_Compilation_Needed - (Source : Other_Source; - Need_To_Compile : out Boolean) - is - Source_Name : constant String := Get_Name_String (Source.File_Name); - Source_Path : constant String := Get_Name_String (Source.Path_Name); - Object_Name : constant String := Get_Name_String (Source.Object_Name); - C_Object_Name : String := Object_Name; - Dep_Name : constant String := Get_Name_String (Source.Dep_Name); - C_Source_Path : constant String := - Normalize_Pathname - (Name => Source_Path, - Resolve_Links => False, - Case_Sensitive => False); - - Source_In_Dependencies : Boolean := False; - -- Set True if source was found in dependency file of its object file - - Dep_File : Prj.Util.Text_File; - Start : Natural; - Finish : Natural; - - Looping : Boolean := False; - -- Set to True at the end of the first Big_Loop - - begin - Canonical_Case_File_Name (C_Object_Name); - - -- Assume the worst, so that statement "return;" may be used if there - -- is any problem. - - Need_To_Compile := True; - - if Verbose_Mode then - Write_Str (" Checking "); - Write_Str (Source_Name); - Write_Line (" ... "); - end if; - - -- If object file does not exist, of course source need to be compiled - - if Source.Object_TS = Empty_Time_Stamp then - if Verbose_Mode then - Write_Str (" -> object file "); - Write_Str (Object_Name); - Write_Line (" does not exist"); - end if; - - return; - end if; - - -- If the object file has been created before the last modification - -- of the source, the source need to be recompiled. - - if Source.Object_TS < Source.Source_TS then - if Verbose_Mode then - Write_Str (" -> object file "); - Write_Str (Object_Name); - Write_Line (" has time stamp earlier than source"); - end if; - - return; - end if; - - -- If there is no dependency file, then the source needs to be - -- recompiled and the dependency file need to be created. - - if Source.Dep_TS = Empty_Time_Stamp then - if Verbose_Mode then - Write_Str (" -> dependency file "); - Write_Str (Dep_Name); - Write_Line (" does not exist"); - end if; - - return; - end if; - - -- The source needs to be recompiled if the source has been modified - -- after the dependency file has been created. - - if Source.Dep_TS < Source.Source_TS then - if Verbose_Mode then - Write_Str (" -> dependency file "); - Write_Str (Dep_Name); - Write_Line (" has time stamp earlier than source"); - end if; - - return; - end if; - - -- Look for all dependencies - - Open (Dep_File, Dep_Name); - - -- If dependency file cannot be open, we need to recompile the source - - if not Is_Valid (Dep_File) then - if Verbose_Mode then - Write_Str (" -> could not open dependency file "); - Write_Line (Dep_Name); - end if; - - return; - end if; - - -- Loop Big_Loop is executed several times only when the dependency file - -- contains several times - -- <object file>: <source1> ... - -- When there is only one of such occurrence, Big_Loop is exited - -- successfully at the beginning of the second loop. - - Big_Loop : - loop - declare - End_Of_File_Reached : Boolean := False; - - begin - loop - if End_Of_File (Dep_File) then - End_Of_File_Reached := True; - exit; - end if; - - Get_Line (Dep_File, Name_Buffer, Name_Len); - - exit when Name_Len > 0 and then Name_Buffer (1) /= '#'; - end loop; - - -- If dependency file contains only empty lines or comments, then - -- dependencies are unknown, and the source needs to be - -- recompiled. - - if End_Of_File_Reached then - -- If we have reached the end of file after the first loop, - -- there is nothing else to do. - - exit Big_Loop when Looping; - - if Verbose_Mode then - Write_Str (" -> dependency file "); - Write_Str (Dep_Name); - Write_Line (" is empty"); - end if; - - Close (Dep_File); - return; - end if; - end; - - Start := 1; - Finish := Index (Name_Buffer (1 .. Name_Len), ": "); - - if Finish /= 0 then - Canonical_Case_File_Name (Name_Buffer (1 .. Finish - 1)); - end if; - - -- First line must start with name of object file, followed by colon - - if Finish = 0 or else - Name_Buffer (1 .. Finish - 1) /= C_Object_Name - then - if Verbose_Mode then - Write_Str (" -> dependency file "); - Write_Str (Dep_Name); - Write_Line (" has wrong format"); - end if; - - Close (Dep_File); - return; - - else - Start := Finish + 2; - - -- Process each line - - Line_Loop : loop - declare - Line : String := Name_Buffer (1 .. Name_Len); - Last : Natural := Name_Len; - - begin - Name_Loop : loop - - -- Find the beginning of the next source path name - - while Start < Last and then Line (Start) = ' ' loop - Start := Start + 1; - end loop; - - -- Go to next line when there is a continuation character - -- \ at the end of the line. - - exit Name_Loop when Start = Last - and then Line (Start) = '\'; - - -- We should not be at the end of the line, without - -- a continuation character \. - - if Start = Last then - if Verbose_Mode then - Write_Str (" -> dependency file "); - Write_Str (Dep_Name); - Write_Line (" has wrong format"); - end if; - - Close (Dep_File); - return; - end if; - - -- Look for the end of the source path name - - Finish := Start; - while Finish < Last loop - if Line (Finish) = '\' then - - -- On Windows, a '\' is part of the path name, - -- except when it is followed by another '\' or by - -- a space. On other platforms, when we are getting - -- a '\' that is not the last character of the - -- line, the next character is part of the path - -- name, even if it is a space. - - if On_Windows - and then Line (Finish + 1) /= '\' - and then Line (Finish + 1) /= ' ' - then - Finish := Finish + 1; - - else - Line (Finish .. Last - 1) := - Line (Finish + 1 .. Last); - Last := Last - 1; - end if; - - else - -- A space that is not preceded by '\' indicates - -- the end of the path name. - - exit when Line (Finish + 1) = ' '; - - Finish := Finish + 1; - end if; - end loop; - - -- Check this source - - declare - Src_Name : constant String := - Normalize_Pathname - (Name => - Line (Start .. Finish), - Resolve_Links => False, - Case_Sensitive => False); - Src_TS : Time_Stamp_Type; - - begin - -- If it is original source, set - -- Source_In_Dependencies. - - if Src_Name = C_Source_Path then - Source_In_Dependencies := True; - end if; - - Name_Len := 0; - Add_Str_To_Name_Buffer (Src_Name); - Src_TS := File_Stamp (File_Name_Type'(Name_Find)); - - -- If the source does not exist, we need to recompile - - if Src_TS = Empty_Time_Stamp then - if Verbose_Mode then - Write_Str (" -> source "); - Write_Str (Src_Name); - Write_Line (" does not exist"); - end if; - - Close (Dep_File); - return; - - -- If the source has been modified after the object - -- file, we need to recompile. - - elsif Src_TS > Source.Object_TS then - if Verbose_Mode then - Write_Str (" -> source "); - Write_Str (Src_Name); - Write_Line - (" has time stamp later than object file"); - end if; - - Close (Dep_File); - return; - end if; - end; - - -- If the source path name ends the line, we are done - - exit Line_Loop when Finish = Last; - - -- Go get the next source on the line - - Start := Finish + 1; - end loop Name_Loop; - end; - - -- If we are here, we had a continuation character \ at the end - -- of the line, so we continue with the next line. - - Get_Line (Dep_File, Name_Buffer, Name_Len); - Start := 1; - end loop Line_Loop; - end if; - - -- Set Looping at the end of the first loop - Looping := True; - end loop Big_Loop; - - Close (Dep_File); - - -- If the original sources were not in the dependency file, then we - -- need to recompile. It may mean that we are using a different source - -- (different variant) for this object file. - - if not Source_In_Dependencies then - if Verbose_Mode then - Write_Str (" -> source "); - Write_Str (Source_Path); - Write_Line (" is not in the dependencies"); - end if; - - return; - end if; - - -- If we are here, then everything is OK, no need to recompile - - if Verbose_Mode then - Write_Line (" -> up to date"); - end if; - - Need_To_Compile := False; - end Check_Compilation_Needed; - - --------------------------- - -- Check_For_C_Plus_Plus -- - --------------------------- - - procedure Check_For_C_Plus_Plus is - begin - C_Plus_Plus_Is_Used := False; - - for Project in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - if - Project_Tree.Projects.Table (Project).Langs - (C_Plus_Plus_Language_Index) - then - C_Plus_Plus_Is_Used := True; - exit; - end if; - end loop; - end Check_For_C_Plus_Plus; - - ------------- - -- Compile -- - ------------- - - procedure Compile - (Source_Id : Other_Source_Id; - Data : Project_Data; - Local_Errors : in out Boolean) - is - Source : Other_Source := - Project_Tree.Other_Sources.Table (Source_Id); - Success : Boolean; - CPATH : String_Access := null; - - begin - -- If the compiler is not known yet, get its path name - - if Compiler_Names (Source.Language) = null then - Get_Compiler (Source.Language); - end if; - - -- For non GCC compilers, get the dependency file, first calling the - -- compiler with the switch -M. - - if not Compiler_Is_Gcc (Source.Language) then - Last_Argument := 0; - - -- Add the source name, preceded by -M - - Add_Argument (Dash_M, True); - Add_Argument (Get_Name_String (Source.Path_Name), True); - - -- Add the compiling switches for this source found in - -- package Compiler of the project file, if they exist. - - Add_Switches - (Data, Compiler, Source.Language, Source.File_Name); - - -- Add the compiling switches for the language specified - -- on the command line, if any. - - for - J in 1 .. Comp_Opts.Last (Options (Source.Language)) - loop - Add_Argument (Options (Source.Language).Table (J), True); - end loop; - - -- Finally, add imported directory switches for this project file - - Add_Search_Directories (Data, Source.Language); - - -- And invoke the compiler using GNAT.Expect - - Display_Command - (Compiler_Names (Source.Language).all, - Compiler_Paths (Source.Language)); - - begin - Non_Blocking_Spawn - (FD, - Compiler_Paths (Source.Language).all, - Arguments (1 .. Last_Argument), - Buffer_Size => 0, - Err_To_Out => True); - - declare - Dep_File : Ada.Text_IO.File_Type; - Result : Expect_Match; - - Status : Integer; - pragma Warnings (Off, Status); - - begin - -- Create the dependency file - - Create (Dep_File, Out_File, Get_Name_String (Source.Dep_Name)); - - loop - Expect (FD, Result, Line_Matcher); - - exit when Result = Expect_Timeout; - - declare - S : constant String := Strip_CR_LF (Expect_Out (FD)); - - begin - -- Each line of the output is put in the dependency - -- file, including errors. If there are errors, the - -- syntax of the dependency file will be incorrect and - -- recompilation will occur automatically the next time - -- the dependencies are checked. - - Put_Line (Dep_File, S); - end; - end loop; - - -- If we are here, it means we had a timeout, so the - -- dependency file may be incomplete. It is safer to - -- delete it, otherwise the dependencies may be wrong. - - Close (FD, Status); - Close (Dep_File); - Delete_File (Get_Name_String (Source.Dep_Name), Success); - - exception - when Process_Died => - - -- This is the normal outcome. Just close the file - - Close (FD, Status); - Close (Dep_File); - - when others => - - -- Something wrong happened. It is safer to delete the - -- dependency file, otherwise the dependencies may be wrong. - - Close (FD, Status); - - if Is_Open (Dep_File) then - Close (Dep_File); - end if; - - Delete_File (Get_Name_String (Source.Dep_Name), Success); - end; - - exception - -- If we cannot spawn the compiler, then the dependencies are - -- not updated. It is safer then to delete the dependency file, - -- otherwise the dependencies may be wrong. - - when Invalid_Process => - Delete_File (Get_Name_String (Source.Dep_Name), Success); - end; - end if; - - Last_Argument := 0; - - -- For GCC compilers, make sure the language is always specified to - -- to the GCC driver, in case the extension is not recognized by the - -- GCC driver as a source of the language. - - if Compiler_Is_Gcc (Source.Language) then - Add_Argument (Dash_x, Verbose_Mode); - Add_Argument - (Get_Name_String (Language_Names.Table (Source.Language)), - Verbose_Mode); - end if; - - Add_Argument (Dash_c, True); - - -- Add the compiling switches for this source found in package Compiler - -- of the project file, if they exist. - - Add_Switches - (Data, Compiler, Source.Language, Source.File_Name); - - -- Specify the source to be compiled - - Add_Argument (Get_Name_String (Source.Path_Name), True); - - -- If non static library project, compile with the PIC option if there - -- is one (when there is no PIC option, MLib.Tgt.PIC_Option returns an - -- empty string, and Add_Argument with an empty string has no effect). - - if Data.Library and then Data.Library_Kind /= Static then - Add_Argument (PIC_Option, True); - end if; - - -- Indicate the name of the object - - Add_Argument (Dash_o, True); - Add_Argument (Get_Name_String (Source.Object_Name), True); - - -- When compiler is GCC, use the magic switch that creates the - -- dependency file in the correct format. - - if Compiler_Is_Gcc (Source.Language) then - Add_Argument - ("-Wp,-MD," & Get_Name_String (Source.Dep_Name), - Verbose_Mode); - end if; - - -- Add the compiling switches for the language specified on the command - -- line, if any. - - for J in 1 .. Comp_Opts.Last (Options (Source.Language)) loop - Add_Argument (Options (Source.Language).Table (J), True); - end loop; - - -- Finally, add the imported directory switches for this project file - -- (or, for gcc compilers, set up the CPATH env var if needed). - - Add_Search_Directories (Data, Source.Language); - - -- Set CPATH, if compiler is GCC - - if Compiler_Is_Gcc (Source.Language) then - CPATH := Current_Include_Paths (Source.Language); - end if; - - -- And invoke the compiler - - Display_Command - (Name => Compiler_Names (Source.Language).all, - Path => Compiler_Paths (Source.Language), - CPATH => CPATH); - - Spawn - (Compiler_Paths (Source.Language).all, - Arguments (1 .. Last_Argument), - Success); - - -- Case of successful compilation - - if Success then - - -- Update the time stamp of the object file - - Source.Object_TS := File_Stamp (Source.Object_Name); - - -- Do some sanity checks - - if Source.Object_TS = Empty_Time_Stamp then - Local_Errors := True; - Report_Error - ("object file ", - Get_Name_String (Source.Object_Name), - " has not been created"); - - elsif Source.Object_TS < Source.Source_TS then - Local_Errors := True; - Report_Error - ("object file ", - Get_Name_String (Source.Object_Name), - " has not been modified"); - - else - -- Everything looks fine, update the Other_Sources table - - Project_Tree.Other_Sources.Table (Source_Id) := Source; - end if; - - -- Compilation failed - - else - Local_Errors := True; - Report_Error - ("compilation of ", - Get_Name_String (Source.Path_Name), - " failed"); - end if; - end Compile; - - -------------------------------- - -- Compile_Individual_Sources -- - -------------------------------- - - procedure Compile_Individual_Sources is - Data : Project_Data := - Project_Tree.Projects.Table (Main_Project); - Source_Id : Other_Source_Id; - Source : Other_Source; - Source_Name : File_Name_Type; - Project_Name : String := Get_Name_String (Data.Name); - Dummy : Boolean := False; - - Ada_Is_A_Language : constant Boolean := - Data.Langs (Ada_Language_Index); - - begin - Ada_Mains.Init; - To_Mixed (Project_Name); - Compile_Only := True; - - Get_Imported_Directories (Main_Project, Data); - Project_Tree.Projects.Table (Main_Project) := Data; - - -- Compilation will occur in the object directory - - if Project_Of_Current_Object_Directory /= Main_Project then - Project_Of_Current_Object_Directory := Main_Project; - Change_Dir (Get_Name_String (Data.Object_Directory)); - - if Verbose_Mode then - Write_Str ("Changing to object directory of """); - Write_Name (Data.Name); - Write_Str (""": """); - Write_Name (Data.Display_Object_Dir); - Write_Line (""""); - end if; - end if; - - if not Data.Other_Sources_Present then - if Ada_Is_A_Language then - Mains.Reset; - - loop - declare - Main : constant String := Mains.Next_Main; - begin - exit when Main'Length = 0; - Ada_Mains.Increment_Last; - Ada_Mains.Table (Ada_Mains.Last) := new String'(Main); - end; - end loop; - - else - Osint.Fail ("project ", Project_Name, " contains no source"); - end if; - - else - Mains.Reset; - - loop - declare - Main : constant String := Mains.Next_Main; - begin - Name_Len := Main'Length; - exit when Name_Len = 0; - Name_Buffer (1 .. Name_Len) := Main; - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Source_Name := Name_Find; - - if not Sources_Compiled.Get (Source_Name) then - Sources_Compiled.Set (Source_Name, True); - - Source_Id := Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Source := Project_Tree.Other_Sources.Table (Source_Id); - exit when Source.File_Name = Source_Name; - Source_Id := Source.Next; - end loop; - - if Source_Id = No_Other_Source then - if Ada_Is_A_Language then - Ada_Mains.Increment_Last; - Ada_Mains.Table (Ada_Mains.Last) := new String'(Main); - - else - Report_Error - (Main, - " is not a valid source of project ", - Project_Name); - end if; - - else - Compile (Source_Id, Data, Dummy); - end if; - end if; - end; - end loop; - end if; - - if Ada_Mains.Last > 0 then - - -- Invoke gnatmake for all Ada sources - - Last_Argument := 0; - Add_Argument (Dash_u, True); - - for Index in 1 .. Ada_Mains.Last loop - Add_Argument (Ada_Mains.Table (Index), True); - end loop; - - Compile_Link_With_Gnatmake (Mains_Specified => False); - end if; - end Compile_Individual_Sources; - - -------------------------------- - -- Compile_Link_With_Gnatmake -- - -------------------------------- - - procedure Compile_Link_With_Gnatmake (Mains_Specified : Boolean) is - Data : constant Project_Data := - Project_Tree.Projects.Table (Main_Project); - Success : Boolean; - - begin - -- Array Arguments may already contain some arguments, so we don't - -- set Last_Argument to 0. - - -- Get the gnatmake to invoke - - Get_Compiler (Ada_Language_Index); - - -- Specify the project file - - Add_Argument (Dash_P, True); - Add_Argument (Get_Name_String (Data.Display_Path_Name), True); - - -- Add the saved switches, if any - - for Index in 1 .. Saved_Switches.Last loop - Add_Argument (Saved_Switches.Table (Index), True); - end loop; - - -- If Mains_Specified is True, find the mains in package Mains - - if Mains_Specified then - Mains.Reset; - - loop - declare - Main : constant String := Mains.Next_Main; - begin - exit when Main'Length = 0; - Add_Argument (Main, True); - end; - end loop; - end if; - - -- Specify output file name, if any was specified on the command line - - if Output_File_Name /= null then - Add_Argument (Dash_o, True); - Add_Argument (Output_File_Name, True); - end if; - - -- Transmit some switches to gnatmake - - -- -c - - if Compile_Only then - Add_Argument (Dash_c, True); - end if; - - -- -d - - if Display_Compilation_Progress then - Add_Argument (Dash_d, True); - end if; - - -- -eL - - if Follow_Links_For_Files then - Add_Argument (Dash_eL, True); - end if; - - -- -k - - if Keep_Going then - Add_Argument (Dash_k, True); - end if; - - -- -f - - if Force_Compilations then - Add_Argument (Dash_f, True); - end if; - - -- -v - - if Verbose_Mode then - Add_Argument (Dash_v, True); - end if; - - -- -q - - if Quiet_Output then - Add_Argument (Dash_q, True); - end if; - - -- -vP1 and -vP2 - - case Current_Verbosity is - when Default => - null; - - when Medium => - Add_Argument (Dash_vP1, True); - - when High => - Add_Argument (Dash_vP2, True); - end case; - - -- If there are compiling options for Ada, transmit them to gnatmake - - if Comp_Opts.Last (Options (Ada_Language_Index)) /= 0 then - Add_Argument (Dash_cargs, True); - - for Arg in 1 .. Comp_Opts.Last (Options (Ada_Language_Index)) loop - Add_Argument (Options (Ada_Language_Index).Table (Arg), True); - end loop; - end if; - - if not Compile_Only then - - -- Linking options - - if Linker_Options.Last /= 0 then - Add_Argument (Dash_largs, True); - else - Add_Argument (Dash_largs, Verbose_Mode); - end if; - - -- Add the archives - - Add_Archives (For_Gnatmake => True); - - -- If there are linking options from the command line, - -- transmit them to gnatmake. - - for Arg in 1 .. Linker_Options.Last loop - Add_Argument (Linker_Options.Table (Arg), True); - end loop; - end if; - - -- And invoke gnatmake - - Display_Command - (Compiler_Names (Ada_Language_Index).all, - Compiler_Paths (Ada_Language_Index)); - - Spawn - (Compiler_Paths (Ada_Language_Index).all, - Arguments (1 .. Last_Argument), - Success); - - -- Report an error if call to gnatmake failed - - if not Success then - Report_Error - ("invocation of ", - Compiler_Names (Ada_Language_Index).all, - " failed"); - end if; - end Compile_Link_With_Gnatmake; - - --------------------- - -- Compile_Sources -- - --------------------- - - procedure Compile_Sources is - Data : Project_Data; - Source_Id : Other_Source_Id; - Source : Other_Source; - - Local_Errors : Boolean := False; - -- Set to True when there is a compilation error. Used only when - -- Keep_Going is True, to inhibit the building of the archive. - - Need_To_Compile : Boolean; - -- Set to True when a source needs to be compiled/recompiled - - Need_To_Rebuild_Archive : Boolean := Force_Compilations; - -- True when the archive needs to be built/rebuilt unconditionally - - Total_Number_Of_Sources : Int := 0; - - Current_Source_Number : Int := 0; - - begin - -- First, get the number of sources - - for Project in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - Data := Project_Tree.Projects.Table (Project); - - if not Data.Virtual and then Data.Other_Sources_Present then - Source_Id := Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Source := Project_Tree.Other_Sources.Table (Source_Id); - Total_Number_Of_Sources := Total_Number_Of_Sources + 1; - Source_Id := Source.Next; - end loop; - end if; - end loop; - - -- Loop through project files - - for Project in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - Local_Errors := False; - Data := Project_Tree.Projects.Table (Project); - - -- Nothing to do when no sources of language other than Ada - - if (not Data.Virtual) and then Data.Other_Sources_Present then - - -- If the imported directory switches are unknown, compute them - - if not Data.Include_Data_Set then - Get_Imported_Directories (Project, Data); - Data.Include_Data_Set := True; - Project_Tree.Projects.Table (Project) := Data; - end if; - - Need_To_Rebuild_Archive := Force_Compilations; - - -- Compilation will occur in the object directory - - if Project_Of_Current_Object_Directory /= Project then - Project_Of_Current_Object_Directory := Project; - Change_Dir (Get_Name_String (Data.Object_Directory)); - - if Verbose_Mode then - Write_Str ("Changing to object directory of """); - Write_Name (Data.Display_Name); - Write_Str (""": """); - Write_Name (Data.Display_Object_Dir); - Write_Line (""""); - end if; - end if; - - -- Process each source one by one - - Source_Id := Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Source := Project_Tree.Other_Sources.Table (Source_Id); - Current_Source_Number := Current_Source_Number + 1; - Need_To_Compile := Force_Compilations; - - -- Check if compilation is needed - - if not Need_To_Compile then - Check_Compilation_Needed (Source, Need_To_Compile); - end if; - - -- Proceed, if compilation is needed - - if Need_To_Compile then - - -- If a source is compiled/recompiled, of course the - -- archive will need to be built/rebuilt. - - Need_To_Rebuild_Archive := True; - Compile (Source_Id, Data, Local_Errors); - end if; - - if Display_Compilation_Progress then - Write_Str ("completed "); - Write_Int (Current_Source_Number); - Write_Str (" out of "); - Write_Int (Total_Number_Of_Sources); - Write_Str (" ("); - Write_Int - ((Current_Source_Number * 100) / Total_Number_Of_Sources); - Write_Str ("%)..."); - Write_Eol; - end if; - - -- Next source, if any - - Source_Id := Source.Next; - end loop; - - if Need_To_Rebuild_Archive and then (not Data.Library) then - Need_To_Rebuild_Global_Archive := True; - end if; - - -- If there was no compilation error and -c was not used, - -- build / rebuild the archive if necessary. - - if not Local_Errors - and then Data.Library - and then not Data.Langs (Ada_Language_Index) - and then not Compile_Only - then - Build_Library (Project, Need_To_Rebuild_Archive); - end if; - end if; - end loop; - end Compile_Sources; - - --------------- - -- Copyright -- - --------------- - - procedure Copyright is - begin - -- Only output the Copyright notice once - - if not Copyright_Output then - Copyright_Output := True; - Write_Eol; - Write_Str ("GPRMAKE "); - Write_Str (Gnatvsn.Gnat_Version_String); - Write_Str (" Copyright 2004-"); - Write_Str (Gnatvsn.Current_Year); - Write_Str (" Free Software Foundation, Inc."); - Write_Eol; - end if; - end Copyright; - - ------------------------------------ - -- Create_Archive_Dependency_File -- - ------------------------------------ - - procedure Create_Archive_Dependency_File - (Name : String; - First_Source : Other_Source_Id) - is - Source_Id : Other_Source_Id; - Source : Other_Source; - Dep_File : Ada.Text_IO.File_Type; - - begin - -- Create the file in Append mode, to avoid automatic insertion of - -- an end of line if file is empty. - - Create (Dep_File, Append_File, Name); - - Source_Id := First_Source; - while Source_Id /= No_Other_Source loop - Source := Project_Tree.Other_Sources.Table (Source_Id); - Put_Line (Dep_File, Get_Name_String (Source.Object_Name)); - Put_Line (Dep_File, String (Source.Object_TS)); - Source_Id := Source.Next; - end loop; - - Close (Dep_File); - - exception - when others => - if Is_Open (Dep_File) then - Close (Dep_File); - end if; - end Create_Archive_Dependency_File; - - ------------------------------------------- - -- Create_Global_Archive_Dependency_File -- - ------------------------------------------- - - procedure Create_Global_Archive_Dependency_File (Name : String) is - Source_Id : Other_Source_Id; - Source : Other_Source; - Dep_File : Ada.Text_IO.File_Type; - - begin - -- Create the file in Append mode, to avoid automatic insertion of - -- an end of line if file is empty. - - Create (Dep_File, Append_File, Name); - - -- Get all the object files of non-Ada sources in non-library projects - - for Project in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - if not Project_Tree.Projects.Table (Project).Library then - Source_Id := - Project_Tree.Projects.Table (Project).First_Other_Source; - while Source_Id /= No_Other_Source loop - Source := Project_Tree.Other_Sources.Table (Source_Id); - - -- Put only those object files that are in the global archive - - if Is_Included_In_Global_Archive - (Source.Object_Name, Project) - then - Put_Line (Dep_File, Get_Name_String (Source.Object_Path)); - Put_Line (Dep_File, String (Source.Object_TS)); - end if; - - Source_Id := Source.Next; - end loop; - end if; - end loop; - - Close (Dep_File); - - exception - when others => - if Is_Open (Dep_File) then - Close (Dep_File); - end if; - end Create_Global_Archive_Dependency_File; - - --------------------- - -- Display_Command -- - --------------------- - - procedure Display_Command - (Name : String; - Path : String_Access; - CPATH : String_Access := null; - Ellipse : Boolean := False) - is - Display_Ellipse : Boolean := Ellipse; - - begin - -- Only display the command in Verbose Mode (-v) or when - -- not in Quiet Output (no -q). - - if Verbose_Mode or (not Quiet_Output) then - - -- In Verbose Mode output the full path of the spawned process - - if Verbose_Mode then - if CPATH /= null then - Write_Str ("CPATH = "); - Write_Line (CPATH.all); - end if; - - Write_Str (Path.all); - - else - Write_Str (Name); - end if; - - -- Display only the arguments for which the display flag is set - -- (in Verbose Mode, the display flag is set for all arguments) - - for Arg in 1 .. Last_Argument loop - if Arguments_Displayed (Arg) then - Write_Char (' '); - Write_Str (Arguments (Arg).all); - - elsif Display_Ellipse then - Write_Str (" ..."); - Display_Ellipse := False; - end if; - end loop; - - Write_Eol; - end if; - end Display_Command; - - ------------------ - -- Get_Compiler -- - ------------------ - - procedure Get_Compiler (For_Language : First_Language_Indexes) is - Data : constant Project_Data := - Project_Tree.Projects.Table (Main_Project); - - Ide : constant Package_Id := - Value_Of - (Name_Ide, - In_Packages => Data.Decl.Packages, - In_Tree => Project_Tree); - -- The id of the package IDE in the project file - - Compiler : constant Variable_Value := - Value_Of - (Name => Language_Names.Table (For_Language), - Index => 0, - Attribute_Or_Array_Name => Name_Compiler_Command, - In_Package => Ide, - In_Tree => Project_Tree); - -- The value of Compiler_Command ("language") in package IDE, if defined - - begin - -- No need to do it again if the compiler is known for this language - - if Compiler_Names (For_Language) = null then - - -- If compiler command is not defined for this language in package - -- IDE, use the default compiler for this language. - - if Compiler = Nil_Variable_Value then - if For_Language in Default_Compiler_Names'Range then - Compiler_Names (For_Language) := - Default_Compiler_Names (For_Language); - - else - Osint.Fail - ("unknown compiler name for language """, - Get_Name_String (Language_Names.Table (For_Language)), - """"); - end if; - - else - Compiler_Names (For_Language) := - new String'(Get_Name_String (Compiler.Value)); - end if; - - -- Check we have a GCC compiler (name ends with "gcc" or "g++") - - declare - Comp_Name : constant String := Compiler_Names (For_Language).all; - Last3 : String (1 .. 3); - begin - if Comp_Name'Length >= 3 then - Last3 := Comp_Name (Comp_Name'Last - 2 .. Comp_Name'Last); - Compiler_Is_Gcc (For_Language) := - (Last3 = "gcc") or (Last3 = "g++"); - else - Compiler_Is_Gcc (For_Language) := False; - end if; - end; - - -- Locate the compiler on the path - - Compiler_Paths (For_Language) := - Locate_Exec_On_Path (Compiler_Names (For_Language).all); - - -- Fail if compiler cannot be found - - if Compiler_Paths (For_Language) = null then - if For_Language = Ada_Language_Index then - Osint.Fail - ("unable to locate """, - Compiler_Names (For_Language).all, - """"); - - else - Osint.Fail - ("unable to locate " & - Get_Name_String (Language_Names.Table (For_Language)), - " compiler """, Compiler_Names (For_Language).all & '"'); - end if; - end if; - end if; - end Get_Compiler; - - ------------------------------ - -- Get_Imported_Directories -- - ------------------------------ - - procedure Get_Imported_Directories - (Project : Project_Id; - Data : in out Project_Data) - is - Imported_Projects : Project_List := Data.Imported_Projects; - - Path_Length : Natural := 0; - Position : Natural := 0; - - procedure Add (Source_Dirs : String_List_Id); - -- Add a list of source directories - - procedure Recursive_Get_Dirs (Prj : Project_Id); - -- Recursive procedure to get the source directories of this project - -- file and of the project files it imports, in the correct order. - - --------- - -- Add -- - --------- - - procedure Add (Source_Dirs : String_List_Id) is - Element_Id : String_List_Id; - Element : String_Element; - Add_Arg : Boolean := True; - - begin - -- Add each source directory path name, preceded by "-I" to Arguments - - Element_Id := Source_Dirs; - while Element_Id /= Nil_String loop - Element := Project_Tree.String_Elements.Table (Element_Id); - - if Element.Value /= No_Name then - Get_Name_String (Element.Display_Value); - - if Name_Len > 0 then - - -- Remove a trailing directory separator: this may cause - -- problems on Windows. - - if Name_Len > 1 - and then Name_Buffer (Name_Len) = Directory_Separator - then - Name_Len := Name_Len - 1; - end if; - - declare - Arg : constant String := - "-I" & Name_Buffer (1 .. Name_Len); - begin - -- Check if directory is already in the list. If it is, - -- no need to put it there again. - - Add_Arg := True; - - for Index in 1 .. Last_Argument loop - if Arguments (Index).all = Arg then - Add_Arg := False; - exit; - end if; - end loop; - - if Add_Arg then - if Path_Length /= 0 then - Path_Length := Path_Length + 1; - end if; - - Path_Length := Path_Length + Name_Len; - - Add_Argument (Arg, True); - end if; - end; - end if; - end if; - - Element_Id := Element.Next; - end loop; - end Add; - - ------------------------ - -- Recursive_Get_Dirs -- - ------------------------ - - procedure Recursive_Get_Dirs (Prj : Project_Id) is - Data : Project_Data; - Imported : Project_List; - - begin - -- Nothing to do if project is undefined - - if Prj /= No_Project then - Data := Project_Tree.Projects.Table (Prj); - - -- Nothing to do if project has already been processed - - if not Data.Seen then - - -- Mark the project as processed, to avoid multiple processing - -- of the same project. - - Project_Tree.Projects.Table (Prj).Seen := True; - - -- Add the source directories of this project - - if not Data.Virtual then - Add (Data.Source_Dirs); - end if; - - Recursive_Get_Dirs (Data.Extends); - - -- Call itself for all imported projects, if any - - Imported := Data.Imported_Projects; - while Imported /= Empty_Project_List loop - Recursive_Get_Dirs - (Project_Tree.Project_Lists.Table (Imported).Project); - Imported := - Project_Tree.Project_Lists.Table (Imported).Next; - end loop; - end if; - end if; - end Recursive_Get_Dirs; - - -- Start of processing for Get_Imported_Directories - - begin - -- First, mark all project as not processed - - for J in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - Project_Tree.Projects.Table (J).Seen := False; - end loop; - - -- Empty Arguments - - Last_Argument := 0; - - -- Process this project individually, project data are already known - - Project_Tree.Projects.Table (Project).Seen := True; - - Add (Data.Source_Dirs); - - Recursive_Get_Dirs (Data.Extends); - - while Imported_Projects /= Empty_Project_List loop - Recursive_Get_Dirs - (Project_Tree.Project_Lists.Table - (Imported_Projects).Project); - Imported_Projects := Project_Tree.Project_Lists.Table - (Imported_Projects).Next; - end loop; - - Data.Imported_Directories_Switches := - new Argument_List'(Arguments (1 .. Last_Argument)); - - -- Create the Include_Path, from the Arguments - - Data.Include_Path := new String (1 .. Path_Length); - Data.Include_Path (1 .. Arguments (1)'Length - 2) := - Arguments (1)(Arguments (1)'First + 2 .. Arguments (1)'Last); - Position := Arguments (1)'Length - 2; - - for Arg in 2 .. Last_Argument loop - Position := Position + 1; - Data.Include_Path (Position) := Path_Separator; - Data.Include_Path - (Position + 1 .. Position + Arguments (Arg)'Length - 2) := - Arguments (Arg)(Arguments (Arg)'First + 2 .. Arguments (Arg)'Last); - Position := Position + Arguments (Arg)'Length - 2; - end loop; - - Last_Argument := 0; - end Get_Imported_Directories; - - ------------- - -- Gprmake -- - ------------- - - procedure Gprmake is - begin - Makegpr.Initialize; - - if Verbose_Mode then - Write_Eol; - Write_Str ("Parsing project file """); - Write_Str (Project_File_Name.all); - Write_Str ("""."); - Write_Eol; - end if; - - -- Parse and process project files for other languages (not for Ada) - - Prj.Pars.Parse - (Project => Main_Project, - In_Tree => Project_Tree, - Project_File_Name => Project_File_Name.all, - Packages_To_Check => Packages_To_Check); - - -- Fail if parsing/processing was unsuccessful - - if Main_Project = No_Project then - Osint.Fail ("""", Project_File_Name.all, """ processing failed"); - end if; - - if Verbose_Mode then - Write_Eol; - Write_Str ("Parsing of project file """); - Write_Str (Project_File_Name.all); - Write_Str (""" is finished."); - Write_Eol; - end if; - - -- If -f was specified, we will certainly need to link (except when - -- -u or -c were specified, of course). - - Need_To_Relink := Force_Compilations; - - if Unique_Compile then - if Mains.Number_Of_Mains = 0 then - Osint.Fail - ("No source specified to compile in 'unique compile' mode"); - else - Compile_Individual_Sources; - Report_Total_Errors ("compilation"); - end if; - - else - declare - Data : constant Prj.Project_Data := - Project_Tree.Projects.Table (Main_Project); - begin - if Data.Library and then Mains.Number_Of_Mains /= 0 then - Osint.Fail - ("Cannot specify mains on the command line " & - "for a Library Project"); - end if; - - -- First check for C++, to link libraries with g++, - -- rather than gcc. - - Check_For_C_Plus_Plus; - - -- Compile sources and build archives for library project, - -- if necessary. - - Compile_Sources; - - -- When Keep_Going is True, if we had some errors, fail now, - -- reporting the number of compilation errors. - -- Do not attempt to link. - - Report_Total_Errors ("compilation"); - - -- If -c was not specified, link the executables, - -- if there are any. - - if not Compile_Only - and then not Data.Library - and then Data.Object_Directory /= No_Path - then - Build_Global_Archive; - Link_Executables; - end if; - - -- When Keep_Going is True, if we had some errors, fail, reporting - -- the number of linking errors. - - Report_Total_Errors ("linking"); - end; - end if; - end Gprmake; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - Set_Mode (Ada_Only); - - -- Do some necessary package initializations - - Csets.Initialize; - Namet.Initialize; - Snames.Initialize; - Prj.Initialize (Project_Tree); - Mains.Delete; - - -- Add the directory where gprmake is invoked in front of the path, - -- if gprmake is invoked from a bin directory or with directory - -- information. Only do this if the platform is not VMS, where the - -- notion of path does not really exist. - - -- Below code shares nasty code duplication with make.adb code??? - - if not OpenVMS then - declare - Prefix : constant String := Executable_Prefix_Path; - Command : constant String := Command_Name; - - begin - if Prefix'Length > 0 then - declare - PATH : constant String := - Prefix & Directory_Separator & "bin" & - Path_Separator & - Getenv ("PATH").all; - begin - Setenv ("PATH", PATH); - end; - - else - for Index in reverse Command'Range loop - if Command (Index) = Directory_Separator then - declare - Absolute_Dir : constant String := - Normalize_Pathname - (Command (Command'First .. Index)); - PATH : constant String := - Absolute_Dir & - Path_Separator & - Getenv ("PATH").all; - begin - Setenv ("PATH", PATH); - end; - - exit; - end if; - end loop; - end if; - end; - end if; - - -- Set Name_Ide and Name_Compiler_Command - - Name_Len := 0; - Add_Str_To_Name_Buffer ("ide"); - Name_Ide := Name_Find; - - Name_Len := 0; - Add_Str_To_Name_Buffer ("compiler_command"); - Name_Compiler_Command := Name_Find; - - -- Make sure the Saved_Switches table is empty - - Saved_Switches.Set_Last (0); - - -- Get the command line arguments - - Scan_Args : for Next_Arg in 1 .. Argument_Count loop - Scan_Arg (Argument (Next_Arg)); - end loop Scan_Args; - - -- Fail if command line ended with "-P" - - if Project_File_Name_Expected then - Osint.Fail ("project file name missing after -P"); - - -- Or if it ended with "-o" - - elsif Output_File_Name_Expected then - Osint.Fail ("output file name missing after -o"); - end if; - - -- If no project file was specified, display the usage and fail - - if Project_File_Name = null then - Usage; - Exit_Program (E_Success); - end if; - - -- To be able of finding libgnat.a in MLib.Tgt, we need to have the - -- default search dirs established in Osint. - - Osint.Add_Default_Search_Dirs; - end Initialize; - - ----------------------------------- - -- Is_Included_In_Global_Archive -- - ----------------------------------- - - function Is_Included_In_Global_Archive - (Object_Name : File_Name_Type; - Project : Project_Id) return Boolean - is - Data : Project_Data := Project_Tree.Projects.Table (Project); - Source : Other_Source_Id; - - begin - while Data.Extended_By /= No_Project loop - Data := Project_Tree.Projects.Table (Data.Extended_By); - - Source := Data.First_Other_Source; - while Source /= No_Other_Source loop - if Project_Tree.Other_Sources.Table (Source).Object_Name = - Object_Name - then - return False; - else - Source := - Project_Tree.Other_Sources.Table (Source).Next; - end if; - end loop; - end loop; - - return True; - end Is_Included_In_Global_Archive; - - ---------------------- - -- Link_Executables -- - ---------------------- - - procedure Link_Executables is - Data : constant Project_Data := - Project_Tree.Projects.Table (Main_Project); - - Mains_Specified : constant Boolean := Mains.Number_Of_Mains /= 0; - -- True if main sources were specified on the command line - - Object_Dir : constant String := - Get_Name_String (Data.Display_Object_Dir); - -- Path of the object directory of the main project - - Source_Id : Other_Source_Id; - Source : Other_Source; - Success : Boolean; - - Linker_Name : String_Access; - Linker_Path : String_Access; - -- The linker name and path, when linking is not done by gnatlink - - Link_Done : Boolean := False; - -- Set to True when the linker is invoked directly (not through - -- gnatmake) to be able to report if mains were up to date at the end - -- of execution. - - procedure Add_C_Plus_Plus_Link_For_Gnatmake; - -- Add the --LINK= switch for gnatlink, depending on the C++ compiler - - procedure Check_Time_Stamps (Exec_Time_Stamp : Time_Stamp_Type); - -- Check if there is an archive that is more recent than the executable - -- to decide if we need to relink. - - procedure Choose_C_Plus_Plus_Link_Process; - -- If the C++ compiler is not g++, create the correct script to link - - procedure Link_Foreign - (Main : String; - Main_Id : File_Name_Type; - Source : Other_Source); - -- Link a non-Ada main, when there is no Ada code - - --------------------------------------- - -- Add_C_Plus_Plus_Link_For_Gnatmake -- - --------------------------------------- - - procedure Add_C_Plus_Plus_Link_For_Gnatmake is - begin - Add_Argument - ("--LINK=" & Compiler_Names (C_Plus_Plus_Language_Index).all, - Verbose_Mode); - end Add_C_Plus_Plus_Link_For_Gnatmake; - - ----------------------- - -- Check_Time_Stamps -- - ----------------------- - - procedure Check_Time_Stamps (Exec_Time_Stamp : Time_Stamp_Type) is - Prj_Data : Project_Data; - - begin - for Prj in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - Prj_Data := Project_Tree.Projects.Table (Prj); - - -- There is an archive only in project - -- files with sources other than Ada - -- sources. - - if Data.Other_Sources_Present then - declare - Archive_Path : constant String := Get_Name_String - (Prj_Data.Display_Object_Dir) & Directory_Separator - & "lib" & Get_Name_String (Prj_Data.Display_Name) - & '.' & Archive_Ext; - Archive_TS : Time_Stamp_Type; - begin - Name_Len := 0; - Add_Str_To_Name_Buffer (Archive_Path); - Archive_TS := File_Stamp (File_Name_Type'(Name_Find)); - - -- If the archive is later than the - -- executable, we need to relink. - - if Archive_TS /= Empty_Time_Stamp - and then - Exec_Time_Stamp < Archive_TS - then - Need_To_Relink := True; - - if Verbose_Mode then - Write_Str (" -> "); - Write_Str (Archive_Path); - Write_Str (" has time stamp "); - Write_Str ("later than "); - Write_Line ("executable"); - end if; - - exit; - end if; - end; - end if; - end loop; - end Check_Time_Stamps; - - ------------------------------------- - -- Choose_C_Plus_Plus_Link_Process -- - ------------------------------------- - - procedure Choose_C_Plus_Plus_Link_Process is - begin - if Compiler_Names (C_Plus_Plus_Language_Index) = null then - Get_Compiler (C_Plus_Plus_Language_Index); - end if; - end Choose_C_Plus_Plus_Link_Process; - - ------------------ - -- Link_Foreign -- - ------------------ - - procedure Link_Foreign - (Main : String; - Main_Id : File_Name_Type; - Source : Other_Source) - is - Executable_Name : constant String := - Get_Name_String - (Executable_Of - (Project => Main_Project, - In_Tree => Project_Tree, - Main => Main_Id, - Index => 0, - Ada_Main => False)); - -- File name of the executable - - Executable_Path : constant String := - Get_Name_String - (Data.Display_Exec_Dir) & - Directory_Separator & Executable_Name; - -- Path name of the executable - - Exec_Time_Stamp : Time_Stamp_Type; - - begin - -- Now, check if the executable is up to date. It is considered - -- up to date if its time stamp is not earlier that the time stamp - -- of any archive. Only do that if we don't know if we need to link. - - if not Need_To_Relink then - - -- Get the time stamp of the executable - - Name_Len := 0; - Add_Str_To_Name_Buffer (Executable_Path); - Exec_Time_Stamp := File_Stamp (File_Name_Type'(Name_Find)); - - if Verbose_Mode then - Write_Str (" Checking executable "); - Write_Line (Executable_Name); - end if; - - -- If executable does not exist, we need to link - - if Exec_Time_Stamp = Empty_Time_Stamp then - Need_To_Relink := True; - - if Verbose_Mode then - Write_Line (" -> not found"); - end if; - - -- Otherwise, get the time stamps of each archive. If one of - -- them is found later than the executable, we need to relink. - - else - Check_Time_Stamps (Exec_Time_Stamp); - end if; - - -- If Need_To_Relink is False, we are done - - if Verbose_Mode and (not Need_To_Relink) then - Write_Line (" -> up to date"); - end if; - end if; - - -- Prepare to link - - if Need_To_Relink then - Link_Done := True; - - Last_Argument := 0; - - -- Specify the executable path name - - Add_Argument (Dash_o, True); - Add_Argument - (Get_Name_String (Data.Display_Exec_Dir) & - Directory_Separator & - Get_Name_String - (Executable_Of - (Project => Main_Project, - In_Tree => Project_Tree, - Main => Main_Id, - Index => 0, - Ada_Main => False)), - True); - - -- Specify the object file of the main source - - Add_Argument - (Object_Dir & Directory_Separator & - Get_Name_String (Source.Object_Name), - True); - - -- Add all the archives, in a correct order - - Add_Archives (For_Gnatmake => False); - - -- Add the switches specified in package Linker of - -- the main project. - - Add_Switches - (Data => Data, - Proc => Linker, - Language => Source.Language, - File_Name => Main_Id); - - -- Add the switches specified in attribute - -- Linker_Options of packages Linker. - - if Link_Options_Switches = null then - Link_Options_Switches := - new Argument_List' - (Linker_Options_Switches (Main_Project, Project_Tree)); - end if; - - Add_Arguments (Link_Options_Switches.all, True); - - -- Add the linking options specified on the - -- command line. - - for Arg in 1 .. Linker_Options.Last loop - Add_Argument (Linker_Options.Table (Arg), True); - end loop; - - -- If there are shared libraries and the run path - -- option is supported, add the run path switch. - - if Lib_Path.Last > 0 then - Add_Argument - (Path_Option.all & - String (Lib_Path.Table (1 .. Lib_Path.Last)), - Verbose_Mode); - end if; - - -- And invoke the linker - - Display_Command (Linker_Name.all, Linker_Path); - Spawn - (Linker_Path.all, - Arguments (1 .. Last_Argument), - Success); - - if not Success then - Report_Error ("could not link ", Main); - end if; - end if; - end Link_Foreign; - - -- Start of processing of Link_Executables - - begin - -- If no mains specified, get mains from attribute Main, if it exists - - if not Mains_Specified then - declare - Element_Id : String_List_Id; - Element : String_Element; - - begin - Element_Id := Data.Mains; - while Element_Id /= Nil_String loop - Element := Project_Tree.String_Elements.Table (Element_Id); - - if Element.Value /= No_Name then - Mains.Add_Main (Get_Name_String (Element.Value)); - end if; - - Element_Id := Element.Next; - end loop; - end; - end if; - - if Mains.Number_Of_Mains = 0 then - - -- If the attribute Main is an empty list or not specified, - -- there is nothing to do. - - if Verbose_Mode then - Write_Line ("No main to link"); - end if; - return; - end if; - - -- Check if -o was used for several mains - - if Output_File_Name /= null and then Mains.Number_Of_Mains > 1 then - Osint.Fail ("cannot specify an executable name for several mains"); - end if; - - -- Check how we are going to do the link - - if not Data.Other_Sources_Present then - - -- Only Ada sources in the main project, and even maybe not - - if Data.Extends = No_Project and then - not Data.Langs (Ada_Language_Index) - then - -- Fail if the main project has no source of any language - - Osint.Fail - ("project """, - Get_Name_String (Data.Name), - """ has no sources, so no main can be linked"); - - else - -- Only Ada sources in the main project, call gnatmake directly - - Last_Argument := 0; - - -- Choose correct linker if there is C++ code in other projects - - if C_Plus_Plus_Is_Used then - Choose_C_Plus_Plus_Link_Process; - Add_Argument (Dash_largs, Verbose_Mode); - Add_C_Plus_Plus_Link_For_Gnatmake; - Add_Argument (Dash_margs, Verbose_Mode); - end if; - - Compile_Link_With_Gnatmake (Mains_Specified); - end if; - - else - -- There are other language sources. First check if there are also - -- sources in Ada. - - if Data.Langs (Ada_Language_Index) then - - -- There is a mix of Ada and other language sources in the main - -- project. Any main that is not a source of the other languages - -- will be deemed to be an Ada main. - - -- Find the mains of the other languages and the Ada mains - - Mains.Reset; - Ada_Mains.Set_Last (0); - Other_Mains.Set_Last (0); - - -- For each main - - loop - declare - Main : constant String := Mains.Next_Main; - Main_Id : File_Name_Type; - - begin - exit when Main'Length = 0; - - -- Get the main file name - - Name_Len := 0; - Add_Str_To_Name_Buffer (Main); - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Main_Id := Name_Find; - - -- Check if it is a source of a language other than Ada - - Source_Id := Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Source := - Project_Tree.Other_Sources.Table (Source_Id); - exit when Source.File_Name = Main_Id; - Source_Id := Source.Next; - end loop; - - -- If it is not, put it in the list of Ada mains - - if Source_Id = No_Other_Source then - Ada_Mains.Increment_Last; - Ada_Mains.Table (Ada_Mains.Last) := new String'(Main); - - -- Otherwise, put it in the list of other mains - - else - Other_Mains.Increment_Last; - Other_Mains.Table (Other_Mains.Last) := Source; - end if; - end; - end loop; - - -- If C++ is one of the other language, create the shell script - -- to do the link. - - if C_Plus_Plus_Is_Used then - Choose_C_Plus_Plus_Link_Process; - end if; - - -- Call gnatmake with the necessary switches for each non-Ada - -- main, if there are some. - - for Main in 1 .. Other_Mains.Last loop - declare - Source : constant Other_Source := Other_Mains.Table (Main); - - begin - Last_Argument := 0; - - -- Add -o if -o was specified - - if Output_File_Name = null then - Add_Argument (Dash_o, True); - Add_Argument - (Get_Name_String - (Executable_Of - (Project => Main_Project, - In_Tree => Project_Tree, - Main => Other_Mains.Table (Main).File_Name, - Index => 0, - Ada_Main => False)), - True); - end if; - - -- Call gnatmake with the -B switch - - Add_Argument (Dash_B, True); - - -- Add to the linking options the object file of the source - - Add_Argument (Dash_largs, Verbose_Mode); - Add_Argument - (Get_Name_String (Source.Object_Name), Verbose_Mode); - - -- If C++ is one of the language, add the --LINK switch - -- to the linking switches. - - if C_Plus_Plus_Is_Used then - Add_C_Plus_Plus_Link_For_Gnatmake; - end if; - - -- Add -margs so that the following switches are for - -- gnatmake - - Add_Argument (Dash_margs, Verbose_Mode); - - -- And link with gnatmake - - Compile_Link_With_Gnatmake (Mains_Specified => False); - end; - end loop; - - -- If there are also Ada mains, call gnatmake for all these mains - - if Ada_Mains.Last /= 0 then - Last_Argument := 0; - - -- Put all the Ada mains as the first arguments - - for Main in 1 .. Ada_Mains.Last loop - Add_Argument (Ada_Mains.Table (Main).all, True); - end loop; - - -- If C++ is one of the languages, add the --LINK switch to - -- the linking switches. - - if Data.Langs (C_Plus_Plus_Language_Index) then - Add_Argument (Dash_largs, Verbose_Mode); - Add_C_Plus_Plus_Link_For_Gnatmake; - Add_Argument (Dash_margs, Verbose_Mode); - end if; - - -- And link with gnatmake - - Compile_Link_With_Gnatmake (Mains_Specified => False); - end if; - - else - -- No Ada source in main project - - -- First, get the linker to invoke - - if Data.Langs (C_Plus_Plus_Language_Index) then - Get_Compiler (C_Plus_Plus_Language_Index); - Linker_Name := Compiler_Names (C_Plus_Plus_Language_Index); - Linker_Path := Compiler_Paths (C_Plus_Plus_Language_Index); - - else - Get_Compiler (C_Language_Index); - Linker_Name := Compiler_Names (C_Language_Index); - Linker_Path := Compiler_Paths (C_Language_Index); - end if; - - Link_Done := False; - - Mains.Reset; - - -- Get each main, check if it is a source of the main project, - -- and if it is, invoke the linker. - - loop - declare - Main : constant String := Mains.Next_Main; - Main_Id : File_Name_Type; - - begin - exit when Main'Length = 0; - - -- Get the file name of the main - - Name_Len := 0; - Add_Str_To_Name_Buffer (Main); - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Main_Id := Name_Find; - - -- Check if it is a source of the main project file - - Source_Id := Data.First_Other_Source; - while Source_Id /= No_Other_Source loop - Source := - Project_Tree.Other_Sources.Table (Source_Id); - exit when Source.File_Name = Main_Id; - Source_Id := Source.Next; - end loop; - - -- Report an error if it is not - - if Source_Id = No_Other_Source then - Report_Error - (Main, "is not a source of project ", - Get_Name_String (Data.Name)); - - else - Link_Foreign (Main, Main_Id, Source); - end if; - end; - end loop; - - -- If no linking was done, report it, except in Quiet Output - - if (Verbose_Mode or (not Quiet_Output)) and (not Link_Done) then - Osint.Write_Program_Name; - - if Mains.Number_Of_Mains = 1 then - - -- If there is only one executable, report its name too - - Write_Str (": """); - Mains.Reset; - - declare - Main : constant String := Mains.Next_Main; - Main_Id : File_Name_Type; - begin - Name_Len := 0; - Add_Str_To_Name_Buffer (Main); - Main_Id := Name_Find; - Write_Str - (Get_Name_String - (Executable_Of - (Project => Main_Project, - In_Tree => Project_Tree, - Main => Main_Id, - Index => 0, - Ada_Main => False))); - Write_Line (""" up to date"); - end; - - else - Write_Line (": all executables up to date"); - end if; - end if; - end if; - end if; - end Link_Executables; - - ------------------ - -- Report_Error -- - ------------------ - - procedure Report_Error - (S1 : String; - S2 : String := ""; - S3 : String := "") - is - begin - -- If Keep_Going is True, output error message preceded by error header - - if Keep_Going then - Total_Number_Of_Errors := Total_Number_Of_Errors + 1; - Write_Str (Error_Header); - Write_Str (S1); - Write_Str (S2); - Write_Str (S3); - Write_Eol; - - -- Otherwise just fail - - else - Osint.Fail (S1, S2, S3); - end if; - end Report_Error; - - ------------------------- - -- Report_Total_Errors -- - ------------------------- - - procedure Report_Total_Errors (Kind : String) is - begin - if Total_Number_Of_Errors /= 0 then - if Total_Number_Of_Errors = 1 then - Osint.Fail - ("One ", Kind, " error"); - - else - Osint.Fail - ("Total of" & Total_Number_Of_Errors'Img, - ' ' & Kind & " errors"); - end if; - end if; - end Report_Total_Errors; - - -------------- - -- Scan_Arg -- - -------------- - - procedure Scan_Arg (Arg : String) is - begin - pragma Assert (Arg'First = 1); - - if Arg'Length = 0 then - return; - end if; - - -- If preceding switch was -P, a project file name need to be - -- specified, not a switch. - - if Project_File_Name_Expected then - if Arg (1) = '-' then - Osint.Fail ("project file name missing after -P"); - else - Project_File_Name_Expected := False; - Project_File_Name := new String'(Arg); - end if; - - -- If preceding switch was -o, an executable name need to be - -- specified, not a switch. - - elsif Output_File_Name_Expected then - if Arg (1) = '-' then - Osint.Fail ("output file name missing after -o"); - else - Output_File_Name_Expected := False; - Output_File_Name := new String'(Arg); - end if; - - -- Set the processor/language for the following switches - - -- -cargs: Ada compiler arguments - - elsif Arg = "-cargs" then - Current_Language := Ada_Language_Index; - Current_Processor := Compiler; - - elsif Arg'Length > 7 and then Arg (1 .. 7) = "-cargs:" then - Name_Len := 0; - Add_Str_To_Name_Buffer (Arg (8 .. Arg'Last)); - To_Lower (Name_Buffer (1 .. Name_Len)); - - declare - Lang : constant Name_Id := Name_Find; - begin - Current_Language := Language_Indexes.Get (Lang); - - if Current_Language = No_Language_Index then - Add_Language_Name (Lang); - Current_Language := Last_Language_Index; - end if; - - Current_Processor := Compiler; - end; - - elsif Arg = "-largs" then - Current_Processor := Linker; - - -- -gargs: gprmake - - elsif Arg = "-gargs" then - Current_Processor := None; - - -- A special test is needed for the -o switch within a -largs since - -- that is another way to specify the name of the final executable. - - elsif Current_Processor = Linker and then Arg = "-o" then - Osint.Fail - ("switch -o not allowed within a -largs. Use -o directly."); - - -- If current processor is not gprmake directly, store the option in - -- the appropriate table. - - elsif Current_Processor /= None then - Add_Option (Arg); - - -- Switches start with '-' - - elsif Arg (1) = '-' then - if Arg'Length > 3 and then Arg (1 .. 3) = "-aP" then - Add_Search_Project_Directory (Arg (4 .. Arg'Last)); - - -- Record the switch, so that it is passed to gnatmake, if - -- gnatmake is called. - - Saved_Switches.Append (new String'(Arg)); - - elsif Arg = "-c" then - Compile_Only := True; - - -- Make sure that when a main is specified and switch -c is used, - -- only the main(s) is/are compiled. - - if Mains.Number_Of_Mains > 0 then - Unique_Compile := True; - end if; - - elsif Arg = "-d" then - Display_Compilation_Progress := True; - - elsif Arg = "-eL" then - Follow_Links_For_Files := True; - - elsif Arg = "-f" then - Force_Compilations := True; - - elsif Arg = "-h" then - Usage; - - elsif Arg = "-k" then - Keep_Going := True; - - elsif Arg = "-o" then - if Output_File_Name /= null then - Osint.Fail ("cannot specify several -o switches"); - - else - Output_File_Name_Expected := True; - end if; - - elsif Arg'Length >= 2 and then Arg (2) = 'P' then - if Project_File_Name /= null then - Osint.Fail ("cannot have several project files specified"); - - elsif Arg'Length = 2 then - Project_File_Name_Expected := True; - - else - Project_File_Name := new String'(Arg (3 .. Arg'Last)); - end if; - - elsif Arg = "-p" or else Arg = "--create-missing-dirs" then - Setup_Projects := True; - - elsif Arg = "-q" then - Quiet_Output := True; - - elsif Arg = "-u" then - Unique_Compile := True; - Compile_Only := True; - - elsif Arg = "-v" then - Verbose_Mode := True; - Copyright; - - elsif Arg'Length = 4 and then Arg (1 .. 3) = "-vP" - and then Arg (4) in '0' .. '2' - then - case Arg (4) is - when '0' => - Current_Verbosity := Prj.Default; - when '1' => - Current_Verbosity := Prj.Medium; - when '2' => - Current_Verbosity := Prj.High; - when others => - null; - end case; - - elsif Arg'Length >= 3 and then Arg (2) = 'X' - and then Is_External_Assignment (Arg) - then - -- Is_External_Assignment has side effects when it returns True - - -- Record the -X switch, so that it will be passed to gnatmake, - -- if gnatmake is called. - - Saved_Switches.Append (new String'(Arg)); - - else - Osint.Fail ("illegal option """, Arg, """"); - end if; - - else - -- Not a switch: must be a main - - Mains.Add_Main (Arg); - - -- Make sure that when a main is specified and switch -c is used, - -- only the main(s) is/are compiled. - - if Compile_Only then - Unique_Compile := True; - end if; - end if; - end Scan_Arg; - - ----------------- - -- Strip_CR_LF -- - ----------------- - - function Strip_CR_LF (Text : String) return String is - To : String (1 .. Text'Length); - Index_To : Natural := 0; - - begin - for Index in Text'Range loop - if (Text (Index) /= ASCII.CR) and then (Text (Index) /= ASCII.LF) then - Index_To := Index_To + 1; - To (Index_To) := Text (Index); - end if; - end loop; - - return To (1 .. Index_To); - end Strip_CR_LF; - - ----------- - -- Usage -- - ----------- - - procedure Usage is - begin - if not Usage_Output then - Usage_Output := True; - Copyright; - - Write_Str ("Usage: "); - Osint.Write_Program_Name; - Write_Str (" -P<project file> [opts] [name] {"); - Write_Str ("[-cargs:lang opts] "); - Write_Str ("[-largs opts] [-gargs opts]}"); - Write_Eol; - Write_Eol; - Write_Str (" name is zero or more file names"); - Write_Eol; - Write_Eol; - - -- GPRMAKE switches - - Write_Str ("gprmake switches:"); - Write_Eol; - - -- Line for -aP - - Write_Str (" -aPdir Add directory dir to project search path"); - Write_Eol; - - -- Line for -c - - Write_Str (" -c Compile only"); - Write_Eol; - - -- Line for -eL - - Write_Str (" -eL Follow symbolic links when processing " & - "project files"); - Write_Eol; - - -- Line for -f - - Write_Str (" -f Force recompilations"); - Write_Eol; - - -- Line for -k - - Write_Str (" -k Keep going after compilation errors"); - Write_Eol; - - -- Line for -o - - Write_Str (" -o name Choose an alternate executable name"); - Write_Eol; - - -- Line for -p - - Write_Str (" -p Create missing obj, lib and exec dirs"); - Write_Eol; - - -- Line for -P - - Write_Str (" -Pproj Use GNAT Project File proj"); - Write_Eol; - - -- Line for -q - - Write_Str (" -q Be quiet/terse"); - Write_Eol; - - -- Line for -u - - Write_Str - (" -u Unique compilation. Only compile the given files"); - Write_Eol; - - -- Line for -v - - Write_Str (" -v Verbose output"); - Write_Eol; - - -- Line for -vPx - - Write_Str (" -vPx Specify verbosity when parsing Project Files"); - Write_Eol; - - -- Line for -X - - Write_Str (" -Xnm=val Specify an external reference for " & - "Project Files"); - Write_Eol; - Write_Eol; - - -- Line for -cargs - - Write_Line (" -cargs opts opts are passed to the Ada compiler"); - - -- Line for -cargs:lang - - Write_Line (" -cargs:<lang> opts"); - Write_Line (" opts are passed to the compiler " & - "for language < lang > "); - - -- Line for -largs - - Write_Str (" -largs opts opts are passed to the linker"); - Write_Eol; - - -- Line for -gargs - - Write_Str (" -gargs opts opts directly interpreted by gprmake"); - Write_Eol; - Write_Eol; - - end if; - end Usage; - -begin - Makeutl.Do_Fail := Report_Error'Access; -end Makegpr; diff --git a/gcc/ada/makegpr.ads b/gcc/ada/makegpr.ads deleted file mode 100644 index 026118f6fbc..00000000000 --- a/gcc/ada/makegpr.ads +++ /dev/null @@ -1,34 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M A K E G P R -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- The following package implements the facilities to compile, bind and/or --- link a set of Ada and non Ada sources, specified in Project Files. - -package Makegpr is - - procedure Gprmake; - -- The driver of gprmake - -end Makegpr; diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index 63b975c36f6..1755ade229c 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -442,7 +442,7 @@ package body Makeutl is new String' (Get_Name_String (In_Tree.Projects.Table - (Proj). Directory)); + (Proj).Directory.Name)); end if; while Options /= Nil_String loop @@ -481,8 +481,13 @@ package body Makeutl is package body Mains is + type File_And_Loc is record + File_Name : File_Name_Type; + Location : Source_Ptr := No_Location; + end record; + package Names is new Table.Table - (Table_Component_Type => File_Name_Type, + (Table_Component_Type => File_And_Loc, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => 10, @@ -502,7 +507,7 @@ package body Makeutl is Name_Len := 0; Add_Str_To_Name_Buffer (Name); Names.Increment_Last; - Names.Table (Names.Last) := Name_Find; + Names.Table (Names.Last) := (Name_Find, No_Location); end Add_Main; ------------ @@ -515,6 +520,19 @@ package body Makeutl is Mains.Reset; end Delete; + ------------------ + -- Get_Location -- + ------------------ + + function Get_Location return Source_Ptr is + begin + if Current in Names.First .. Names.Last then + return Names.Table (Current).Location; + else + return No_Location; + end if; + end Get_Location; + --------------- -- Next_Main -- --------------- @@ -523,10 +541,9 @@ package body Makeutl is begin if Current >= Names.Last then return ""; - else Current := Current + 1; - return Get_Name_String (Names.Table (Current)); + return Get_Name_String (Names.Table (Current).File_Name); end if; end Next_Main; @@ -548,6 +565,29 @@ package body Makeutl is Current := 0; end Reset; + ------------------ + -- Set_Location -- + ------------------ + + procedure Set_Location (Location : Source_Ptr) is + begin + if Names.Last > 0 then + Names.Table (Names.Last).Location := Location; + end if; + end Set_Location; + + ----------------- + -- Update_Main -- + ----------------- + + procedure Update_Main (Name : String) is + begin + if Current in Names.First .. Names.Last then + Name_Len := 0; + Add_Str_To_Name_Buffer (Name); + Names.Table (Current).File_Name := Name_Find; + end if; + end Update_Main; end Mains; ---------- diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index 9672744a1ac..b6483f3e520 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -103,6 +103,10 @@ package Makeutl is procedure Add_Main (Name : String); -- Add one main to the table + procedure Set_Location (Location : Source_Ptr); + -- Set the location of the last main added. By default, the location is + -- No_Location. + procedure Delete; -- Empty the table @@ -113,6 +117,12 @@ package Makeutl is -- Increase the index and return the next main. -- If table is exhausted, return an empty string. + function Get_Location return Source_Ptr; + -- Get the location of the current main + + procedure Update_Main (Name : String); + -- Update the file name of the current main + function Number_Of_Mains return Natural; -- Returns the number of mains added with Add_Main since the last call -- to Delete. diff --git a/gcc/ada/mingw32.h b/gcc/ada/mingw32.h index 8018e14986c..e8d95558d0d 100644 --- a/gcc/ada/mingw32.h +++ b/gcc/ada/mingw32.h @@ -93,10 +93,16 @@ version instead of the previous enhanced version to ease building GNAT on Windows platforms. By using STD_MINGW or OLD_MINGW it is possible to build GNAT using both MingW include files (Old MingW + ACT changes and standard - MingW starting with version 1.3. */ + MingW starting with version 1.3. + For w64 Mingw the define STD_MINGW is always set to value 1, because + there is no old header set present. */ +#ifdef _WIN64 +#define STD_MINGW 1 +#else #define STD_MINGW ((__MINGW32_MAJOR_VERSION == 1 \ && __MINGW32_MINOR_VERSION >= 3) \ || (__MINGW32_MAJOR_VERSION >= 2)) +#endif #define OLD_MINGW (!(STD_MINGW)) diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index 193b54ca408..7e86facd99d 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -322,7 +322,8 @@ package body MLib.Prj is -- g-trasym.obj. Object_Directory_Path : constant String := - Get_Name_String (Data.Display_Object_Dir); + Get_Name_String + (Data.Object_Directory.Display_Name); Standalone : constant Boolean := Data.Standalone_Library; @@ -713,14 +714,15 @@ package body MLib.Prj is if Libgnarl_Needed = Unknown then if Data.Libgnarl_Needed = Unknown - and then Data.Object_Directory /= No_Path + and then Data.Object_Directory /= No_Path_Information then -- Check if libgnarl is needed for this library declare Object_Dir_Path : constant String := Get_Name_String - (Data.Display_Object_Dir); + (Data.Object_Directory. + Display_Name); Object_Dir : Dir_Type; Filename : String (1 .. 255); Last : Natural; @@ -799,7 +801,7 @@ package body MLib.Prj is Current := Library_Projs.Table (Index); Get_Name_String - (In_Tree.Projects.Table (Current).Display_Library_Dir); + (In_Tree.Projects.Table (Current).Library_Dir.Display_Name); Opts.Increment_Last; Opts.Table (Opts.Last) := new String'("-L" & Name_Buffer (1 .. Name_Len)); @@ -966,7 +968,7 @@ package body MLib.Prj is Unit := In_Tree.Units.Table (Source); if Unit.File_Names (Body_Part).Name /= No_File - and then Unit.File_Names (Body_Part).Path /= Slash + and then Unit.File_Names (Body_Part).Path.Name /= Slash then if Check_Project (Unit.File_Names (Body_Part).Project) @@ -979,7 +981,7 @@ package body MLib.Prj is Src_Ind := Sinput.P.Load_Project_File (Get_Name_String (Unit.File_Names - (Body_Part).Path)); + (Body_Part).Path.Name)); -- Add the ALI file only if it is not a subunit @@ -999,7 +1001,7 @@ package body MLib.Prj is end if; elsif Unit.File_Names (Specification).Name /= No_File - and then Unit.File_Names (Specification).Path /= Slash + and then Unit.File_Names (Specification).Path.Name /= Slash and then Check_Project (Unit.File_Names (Specification).Project) then @@ -1318,7 +1320,7 @@ package body MLib.Prj is end if; Lib_Dirpath := - new String'(Get_Name_String (Data.Display_Library_Dir)); + new String'(Get_Name_String (Data.Library_Dir.Display_Name)); Lib_Filename := new String'(Get_Name_String (Data.Library_Name)); case Data.Library_Kind is @@ -1355,176 +1357,187 @@ package body MLib.Prj is There_Are_Foreign_Sources := Data.Other_Sources_Present; loop - declare - Object_Dir_Path : constant String := - Get_Name_String (Data.Display_Object_Dir); - Object_Dir : Dir_Type; - Filename : String (1 .. 255); - Last : Natural; - Id : Name_Id; + if Data.Object_Directory /= No_Path_Information then + declare + Object_Dir_Path : constant String := + Get_Name_String + (Data.Object_Directory.Display_Name); + Object_Dir : Dir_Type; + Filename : String (1 .. 255); + Last : Natural; + Id : Name_Id; - begin - Open (Dir => Object_Dir, Dir_Name => Object_Dir_Path); + begin + Open (Dir => Object_Dir, Dir_Name => Object_Dir_Path); - -- For all entries in the object directory + -- For all entries in the object directory - loop - Read (Object_Dir, Filename, Last); + loop + Read (Object_Dir, Filename, Last); - exit when Last = 0; + exit when Last = 0; - -- Check if it is an object file + -- Check if it is an object file - if Is_Obj (Filename (1 .. Last)) then - declare - Object_Path : constant String := - Normalize_Pathname - (Object_Dir_Path & Directory_Separator & - Filename (1 .. Last)); - C_Object_Path : String := Object_Path; - C_Filename : String := Filename (1 .. Last); + if Is_Obj (Filename (1 .. Last)) then + declare + Object_Path : constant String := + Normalize_Pathname + (Object_Dir_Path & + Directory_Separator & + Filename (1 .. Last)); + C_Object_Path : String := Object_Path; + C_Filename : String := Filename (1 .. Last); - begin - Canonical_Case_File_Name (C_Object_Path); - Canonical_Case_File_Name (C_Filename); + begin + Canonical_Case_File_Name (C_Object_Path); + Canonical_Case_File_Name (C_Filename); - -- If in the object directory of an extended project, - -- do not consider generated object files. + -- If in the object directory of an extended + -- project, do not consider generated object files. - if In_Main_Object_Directory - or else Last < 5 - or else C_Filename (1 .. B_Start'Length) /= - B_Start.all - then - Name_Len := Last; - Name_Buffer (1 .. Name_Len) := - C_Filename (1 .. Last); - Id := Name_Find; - - if not Objects_Htable.Get (Id) then - declare - ALI_File : constant String := - Ext_To - (C_Filename - (1 .. Last), "ali"); - ALI_Path : constant String := - Ext_To (C_Object_Path, "ali"); - Add_It : Boolean := - There_Are_Foreign_Sources - or else - (Last > 5 + if In_Main_Object_Directory + or else Last < 5 + or else + C_Filename (1 .. B_Start'Length) /= B_Start.all + then + Name_Len := Last; + Name_Buffer (1 .. Name_Len) := + C_Filename (1 .. Last); + Id := Name_Find; + + if not Objects_Htable.Get (Id) then + declare + ALI_File : constant String := + Ext_To + (C_Filename + (1 .. Last), "ali"); + ALI_Path : constant String := + Ext_To (C_Object_Path, "ali"); + Add_It : Boolean := + There_Are_Foreign_Sources + or else + (Last > 5 and then - C_Filename - (1 .. B_Start'Length) = - B_Start.all); - Fname : File_Name_Type; - Proj : Project_Id; - - begin - if Is_Regular_File (ALI_Path) then - - -- If there is an ALI file, check if the - -- object file should be added to the - -- library. If there are foreign sources - -- we put all object files in the library. - - if not Add_It then - for Index in - 1 .. Unit_Table.Last (In_Tree.Units) - loop - if In_Tree.Units.Table - (Index).File_Names - (Body_Part).Name /= No_File - then - Proj := - In_Tree.Units.Table (Index). - File_Names - (Body_Part).Project; - Fname := - In_Tree.Units.Table (Index). - File_Names (Body_Part).Name; - - elsif - In_Tree.Units.Table - (Index).File_Names - (Specification).Name /= No_File - then - Proj := - In_Tree.Units.Table + C_Filename + (1 .. B_Start'Length) = + B_Start.all); + Fname : File_Name_Type; + Proj : Project_Id; + + begin + if Is_Regular_File (ALI_Path) then + + -- If there is an ALI file, check if + -- the object file should be added to + -- the library. If there are foreign + -- sources we put all object files in + -- the library. + + if not Add_It then + for Index in + 1 .. Unit_Table.Last + (In_Tree.Units) + loop + if In_Tree.Units.Table (Index).File_Names - (Specification).Project; - Fname := + (Body_Part).Name /= No_File + then + Proj := + In_Tree.Units.Table (Index). + File_Names + (Body_Part).Project; + Fname := + In_Tree.Units.Table (Index). + File_Names (Body_Part).Name; + + elsif In_Tree.Units.Table (Index).File_Names - (Specification).Name; - - else - Proj := No_Project; - end if; - - Add_It := Proj /= No_Project; - - -- If the source is in the project - -- or a project it extends, we may - -- put it in the library. - - if Add_It then - Add_It := Check_Project (Proj); - end if; - - -- But we don't, if the ALI file - -- does not correspond to the unit. - - if Add_It then - declare - F : constant String := - Ext_To - (Get_Name_String - (Fname), "ali"); - begin - Add_It := F = ALI_File; - end; - end if; - - exit when Add_It; - end loop; - end if; + (Specification).Name /= + No_File + then + Proj := + In_Tree.Units.Table + (Index).File_Names + (Specification).Project; + Fname := + In_Tree.Units.Table + (Index).File_Names + (Specification).Name; + + else + Proj := No_Project; + end if; + + Add_It := Proj /= No_Project; + + -- If the source is in the + -- project or a project it + -- extends, we may put it in + -- the library. + + if Add_It then + Add_It := Check_Project (Proj); + end if; + + -- But we don't, if the ALI file + -- does not correspond to the + -- unit. + + if Add_It then + declare + F : constant String := + Ext_To + (Get_Name_String + (Fname), "ali"); + begin + Add_It := F = ALI_File; + end; + end if; + + exit when Add_It; + end loop; + end if; - if Add_It then - Objects_Htable.Set (Id, True); - Objects.Append - (new String'(Object_Path)); + if Add_It then + Objects_Htable.Set (Id, True); + Objects.Append + (new String'(Object_Path)); - -- Record the ALI file + -- Record the ALI file - ALIs.Append (new String'(ALI_Path)); + ALIs.Append (new String'(ALI_Path)); - -- Find out if for this ALI file, - -- libgnarl or libdecgnat or - -- g-trasym.obj (on OpenVMS) is - -- necessary. + -- Find out if for this ALI file, + -- libgnarl or libdecgnat or + -- g-trasym.obj (on OpenVMS) is + -- necessary. - Check_Libs (ALI_Path, True); - end if; + Check_Libs (ALI_Path, True); + end if; - elsif There_Are_Foreign_Sources then - Objects.Append (new String'(Object_Path)); - end if; - end; + elsif There_Are_Foreign_Sources then + Objects.Append + (new String'(Object_Path)); + end if; + end; + end if; end if; - end if; - end; - end if; - end loop; + end; + end if; + end loop; - Close (Dir => Object_Dir); + Close (Dir => Object_Dir); - exception - when Directory_Error => - Com.Fail ("cannot find object directory """, - Get_Name_String (Data.Object_Directory), - """"); - end; + exception + when Directory_Error => + Com.Fail ("cannot find object directory """, + Get_Name_String + (Data.Object_Directory.Display_Name), + """"); + end; + end if; exit when Data.Extends = No_Project; @@ -1798,7 +1811,7 @@ package body MLib.Prj is begin Get_Name_String - (In_Tree.Projects.Table (For_Project).Library_Dir); + (In_Tree.Projects.Table (For_Project).Library_Dir.Name); Change_Dir (Name_Buffer (1 .. Name_Len)); exception @@ -1938,21 +1951,22 @@ package body MLib.Prj is Copy_ALI_Files (Files => Ali_Files.all, - To => In_Tree.Projects.Table (For_Project).Library_ALI_Dir, + To => In_Tree.Projects.Table + (For_Project).Library_ALI_Dir.Name, Interfaces => Arguments (1 .. Argument_Number)); -- Copy interface sources if Library_Src_Dir specified if Standalone and then In_Tree.Projects.Table - (For_Project).Library_Src_Dir /= No_Path + (For_Project).Library_Src_Dir /= No_Path_Information then -- Clean the interface copy directory: remove any source that -- could be a source of the project. begin Get_Name_String - (In_Tree.Projects.Table (For_Project).Library_Src_Dir); + (In_Tree.Projects.Table (For_Project).Library_Src_Dir.Name); Change_Dir (Name_Buffer (1 .. Name_Len)); exception @@ -2030,7 +2044,7 @@ package body MLib.Prj is In_Tree => In_Tree, Interfaces => Arguments (1 .. Argument_Number), To_Dir => In_Tree.Projects.Table - (For_Project).Display_Library_Src_Dir); + (For_Project).Library_Src_Dir.Display_Name); end if; end if; @@ -2084,14 +2098,14 @@ package body MLib.Prj is Lib_Name : constant File_Name_Type := Library_File_Name_For (For_Project, In_Tree); begin - Change_Dir (Get_Name_String (Data.Library_Dir)); + Change_Dir (Get_Name_String (Data.Library_Dir.Name)); Lib_TS := File_Stamp (Lib_Name); In_Tree.Projects.Table (For_Project).Library_TS := Lib_TS; end; if not Data.Externally_Built and then not Data.Need_To_Build_Lib - and then Data.Object_Directory /= No_Path + and then Data.Object_Directory /= No_Path_Information then declare Obj_TS : Time_Stamp_Type; @@ -2105,7 +2119,7 @@ package body MLib.Prj is -- If the library file does not exist, then the time stamp will -- be Empty_Time_Stamp, earlier than any other time stamp. - Change_Dir (Get_Name_String (Data.Object_Directory)); + Change_Dir (Get_Name_String (Data.Object_Directory.Name)); Open (Dir => Object_Dir, Dir_Name => "."); -- For all entries in the object directory @@ -2209,7 +2223,7 @@ package body MLib.Prj is and then Data.File_Names (J).Name = File_Name then Copy_File - (Get_Name_String (Data.File_Names (J).Path), + (Get_Name_String (Data.File_Names (J).Path.Name), Target, Success, Mode => Overwrite, @@ -2250,8 +2264,7 @@ package body MLib.Prj is Change_Dir (Get_Name_String - (In_Tree.Projects.Table - (For_Project).Object_Directory)); + (In_Tree.Projects.Table (For_Project).Object_Directory.Name)); for Index in Interfaces'Range loop diff --git a/gcc/ada/mlib-tgt.adb b/gcc/ada/mlib-tgt.adb index e4d0441d55a..b2c7c952ede 100644 --- a/gcc/ada/mlib-tgt.adb +++ b/gcc/ada/mlib-tgt.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- -- @@ -340,7 +340,7 @@ package body MLib.Tgt is declare Lib_Dir : constant String := Get_Name_String - (In_Tree.Projects.Table (Project).Library_Dir); + (In_Tree.Projects.Table (Project).Library_Dir.Name); Lib_Name : constant String := Get_Name_String (In_Tree.Projects.Table (Project).Library_Name); diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index f2aed1ea03f..d98588b76f3 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -173,9 +173,8 @@ package Osint is (Wildcard_Host_File : String; Only_Dirs : Boolean) return String_Access_List_Access; -- Expand a wildcard host syntax file or directory specification (e.g. on - -- a VMS host, any file or directory spec that contains: - -- "*", or "%", or "...") - -- and return a list of valid Unix syntax file or directory specs. + -- a VMS host, any file or directory spec that contains: "*", or "%", or + -- "...") and return a list of valid Unix syntax file or directory specs. -- If Only_Dirs is True, then only return directories. function To_Canonical_Dir_Spec @@ -369,10 +368,10 @@ package Osint is -- without any directory information. The implementation is responsible -- for searching for the file in the appropriate directories. -- - -- Note the special case that if the file name is gnat.adc, then the - -- search for the file is done ONLY in the directory corresponding to - -- the current compilation environment, i.e. in the same directory - -- where the ali and object files will be written. + -- Note the special case that if the file name is gnat.adc, then the search + -- for the file is done ONLY in the directory corresponding to the current + -- compilation environment, i.e. in the same directory where the ali and + -- object files will be written. function Full_Source_Name return File_Name_Type; function Current_Source_File_Stamp return Time_Stamp_Type; @@ -508,14 +507,15 @@ package Osint is (Source_File : File_Name_Type; Munit_Index : Nat := 0) return File_Name_Type; -- Given the name of a source file, returns the name of the corresponding - -- library information file. This may be the name of the object file, or - -- of a separate file used to store the library information. In either case - -- the returned result is suitable for use in a call to Read_Library_Info. - -- The Munit_Index is the unit index in multiple unit per file mode, or - -- zero in normal single unit per file mode (used to add ~nnn suffix). - -- Note: this subprogram is in this section because it is used by the - -- compiler to determine the proper library information names to be placed - -- in the generated library information file. + -- library information file. This may be the name of the object file or of + -- a separate file used to store the library information. In the current + -- implementation, a separate file (the ALI file) is always used. In either + -- case the returned result is suitable for calling Read_Library_Info. The + -- Munit_Index is the unit index in multiple unit per file mode, or zero in + -- normal single unit per file mode (used to add ~nnn suffix). Note: this + -- subprogram is in this section because it is used by the compiler to + -- determine the proper library information names to be placed in the + -- generated library information file. ----------------- -- Termination -- diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index e2b1fbc936b..6f6c888b4e6 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -231,6 +231,7 @@ package body Prj.Attr is "Ladefault_switches#" & "Lcswitches#" & "LVlinker_options#" & + "SVmap_file_option#" & -- Configuration - Linking diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index bbc45c57d3c..dd52f353287 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.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- -- @@ -251,7 +251,7 @@ package body Prj.Env is if (Data.Library and then Including_Libraries) or else - (Data.Object_Directory /= No_Path + (Data.Object_Directory /= No_Path_Information and then (not Including_Libraries or else not Data.Library)) then @@ -260,19 +260,22 @@ package body Prj.Env is -- files; otherwise add the object directory. if Data.Library then - if Data.Object_Directory = No_Path + if Data.Object_Directory = No_Path_Information or else - Contains_ALI_Files (Data.Library_ALI_Dir) + Contains_ALI_Files (Data.Library_ALI_Dir.Name) then - Add_To_Path (Get_Name_String (Data.Library_ALI_Dir)); + Add_To_Path + (Get_Name_String (Data.Library_ALI_Dir.Name)); else - Add_To_Path (Get_Name_String (Data.Object_Directory)); + Add_To_Path + (Get_Name_String (Data.Object_Directory.Name)); end if; else -- For a non library project, add the object directory - Add_To_Path (Get_Name_String (Data.Object_Directory)); + Add_To_Path + (Get_Name_String (Data.Object_Directory.Name)); end if; end if; @@ -520,7 +523,7 @@ package body Prj.Env is -- If we don't know the path name of the body of this unit, -- we compute it, and we store it. - if Data.File_Names (Body_Part).Path = No_Path then + if Data.File_Names (Body_Part).Path = No_Path_Information then declare Current_Source : String_List_Id := In_Tree.Projects.Table @@ -530,7 +533,7 @@ package body Prj.Env is begin -- By default, put the file name - Data.File_Names (Body_Part).Path := + Data.File_Names (Body_Part).Path.Name := Path_Name_Type (Data.File_Names (Body_Part).Name); -- For each source directory @@ -550,7 +553,7 @@ package body Prj.Env is if Path /= null then Name_Len := Path'Length; Name_Buffer (1 .. Name_Len) := Path.all; - Data.File_Names (Body_Part).Path := Name_Enter; + Data.File_Names (Body_Part).Path.Name := Name_Enter; exit; else @@ -566,7 +569,7 @@ package body Prj.Env is -- Returned the stored value - return Namet.Get_Name_String (Data.File_Names (Body_Part).Path); + return Namet.Get_Name_String (Data.File_Names (Body_Part).Path.Name); end Body_Path_Name_Of; ------------------------ @@ -1005,13 +1008,13 @@ package body Prj.Env is -- If there is a spec, put it in the mapping if Data.Name /= No_File then - if Data.Path = Slash then + if Data.Path.Name = Slash then Fmap.Add_Forbidden_File_Name (Data.Name); else Fmap.Add_To_File_Map (Unit_Name => Unit_Name_Type (The_Unit_Data.Name), File_Name => Data.Name, - Path_Name => File_Name_Type (Data.Path)); + Path_Name => File_Name_Type (Data.Path.Name)); end if; end if; @@ -1020,13 +1023,13 @@ package body Prj.Env is -- If there is a body (or subunit) put it in the mapping if Data.Name /= No_File then - if Data.Path = Slash then + if Data.Path.Name = Slash then Fmap.Add_Forbidden_File_Name (Data.Name); else Fmap.Add_To_File_Map (Unit_Name => Unit_Name_Type (The_Unit_Data.Name), File_Name => Data.Name, - Path_Name => File_Name_Type (Data.Path)); + Path_Name => File_Name_Type (Data.Path.Name)); end if; end if; end if; @@ -1111,7 +1114,7 @@ package body Prj.Env is -- Line with the path name - Get_Name_String (Data.Path); + Get_Name_String (Data.Path.Name); Put_Name_Buffer; end Put_Data; @@ -1334,7 +1337,7 @@ package body Prj.Env is if Src_Data.Language_Name = Language and then not Src_Data.Locally_Removed and then Src_Data.Replaced_By = No_Source - and then Src_Data.Path /= No_Path + and then Src_Data.Path.Name /= No_Path then if Src_Data.Unit /= No_Name then Get_Name_String (Src_Data.Unit); @@ -1359,7 +1362,7 @@ package body Prj.Env is Get_Name_String (Src_Data.File); Put_Name_Buffer; - Get_Name_String (Src_Data.Path); + Get_Name_String (Src_Data.Path.Name); Put_Name_Buffer; end if; @@ -1542,7 +1545,7 @@ package body Prj.Env is if Full_Path then return Get_Name_String - (Unit.File_Names (Body_Part).Path); + (Unit.File_Names (Body_Part).Path.Name); else return Get_Name_String (Current_Name); @@ -1558,7 +1561,7 @@ package body Prj.Env is if Full_Path then return Get_Name_String - (Unit.File_Names (Body_Part).Path); + (Unit.File_Names (Body_Part).Path.Name); else return Extended_Body_Name; @@ -1605,7 +1608,7 @@ package body Prj.Env is if Full_Path then return Get_Name_String - (Unit.File_Names (Specification).Path); + (Unit.File_Names (Specification).Path.Name); else return Get_Name_String (Current_Name); end if; @@ -1620,7 +1623,7 @@ package body Prj.Env is if Full_Path then return Get_Name_String - (Unit.File_Names (Specification).Path); + (Unit.File_Names (Specification).Path.Name); else return Extended_Spec_Name; end if; @@ -1723,8 +1726,8 @@ package body Prj.Env is -- If there is an object directory, call Action with its name - if Data.Object_Directory /= No_Path then - Get_Name_String (Data.Display_Object_Dir); + if Data.Object_Directory /= No_Path_Information then + Get_Name_String (Data.Object_Directory.Display_Name); Action (Name_Buffer (1 .. Name_Len)); end if; @@ -1899,16 +1902,17 @@ package body Prj.Env is and then Namet.Get_Name_String (Unit.File_Names (Specification).Name) = Original_Name) - or else (Unit.File_Names (Specification).Path /= No_Path + or else (Unit.File_Names (Specification).Path /= + No_Path_Information and then Namet.Get_Name_String - (Unit.File_Names (Specification).Path) = + (Unit.File_Names (Specification).Path.Name) = Original_Name) then Project := Ultimate_Extension_Of (Project => Unit.File_Names (Specification).Project, In_Tree => In_Tree); - Path := Unit.File_Names (Specification).Display_Path; + Path := Unit.File_Names (Specification).Path.Display_Name; if Current_Verbosity > Default then Write_Str ("Done: Specification."); @@ -1921,15 +1925,15 @@ package body Prj.Env is and then Namet.Get_Name_String (Unit.File_Names (Body_Part).Name) = Original_Name) - or else (Unit.File_Names (Body_Part).Path /= No_Path + or else (Unit.File_Names (Body_Part).Path /= No_Path_Information and then Namet.Get_Name_String - (Unit.File_Names (Body_Part).Path) = + (Unit.File_Names (Body_Part).Path.Name) = Original_Name) then Project := Ultimate_Extension_Of (Project => Unit.File_Names (Body_Part).Project, In_Tree => In_Tree); - Path := Unit.File_Names (Body_Part).Display_Path; + Path := Unit.File_Names (Body_Part).Path.Display_Name; if Current_Verbosity > Default then Write_Str ("Done: Body."); @@ -2121,7 +2125,7 @@ package body Prj.Env is Write_Str (" Project: "); Get_Name_String (In_Tree.Projects.Table - (Unit.File_Names (Specification).Project).Path_Name); + (Unit.File_Names (Specification).Project).Path.Name); Write_Line (Name_Buffer (1 .. Name_Len)); end if; @@ -2139,7 +2143,7 @@ package body Prj.Env is Write_Str (" Project: "); Get_Name_String (In_Tree.Projects.Table - (Unit.File_Names (Body_Part).Project).Path_Name); + (Unit.File_Names (Body_Part).Project).Path.Name); Write_Line (Name_Buffer (1 .. Name_Len)); end if; @@ -2328,7 +2332,7 @@ package body Prj.Env is if (Data.Library and Including_Libraries) or else - (Data.Object_Directory /= No_Path + (Data.Object_Directory /= No_Path_Information and then (not Including_Libraries or else not Data.Library)) then @@ -2338,14 +2342,15 @@ package body Prj.Env is -- otherwise add the object directory. if Data.Library then - if Data.Object_Directory = No_Path - or else Contains_ALI_Files (Data.Library_ALI_Dir) + if Data.Object_Directory = No_Path_Information + or else Contains_ALI_Files + (Data.Library_ALI_Dir.Name) then Add_To_Object_Path - (Data.Library_ALI_Dir, In_Tree); + (Data.Library_ALI_Dir.Name, In_Tree); else Add_To_Object_Path - (Data.Object_Directory, In_Tree); + (Data.Object_Directory.Name, In_Tree); end if; -- For a non-library project, add the object @@ -2359,7 +2364,7 @@ package body Prj.Env is and then There_Are_Ada_Sources (In_Tree, Project) then Add_To_Object_Path - (Data.Object_Directory, In_Tree); + (Data.Object_Directory.Name, In_Tree); end if; end if; end if; @@ -2566,7 +2571,7 @@ package body Prj.Env is Data : Unit_Data := In_Tree.Units.Table (Unit); begin - if Data.File_Names (Specification).Path = No_Path then + if Data.File_Names (Specification).Path.Name = No_Path then declare Current_Source : String_List_Id := In_Tree.Projects.Table @@ -2574,7 +2579,7 @@ package body Prj.Env is Path : GNAT.OS_Lib.String_Access; begin - Data.File_Names (Specification).Path := + Data.File_Names (Specification).Path.Name := Path_Name_Type (Data.File_Names (Specification).Name); while Current_Source /= Nil_String loop @@ -2588,7 +2593,7 @@ package body Prj.Env is if Path /= null then Name_Len := Path'Length; Name_Buffer (1 .. Name_Len) := Path.all; - Data.File_Names (Specification).Path := Name_Enter; + Data.File_Names (Specification).Path.Name := Name_Enter; exit; else Current_Source := @@ -2601,7 +2606,7 @@ package body Prj.Env is end; end if; - return Namet.Get_Name_String (Data.File_Names (Specification).Path); + return Namet.Get_Name_String (Data.File_Names (Specification).Path.Name); end Spec_Path_Name_Of; --------------------------- diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads index 83da472229f..39e369256a8 100644 --- a/gcc/ada/prj-env.ads +++ b/gcc/ada/prj-env.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- -- @@ -85,14 +85,14 @@ package Prj.Env is function Ada_Include_Path (Project : Project_Id; In_Tree : Project_Tree_Ref) return String_Access; - -- Get the ADA_INCLUDE_PATH of a Project file. For the first call, compute - -- it and cache it. + -- Get the source search path of a Project file. For the first call, + -- compute it and cache it. function Ada_Include_Path (Project : Project_Id; In_Tree : Project_Tree_Ref; Recursive : Boolean) return String; - -- Get the ADA_INCLUDE_PATH of a Project file. If Recursive it True, + -- Get the source search path of a Project file. If Recursive it True, -- get all the source directories of the imported and modified project -- files (recursively). If Recursive is False, just get the path for the -- source directories of Project. Note: the resulting String may be empty diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index a2fb600653d..d84ba7fbbf7 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -162,6 +162,16 @@ package body Prj.Nmsc is -- A hash table to store naming exceptions for Ada. For each file name -- there is one or several unit in table Ada_Naming_Exception_Table. + package Object_File_Names is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => File_Name_Type, + No_Element => No_File, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + -- A hash table to store the object file names for a project, to check that + -- two different sources have different object file names. + type File_Found is record File : File_Name_Type := No_File; Found : Boolean := False; @@ -678,7 +688,7 @@ package body Prj.Nmsc is (Lang_Id).Config.Dependency_Kind; Src_Data.Naming_Exception := Naming_Exception; - if Src_Data.Compiled then + if Src_Data.Compiled and then Src_Data.Object_Exists then Src_Data.Object := Object_Name (File_Name); Src_Data.Dep_Name := Dependency_Name (File_Name, Src_Data.Dependency); @@ -686,8 +696,7 @@ package body Prj.Nmsc is end if; if Path /= No_Path then - Src_Data.Path := Path; - Src_Data.Display_Path := Display_Path; + Src_Data.Path := (Path, Display_Path); Source_Paths_Htable.Set (In_Tree.Source_Paths_HT, Path, Id); end if; @@ -1831,9 +1840,7 @@ package body Prj.Nmsc is Data.Config.Linker := Path_Name_Type (Attribute.Value.Value); - elsif - Attribute.Name = Name_Required_Switches - then + elsif Attribute.Name = Name_Required_Switches then -- Attribute Required_Switches: the minimum -- options to use when invoking the linker @@ -1843,6 +1850,8 @@ package body Prj.Nmsc is From_List => Attribute.Value.Values, In_Tree => In_Tree); + elsif Attribute.Name = Name_Map_File_Option then + Data.Config.Map_File_Option := Attribute.Value.Value; end if; end if; @@ -1996,6 +2005,10 @@ package body Prj.Nmsc is From_List => List, In_Tree => In_Tree); + elsif Attribute.Name = Name_Library_GCC then + Data.Config.Shared_Lib_Driver := + File_Name_Type (Attribute.Value.Value); + elsif Attribute.Name = Name_Archive_Suffix then Data.Config.Archive_Suffix := File_Name_Type (Attribute.Value.Value); @@ -2551,7 +2564,7 @@ package body Prj.Nmsc is -- Compute the object path name - Get_Name_String (Data.Display_Object_Dir); + Get_Name_String (Data.Object_Directory.Display_Name); if Name_Buffer (Name_Len) /= Directory_Separator and then Name_Buffer (Name_Len) /= '/' @@ -2574,7 +2587,7 @@ package body Prj.Nmsc is -- Compute the dependency path name - Get_Name_String (Data.Display_Object_Dir); + Get_Name_String (Data.Object_Directory.Display_Name); if Name_Buffer (Name_Len) /= Directory_Separator and then Name_Buffer (Name_Len) /= '/' @@ -2844,7 +2857,7 @@ package body Prj.Nmsc is if Current_Verbosity = High then Write_Str (" interface: "); - Write_Line (Get_Name_String (Src_Data.Path)); + Write_Line (Get_Name_String (Src_Data.Path.Name)); end if; end if; @@ -3847,13 +3860,15 @@ package body Prj.Nmsc is Error_Msg_Name_2 := Proj_Data.Name; if Extends then - Error_Msg - (Project, In_Tree, - Continuation.all & - "library project %% cannot extend project %% " & - "that is not a library project", - Data.Location); - Continuation := Continuation_String'Access; + if Data.Library_Kind /= Static then + Error_Msg + (Project, In_Tree, + Continuation.all & + "shared library project %% cannot extend " & + "project %% that is not a library project", + Data.Location); + Continuation := Continuation_String'Access; + end if; elsif Data.Library_Kind /= Static then Error_Msg @@ -3936,8 +3951,6 @@ package body Prj.Nmsc is -- inherit library directory. Data.Library_Dir := Extended_Data.Library_Dir; - Data.Display_Library_Dir := - Extended_Data.Display_Library_Dir; Library_Directory_Present := True; end if; end if; @@ -3978,20 +3991,20 @@ package body Prj.Nmsc is else -- Find path name (unless inherited), check that it is a directory - if Data.Library_Dir = No_Path then + if Data.Library_Dir = No_Path_Information then Locate_Directory (Project, In_Tree, File_Name_Type (Lib_Dir.Value), - Data.Display_Directory, - Data.Library_Dir, - Data.Display_Library_Dir, + Data.Directory.Display_Name, + Data.Library_Dir.Name, + Data.Library_Dir.Display_Name, Create => "library", Current_Dir => Current_Dir, Location => Lib_Dir.Location); end if; - if Data.Library_Dir = No_Path then + if Data.Library_Dir = No_Path_Information then -- Get the absolute name of the library directory that -- does not exist, to report an error. @@ -4006,7 +4019,7 @@ package body Prj.Nmsc is File_Name_Type (Lib_Dir.Value); else - Get_Name_String (Data.Display_Directory); + Get_Name_String (Data.Directory.Display_Name); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; @@ -4031,14 +4044,13 @@ package body Prj.Nmsc is -- The library directory cannot be the same as the Object -- directory. - elsif Data.Library_Dir = Data.Object_Directory then + elsif Data.Library_Dir.Name = Data.Object_Directory.Name then Error_Msg (Project, In_Tree, "library directory cannot be the same " & "as object directory", Lib_Dir.Location); - Data.Library_Dir := No_Path; - Data.Display_Library_Dir := No_Path; + Data.Library_Dir := No_Path_Information; else declare @@ -4055,7 +4067,9 @@ package body Prj.Nmsc is Dir_Elem := In_Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; - if Data.Library_Dir = Path_Name_Type (Dir_Elem.Value) then + if + Data.Library_Dir.Name = Path_Name_Type (Dir_Elem.Value) + then Err_Vars.Error_Msg_File_1 := File_Name_Type (Dir_Elem.Value); Error_Msg @@ -4083,7 +4097,7 @@ package body Prj.Nmsc is In_Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; - if Data.Library_Dir = + if Data.Library_Dir.Name = Path_Name_Type (Dir_Elem.Value) then Err_Vars.Error_Msg_File_1 := @@ -4105,15 +4119,15 @@ package body Prj.Nmsc is end if; if not OK then - Data.Library_Dir := No_Path; - Data.Display_Library_Dir := No_Path; + Data.Library_Dir := No_Path_Information; elsif Current_Verbosity = High then -- Display the Library directory in high verbosity Write_Str ("Library directory ="""); - Write_Str (Get_Name_String (Data.Display_Library_Dir)); + Write_Str + (Get_Name_String (Data.Library_Dir.Display_Name)); Write_Line (""""); end if; end; @@ -4123,7 +4137,7 @@ package body Prj.Nmsc is end if; Data.Library := - Data.Library_Dir /= No_Path + Data.Library_Dir /= No_Path_Information and then Data.Library_Name /= No_Name; @@ -4172,7 +4186,6 @@ package body Prj.Nmsc is Write_Line ("No library ALI directory specified"); end if; Data.Library_ALI_Dir := Data.Library_Dir; - Data.Display_Library_ALI_Dir := Data.Display_Library_Dir; else -- Find path name, check that it is a directory @@ -4181,14 +4194,14 @@ package body Prj.Nmsc is (Project, In_Tree, File_Name_Type (Lib_ALI_Dir.Value), - Data.Display_Directory, - Data.Library_ALI_Dir, - Data.Display_Library_ALI_Dir, + Data.Directory.Display_Name, + Data.Library_ALI_Dir.Name, + Data.Library_ALI_Dir.Display_Name, Create => "library ALI", Current_Dir => Current_Dir, Location => Lib_ALI_Dir.Location); - if Data.Library_ALI_Dir = No_Path then + if Data.Library_ALI_Dir = No_Path_Information then -- Get the absolute name of the library ALI directory that -- does not exist, to report an error. @@ -4203,7 +4216,7 @@ package body Prj.Nmsc is File_Name_Type (Lib_Dir.Value); else - Get_Name_String (Data.Display_Directory); + Get_Name_String (Data.Directory.Display_Name); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; @@ -4237,8 +4250,7 @@ package body Prj.Nmsc is "library 'A'L'I directory cannot be the same " & "as object directory", Lib_ALI_Dir.Location); - Data.Library_ALI_Dir := No_Path; - Data.Display_Library_ALI_Dir := No_Path; + Data.Library_ALI_Dir := No_Path_Information; else declare @@ -4255,7 +4267,7 @@ package body Prj.Nmsc is Dir_Elem := In_Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; - if Data.Library_ALI_Dir = + if Data.Library_ALI_Dir.Name = Path_Name_Type (Dir_Elem.Value) then Err_Vars.Error_Msg_File_1 := @@ -4289,7 +4301,7 @@ package body Prj.Nmsc is In_Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; - if Data.Library_ALI_Dir = + if Data.Library_ALI_Dir.Name = Path_Name_Type (Dir_Elem.Value) then Err_Vars.Error_Msg_File_1 := @@ -4312,8 +4324,7 @@ package body Prj.Nmsc is end if; if not OK then - Data.Library_ALI_Dir := No_Path; - Data.Display_Library_ALI_Dir := No_Path; + Data.Library_ALI_Dir := No_Path_Information; elsif Current_Verbosity = High then @@ -4322,7 +4333,8 @@ package body Prj.Nmsc is Write_Str ("Library ALI directory ="""); Write_Str - (Get_Name_String (Data.Display_Library_ALI_Dir)); + (Get_Name_String + (Data.Library_ALI_Dir.Display_Name)); Write_Line (""""); end if; end; @@ -4680,7 +4692,7 @@ package body Prj.Nmsc is Data.Other_Sources_Present := False; else - -- If the configuration file does not define a language either + -- Fail if there is no default language defined if Def_Lang.Default then if not Default_Language_Is_Ada then @@ -4695,8 +4707,6 @@ package body Prj.Nmsc is end if; else - -- ??? Are we supporting a single default language in the - -- configuration file ? Get_Name_String (Def_Lang.Value); To_Lower (Name_Buffer (1 .. Name_Len)); Def_Lang_Id := Name_Find; @@ -5058,8 +5068,8 @@ package body Prj.Nmsc is In_Tree.Units.Table (The_Unit_Id); if The_Unit_Data.File_Names (Body_Part).Name /= No_File - and then The_Unit_Data.File_Names (Body_Part).Path /= - Slash + and then The_Unit_Data.File_Names + (Body_Part).Path.Name /= Slash then if Check_Project (The_Unit_Data.File_Names (Body_Part).Project, @@ -5079,7 +5089,7 @@ package body Prj.Nmsc is Src_Ind := Sinput.P.Load_Project_File (Get_Name_String (The_Unit_Data.File_Names - (Body_Part).Path)); + (Body_Part).Path.Name)); if Sinput.P.Source_File_Is_Subunit (Src_Ind) @@ -5113,7 +5123,7 @@ package body Prj.Nmsc is elsif The_Unit_Data.File_Names (Specification).Name /= No_File and then The_Unit_Data.File_Names - (Specification).Path /= Slash + (Specification).Path.Name /= Slash and then Check_Project (The_Unit_Data.File_Names (Specification).Project, @@ -5196,8 +5206,7 @@ package body Prj.Nmsc is In_Tree.Sources.Table (Source).Other_Part /= No_Source then - Source := - In_Tree.Sources.Table (Source).Other_Part; + Source := In_Tree.Sources.Table (Source).Other_Part; end if; String_Element_Table.Increment_Last @@ -5288,16 +5297,16 @@ package body Prj.Nmsc is (Project, In_Tree, Dir_Id, - Data.Display_Directory, - Data.Library_Src_Dir, - Data.Display_Library_Src_Dir, + Data.Directory.Display_Name, + Data.Library_Src_Dir.Name, + Data.Library_Src_Dir.Display_Name, Create => "library source copy", Current_Dir => Current_Dir, Location => Lib_Src_Dir.Location); -- If directory does not exist, report an error - if Data.Library_Src_Dir = No_Path then + if Data.Library_Src_Dir = No_Path_Information then -- Get the absolute name of the library directory that does -- not exist, to report an error. @@ -5311,7 +5320,7 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := Dir_Id; else - Get_Name_String (Data.Directory); + Get_Name_String (Data.Directory.Name); if Name_Buffer (Name_Len) /= Directory_Separator @@ -5346,7 +5355,7 @@ package body Prj.Nmsc is "directory to copy interfaces cannot be " & "the object directory", Lib_Src_Dir.Location); - Data.Library_Src_Dir := No_Path; + Data.Library_Src_Dir := No_Path_Information; else declare @@ -5363,7 +5372,7 @@ package body Prj.Nmsc is -- Report error if it is one of the source directories - if Data.Library_Src_Dir = + if Data.Library_Src_Dir.Name = Path_Name_Type (Src_Dir.Value) then Error_Msg @@ -5371,14 +5380,14 @@ package body Prj.Nmsc is "directory to copy interfaces cannot " & "be one of the source directories", Lib_Src_Dir.Location); - Data.Library_Src_Dir := No_Path; + Data.Library_Src_Dir := No_Path_Information; exit; end if; Src_Dirs := Src_Dir.Next; end loop; - if Data.Library_Src_Dir /= No_Path then + if Data.Library_Src_Dir /= No_Path_Information then -- It cannot be a source directory of any other -- project either. @@ -5395,7 +5404,7 @@ package body Prj.Nmsc is -- Report error if it is one of the source -- directories - if Data.Library_Src_Dir = + if Data.Library_Src_Dir.Name = Path_Name_Type (Src_Dir.Value) then Error_Msg_File_1 := @@ -5408,7 +5417,7 @@ package body Prj.Nmsc is "be the same as source directory { of " & "project %%", Lib_Src_Dir.Location); - Data.Library_Src_Dir := No_Path; + Data.Library_Src_Dir := No_Path_Information; exit Project_Loop; end if; @@ -5421,11 +5430,11 @@ package body Prj.Nmsc is -- In high verbosity, if there is a valid Library_Src_Dir, -- display its path name. - if Data.Library_Src_Dir /= No_Path + if Data.Library_Src_Dir /= No_Path_Information and then Current_Verbosity = High then Write_Str ("Directory to copy interfaces ="""); - Write_Str (Get_Name_String (Data.Library_Src_Dir)); + Write_Str (Get_Name_String (Data.Library_Src_Dir.Name)); Write_Line (""""); end if; end if; @@ -5550,7 +5559,8 @@ package body Prj.Nmsc is else if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then Name_Len := 0; - Add_Str_To_Name_Buffer (Get_Name_String (Data.Directory)); + Add_Str_To_Name_Buffer + (Get_Name_String (Data.Directory.Name)); Add_Char_To_Name_Buffer (Directory_Separator); Add_Str_To_Name_Buffer (Get_Name_String (Lib_Ref_Symbol_File.Value)); @@ -5599,7 +5609,7 @@ package body Prj.Nmsc is Symb_Path : constant String := Normalize_Pathname (Get_Name_String - (Data.Object_Directory) & + (Data.Object_Directory.Name) & Directory_Separator & Name_Buffer (1 .. Name_Len), Directory => Current_Dir, @@ -6360,7 +6370,7 @@ package body Prj.Nmsc is Normalize_Pathname (Name => Get_Name_String (Base_Dir), Directory => - Get_Name_String (Data.Display_Directory), + Get_Name_String (Data.Directory.Display_Name), Resolve_Links => False, Case_Sensitive => True); @@ -6412,7 +6422,7 @@ package body Prj.Nmsc is (Project => Project, In_Tree => In_Tree, Name => From, - Parent => Data.Display_Directory, + Parent => Data.Directory.Display_Name, Dir => Path_Name, Display => Display_Path_Name, Current_Dir => Current_Dir); @@ -6547,7 +6557,6 @@ package body Prj.Nmsc is -- We set the object directory to its default Data.Object_Directory := Data.Directory; - Data.Display_Object_Dir := Data.Display_Directory; if Object_Dir.Value /= Empty_String then Get_Name_String (Object_Dir.Value); @@ -6565,14 +6574,14 @@ package body Prj.Nmsc is (Project, In_Tree, File_Name_Type (Object_Dir.Value), - Data.Display_Directory, - Data.Object_Directory, - Data.Display_Object_Dir, + Data.Directory.Display_Name, + Data.Object_Directory.Name, + Data.Object_Directory.Display_Name, Create => "object", Location => Object_Dir.Location, Current_Dir => Current_Dir); - if Data.Object_Directory = No_Path then + if Data.Object_Directory = No_Path_Information then -- The object directory does not exist, report an error if the -- project is not externally built. @@ -6591,14 +6600,16 @@ package body Prj.Nmsc is -- tools that recover from errors; for example, these tools -- could create the non existent directory. - Data.Display_Object_Dir := Path_Name_Type (Object_Dir.Value); + Data.Object_Directory.Display_Name := + Path_Name_Type (Object_Dir.Value); if Osint.File_Names_Case_Sensitive then - Data.Object_Directory := Path_Name_Type (Object_Dir.Value); + Data.Object_Directory.Name := + Path_Name_Type (Object_Dir.Value); else Get_Name_String (Object_Dir.Value); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Data.Object_Directory := Name_Find; + Data.Object_Directory.Name := Name_Find; end if; end if; end if; @@ -6610,20 +6621,20 @@ package body Prj.Nmsc is (Project, In_Tree, Name_Find, - Data.Display_Directory, - Data.Object_Directory, - Data.Display_Object_Dir, + Data.Directory.Name, + Data.Object_Directory.Name, + Data.Object_Directory.Display_Name, Create => "object", Location => Object_Dir.Location, Current_Dir => Current_Dir); end if; if Current_Verbosity = High then - if Data.Object_Directory = No_Path then + if Data.Object_Directory = No_Path_Information then Write_Line ("No object directory"); else Write_Str ("Object directory: """); - Write_Str (Get_Name_String (Data.Display_Object_Dir)); + Write_Str (Get_Name_String (Data.Object_Directory.Display_Name)); Write_Line (""""); end if; end if; @@ -6636,7 +6647,6 @@ package body Prj.Nmsc is -- We set the object directory to its default Data.Exec_Directory := Data.Object_Directory; - Data.Display_Exec_Dir := Data.Display_Object_Dir; if Exec_Dir.Value /= Empty_String then Get_Name_String (Exec_Dir.Value); @@ -6654,14 +6664,14 @@ package body Prj.Nmsc is (Project, In_Tree, File_Name_Type (Exec_Dir.Value), - Data.Display_Directory, - Data.Exec_Directory, - Data.Display_Exec_Dir, + Data.Directory.Name, + Data.Exec_Directory.Name, + Data.Exec_Directory.Display_Name, Create => "exec", Location => Exec_Dir.Location, Current_Dir => Current_Dir); - if Data.Exec_Directory = No_Path then + if Data.Exec_Directory = No_Path_Information then Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value); Error_Msg (Project, In_Tree, @@ -6672,11 +6682,11 @@ package body Prj.Nmsc is end if; if Current_Verbosity = High then - if Data.Exec_Directory = No_Path then + if Data.Exec_Directory = No_Path_Information then Write_Line ("No exec directory"); else Write_Str ("Exec directory: """); - Write_Str (Get_Name_String (Data.Display_Exec_Dir)); + Write_Str (Get_Name_String (Data.Exec_Directory.Display_Name)); Write_Line (""""); end if; end if; @@ -6705,7 +6715,7 @@ package body Prj.Nmsc is if Data.Extends = No_Project and then Data.Object_Directory = Data.Directory then - Data.Object_Directory := No_Path; + Data.Object_Directory := No_Path_Information; end if; elsif Source_Dirs.Default then @@ -6718,8 +6728,8 @@ package body Prj.Nmsc is Data.Source_Dirs := String_Element_Table.Last (In_Tree.String_Elements); In_Tree.String_Elements.Table (Data.Source_Dirs) := - (Value => Name_Id (Data.Directory), - Display_Value => Name_Id (Data.Display_Directory), + (Value => Name_Id (Data.Directory.Name), + Display_Value => Name_Id (Data.Directory.Display_Name), Location => No_Location, Flag => False, Next => Nil_String, @@ -6728,7 +6738,7 @@ package body Prj.Nmsc is if Current_Verbosity = High then Write_Line ("Single source directory:"); Write_Str (" """); - Write_Str (Get_Name_String (Data.Display_Directory)); + Write_Str (Get_Name_String (Data.Directory.Display_Name)); Write_Line (""""); end if; @@ -6749,7 +6759,7 @@ package body Prj.Nmsc is if Data.Extends = No_Project and then Data.Object_Directory = Data.Directory then - Data.Object_Directory := No_Path; + Data.Object_Directory := No_Path_Information; end if; Data.Source_Dirs := Nil_String; @@ -6842,7 +6852,7 @@ package body Prj.Nmsc is -- inherit the Mains from the project we are extending. if Mains.Default then - if Data.Extends /= No_Project then + if not Data.Library and then Data.Extends /= No_Project then Data.Mains := In_Tree.Projects.Table (Data.Extends).Mains; end if; @@ -7525,7 +7535,7 @@ package body Prj.Nmsc is Path_Name_Of (File_Name_Type (Excluded_Source_List_File.Value), - Data.Directory); + Data.Directory.Name); begin if Source_File_Path_Name'Length = 0 then @@ -7665,7 +7675,7 @@ package body Prj.Nmsc is if Data.Extends = No_Project and then Data.Object_Directory = Data.Directory then - Data.Object_Directory := No_Path; + Data.Object_Directory := No_Path_Information; end if; end if; end if; @@ -7758,7 +7768,7 @@ package body Prj.Nmsc is declare Source_File_Path_Name : constant String := Path_Name_Of - (File_Name_Type (Source_List_File.Value), Data.Directory); + (File_Name_Type (Source_List_File.Value), Data.Directory.Name); begin if Source_File_Path_Name'Length = 0 then @@ -7824,7 +7834,7 @@ package body Prj.Nmsc is -- 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. + -- For other language, the source is simply removed. declare Source : Source_Id; @@ -7836,7 +7846,7 @@ package body Prj.Nmsc is Src_Data := In_Tree.Sources.Table (Source); if Src_Data.Naming_Exception - and then Src_Data.Path = No_Path + and then Src_Data.Path = No_Path_Information then if Src_Data.Unit /= No_Name then Error_Msg_Name_1 := Name_Id (Src_Data.Display_File); @@ -7845,11 +7855,9 @@ package body Prj.Nmsc is (Project, In_Tree, "source file %% for unit %% not found", No_Location); - - else - Remove_Source - (Source, No_Source, Project, Data, In_Tree); end if; + + Remove_Source (Source, No_Source, Project, Data, In_Tree); end if; Source := Src_Data.Next_In_Project; @@ -8514,9 +8522,8 @@ package body Prj.Nmsc is Check_Name := True; else - In_Tree.Sources.Table (Name_Loc.Source).Path := Path_Id; - In_Tree.Sources.Table - (Name_Loc.Source).Display_Path := Display_Path_Id; + In_Tree.Sources.Table (Name_Loc.Source).Path := + (Path_Id, Display_Path_Id); Source_Paths_Htable.Set (In_Tree.Source_Paths_HT, @@ -8579,13 +8586,21 @@ package body Prj.Nmsc is if Unit /= No_Name and then Src_Data.Unit = Unit - and then Src_Data.Kind /= Kind + and then + ((Src_Data.Kind = Spec and then Kind = Impl) + or else + (Src_Data.Kind = Impl and then Kind = Spec)) then Other_Part := Source; elsif (Unit /= No_Name and then Src_Data.Unit = Unit - and then Src_Data.Kind = Kind) + and then + (Src_Data.Kind = Kind + or else + (Src_Data.Kind = Sep and then Kind = Impl) + or else + (Src_Data.Kind = Impl and then Kind = Sep))) or else (Unit = No_Name and then Src_Data.File = File_Name) then -- Duplication of file/unit in same project is only @@ -8636,7 +8651,7 @@ package body Prj.Nmsc is Error_Msg_Name_1 := In_Tree.Projects.Table (Src_Data.Project).Name; - Error_Msg_Name_2 := Name_Id (Src_Data.Display_Path); + Error_Msg_Name_2 := Name_Id (Src_Data.Path.Display_Name); Error_Msg (Project, In_Tree, "\ project %%, %%", No_Location); @@ -8853,7 +8868,7 @@ package body Prj.Nmsc is if Extended = Project or else Project_Extends (Project, Extended, In_Tree) then - Unit.File_Names (Kind).Path := Slash; + Unit.File_Names (Kind).Path.Name := Slash; Unit.File_Names (Kind).Needs_Pragma := False; In_Tree.Units.Table (Index) := Unit; Add_Forbidden_File_Name @@ -9064,6 +9079,8 @@ package body Prj.Nmsc is Find_Explicit_Sources (Ada_Language_Index, Current_Dir, Project, In_Tree, Data); + -- Mark as such the sources that are declared as excluded + FF := Excluded_Sources_Htable.Get_First; while FF /= No_File_Found loop OK := False; @@ -9099,6 +9116,98 @@ package body Prj.Nmsc is FF := Excluded_Sources_Htable.Get_Next; end loop; + + -- Check that two sources of this project do not have the same object + -- file name. + + Check_Object_File_Names : declare + Src_Id : Source_Id; + Src_Data : Source_Data; + Source_Name : File_Name_Type; + + procedure Check_Object; + -- Check if object file name of the current source is already in + -- hash table Object_File_Names. If it is, report an error. If it + -- is not, put it there with the file name of the current source. + + ------------------ + -- Check_Object -- + ------------------ + + procedure Check_Object is + begin + Source_Name := Object_File_Names.Get (Src_Data.Object); + + if Source_Name /= No_File then + Error_Msg_File_1 := Src_Data.File; + Error_Msg_File_2 := Source_Name; + Error_Msg + (Project, + In_Tree, + "{ and { have the same object file name", + No_Location); + + else + Object_File_Names.Set (Src_Data.Object, Src_Data.File); + end if; + end Check_Object; + + -- Start of processing for Check_Object_File_Names + + begin + Object_File_Names.Reset; + Src_Id := In_Tree.First_Source; + while Src_Id /= No_Source loop + Src_Data := In_Tree.Sources.Table (Src_Id); + + if Src_Data.Compiled and then Src_Data.Object_Exists + and then Project_Extends (Project, Src_Data.Project, In_Tree) + then + if Src_Data.Unit = No_Name then + if Src_Data.Kind = Impl then + Check_Object; + end if; + + else + case Src_Data.Kind is + when Spec => + if Src_Data.Other_Part = No_Source then + Check_Object; + end if; + + when Sep => + null; + + when Impl => + if Src_Data.Other_Part /= No_Source then + Check_Object; + + else + -- Check if it is a subunit + + declare + Src_Ind : constant Source_File_Index := + Sinput.P.Load_Project_File + (Get_Name_String + (Src_Data.Path.Name)); + + begin + if Sinput.P.Source_File_Is_Subunit + (Src_Ind) + then + In_Tree.Sources.Table (Src_Id).Kind := Sep; + else + Check_Object; + end if; + end; + end if; + end case; + end if; + end if; + + Src_Id := Src_Data.Next_In_Sources; + end loop; + end Check_Object_File_Names; end Process_Sources_In_Multi_Language_Mode; -- Start of processing for Look_For_Sources @@ -9134,15 +9243,15 @@ package body Prj.Nmsc is (File_Name : File_Name_Type; Directory : Path_Name_Type) return String is - Result : String_Access; - + Result : String_Access; The_Directory : constant String := Get_Name_String (Directory); begin Get_Name_String (File_Name); - Result := Locate_Regular_File - (File_Name => Name_Buffer (1 .. Name_Len), - Path => The_Directory); + Result := + Locate_Regular_File + (File_Name => Name_Buffer (1 .. Name_Len), + Path => The_Directory); if Result = null then return ""; @@ -9381,14 +9490,17 @@ package body Prj.Nmsc is if (The_Unit_Data.File_Names (Unit_Kind).Name = Canonical_File_Name and then - The_Unit_Data.File_Names (Unit_Kind).Path = Slash) + The_Unit_Data.File_Names + (Unit_Kind).Path.Name = Slash) or else The_Unit_Data.File_Names (Unit_Kind).Name = No_File or else Project_Extends (Data.Extends, The_Unit_Data.File_Names (Unit_Kind).Project, In_Tree) then - if The_Unit_Data.File_Names (Unit_Kind).Path = Slash then + if + The_Unit_Data.File_Names (Unit_Kind).Path.Name = Slash + then Remove_Forbidden_File_Name (The_Unit_Data.File_Names (Unit_Kind).Name); end if; @@ -9405,8 +9517,7 @@ package body Prj.Nmsc is (Name => Canonical_File_Name, Index => Unit_Ind, Display_Name => File_Name, - Path => Canonical_Path_Name, - Display_Path => Path_Name, + Path => (Canonical_Path_Name, Path_Name), Project => Project, Needs_Pragma => Needs_Pragma); In_Tree.Units.Table (The_Unit) := The_Unit_Data; @@ -9415,8 +9526,8 @@ package body Prj.Nmsc is 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) + The_Unit_Data.File_Names + (Unit_Kind).Path.Name = Canonical_Path_Name) then if Previous_Source = Nil_String then Data.Ada_Sources := Nil_String; @@ -9448,7 +9559,7 @@ package body Prj.Nmsc is (The_Unit_Data.File_Names (Unit_Kind).Project).Name; Err_Vars.Error_Msg_File_1 := File_Name_Type - (The_Unit_Data.File_Names (Unit_Kind).Path); + (The_Unit_Data.File_Names (Unit_Kind).Path.Name); Error_Msg (Project, In_Tree, "\ project file %%, {", The_Location); @@ -9498,8 +9609,7 @@ package body Prj.Nmsc is (Name => Canonical_File_Name, Index => Unit_Ind, Display_Name => File_Name, - Path => Canonical_Path_Name, - Display_Path => Path_Name, + Path => (Canonical_Path_Name, Path_Name), Project => Project, Needs_Pragma => Needs_Pragma); In_Tree.Units.Table (The_Unit) := The_Unit_Data; diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index ab9208f9e94..67c913378dd 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -39,6 +39,8 @@ with Table; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Exceptions; use Ada.Exceptions; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; + with System.HTable; use System.HTable; package body Prj.Part is @@ -1864,15 +1866,65 @@ package body Prj.Part is ------------------- function Try_Path_Name (Path : String) return String_Access is + Prj_Path : constant String := Project_Path; + First : Natural; + Last : Natural; + Result : String_Access := null; + begin if Current_Verbosity = High then Write_Str (" Trying "); Write_Line (Path); end if; - return Locate_Regular_File - (File_Name => Path, - Path => Project_Path); + if Is_Absolute_Path (Path) then + if Is_Regular_File (Path) then + Result := new String'(Path); + end if; + + else + -- Because we don't want to resolve symbolic links, we cannot use + -- Locate_Regular_File. So, we try each possible path + -- successively. + + First := Prj_Path'First; + while First <= Prj_Path'Last loop + while First <= Prj_Path'Last + and then Prj_Path (First) = Path_Separator + loop + First := First + 1; + end loop; + + exit when First > Prj_Path'Last; + + Last := First; + while Last < Prj_Path'Last + and then Prj_Path (Last + 1) /= Path_Separator + loop + Last := Last + 1; + end loop; + + Name_Len := 0; + + if not Is_Absolute_Path (Prj_Path (First .. Last)) then + Add_Str_To_Name_Buffer (Get_Current_Dir); + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + + Add_Str_To_Name_Buffer (Prj_Path (First .. Last)); + Add_Char_To_Name_Buffer (Directory_Separator); + Add_Str_To_Name_Buffer (Path); + + if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then + Result := new String'(Name_Buffer (1 .. Name_Len)); + exit; + end if; + + First := Last + 1; + end loop; + end if; + + return Result; end Try_Path_Name; -- Local Declarations diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 13f1d947804..67ae8ba85f0 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -2315,13 +2315,13 @@ package body Prj.Proc is declare Object_Dir : constant Path_Name_Type := In_Tree.Projects.Table - (Project).Object_Directory; + (Project).Object_Directory.Name; begin for Index in Project_Table.First .. Project_Table.Last (In_Tree.Projects) loop if In_Tree.Projects.Table (Index).Virtual then - In_Tree.Projects.Table (Index).Object_Directory := + In_Tree.Projects.Table (Index).Object_Directory.Name := Object_Dir; end if; end loop; @@ -2338,7 +2338,7 @@ package body Prj.Proc is Extending := In_Tree.Projects.Table (Proj).Extended_By; if Extending /= No_Project then - Obj_Dir := In_Tree.Projects.Table (Proj).Object_Directory; + Obj_Dir := In_Tree.Projects.Table (Proj).Object_Directory.Name; -- Check that a project being extended does not share its -- object directory with any project that extends it, directly @@ -2351,8 +2351,8 @@ package body Prj.Proc is if In_Tree.Projects.Table (Extending2).Ada_Sources /= Nil_String and then - In_Tree.Projects.Table (Extending2).Object_Directory = - Obj_Dir + In_Tree.Projects.Table + (Extending2).Object_Directory.Name = Obj_Dir then if In_Tree.Projects.Table (Extending2).Virtual then Error_Msg_Name_1 := @@ -2562,20 +2562,20 @@ package body Prj.Proc is Processed_Data.Display_Name := Name_Find; end if; - Processed_Data.Display_Path_Name := + Processed_Data.Path.Display_Name := Path_Name_Of (From_Project_Node, From_Project_Node_Tree); - Get_Name_String (Processed_Data.Display_Path_Name); + Get_Name_String (Processed_Data.Path.Display_Name); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Processed_Data.Path_Name := Name_Find; + Processed_Data.Path.Name := Name_Find; Processed_Data.Location := Location_Of (From_Project_Node, From_Project_Node_Tree); - Processed_Data.Display_Directory := + Processed_Data.Directory.Display_Name := Directory_Of (From_Project_Node, From_Project_Node_Tree); - Get_Name_String (Processed_Data.Display_Directory); + Get_Name_String (Processed_Data.Directory.Display_Name); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Processed_Data.Directory := Name_Find; + Processed_Data.Directory.Name := Name_Find; Processed_Data.Extended_By := Extended_By; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 0435509988e..d838b114442 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -95,21 +95,16 @@ package body Prj is First_Referred_By => No_Project, Name => No_Name, Display_Name => No_Name, - Path_Name => No_Path, - Display_Path_Name => No_Path, + Path => No_Path_Information, Virtual => False, Location => No_Location, Mains => Nil_String, - Directory => No_Path, - Display_Directory => No_Path, + Directory => No_Path_Information, Dir_Path => null, Library => False, - Library_Dir => No_Path, - Display_Library_Dir => No_Path, - Library_Src_Dir => No_Path, - Display_Library_Src_Dir => No_Path, - Library_ALI_Dir => No_Path, - Display_Library_ALI_Dir => No_Path, + Library_Dir => No_Path_Information, + Library_Src_Dir => No_Path_Information, + Library_ALI_Dir => No_Path_Information, Library_Name => No_Name, Library_Kind => Static, Lib_Internal_Name => No_Name, @@ -131,11 +126,9 @@ package body Prj is Include_Language => No_Language_Index, Source_Dirs => Nil_String, Known_Order_Of_Source_Dirs => True, - Object_Directory => No_Path, - Display_Object_Dir => No_Path, + Object_Directory => No_Path_Information, Library_TS => Empty_Time_Stamp, - Exec_Directory => No_Path, - Display_Exec_Dir => No_Path, + Exec_Directory => No_Path_Information, Extends => No_Project, Extended_By => No_Project, Naming => Std_Naming_Data, diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index c547eb66397..5d8caa79cd3 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -150,6 +150,13 @@ package Prj is function Empty_String return Name_Id; -- Return the id for an empty string "" + type Path_Information is record + Name : Path_Name_Type := No_Path; + Display_Name : Path_Name_Type := No_Path; + end record; + + No_Path_Information : constant Path_Information := (No_Path, No_Path); + type Project_Id is new Nat; No_Project : constant Project_Id := 0; -- Id of a Project File @@ -672,11 +679,8 @@ package Prj is Display_File : File_Name_Type := No_File; -- File name of the source, for display purposes - Path : Path_Name_Type := No_Path; - -- Canonical path name of the source - - Display_Path : Path_Name_Type := No_Path; - -- Path name of the source, for display purposes + Path : Path_Information := No_Path_Information; + -- Path name of the source Source_TS : Time_Stamp_Type := Empty_Time_Stamp; -- Time stamp of the source file @@ -756,8 +760,7 @@ package Prj is Replaced_By => No_Source, File => No_File, Display_File => No_File, - Path => No_Path, - Display_Path => No_Path, + Path => No_Path_Information, Source_TS => Empty_Time_Stamp, Object_Project => No_Project, Object_Exists => True, @@ -1125,100 +1128,106 @@ package Prj is -- The table that contains the lists of project files type Project_Configuration is record - Run_Path_Option : Name_List_Index := No_Name_List; - -- The option to use when linking to specify the path where to look - -- for libraries. + Run_Path_Option : Name_List_Index := No_Name_List; + -- The option to use when linking to specify the path where to look for + -- libraries. + + Executable_Suffix : Name_Id := No_Name; + -- The suffix of executables, when specified in the configuration or in + -- package Builder of the main project. When this is not specified, the + -- executable suffix is the default for the platform. - Executable_Suffix : Name_Id := No_Name; - -- The suffix of executables, when specified in the configuration - -- or in package Builder of the main project. When this is not - -- specified, the executable suffix is the default for the platform. + -- Linking - -- Linking + Linker : Path_Name_Type := No_Path; + -- Path name of the linker driver. Specified in the configuration or in + -- the package Builder of the main project. - Linker : Path_Name_Type := No_Path; - -- Path name of the linker driver. Specified in the configuration - -- or in the package Builder of the main project. + Map_File_Option : Name_Id := No_Name; + -- Option to use when invoking the linker to build a map file - Minimum_Linker_Options : Name_List_Index := No_Name_List; - -- The minimum options for the linker driver. Specified in the - -- configuration. + Minimum_Linker_Options : Name_List_Index := No_Name_List; + -- The minimum options for the linker driver. Specified in the + -- configuration. - Linker_Executable_Option : Name_List_Index := No_Name_List; - -- The option(s) to indicate the name of the executable in the - -- linker command. Specified in the configuration. When not - -- specified, default to -o <executable name>. + Linker_Executable_Option : Name_List_Index := No_Name_List; + -- The option(s) to indicate the name of the executable in the linker + -- command. Specified in the configuration. When not specified, default + -- to -o <executable name>. - Linker_Lib_Dir_Option : Name_Id := No_Name; - -- The option to specify where to find a library for linking. - -- Specified in the configuration. When not specified, defaults to - -- "-L". + Linker_Lib_Dir_Option : Name_Id := No_Name; + -- The option to specify where to find a library for linking. Specified + -- in the configuration. When not specified, defaults to "-L". - Linker_Lib_Name_Option : Name_Id := No_Name; - -- The option to specify the name of a library for linking. Specified - -- in the configuration. When not specified, defaults to "-l". + Linker_Lib_Name_Option : Name_Id := No_Name; + -- The option to specify the name of a library for linking. Specified in + -- the configuration. When not specified, defaults to "-l". - -- Libraries + -- Libraries - Library_Builder : Path_Name_Type := No_Path; - -- The executable to build library (specified in the configuration) + Library_Builder : Path_Name_Type := No_Path; + -- The executable to build library (specified in the configuration) - Lib_Support : Library_Support := None; - -- The level of library support. Specified in the configuration. - -- Support is none, static libraries only or both static and shared - -- libraries. + Lib_Support : Library_Support := None; + -- The level of library support. Specified in the configuration. Support + -- is none, static libraries only or both static and shared libraries. - -- Archives + Archive_Builder : Name_List_Index := No_Name_List; + -- The name of the executable to build archives, with the minimum + -- switches. Specified in the configuration. - Archive_Builder : Name_List_Index := No_Name_List; - -- The name of the executable to build archives, with the minimum - -- switches. Specified in the configuration. + Archive_Builder_Append_Option : Name_List_Index := No_Name_List; + -- The options to append object files to an archive - Archive_Builder_Append_Option : Name_List_Index := No_Name_List; - -- The options to append object files to an archive + Archive_Indexer : Name_List_Index := No_Name_List; + -- The name of the executable to index archives, with the minimum + -- switches. Specified in the configuration. - Archive_Indexer : Name_List_Index := No_Name_List; - -- The name of the executable to index archives, with the minimum - -- switches. Specified in the configuration. + Archive_Suffix : File_Name_Type := No_File; + -- The suffix of archives. Specified in the configuration. When not + -- specified, defaults to ".a". - Archive_Suffix : File_Name_Type := No_File; - -- The suffix of archives. Specified in the configuration. When not - -- specified, defaults to ".a". + Lib_Partial_Linker : Name_List_Index := No_Name_List; - Lib_Partial_Linker : Name_List_Index := No_Name_List; + -- Shared libraries - -- Shared libraries + Shared_Lib_Driver : File_Name_Type := No_File; + -- The driver to link shared libraries. Set with attribute Library_GCC. + -- Default to gcc. - Shared_Lib_Prefix : File_Name_Type := No_File; - -- Part of a shared library file name that precedes the name of the - -- library. Specified in the configuration. When not specified, - -- defaults to "lib". + Shared_Lib_Prefix : File_Name_Type := No_File; + -- Part of a shared library file name that precedes the name of the + -- library. Specified in the configuration. When not specified, defaults + -- to "lib". - Shared_Lib_Suffix : File_Name_Type := No_File; - -- Suffix of shared libraries, after the library name in the shared - -- library name. Specified in the configuration. When not specified, - -- default to ".so". + Shared_Lib_Suffix : File_Name_Type := No_File; + -- Suffix of shared libraries, after the library name in the shared + -- library name. Specified in the configuration. When not specified, + -- default to ".so". - Shared_Lib_Min_Options : Name_List_Index := No_Name_List; - -- Comment ??? + Shared_Lib_Min_Options : Name_List_Index := No_Name_List; + -- The minimum options to use when building a shared library - Lib_Version_Options : Name_List_Index := No_Name_List; - -- Comment ??? + Lib_Version_Options : Name_List_Index := No_Name_List; + -- The options to use to specify a library version - Symbolic_Link_Supported : Boolean := False; - -- Comment ??? + Symbolic_Link_Supported : Boolean := False; + -- True if the platform supports symbolic link files - Lib_Maj_Min_Id_Supported : Boolean := False; - -- Comment ??? + Lib_Maj_Min_Id_Supported : Boolean := False; + -- True if platform supports library major and minor options, such as + -- libname.so -> libname.so.2 -> libname.so.2.4 - Auto_Init_Supported : Boolean := False; - -- Comment ??? + Auto_Init_Supported : Boolean := False; + -- True if automatic initialisation is supported for shared stand-alone + -- libraries. end record; Default_Project_Config : constant Project_Configuration := (Run_Path_Option => No_Name_List, Executable_Suffix => No_Name, Linker => No_Path, + Map_File_Option => No_Name, Minimum_Linker_Options => No_Name_List, Linker_Executable_Option => No_Name_List, Linker_Lib_Dir_Option => No_Name, @@ -1230,6 +1239,7 @@ package Prj is Archive_Indexer => No_Name_List, Archive_Suffix => No_File, Lib_Partial_Linker => No_Name_List, + Shared_Lib_Driver => No_File, Shared_Lib_Prefix => No_File, Shared_Lib_Suffix => No_File, Shared_Lib_Min_Options => No_Name_List, @@ -1245,6 +1255,17 @@ package Prj is -- separator. type Project_Data is record + + ------------- + -- General -- + ------------- + + Name : Name_Id := No_Name; + -- The name of the project + + Display_Name : Name_Id := No_Name; + -- The name of the project with the spelling of its declaration + Qualifier : Project_Qualifier := Unspecified; -- The eventual qualifier for this project @@ -1252,90 +1273,115 @@ package Prj is -- True if the project is externally built. In such case, the Project -- Manager will not modify anything in this project. + Config : Project_Configuration; + + Path : Path_Information := No_Path_Information; + -- The path name of the project file + + Virtual : Boolean := False; + -- True for virtual extending projects + + Location : Source_Ptr := No_Location; + -- The location in the project file source of the reserved word project + + Naming : Naming_Data := Standard_Naming_Data; + -- The naming scheme of this project file + + --------------- + -- Languages -- + --------------- + Languages : Name_List_Index := No_Name_List; -- The list of languages of the sources of this project - Config : Project_Configuration; + Include_Language : Language_Index := No_Language_Index; + + First_Language_Processing : Language_Index := No_Language_Index; + -- First index of the language data in the project + + 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 + -- sources of the project. There may be only one unit-based language + -- in one project. + + -------------- + -- Projects -- + -------------- First_Referred_By : Project_Id := No_Project; -- The project, if any, that was the first to be known as importing or -- extending this project - Name : Name_Id := No_Name; - -- The name of the project + Mains : String_List_Id := Nil_String; + -- List of mains specified by attribute Main - Display_Name : Name_Id := No_Name; - -- The name of the project with the spelling of its declaration + Extends : Project_Id := No_Project; + -- The reference of the project file, if any, that this project file + -- extends. - Path_Name : Path_Name_Type := No_Path; - -- The path name of the project file + Extended_By : Project_Id := No_Project; + -- The reference of the project file, if any, that extends this project + -- file. - Display_Path_Name : Path_Name_Type := No_Path; - -- The path name used for display purposes. May be different from - -- Path_Name for platforms where the file names are case-insensitive. + Decl : Declarations := No_Declarations; + -- The declarations (variables, attributes and packages) of this project + -- file. - Virtual : Boolean := False; - -- True for virtual extending projects + Imported_Projects : Project_List := Empty_Project_List; + -- The list of all directly imported projects, if any - Location : Source_Ptr := No_Location; - -- The location in the project file source of the reserved word project + All_Imported_Projects : Project_List := Empty_Project_List; + -- The list of all projects imported directly or indirectly, if any - Mains : String_List_Id := Nil_String; - -- List of mains specified by attribute Main + ----------------- + -- Directories -- + ----------------- - Directory : Path_Name_Type := No_Path; + Directory : Path_Information := No_Path_Information; -- Path name of the directory where the project file resides - Display_Directory : Path_Name_Type := No_Path; - -- The path name of the project directory, for display purposes. May be - -- different from Directory for platforms where the file names are - -- case-insensitive. - Dir_Path : String_Access; - -- Same as Directory, but as an access to String + -- Same as Directory.Name, but as an access to String + + Object_Directory : Path_Information := No_Path_Information; + -- The path name of the object directory of this project file + + Exec_Directory : Path_Information := No_Path_Information; + -- The path name of the exec directory of this project file. Default is + -- equal to Object_Directory. + + ------------- + -- Library -- + ------------- + + Library : Boolean := False; + -- True if this is a library project + + Library_Name : Name_Id := No_Name; + -- If a library project, name of the library + + Library_Kind : Lib_Kind := Static; + -- If a library project, kind of library - Library_Dir : Path_Name_Type := No_Path; + Library_Dir : Path_Information := No_Path_Information; -- If a library project, path name of the directory where the library -- resides. - Display_Library_Dir : Path_Name_Type := No_Path; - -- The path name of the library directory, for display purposes. May be - -- different from Library_Dir for platforms where the file names are - -- case-insensitive. - Library_TS : Time_Stamp_Type := Empty_Time_Stamp; -- The timestamp of a library file in a library project - Library_Src_Dir : Path_Name_Type := No_Path; + Library_Src_Dir : Path_Information := No_Path_Information; -- If a Stand-Alone Library project, path name of the directory where -- the sources of the interfaces of the library are copied. By default, -- if attribute Library_Src_Dir is not specified, sources of the -- interfaces are not copied anywhere. - Display_Library_Src_Dir : Path_Name_Type := No_Path; - -- The path name of the library source directory, for display purposes. - -- May be different from Library_Src_Dir for platforms where the file - -- names are case-insensitive. - - Library_ALI_Dir : Path_Name_Type := No_Path; + Library_ALI_Dir : Path_Information := No_Path_Information; -- In a library project, path name of the directory where the ALI files -- are copied. If attribute Library_ALI_Dir is not specified, ALI files -- are copied in the Library_Dir. - Display_Library_ALI_Dir : Path_Name_Type := No_Path; - -- The path name of the library ALI directory, for display purposes. May - -- 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 - - Library_Kind : Lib_Kind := Static; - -- If a library project, kind of library - Lib_Internal_Name : Name_Id := No_Name; -- If a library project, internal name store inside the library @@ -1350,12 +1396,17 @@ package Prj is -- For non static Stand-Alone Library Project Files, indicate if -- the library initialisation should be automatic. - Libgnarl_Needed : Yes_No_Unknown := Unknown; - -- Set to True when libgnarl is needed to link - Symbol_Data : Symbol_Record := No_Symbols; -- Symbol file name, reference symbol file name, symbol policy + Need_To_Build_Lib : Boolean := False; + -- Indicates that the library of a Library Project needs to be built or + -- rebuilt. + + ------------- + -- Sources -- + ------------- + Ada_Sources : String_List_Id := Nil_String; -- The list of all the Ada source file names (gnatmake only) @@ -1370,19 +1421,15 @@ package Prj is -- 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 - -- sources of the project. There may be only one unit-based language - -- in one project. - Imported_Directories_Switches : Argument_List_Access := null; -- List of the source search switches (-I<source dir>) to be used when -- compiling. Include_Path : String_Access := null; - -- Value of the environment variable to indicate the source search path, - -- instead of a list of switches (Imported_Directories_Switches). + -- The search source path for the project. Used as the value for an + -- environment variable, specified by attribute Include_Path + -- (<language>). The names of the environment variables are in component + -- Include_Path of the records Language_Config. Include_Path_File : Path_Name_Type := No_Path; -- The path name of the of the source search directory file @@ -1390,8 +1437,6 @@ package Prj is Include_Data_Set : Boolean := False; -- Set True when Imported_Directories_Switches or Include_Path are set - Include_Language : Language_Index := No_Language_Index; - Source_Dirs : String_List_Id := Nil_String; -- The list of all the source directories @@ -1400,57 +1445,38 @@ package Prj is -- the ordering of the source subdirs depend on the OS. If True, -- duplicate file names in the same project file are allowed. - Object_Directory : Path_Name_Type := No_Path; - -- The path name of the object directory of this project file - - Display_Object_Dir : Path_Name_Type := No_Path; - -- The path name of the object directory, for display purposes. May be - -- different from Object_Directory for platforms where the file names - -- are case-insensitive. - - Exec_Directory : Path_Name_Type := No_Path; - -- The path name of the exec directory of this project file. Default is - -- equal to Object_Directory. - - Display_Exec_Dir : Path_Name_Type := No_Path; - -- The path name of the exec directory, for display purposes. May be - -- different from Exec_Directory for platforms where the file names are - -- case-insensitive. - - Extends : Project_Id := No_Project; - -- The reference of the project file, if any, that this project file - -- extends. - - Extended_By : Project_Id := No_Project; - -- The reference of the project file, if any, that extends this project - -- file. + Ada_Include_Path : String_Access := null; + -- The cached value of source search path for this project file. Set by + -- the first call to Prj.Env.Ada_Include_Path for the project. Do not + -- use this field directly outside of the project manager, use + -- Prj.Env.Ada_Include_Path instead. - Naming : Naming_Data := Standard_Naming_Data; - -- The naming scheme of this project file + ------------- + -- Linking -- + ------------- - First_Language_Processing : Language_Index := No_Language_Index; - -- First index of the language data in the project + Linker_Name : File_Name_Type := No_File; + -- Value of attribute Language_Processing'Linker in the project file - Decl : Declarations := No_Declarations; - -- The declarations (variables, attributes and packages) of this project - -- file. + Linker_Path : Path_Name_Type := No_Path; + -- Path of linker when attribute Language_Processing'Linker is specified - Imported_Projects : Project_List := Empty_Project_List; - -- The list of all directly imported projects, if any + Minimum_Linker_Options : Name_List_Index := No_Name_List; + -- List of options specified in attribute + -- Language_Processing'Minimum_Linker_Options. - All_Imported_Projects : Project_List := Empty_Project_List; - -- The list of all projects imported directly or indirectly, if any - - Ada_Include_Path : String_Access := null; - -- The cached value of ADA_INCLUDE_PATH for this project file. Do not - -- use this field directly outside of the compiler, use - -- Prj.Env.Ada_Include_Path instead. + ------------------- + -- Miscellaneous -- + ------------------- Ada_Objects_Path : String_Access := null; -- The cached value of ADA_OBJECTS_PATH for this project file. Do not -- use this field directly outside of the compiler, use -- Prj.Env.Ada_Objects_Path instead. + Libgnarl_Needed : Yes_No_Unknown := Unknown; + -- Set to True when libgnarl is needed to link + Objects_Path : String_Access := null; -- The cached value of the object dir path, used during the binding -- phase of gprbuild. @@ -1470,16 +1496,6 @@ package Prj is -- An indication that the configuration pragmas file is a temporary file -- that must be deleted at the end. - Linker_Name : File_Name_Type := No_File; - -- Value of attribute Language_Processing'Linker in the project file - - Linker_Path : Path_Name_Type := No_Path; - -- Path of linker when attribute Language_Processing'Linker is specified - - Minimum_Linker_Options : Name_List_Index := No_Name_List; - -- List of options specified in attribute - -- Language_Processing'Minimum_Linker_Options. - Config_Checked : Boolean := False; -- A flag to avoid checking repetitively the configuration pragmas file @@ -1491,10 +1507,6 @@ package Prj is -- A flag to mark a project as "visited" to avoid processing the same -- project several time. - Need_To_Build_Lib : Boolean := False; - -- Indicates that the library of a Library Project needs to be built or - -- rebuilt. - Depth : Natural := 0; -- The maximum depth of a project in the project graph. Depth of main -- project is 0. @@ -1568,13 +1580,12 @@ package Prj is type Spec_Or_Body is (Specification, Body_Part); type File_Name_Data is record - Name : File_Name_Type := No_File; - Index : Int := 0; - Display_Name : File_Name_Type := No_File; - Path : Path_Name_Type := No_Path; - Display_Path : Path_Name_Type := No_Path; - Project : Project_Id := No_Project; - Needs_Pragma : Boolean := False; + Name : File_Name_Type := No_File; + Index : Int := 0; + Display_Name : File_Name_Type := No_File; + Path : Path_Information := No_Path_Information; + Project : Project_Id := No_Project; + Needs_Pragma : Boolean := False; end record; -- File and Path name of a spec or body diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 5049c5b1be4..2f1bd5dec3d 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.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- -- @@ -321,7 +321,16 @@ package body Restrict is if Restriction_Warnings (R) then Restriction_Msg ("|violation of restriction %#?", Rimage, N); else - Restriction_Msg ("|violation of restriction %#", Rimage, N); + -- Normally a restriction violation is a non-serious error, + -- but we treat violation of No_Finalization as a serious + -- error, since we want to turn off expansion in this case, + -- expansion just causes too many cascaded errors. + + if R = No_Finalization then + Restriction_Msg ("violation of restriction %#", Rimage, N); + else + Restriction_Msg ("|violation of restriction %#", Rimage, N); + end if; end if; -- Otherwise we have the case of an implicit restriction diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index fbc8a8a54f8..bb81d85ed79 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -105,14 +105,18 @@ package Restrict is Implementation_Restriction : array (All_Restrictions) of Boolean := (Simple_Barriers => True, + No_Asynchronous_Control => True, No_Calendar => True, No_Dispatching_Calls => True, No_Dynamic_Attachment => True, + No_Elaboration_Code => True, No_Enumeration_Maps => True, No_Entry_Calls_In_Elaboration_Code => True, No_Entry_Queue => True, No_Exception_Handlers => True, No_Exception_Registration => True, + No_Implementation_Attributes => True, + No_Implementation_Pragmas => True, No_Implicit_Conditionals => True, No_Implicit_Dynamic_Code => True, No_Implicit_Loops => True, @@ -126,12 +130,11 @@ package Restrict is No_Streams => True, No_Task_Attributes_Package => True, No_Task_Termination => True, + No_Unchecked_Conversion => True, + No_Unchecked_Deallocation => True, No_Wide_Characters => True, Static_Priorities => True, Static_Storage_Size => True, - No_Implementation_Attributes => True, - No_Implementation_Pragmas => True, - No_Elaboration_Code => True, others => False); -- The following table records entries made by Restrictions pragmas diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 650e2eaad3f..a0efccc3f06 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -959,7 +959,9 @@ package body Rtsfind is if Get_PCS_Name = Name_No_DSA then Check_RPC_Failure ("distribution feature not supported"); - elsif Get_PCS_Version /= Exp_Dist.PCS_Version_Number then + elsif Get_PCS_Version /= + Exp_Dist.PCS_Version_Number (Get_PCS_Name) + then Check_RPC_Failure ("PCS version mismatch"); end if; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 83f745499e2..b3bbf6a3539 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -144,6 +144,7 @@ package Rtsfind is -- Children of Ada.Real_Time Ada_Real_Time_Delays, + Ada_Real_Time_Timing_Events, -- Children of Ada.Streams @@ -394,7 +395,7 @@ package Rtsfind is -- Range of values for children of Ada.Interrupts subtype Ada_Real_Time_Child is Ada_Child - range Ada_Real_Time_Delays .. Ada_Real_Time_Delays; + range Ada_Real_Time_Delays .. Ada_Real_Time_Timing_Events; -- Range of values for children of Ada.Real_Time subtype Ada_Streams_Child is Ada_Child @@ -470,6 +471,12 @@ package Rtsfind is RE_Null, + RO_CA_Time, -- Ada.Calendar + + RO_CA_Delay_For, -- Ada.Calendar.Delays + RO_CA_Delay_Until, -- Ada.Calendar.Delays + RO_CA_To_Duration, -- Ada.Calendar.Delays + RE_Set_Deadline, -- Ada.Dispatching.EDF RE_Code_Loc, -- Ada.Exceptions @@ -503,6 +510,16 @@ package Rtsfind is RE_Names, -- Ada.Interrupts.Names + RE_Clock, -- Ada.Real_Time + RE_Time_Span, -- Ada.Real_Time + RE_Time_Span_Zero, -- Ada.Real_Time + RO_RT_Time, -- Ada.Real_Time + + RO_RT_Delay_Until, -- Ada.Real_Time.Delays + RO_RT_To_Duration, -- Ada.Real_Time.Delays + + RE_Timing_Event, -- Ada_Real_Time_Timing_Events + RE_Root_Stream_Type, -- Ada.Streams RE_Stream_Element, -- Ada.Streams @@ -590,24 +607,13 @@ package Rtsfind is RE_TK_Tagged, -- Ada.Tags RE_TK_Task, -- Ada.Tags + RE_Set_Specific_Handler, -- Ada.Task_Termination + RE_Specific_Handler, -- Ada.Task_Termination + RE_Abort_Task, -- Ada.Task_Identification RE_Current_Task, -- Ada.Task_Identification RO_AT_Task_Id, -- Ada.Task_Identification - RO_CA_Time, -- Ada.Calendar - - RO_CA_Delay_For, -- Ada.Calendar.Delays - RO_CA_Delay_Until, -- Ada.Calendar.Delays - RO_CA_To_Duration, -- Ada.Calendar.Delays - - RE_Clock, -- Ada.Real_Time - RE_Time_Span, -- Ada.Real_Time - RE_Time_Span_Zero, -- Ada.Real_Time - RO_RT_Time, -- Ada.Real_Time - - RO_RT_Delay_Until, -- Ada.Real_Time.Delays - RO_RT_To_Duration, -- Ada.Real_Time.Delays - RE_Integer_64, -- Interfaces RE_Unsigned_8, -- Interfaces RE_Unsigned_16, -- Interfaces @@ -1078,6 +1084,7 @@ package Rtsfind is RE_DSA_Implementation, -- System.Partition_Interface RE_PCS_Version, -- System.Partition_Interface + RE_Get_RACW, -- System.Partition_Interface RE_Get_RCI_Package_Receiver, -- System.Partition_Interface RE_Get_Unique_Remote_Pointer, -- System.Partition_Interface RE_RACW_Stub_Type_Access, -- System.Partition_Interface @@ -1451,6 +1458,9 @@ package Rtsfind is RE_Mul_G, -- System.Vax_Float_Operations RE_Neg_F, -- System.Vax_Float_Operations RE_Neg_G, -- System.Vax_Float_Operations + RE_Return_D, -- System.Vax_Float_Operations + RE_Return_F, -- System.Vax_Float_Operations + RE_Return_G, -- System.Vax_Float_Operations RE_Sub_F, -- System.Vax_Float_Operations RE_Sub_G, -- System.Vax_Float_Operations @@ -1516,7 +1526,9 @@ package Rtsfind is RE_Lock_Entries, -- Tasking.Protected_Objects.Entries RO_PE_Get_Ceiling, -- Tasking.Protected_Objects.Entries RO_PE_Set_Ceiling, -- Tasking.Protected_Objects.Entries + RO_PE_Set_Entry_Name, -- Tasking.Protected_Objects.Entries RE_Unlock_Entries, -- Tasking.Protected_Objects.Entries + RE_Communication_Block, -- Protected_Objects.Operations RE_Protected_Entry_Call, -- Protected_Objects.Operations RE_Service_Entries, -- Protected_Objects.Operations @@ -1590,16 +1602,23 @@ package Rtsfind is RE_Free_Task, -- System.Tasking.Stages RE_Expunge_Unactivated_Tasks, -- System.Tasking.Stages RE_Move_Activation_Chain, -- System_Tasking_Stages + RO_TS_Set_Entry_Name, -- System.Tasking.Stages RE_Terminated); -- System.Tasking.Stages - -- The following declarations build a table that is indexed by the - -- RTE function to determine the unit containing the given entity. - -- This table is sorted in order of package names. + -- The following declarations build a table that is indexed by the RTE + -- function to determine the unit containing the given entity. This table + -- is sorted in order of package names. RE_Unit_Table : array (RE_Id) of RTU_Id := ( RE_Null => RTU_Null, + RO_CA_Time => Ada_Calendar, + + RO_CA_Delay_For => Ada_Calendar_Delays, + RO_CA_Delay_Until => Ada_Calendar_Delays, + RO_CA_To_Duration => Ada_Calendar_Delays, + RE_Set_Deadline => Ada_Dispatching_EDF, RE_Code_Loc => Ada_Exceptions, @@ -1633,6 +1652,16 @@ package Rtsfind is RE_Names => Ada_Interrupts_Names, + RE_Clock => Ada_Real_Time, + RE_Time_Span => Ada_Real_Time, + RE_Time_Span_Zero => Ada_Real_Time, + RO_RT_Time => Ada_Real_Time, + + RO_RT_Delay_Until => Ada_Real_Time_Delays, + RO_RT_To_Duration => Ada_Real_Time_Delays, + + RE_Timing_Event => Ada_Real_Time_Timing_Events, + RE_Root_Stream_Type => Ada_Streams, RE_Stream_Element => Ada_Streams, @@ -1720,22 +1749,13 @@ package Rtsfind is RE_TK_Tagged => Ada_Tags, RE_TK_Task => Ada_Tags, + RE_Set_Specific_Handler => Ada_Task_Termination, + RE_Specific_Handler => Ada_Task_Termination, + RE_Abort_Task => Ada_Task_Identification, RE_Current_Task => Ada_Task_Identification, RO_AT_Task_Id => Ada_Task_Identification, - RO_CA_Time => Ada_Calendar, - RO_CA_Delay_For => Ada_Calendar_Delays, - RO_CA_Delay_Until => Ada_Calendar_Delays, - RO_CA_To_Duration => Ada_Calendar_Delays, - - RE_Clock => Ada_Real_Time, - RE_Time_Span => Ada_Real_Time, - RE_Time_Span_Zero => Ada_Real_Time, - RO_RT_Time => Ada_Real_Time, - RO_RT_Delay_Until => Ada_Real_Time_Delays, - RO_RT_To_Duration => Ada_Real_Time_Delays, - RE_Integer_64 => Interfaces, RE_Unsigned_8 => Interfaces, RE_Unsigned_16 => Interfaces, @@ -2206,6 +2226,7 @@ package Rtsfind is RE_DSA_Implementation => System_Partition_Interface, RE_PCS_Version => System_Partition_Interface, + RE_Get_RACW => System_Partition_Interface, RE_Get_RCI_Package_Receiver => System_Partition_Interface, RE_Get_Unique_Remote_Pointer => System_Partition_Interface, RE_RACW_Stub_Type_Access => System_Partition_Interface, @@ -2579,6 +2600,9 @@ package Rtsfind is RE_Mul_G => System_Vax_Float_Operations, RE_Neg_F => System_Vax_Float_Operations, RE_Neg_G => System_Vax_Float_Operations, + RE_Return_D => System_Vax_Float_Operations, + RE_Return_F => System_Vax_Float_Operations, + RE_Return_G => System_Vax_Float_Operations, RE_Sub_F => System_Vax_Float_Operations, RE_Sub_G => System_Vax_Float_Operations, @@ -2652,8 +2676,11 @@ package Rtsfind is System_Tasking_Protected_Objects_Entries, RO_PE_Set_Ceiling => System_Tasking_Protected_Objects_Entries, + RO_PE_Set_Entry_Name => + System_Tasking_Protected_Objects_Entries, RE_Unlock_Entries => System_Tasking_Protected_Objects_Entries, + RE_Communication_Block => System_Tasking_Protected_Objects_Operations, RE_Protected_Entry_Call => @@ -2754,6 +2781,7 @@ package Rtsfind is RE_Free_Task => System_Tasking_Stages, RE_Expunge_Unactivated_Tasks => System_Tasking_Stages, RE_Move_Activation_Chain => System_Tasking_Stages, + RO_TS_Set_Entry_Name => System_Tasking_Stages, RE_Terminated => System_Tasking_Stages); -------------------------------- diff --git a/gcc/ada/s-carun8.ads b/gcc/ada/s-carun8.ads index 2bbbe6a08d3..fde805b45d3 100644 --- a/gcc/ada/s-carun8.ads +++ b/gcc/ada/s-carun8.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-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,20 +49,20 @@ package System.Compare_Array_Unsigned_8 is Right : System.Address; Left_Len : Natural; Right_Len : Natural) return Integer; - -- Compare the array starting at address Left of length Left_Len - -- with the array starting at address Right of length Right_Len. - -- The comparison is in the normal Ada semantic sense of array - -- comparison. The result is -1,0,+1 for Left<Right, Left=Right, - -- Left>Right respectively. This function works with 4 byte words - -- if the operands are aligned on 4-byte boundaries and long enough. + -- Compare the array starting at address Left of length Left_Len with the + -- array starting at address Right of length Right_Len. The comparison is + -- in the normal Ada semantic sense of array comparison. The result is -1, + -- 0, +1 for Left < Right, Left = Right, Left > Right respectively. This + -- function works with 4 byte words if the operands are aligned on 4-byte + -- boundaries and long enough. function Compare_Array_U8_Unaligned (Left : System.Address; Right : System.Address; Left_Len : Natural; Right_Len : Natural) return Integer; - -- Same functionality as Compare_Array_U8 but always proceeds by - -- bytes. Used when the caller knows that the operands are unaligned, - -- or short enough that it makes no sense to go by words. + -- Same functionality as Compare_Array_U8 but always proceeds by bytes. + -- Used when the caller knows that the operands are unaligned, or short + -- enough that it makes no sense to go by words. end System.Compare_Array_Unsigned_8; diff --git a/gcc/ada/s-casi16.adb b/gcc/ada/s-casi16.adb index 3980ce7d74f..846ec8dff00 100644 --- a/gcc/ada/s-casi16.adb +++ b/gcc/ada/s-casi16.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-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- -- @@ -44,10 +44,7 @@ package body System.Compare_Array_Signed_16 is for Half'Size use 16; -- Used to process operands by half words - type Uhalf is record - H : Half; - end record; - pragma Pack (Uhalf); + type Uhalf is new Half; for Uhalf'Alignment use 1; -- Used to process operands when unaligned @@ -110,8 +107,8 @@ package body System.Compare_Array_Signed_16 is else while Clen /= 0 loop - if U (L).H /= U (R).H then - if U (L).H > U (R).H then + if U (L).all /= U (R).all then + if U (L).all > U (R).all then return +1; else return -1; diff --git a/gcc/ada/s-casi32.adb b/gcc/ada/s-casi32.adb index 7ce89da47d7..7076918491c 100644 --- a/gcc/ada/s-casi32.adb +++ b/gcc/ada/s-casi32.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-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,10 +41,7 @@ package body System.Compare_Array_Signed_32 is for Word'Size use 32; -- Used to process operands by words - type Uword is record - W : Word; - end record; - pragma Pack (Uword); + type Uword is new Word; for Uword'Alignment use 1; -- Used to process operands when unaligned @@ -93,8 +90,8 @@ package body System.Compare_Array_Signed_32 is else while Clen /= 0 loop - if U (L).W /= U (R).W then - if U (L).W > U (R).W then + if U (L).all /= U (R).all then + if U (L).all > U (R).all then return +1; else return -1; diff --git a/gcc/ada/s-casi64.adb b/gcc/ada/s-casi64.adb index 0cbae743b1a..0bf9745d375 100644 --- a/gcc/ada/s-casi64.adb +++ b/gcc/ada/s-casi64.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-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,10 +41,7 @@ package body System.Compare_Array_Signed_64 is for Word'Size use 64; -- Used to process operands by words - type Uword is record - W : Word; - end record; - pragma Pack (Uword); + type Uword is new Word; for Uword'Alignment use 1; -- Used to process operands when unaligned @@ -93,8 +90,8 @@ package body System.Compare_Array_Signed_64 is else while Clen /= 0 loop - if U (L).W /= U (R).W then - if U (L).W > U (R).W then + if U (L).all /= U (R).all then + if U (L).all > U (R).all then return +1; else return -1; diff --git a/gcc/ada/s-caun16.adb b/gcc/ada/s-caun16.adb index 9bbbb968c83..b75d8bb9be3 100644 --- a/gcc/ada/s-caun16.adb +++ b/gcc/ada/s-caun16.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-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- -- @@ -44,10 +44,7 @@ package body System.Compare_Array_Unsigned_16 is for Half'Size use 16; -- Used to process operands by half words - type Uhalf is record - H : Half; - end record; - pragma Pack (Uhalf); + type Uhalf is new Half; for Uhalf'Alignment use 1; -- Used to process operands when unaligned @@ -110,8 +107,8 @@ package body System.Compare_Array_Unsigned_16 is else while Clen /= 0 loop - if U (L).H /= U (R).H then - if U (L).H > U (R).H then + if U (L).all /= U (R).all then + if U (L).all > U (R).all then return +1; else return -1; diff --git a/gcc/ada/s-caun32.adb b/gcc/ada/s-caun32.adb index c0289395214..a7dcd8f086d 100644 --- a/gcc/ada/s-caun32.adb +++ b/gcc/ada/s-caun32.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-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,10 +41,7 @@ package body System.Compare_Array_Unsigned_32 is for Word'Size use 32; -- Used to process operands by words - type Uword is record - W : Word; - end record; - pragma Pack (Uword); + type Uword is new Word; for Uword'Alignment use 1; -- Used to process operands when unaligned @@ -93,8 +90,8 @@ package body System.Compare_Array_Unsigned_32 is else while Clen /= 0 loop - if U (L).W /= U (R).W then - if U (L).W > U (R).W then + if U (L).all /= U (R).all then + if U (L).all > U (R).all then return +1; else return -1; diff --git a/gcc/ada/s-caun64.adb b/gcc/ada/s-caun64.adb index 10ff8176496..28d2c15bce6 100644 --- a/gcc/ada/s-caun64.adb +++ b/gcc/ada/s-caun64.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-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- -- @@ -40,10 +40,7 @@ package body System.Compare_Array_Unsigned_64 is type Word is mod 2 ** 64; -- Used to process operands by words - type Uword is record - W : Word; - end record; - pragma Pack (Uword); + type Uword is new Word; for Uword'Alignment use 1; -- Used to process operands when unaligned @@ -92,8 +89,8 @@ package body System.Compare_Array_Unsigned_64 is else while Clen /= 0 loop - if U (L).W /= U (R).W then - if U (L).W > U (R).W then + if U (L).all /= U (R).all then + if U (L).all > U (R).all then return +1; else return -1; diff --git a/gcc/ada/s-direio.adb b/gcc/ada/s-direio.adb index d7d94957c0b..c764a1c658e 100644 --- a/gcc/ada/s-direio.adb +++ b/gcc/ada/s-direio.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- -- @@ -251,15 +251,23 @@ package body System.Direct_IO is ----------- procedure Reset (File : in out File_Type; Mode : FCB.File_Mode) is + pragma Unmodified (File); + -- File is actually modified via Unrestricted_Access below, but + -- GNAT will generate a warning anyway. + begin - FIO.Reset (AP (File), Mode); + FIO.Reset (AP (File)'Unrestricted_Access, Mode); File.Index := 1; File.Last_Op := Op_Read; end Reset; procedure Reset (File : in out File_Type) is + pragma Unmodified (File); + -- File is actually modified via Unrestricted_Access below, but + -- GNAT will generate a warning anyway. + begin - FIO.Reset (AP (File)); + FIO.Reset (AP (File)'Unrestricted_Access); File.Index := 1; File.Last_Op := Op_Read; end Reset; diff --git a/gcc/ada/s-direio.ads b/gcc/ada/s-direio.ads index a43ebb67fc7..3e32c982d42 100644 --- a/gcc/ada/s-direio.ads +++ b/gcc/ada/s-direio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, 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- -- @@ -111,7 +111,6 @@ package System.Direct_IO is Size : Interfaces.C_Streams.size_t); procedure Reset (File : in out File_Type; Mode : FCB.File_Mode); - procedure Reset (File : in out File_Type); procedure Set_Index (File : File_Type; To : Positive_Count); @@ -125,4 +124,21 @@ package System.Direct_IO is Zeroes : System.Storage_Elements.Storage_Array); -- Note: Zeroes is the buffer of zeroes used to fill out partial records + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, FCB.File_Mode), + Mechanism => (File => Reference)); + end System.Direct_IO; diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index f34e68ab696..bfe7d6b0cc5 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -206,9 +206,10 @@ package body System.File_IO is -- Close -- ----------- - procedure Close (File : in out AFCB_Ptr) is + procedure Close (File_Ptr : access AFCB_Ptr) is Close_Status : int := 0; Dup_Strm : Boolean := False; + File : AFCB_Ptr renames File_Ptr.all; begin -- Take a task lock, to protect the global data value Open_Files @@ -296,7 +297,8 @@ package body System.File_IO is -- Delete -- ------------ - procedure Delete (File : in out AFCB_Ptr) is + procedure Delete (File_Ptr : access AFCB_Ptr) is + File : AFCB_Ptr renames File_Ptr.all; begin Check_File_Open (File); @@ -308,7 +310,7 @@ package body System.File_IO is Filename : aliased constant String := File.Name.all; begin - Close (File); + Close (File_Ptr); -- Now unlink the external file. Note that we use the full name -- in this unlink, because the working directory may have changed @@ -354,7 +356,7 @@ package body System.File_IO is procedure Finalize (V : in out File_IO_Clean_Up_Type) is pragma Warnings (Off, V); - Fptr1 : AFCB_Ptr; + Fptr1 : aliased AFCB_Ptr; Fptr2 : AFCB_Ptr; Discard : int; @@ -371,7 +373,7 @@ package body System.File_IO is Fptr1 := Open_Files; while Fptr1 /= null loop Fptr2 := Fptr1.Next; - Close (Fptr1); + Close (Fptr1'Access); Fptr1 := Fptr2; end loop; @@ -1058,17 +1060,19 @@ package body System.File_IO is -- The reset which does not change the mode simply does a rewind - procedure Reset (File : in out AFCB_Ptr) is + procedure Reset (File_Ptr : access AFCB_Ptr) is + File : AFCB_Ptr renames File_Ptr.all; begin Check_File_Open (File); - Reset (File, File.Mode); + Reset (File_Ptr, File.Mode); end Reset; -- The reset with a change in mode is done using freopen, and is -- not permitted except for regular files (since otherwise there -- is no name for the freopen, and in any case it seems meaningless) - procedure Reset (File : in out AFCB_Ptr; Mode : File_Mode) is + procedure Reset (File_Ptr : access AFCB_Ptr; Mode : File_Mode) is + File : AFCB_Ptr renames File_Ptr.all; Fopstr : aliased Fopen_String; begin @@ -1106,7 +1110,7 @@ package body System.File_IO is (File.Name.all'Address, Fopstr'Address, File.Stream, File.Encoding); if File.Stream = NULL_Stream then - Close (File); + Close (File_Ptr); raise Use_Error; else diff --git a/gcc/ada/s-fileio.ads b/gcc/ada/s-fileio.ads index 6cd787104d1..f69c580856b 100644 --- a/gcc/ada/s-fileio.ads +++ b/gcc/ada/s-fileio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, 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- -- @@ -100,20 +100,23 @@ package System.File_IO is -- this allocated file control block. If the open/create fails, then the -- fields of File are undefined, and File_Ptr is unchanged. - procedure Close (File : in out FCB.AFCB_Ptr); + procedure Close (File_Ptr : access FCB.AFCB_Ptr); -- The file is closed, all storage associated with it is released, and -- File is set to null. Note that this routine calls AFCB_Close to perform -- any specialized close actions, then closes the file at the system level, -- then frees the mode and form strings, and finally calls AFCB_Free to - -- free the file control block itself, setting File to null. + -- free the file control block itself, setting File.all to null. Note that + -- for this assignment to be done in all cases, including those where + -- an exception is raised, we can't use an IN OUT parameter (which would + -- not be copied back in case of abnormal return). - procedure Delete (File : in out FCB.AFCB_Ptr); + procedure Delete (File_Ptr : access FCB.AFCB_Ptr); -- The indicated file is unlinked - procedure Reset (File : in out FCB.AFCB_Ptr; Mode : FCB.File_Mode); + procedure Reset (File_Ptr : access FCB.AFCB_Ptr; Mode : FCB.File_Mode); -- The file is reset, and the mode changed as indicated - procedure Reset (File : in out FCB.AFCB_Ptr); + procedure Reset (File_Ptr : access FCB.AFCB_Ptr); -- The files is reset, and the mode is unchanged function Mode (File : FCB.AFCB_Ptr) return FCB.File_Mode; diff --git a/gcc/ada/s-osinte-aix.adb b/gcc/ada/s-osinte-aix.adb index 469ce3bfbb4..cdaff52b20d 100644 --- a/gcc/ada/s-osinte-aix.adb +++ b/gcc/ada/s-osinte-aix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2008, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -65,13 +65,18 @@ package body System.OS_Interface is Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + begin -- For the case SCHED_OTHER the only valid priority across all supported - -- versions of AIX is 1. Otherwise, for SCHED_RR and SCHED_FIFO, the - -- system defines priorities in the range 1 .. 127. This means that we - -- must map System.Any_Priority in the range 0 .. 126 to 1 .. 127. + -- versions of AIX is 1 (note that the scheduling policy can be set + -- with the pragma Task_Dispatching_Policy or setting the time slice + -- value). Otherwise, for SCHED_RR and SCHED_FIFO, the system defines + -- priorities in the range 1 .. 127. This means that we must map + -- System.Any_Priority in the range 0 .. 126 to 1 .. 127. - if Dispatching_Policy = ' ' then + if Dispatching_Policy = ' ' and then Time_Slice_Val < 0 then return 1; else return Interfaces.C.int (Prio) + 1; diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index 2c5ffb60832..bbe422377de 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -89,6 +89,7 @@ package System.Rident is No_Implicit_Loops, -- GNAT No_Initialize_Scalars, -- GNAT No_Local_Allocators, -- (RM H.4(8)) + No_Local_Timing_Events, -- (RM D.7(10.2/2)) No_Local_Protected_Objects, -- GNAT No_Nested_Finalization, -- (RM D.7(4)) No_Protected_Type_Allocators, -- GNAT @@ -99,6 +100,7 @@ package System.Rident is No_Requeue_Statements, -- GNAT No_Secondary_Stack, -- GNAT No_Select_Statements, -- GNAT (Ravenscar) + No_Specific_Termination_Handlers, -- (RM D.7(10.7/2)) No_Standard_Storage_Pools, -- GNAT No_Streams, -- GNAT No_Task_Allocators, -- (RM D.7(7)) diff --git a/gcc/ada/s-stausa.adb b/gcc/ada/s-stausa.adb index 6eb8a0ca6ef..07668da318e 100644 --- a/gcc/ada/s-stausa.adb +++ b/gcc/ada/s-stausa.adb @@ -205,10 +205,10 @@ package body System.Stack_Usage is Result_Array := new Result_Array_Type (1 .. Buffer_Size); Result_Array.all := (others => - (Task_Name => (others => ASCII.NUL), - Measure => 0, - Max_Size => 0, - Overflow_Guard => 0)); + (Task_Name => (others => ASCII.NUL), + Min_Measure => 0, + Max_Measure => 0, + Max_Size => 0)); -- Set the Is_Enabled flag to true, so that the task wrapper knows that -- it has to handle dynamic stack analysis @@ -233,7 +233,7 @@ package body System.Stack_Usage is (Environment_Task_Analyzer, "ENVIRONMENT TASK", Stack_Size, - 0, + Stack_Size, System.Storage_Elements.To_Integer (Bottom_Of_Stack'Address)); Fill_Stack (Environment_Task_Analyzer); @@ -253,32 +253,49 @@ package body System.Stack_Usage is ---------------- procedure Fill_Stack (Analyzer : in out Stack_Analyzer) is - -- Change the local variables and parameters of this function with -- super-extra care. The more the stack frame size of this function is -- big, the more an "instrumentation threshold at writing" error is -- likely to happen. - Stack : aliased Stack_Slots (1 .. Analyzer.Size / Bytes_Per_Pattern); + Current_Stack_Level : aliased Integer; begin - Stack := (others => Analyzer.Pattern); + -- Reajust the pattern size. When we arrive in this function, there is + -- already a given amount of stack used, that we won't analyze. + + Analyzer.Stack_Used_When_Filling := + Stack_Size + (Analyzer.Bottom_Of_Stack, + To_Stack_Address (Current_Stack_Level'Address)) + + Natural (Current_Stack_Level'Size); + + Analyzer.Pattern_Size := + Analyzer.Pattern_Size - Analyzer.Stack_Used_When_Filling; + + declare + Stack : aliased Stack_Slots + (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); + + begin + Stack := (others => Analyzer.Pattern); - Analyzer.Stack_Overlay_Address := Stack'Address; + Analyzer.Stack_Overlay_Address := Stack'Address; - Analyzer.Bottom_Pattern_Mark := - To_Stack_Address (Stack (Bottom_Slot_Index_In (Stack))'Address); - Analyzer.Top_Pattern_Mark := - To_Stack_Address (Stack (Top_Slot_Index_In (Stack))'Address); + Analyzer.Bottom_Pattern_Mark := + To_Stack_Address (Stack (Bottom_Slot_Index_In (Stack))'Address); + Analyzer.Top_Pattern_Mark := + To_Stack_Address (Stack (Top_Slot_Index_In (Stack))'Address); - -- If Arr has been packed, the following assertion must be true (we add - -- the size of the element whose address is: - -- Min (Analyzer.Inner_Pattern_Mark, Analyzer.Outer_Pattern_Mark)): + -- If Arr has been packed, the following assertion must be true (we + -- add the size of the element whose address is: + -- Min (Analyzer.Inner_Pattern_Mark, Analyzer.Outer_Pattern_Mark)): - pragma Assert - (Analyzer.Size = - Stack_Size - (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Pattern_Mark)); + pragma Assert + (Analyzer.Pattern_Size = + Stack_Size + (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Pattern_Mark)); + end; end Fill_Stack; ------------------------- @@ -286,25 +303,25 @@ package body System.Stack_Usage is ------------------------- procedure Initialize_Analyzer - (Analyzer : in out Stack_Analyzer; - Task_Name : String; - Size : Natural; - Overflow_Guard : Natural; - Bottom : Stack_Address; - Pattern : Unsigned_32 := 16#DEAD_BEEF#) + (Analyzer : in out Stack_Analyzer; + Task_Name : String; + Stack_Size : Natural; + Max_Pattern_Size : Natural; + Bottom : Stack_Address; + Pattern : Unsigned_32 := 16#DEAD_BEEF#) is begin -- Initialize the analyzer fields Analyzer.Bottom_Of_Stack := Bottom; - Analyzer.Size := Size; + Analyzer.Stack_Size := Stack_Size; + Analyzer.Pattern_Size := Max_Pattern_Size; Analyzer.Pattern := Pattern; Analyzer.Result_Id := Next_Id; Analyzer.Task_Name := (others => ' '); - -- Compute the task name, and truncate it if it's bigger than - -- Task_Name_Length + -- Compute the task name, and truncate if bigger than Task_Name_Length if Task_Name'Length <= Task_Name_Length then Analyzer.Task_Name (1 .. Task_Name'Length) := Task_Name; @@ -314,8 +331,6 @@ package body System.Stack_Usage is Task_Name'First + Task_Name_Length - 1); end if; - Analyzer.Overflow_Guard := Overflow_Guard; - Next_Id := Next_Id + 1; end Initialize_Analyzer; @@ -346,7 +361,7 @@ package body System.Stack_Usage is -- is, the more an "instrumentation threshold at reading" error is -- likely to happen. - Stack : Stack_Slots (1 .. Analyzer.Size / Bytes_Per_Pattern); + Stack : Stack_Slots (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); for Stack'Address use Analyzer.Stack_Overlay_Address; begin @@ -382,10 +397,8 @@ package body System.Stack_Usage is --------------------- function Get_Usage_Range (Result : Task_Result) return String is - Min_Used_Str : constant String := - Natural'Image (Result.Measure); - Max_Used_Str : constant String := - Natural'Image (Result.Measure + Result.Overflow_Guard); + Min_Used_Str : constant String := Natural'Image (Result.Min_Measure); + Max_Used_Str : constant String := Natural'Image (Result.Max_Measure); begin return "[" & Min_Used_Str (2 .. Min_Used_Str'Last) & " -" & Max_Used_Str & "]"; @@ -458,8 +471,8 @@ package body System.Stack_Usage is for J in Result_Array'Range loop exit when J >= Next_Id; - if Result_Array (J).Measure - > Result_Array (Max_Actual_Use_Result_Id).Measure + if Result_Array (J).Max_Measure + > Result_Array (Max_Actual_Use_Result_Id).Max_Measure then Max_Actual_Use_Result_Id := J; end if; @@ -526,15 +539,18 @@ package body System.Stack_Usage is ------------------- procedure Report_Result (Analyzer : Stack_Analyzer) is - Result : constant Task_Result := - (Task_Name => Analyzer.Task_Name, - Max_Size => Analyzer.Size + Analyzer.Overflow_Guard, - Measure => Stack_Size - (Analyzer.Topmost_Touched_Mark, - Analyzer.Bottom_Of_Stack), - Overflow_Guard => Analyzer.Overflow_Guard - - Natural (Analyzer.Bottom_Of_Stack - - Analyzer.Bottom_Pattern_Mark)); + Measure : constant Natural := + Stack_Size + (Analyzer.Topmost_Touched_Mark, + Analyzer.Bottom_Of_Stack) + + Analyzer.Stack_Used_When_Filling; + + Result : constant Task_Result := + (Task_Name => Analyzer.Task_Name, + Max_Size => Analyzer.Stack_Size, + Min_Measure => Measure, + Max_Measure => Measure + Analyzer.Stack_Size + - Analyzer.Pattern_Size); begin if Analyzer.Result_Id in Result_Array'Range then @@ -550,7 +566,7 @@ package body System.Stack_Usage is Result_Str_Len : constant Natural := Get_Usage_Range (Result)'Length; Size_Str_Len : constant Natural := - Natural'Image (Analyzer.Size)'Length; + Natural'Image (Analyzer.Stack_Size)'Length; Max_Stack_Size_Len : Natural; Max_Actual_Use_Len : Natural; diff --git a/gcc/ada/s-stausa.ads b/gcc/ada/s-stausa.ads index b309c3735e8..7c500bffaec 100644 --- a/gcc/ada/s-stausa.ads +++ b/gcc/ada/s-stausa.ads @@ -41,10 +41,6 @@ package System.Stack_Usage is package SSE renames System.Storage_Elements; - -- The alignment clause seems dubious, what about architectures where - -- the maximum alignment is less than 4??? - -- Anyway, why not use Interfaces.Unsigned_32??? - subtype Stack_Address is SSE.Integer_Address; -- Address on the stack @@ -53,9 +49,8 @@ package System.Stack_Usage is renames System.Storage_Elements.To_Integer; type Stack_Analyzer is private; - -- Type of the stack analyzer tool. It is used to fill a portion of - -- the stack with Pattern, and to compute the stack used after some - -- execution. + -- Type of the stack analyzer tool. It is used to fill a portion of the + -- stack with Pattern, and to compute the stack used after some execution. -- Usage: @@ -90,9 +85,9 @@ package System.Stack_Usage is -- Errors: -- -- We are instrumenting the code to measure the stack used by the user - -- code. This method has a number of systematic errors, but several - -- methods can be used to evaluate or reduce those errors. Here are - -- those errors and the strategy that we use to deal with them: + -- code. This method has a number of systematic errors, but several methods + -- can be used to evaluate or reduce those errors. Here are those errors + -- and the strategy that we use to deal with them: -- Bottom offset: @@ -164,8 +159,8 @@ package System.Stack_Usage is -- Description: The pattern zone does not fit on the stack. This may -- lead to an erroneous execution. - -- Strategy: Specify a storage size that is bigger than the size of the - -- pattern. 2 times bigger should be enough. + -- Strategy: Specify a storage size that is bigger than the size of the + -- pattern. 2 times bigger should be enough. -- Augmentation of the user stack frames: @@ -211,15 +206,18 @@ package System.Stack_Usage is -- Analyzer.Top_Pattern_Mark procedure Initialize_Analyzer - (Analyzer : in out Stack_Analyzer; - Task_Name : String; - Size : Natural; - Overflow_Guard : Natural; - Bottom : Stack_Address; - Pattern : Interfaces.Unsigned_32 := 16#DEAD_BEEF#); + (Analyzer : in out Stack_Analyzer; + Task_Name : String; + Stack_Size : Natural; + Max_Pattern_Size : Natural; + Bottom : Stack_Address; + Pattern : Interfaces.Unsigned_32 := 16#DEAD_BEEF#); -- Should be called before any use of a Stack_Analyzer, to initialize it. - -- Size is the size of the pattern zone. Bottom should be a close - -- approximation of the caller base frame address. + -- Max_Pattern_Size is the size of the pattern zone, might be smaller than + -- the full stack size in order to take into account e.g. the secondary + -- stack and a guard against overflow. The actual size taken will be + -- reajusted with data already used at the time the stack is actually + -- filled. Is_Enabled : Boolean := False; -- When this flag is true, then stack analysis is enabled @@ -274,7 +272,10 @@ private Task_Name : String (1 .. Task_Name_Length); -- Name of the task - Size : Natural; + Stack_Size : Natural; + -- Entire size of the analyzed stack + + Pattern_Size : Natural; -- Size of the pattern zone Pattern : Pattern_Type; @@ -304,9 +305,9 @@ private -- Id of the result. If less than value given to gnatbind -u corresponds -- to the location in the result array of result for the current task. - Overflow_Guard : Natural; - -- The amount of bytes that won't be analyzed in order to prevent - -- writing out of the stack + Stack_Used_When_Filling : Natural := 0; + -- Amount of stack that was already used when actually filling the + -- memory, and therefore not analyzed. end record; Environment_Task_Analyzer : Stack_Analyzer; @@ -314,10 +315,16 @@ private Compute_Environment_Task : Boolean; type Task_Result is record - Task_Name : String (1 .. Task_Name_Length); - Measure : Natural; - Max_Size : Natural; - Overflow_Guard : Natural; + Task_Name : String (1 .. Task_Name_Length); + + Min_Measure : Natural; + -- Minimum value for the measure + + Max_Measure : Natural; + -- Maximum value for the measure, taking into account the actual size + -- of the pattern filled. + + Max_Size : Natural; end record; type Result_Array_Type is array (Positive range <>) of Task_Result; diff --git a/gcc/ada/s-tasinf-mingw.adb b/gcc/ada/s-tasinf-mingw.adb index 33b9c739853..644192b0a94 100644 --- a/gcc/ada/s-tasinf-mingw.adb +++ b/gcc/ada/s-tasinf-mingw.adb @@ -33,6 +33,12 @@ -- This is the Windows (native) version of this module +with System.OS_Interface; +pragma Unreferenced (System.OS_Interface); +-- System.OS_Interface is not used today, but the protocol between the +-- run-time and the binder is that any tasking application uses +-- System.OS_Interface, so notify the binder with this "with" clause. + package body System.Task_Info is N_CPU : Natural := 0; diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb index 7d78f5112a7..822dc9320fc 100644 --- a/gcc/ada/s-taskin.adb +++ b/gcc/ada/s-taskin.adb @@ -35,6 +35,8 @@ pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during tasking -- operations. It causes infinite loops and other problems. +with Ada.Unchecked_Deallocation; + with System.Task_Primitives.Operations; with System.Storage_Elements; @@ -42,6 +44,19 @@ package body System.Tasking is package STPO renames System.Task_Primitives.Operations; + ---------------------------- + -- Free_Entry_Names_Array -- + ---------------------------- + + procedure Free_Entry_Names_Array (Obj : in out Entry_Names_Array) is + procedure Free_String is new + Ada.Unchecked_Deallocation (String, String_Access); + begin + for Index in Obj'Range loop + Free_String (Obj (Index)); + end loop; + end Free_Entry_Names_Array; + --------------------- -- Detect_Blocking -- --------------------- diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index 70e755da016..87afc802e54 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -237,6 +237,19 @@ package System.Tasking is type Task_Entry_Queue_Array is array (Task_Entry_Index range <>) of Entry_Queue; + -- A data structure which contains the string names of entries and entry + -- family members. + + type String_Access is access all String; + + type Entry_Names_Array is + array (Entry_Index range <>) of String_Access; + + type Entry_Names_Array_Access is access all Entry_Names_Array; + + procedure Free_Entry_Names_Array (Obj : in out Entry_Names_Array); + -- Deallocate all string names contained in an entry names array + ---------------------------------- -- Entry_Call_Record definition -- ---------------------------------- @@ -441,19 +454,17 @@ package System.Tasking is -- and rendezvous. -- -- Ada 95 notes: In Ada 95, this field will be transferred to the - -- Priority field of an Entry_Calls component when an entry call - -- is initiated. The Priority of the Entry_Calls component will not - -- change for the duration of the call. The accepting task can - -- use it to boost its own priority without fear of its changing in - -- the meantime. + -- Priority field of an Entry_Calls component when an entry call is + -- initiated. The Priority of the Entry_Calls component will not change + -- for the duration of the call. The accepting task can use it to boost + -- its own priority without fear of its changing in the meantime. -- - -- This can safely be used in the priority ordering - -- of entry queues. Once a call is queued, its priority does not - -- change. + -- This can safely be used in the priority ordering of entry queues. + -- Once a call is queued, its priority does not change. -- - -- Since an entry call cannot be made while executing - -- a protected action, the priority of a task will never reflect a - -- priority ceiling change at the point of an entry call. + -- Since an entry call cannot be made while executing a protected + -- action, the priority of a task will never reflect a priority ceiling + -- change at the point of an entry call. -- -- Protection: Only written by Self, and only accessed when Acceptor -- accepts an entry or when Created activates, at which points Self is @@ -467,8 +478,8 @@ package System.Tasking is -- can be read/written from protected interrupt handlers. Task_Image : String (1 .. System.Parameters.Max_Task_Image_Length); - -- Hold a string that provides a readable id for task, - -- built from the variable of which it is a value or component. + -- Hold a string that provides a readable id for task, built from the + -- variable of which it is a value or component. Task_Image_Len : Natural; -- Actual length of Task_Image @@ -489,7 +500,7 @@ package System.Tasking is Task_Arg : System.Address; -- The argument to task procedure. Provide a handle for discriminant - -- information + -- information. -- -- Protection: Part of the synchronization between Self and Activator. -- Activator writes it, once, before Self starts executing. Thereafter, @@ -605,10 +616,9 @@ package System.Tasking is -- Restricted_Ada_Task_Control_Block -- --------------------------------------- - -- This type should only be used by the restricted GNARLI and by - -- restricted GNULL implementations to allocate an ATCB (see - -- System.Task_Primitives.Operations.New_ATCB) that will take - -- significantly less memory. + -- This type should only be used by the restricted GNARLI and by restricted + -- GNULL implementations to allocate an ATCB (see System.Task_Primitives. + -- Operations.New_ATCB) that will take significantly less memory. -- Note that the restricted GNARLI should only access fields that are -- present in the Restricted_Ada_Task_Control_Block structure. @@ -855,6 +865,11 @@ package System.Tasking is -- associated with protected objects or task entries, and are protected -- by the protected object lock or Acceptor.L, respectively. + Entry_Names : Entry_Names_Array_Access := null; + -- An array of string names which denotes entry [family member] names. + -- The structure is indexed by task entry index and contains Entry_Num + -- components. + New_Base_Priority : System.Any_Priority; -- New value for Base_Priority (for dynamic priorities package) -- diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index d3c6739fb3d..d28cb7e42d2 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -88,6 +88,9 @@ package body System.Tasking.Stages is procedure Free is new Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + procedure Free_Entry_Names (T : Task_Id); + -- Deallocate all string names associated with task entries + procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id); -- This procedure outputs the task specific message for exception -- tracing purposes. @@ -465,7 +468,8 @@ package body System.Tasking.Stages is Elaborated : Access_Boolean; Chain : in out Activation_Chain; Task_Image : String; - Created_Task : out Task_Id) + Created_Task : out Task_Id; + Build_Entry_Names : Boolean) is T, P : Task_Id; Self_ID : constant Task_Id := STPO.Self; @@ -605,6 +609,11 @@ package body System.Tasking.Stages is T.Common.Task_Image_Len := Len; end if; + if Build_Entry_Names then + T.Entry_Names := + new Entry_Names_Array (1 .. Entry_Index (Num_Entries)); + end if; + Unlock (Self_ID); Unlock_RTS; @@ -816,6 +825,26 @@ package body System.Tasking.Stages is end Finalize_Global_Tasks; + ---------------------- + -- Free_Entry_Names -- + ---------------------- + + procedure Free_Entry_Names (T : Task_Id) is + Names : Entry_Names_Array_Access := T.Entry_Names; + + procedure Free_Entry_Names_Array_Access is new + Ada.Unchecked_Deallocation + (Entry_Names_Array, Entry_Names_Array_Access); + + begin + if Names = null then + return; + end if; + + Free_Entry_Names_Array (Names.all); + Free_Entry_Names_Array_Access (Names); + end Free_Entry_Names; + --------------- -- Free_Task -- --------------- @@ -837,6 +866,7 @@ package body System.Tasking.Stages is Initialization.Task_Unlock (Self_Id); + Free_Entry_Names (T); System.Task_Primitives.Operations.Finalize_TCB (T); -- If the task is not terminated, then we simply ignore the call. This @@ -895,6 +925,23 @@ package body System.Tasking.Stages is Initialization.Undefer_Abort (Self_ID); end Move_Activation_Chain; + -- Compiler interface only. Do not call from within the RTS. + + -------------------- + -- Set_Entry_Name -- + -------------------- + + procedure Set_Entry_Name + (T : Task_Id; + Pos : Task_Entry_Index; + Val : String_Access) + is + begin + pragma Assert (T.Entry_Names /= null); + + T.Entry_Names (Entry_Index (Pos)) := Val; + end Set_Entry_Name; + ------------------ -- Task_Wrapper -- ------------------ @@ -1018,8 +1065,6 @@ package body System.Tasking.Stages is Overflow_Guard := Big_Overflow_Guard; end if; - Size := Size - Overflow_Guard; - if not Parameters.Sec_Stack_Dynamic then Self_ID.Common.Compiler_Data.Sec_Stack_Addr := Secondary_Stack'Address; @@ -1031,14 +1076,18 @@ package body System.Tasking.Stages is Self_ID.Common.Task_Alternate_Stack := Task_Alternate_Stack'Address; end if; + Size := Size - Overflow_Guard; + if System.Stack_Usage.Is_Enabled then STPO.Lock_RTS; - Initialize_Analyzer (Self_ID.Common.Analyzer, - Self_ID.Common.Task_Image - (1 .. Self_ID.Common.Task_Image_Len), - Size, - Overflow_Guard, - SSE.To_Integer (Bottom_Of_Stack'Address)); + Initialize_Analyzer + (Self_ID.Common.Analyzer, + Self_ID.Common.Task_Image + (1 .. Self_ID.Common.Task_Image_Len), + Natural + (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size), + Size, + SSE.To_Integer (Bottom_Of_Stack'Address)); STPO.Unlock_RTS; Fill_Stack (Self_ID.Common.Analyzer); end if; @@ -1419,15 +1468,15 @@ package body System.Tasking.Stages is -------------------------------- procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is - C : Task_Id; - P : Task_Id; - CM : constant Master_Level := Self_ID.Master_Within; - T : aliased Task_Id; + C : Task_Id; + P : Task_Id; + CM : constant Master_Level := Self_ID.Master_Within; + T : aliased Task_Id; To_Be_Freed : Task_Id; - -- This is a list of ATCBs to be freed, after we have released - -- all RTS locks. This is necessary because of the locking order - -- rules, since the storage manager uses Global_Task_Lock. + -- This is a list of ATCBs to be freed, after we have released all RTS + -- locks. This is necessary because of the locking order rules, since + -- the storage manager uses Global_Task_Lock. pragma Warnings (Off); function Check_Unactivated_Tasks return Boolean; @@ -1877,6 +1926,7 @@ package body System.Tasking.Stages is Unlock_RTS; end if; + Free_Entry_Names (T); System.Task_Primitives.Operations.Finalize_TCB (T); end Vulnerable_Free_Task; diff --git a/gcc/ada/s-tassta.ads b/gcc/ada/s-tassta.ads index 36f0fbfc3f2..cee2d3b958e 100644 --- a/gcc/ada/s-tassta.ads +++ b/gcc/ada/s-tassta.ads @@ -180,7 +180,8 @@ package System.Tasking.Stages is Elaborated : Access_Boolean; Chain : in out Activation_Chain; Task_Image : String; - Created_Task : out Task_Id); + Created_Task : out Task_Id; + Build_Entry_Names : Boolean); -- Compiler interface only. Do not call from within the RTS. -- This must be called to create a new task. -- @@ -190,7 +191,7 @@ package System.Tasking.Stages is -- Task_Info is the task info associated with the created task, or -- Unspecified_Task_Info if none. -- Relative_Deadline is the relative deadline associated with the created - -- task by means of a pragma Relative_Deadline, or 0.0 if none. + -- task by means of a pragma Relative_Deadline, or 0.0 if none. -- State is the compiler generated task's procedure body -- Discriminants is a pointer to a limited record whose discriminants -- are those of the task to create. This parameter should be passed as @@ -205,6 +206,8 @@ package System.Tasking.Stages is -- run time can store to ease the debugging and the -- Ada.Task_Identification facility. -- Created_Task is the resulting task. + -- Build_Entry_Names is a flag which controls the allocation of the data + -- structure which stores all entry names. -- -- This procedure can raise Storage_Error if the task creation failed. @@ -276,6 +279,13 @@ package System.Tasking.Stages is -- that doesn't happen, they will never be activated, and will become -- terminated on leaving the return statement. + procedure Set_Entry_Name + (T : Task_Id; + Pos : Task_Entry_Index; + Val : String_Access); + -- This is called by the compiler to map a string which denotes an entry + -- name to a task entry index. + function Terminated (T : Task_Id) return Boolean; -- This is called by the compiler to implement the 'Terminated attribute. -- Though is not required to be so by the ARM, we choose to synchronize diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb index 986a30af9e8..38126956b9e 100644 --- a/gcc/ada/s-tpoben.adb +++ b/gcc/ada/s-tpoben.adb @@ -43,6 +43,8 @@ -- Note: the compiler generates direct calls to this interface, via Rtsfind +with Ada.Unchecked_Deallocation; + with System.Task_Primitives.Operations; with System.Restrictions; with System.Parameters; @@ -58,6 +60,13 @@ package body System.Tasking.Protected_Objects.Entries is use Parameters; use Task_Primitives.Operations; + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Free_Entry_Names (Object : Protection_Entries); + -- Deallocate all string names associated with protected entries + ---------------- -- Local Data -- ---------------- @@ -134,6 +143,8 @@ package body System.Tasking.Protected_Objects.Entries is end loop; end loop; + Free_Entry_Names (Object); + Object.Finalized := True; if Single_Lock then @@ -145,6 +156,26 @@ package body System.Tasking.Protected_Objects.Entries is STPO.Finalize_Lock (Object.L'Unrestricted_Access); end Finalize; + ---------------------- + -- Free_Entry_Names -- + ---------------------- + + procedure Free_Entry_Names (Object : Protection_Entries) is + Names : Entry_Names_Array_Access := Object.Entry_Names; + + procedure Free_Entry_Names_Array_Access is new + Ada.Unchecked_Deallocation + (Entry_Names_Array, Entry_Names_Array_Access); + + begin + if Names = null then + return; + end if; + + Free_Entry_Names_Array (Names.all); + Free_Entry_Names_Array_Access (Names); + end Free_Entry_Names; + ----------------- -- Get_Ceiling -- ----------------- @@ -177,14 +208,15 @@ package body System.Tasking.Protected_Objects.Entries is Ceiling_Priority : Integer; Compiler_Info : System.Address; Entry_Bodies : Protected_Entry_Body_Access; - Find_Body_Index : Find_Body_Index_Access) + Find_Body_Index : Find_Body_Index_Access; + Build_Entry_Names : Boolean) is Init_Priority : Integer := Ceiling_Priority; Self_ID : constant Task_Id := STPO.Self; begin if Init_Priority = Unspecified_Priority then - Init_Priority := System.Priority'Last; + Init_Priority := System.Priority'Last; end if; if Locking_Policy = 'C' @@ -213,6 +245,11 @@ package body System.Tasking.Protected_Objects.Entries is Object.Entry_Queues (E).Head := null; Object.Entry_Queues (E).Tail := null; end loop; + + if Build_Entry_Names then + Object.Entry_Names := + new Entry_Names_Array (1 .. Entry_Index (Object.Num_Entries)); + end if; end Initialize_Protection_Entries; ------------------ @@ -358,6 +395,21 @@ package body System.Tasking.Protected_Objects.Entries is end Set_Ceiling; -------------------- + -- Set_Entry_Name -- + -------------------- + + procedure Set_Entry_Name + (Object : Protection_Entries'Class; + Pos : Protected_Entry_Index; + Val : String_Access) + is + begin + pragma Assert (Object.Entry_Names /= null); + + Object.Entry_Names (Entry_Index (Pos)) := Val; + end Set_Entry_Name; + + -------------------- -- Unlock_Entries -- -------------------- diff --git a/gcc/ada/s-tpoben.ads b/gcc/ada/s-tpoben.ads index 9feba091396..b3dea7b03d2 100644 --- a/gcc/ada/s-tpoben.ads +++ b/gcc/ada/s-tpoben.ads @@ -113,7 +113,7 @@ package System.Tasking.Protected_Objects.Entries is Old_Base_Priority : System.Any_Priority; -- Task's base priority when the protected operation was called - Pending_Action : Boolean; + Pending_Action : Boolean; -- Flag indicating that priority has been dipped temporarily in order -- to avoid violating the priority ceiling of the lock associated with -- this protected object, in Lock_Server. The flag tells Unlock_Server @@ -132,11 +132,16 @@ package System.Tasking.Protected_Objects.Entries is -- Pointer to an array containing the executable code for all entry -- bodies of a protected type. - -- The following function maps the entry index in a call (which denotes - -- the queue to the proper entry) into the body of the entry. - Find_Body_Index : Find_Body_Index_Access; - Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries); + -- A function which maps the entry index in a call (which denotes the + -- queue of the proper entry) into the body of the entry. + + Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries); + + Entry_Names : Entry_Names_Array_Access := null; + -- An array of string names which denotes entry [family member] names. + -- The structure is indexed by protected entry index and contains Num_ + -- Entries components. end record; -- No default initial values for this type, since call records @@ -164,11 +169,12 @@ package System.Tasking.Protected_Objects.Entries is -- System.Tasking.Protected_Objects.Initialize_Protection. procedure Initialize_Protection_Entries - (Object : Protection_Entries_Access; - Ceiling_Priority : Integer; - Compiler_Info : System.Address; - Entry_Bodies : Protected_Entry_Body_Access; - Find_Body_Index : Find_Body_Index_Access); + (Object : Protection_Entries_Access; + Ceiling_Priority : Integer; + Compiler_Info : System.Address; + Entry_Bodies : Protected_Entry_Body_Access; + Find_Body_Index : Find_Body_Index_Access; + Build_Entry_Names : Boolean); -- Initialize the Object parameter so that it can be used by the runtime -- to keep track of the runtime state of a protected object. @@ -202,6 +208,13 @@ package System.Tasking.Protected_Objects.Entries is Prio : System.Any_Priority); -- Sets the new ceiling priority of the protected object + procedure Set_Entry_Name + (Object : Protection_Entries'Class; + Pos : Protected_Entry_Index; + Val : String_Access); + -- This is called by the compiler to map a string which denotes an entry + -- name to a protected entry index. + procedure Unlock_Entries (Object : Protection_Entries_Access); -- Relinquish ownership of the lock for the object represented by the -- Object parameter. If this ownership was for write access, or if it was diff --git a/gcc/ada/s-vaflop-vms-alpha.adb b/gcc/ada/s-vaflop-vms-alpha.adb index e7d561bed16..d00ca1dba85 100644 --- a/gcc/ada/s-vaflop-vms-alpha.adb +++ b/gcc/ada/s-vaflop-vms-alpha.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2008, Free Software Foundation, Inc. -- -- (Version for Alpha OpenVMS) -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- @@ -32,7 +32,7 @@ -- -- ------------------------------------------------------------------------------ -with System.IO; use System.IO; +with System.IO; with System.Machine_Code; use System.Machine_Code; package body System.Vax_Float_Operations is @@ -328,7 +328,7 @@ package body System.Vax_Float_Operations is procedure Debug_Output_D (Arg : D) is begin - Put (D'Image (Arg)); + System.IO.Put (D'Image (Arg)); end Debug_Output_D; -------------------- @@ -337,7 +337,7 @@ package body System.Vax_Float_Operations is procedure Debug_Output_F (Arg : F) is begin - Put (F'Image (Arg)); + System.IO.Put (F'Image (Arg)); end Debug_Output_F; -------------------- @@ -346,7 +346,7 @@ package body System.Vax_Float_Operations is procedure Debug_Output_G (Arg : G) is begin - Put (G'Image (Arg)); + System.IO.Put (G'Image (Arg)); end Debug_Output_G; -------------------- @@ -627,7 +627,7 @@ package body System.Vax_Float_Operations is procedure pd (Arg : D) is begin - Put_Line (D'Image (Arg)); + System.IO.Put_Line (D'Image (Arg)); end pd; -------- @@ -636,7 +636,7 @@ package body System.Vax_Float_Operations is procedure pf (Arg : F) is begin - Put_Line (F'Image (Arg)); + System.IO.Put_Line (F'Image (Arg)); end pf; -------- @@ -645,9 +645,58 @@ package body System.Vax_Float_Operations is procedure pg (Arg : G) is begin - Put_Line (G'Image (Arg)); + System.IO.Put_Line (G'Image (Arg)); end pg; + -------------- + -- Return_D -- + -------------- + + function Return_D (X : D) return D is + R : D; + + begin + -- The return value is already in $f0 so we need to trick the compiler + -- into thinking that we're moving X to $f0. + + Asm ("cvtdg $f0,$f0", Inputs => D'Asm_Input ("g", X), Clobber => "$f0", + Volatile => True); + Asm ("stg $f0,%0", D'Asm_Output ("=m", R), Volatile => True); + return R; + end Return_D; + + -------------- + -- Return_F -- + -------------- + + function Return_F (X : F) return F is + R : F; + + begin + -- The return value is already in $f0 so we need to trick the compiler + -- into thinking that we're moving X to $f0. + + Asm ("stf $f0,%0", F'Asm_Output ("=m", R), F'Asm_Input ("g", X), + Clobber => "$f0", Volatile => True); + return R; + end Return_F; + + -------------- + -- Return_G -- + -------------- + + function Return_G (X : G) return G is + R : G; + + begin + -- The return value is already in $f0 so we need to trick the compiler + -- into thinking that we're moving X to $f0. + + Asm ("stg $f0,%0", G'Asm_Output ("=m", R), G'Asm_Input ("g", X), + Clobber => "$f0", Volatile => True); + return R; + end Return_G; + ----------- -- Sub_F -- ----------- diff --git a/gcc/ada/s-vaflop.adb b/gcc/ada/s-vaflop.adb index 0741664082b..79e295f94c1 100644 --- a/gcc/ada/s-vaflop.adb +++ b/gcc/ada/s-vaflop.adb @@ -37,7 +37,7 @@ -- case where the -gnatdm switch is used to force testing of VMS features -- on non-VMS systems. -with System.IO; use System.IO; +with System.IO; package body System.Vax_Float_Operations is pragma Warnings (Off); @@ -94,7 +94,7 @@ package body System.Vax_Float_Operations is procedure Debug_Output_D (Arg : D) is begin - Put (D'Image (Arg)); + System.IO.Put (D'Image (Arg)); end Debug_Output_D; -------------------- @@ -103,7 +103,7 @@ package body System.Vax_Float_Operations is procedure Debug_Output_F (Arg : F) is begin - Put (F'Image (Arg)); + System.IO.Put (F'Image (Arg)); end Debug_Output_F; -------------------- @@ -112,7 +112,7 @@ package body System.Vax_Float_Operations is procedure Debug_Output_G (Arg : G) is begin - Put (G'Image (Arg)); + System.IO.Put (G'Image (Arg)); end Debug_Output_G; -------------------- @@ -352,7 +352,7 @@ package body System.Vax_Float_Operations is procedure pd (Arg : D) is begin - Put_Line (D'Image (Arg)); + System.IO.Put_Line (D'Image (Arg)); end pd; -------- @@ -361,7 +361,7 @@ package body System.Vax_Float_Operations is procedure pf (Arg : F) is begin - Put_Line (F'Image (Arg)); + System.IO.Put_Line (F'Image (Arg)); end pf; -------- @@ -370,7 +370,7 @@ package body System.Vax_Float_Operations is procedure pg (Arg : G) is begin - Put_Line (G'Image (Arg)); + System.IO.Put_Line (G'Image (Arg)); end pg; ------------ @@ -400,6 +400,33 @@ package body System.Vax_Float_Operations is return F (X); end S_To_F; + -------------- + -- Return_D -- + -------------- + + function Return_D (X : D) return D is + begin + return X; + end Return_D; + + -------------- + -- Return_F -- + -------------- + + function Return_F (X : F) return F is + begin + return X; + end Return_F; + + -------------- + -- Return_G -- + -------------- + + function Return_G (X : G) return G is + begin + return X; + end Return_G; + ----------- -- Sub_F -- ----------- diff --git a/gcc/ada/s-vaflop.ads b/gcc/ada/s-vaflop.ads index 47e991a3b33..caf1dcc4e9c 100644 --- a/gcc/ada/s-vaflop.ads +++ b/gcc/ada/s-vaflop.ads @@ -143,6 +143,20 @@ package System.Vax_Float_Operations is function Ne_G (X, Y : G) return Boolean; -- Compares for X /= Y + ---------------------- + -- Return Functions -- + ---------------------- + + function Return_D (X : D) return D; + function Return_F (X : F) return F; + function Return_G (X : G) return G; + -- Deal with returned value for an imported function where the function + -- result is of VAX Float type. Usually nothing needs to be done, and these + -- functions return their argument unchanged. But for the case of VMS Alpha + -- the return value is already in $f0, so we need to trick the compiler + -- into thinking that we are moving X to $f0. See bodies for this case + -- for the Asm sequence generated to achieve this. + ---------------------------------- -- Routines for Valid Attribute -- ---------------------------------- @@ -190,43 +204,46 @@ package System.Vax_Float_Operations is -- types, and are retained for backwards compatibility. private - pragma Inline (D_To_G); - pragma Inline (F_To_G); - pragma Inline (F_To_Q); - pragma Inline (F_To_S); - pragma Inline (G_To_D); - pragma Inline (G_To_F); - pragma Inline (G_To_Q); - pragma Inline (G_To_T); - pragma Inline (Q_To_F); - pragma Inline (Q_To_G); - pragma Inline (S_To_F); - pragma Inline (T_To_G); - - pragma Inline (Abs_F); - pragma Inline (Abs_G); - pragma Inline (Add_F); - pragma Inline (Add_G); - pragma Inline (Div_G); - pragma Inline (Div_F); - pragma Inline (Mul_F); - pragma Inline (Mul_G); - pragma Inline (Neg_G); - pragma Inline (Neg_F); - pragma Inline (Sub_F); - pragma Inline (Sub_G); - - pragma Inline (Eq_F); - pragma Inline (Eq_G); - pragma Inline (Le_F); - pragma Inline (Le_G); - pragma Inline (Lt_F); - pragma Inline (Lt_G); - pragma Inline (Ne_F); - pragma Inline (Ne_G); - - pragma Inline (Valid_D); - pragma Inline (Valid_F); - pragma Inline (Valid_G); + pragma Inline_Always (D_To_G); + pragma Inline_Always (F_To_G); + pragma Inline_Always (F_To_Q); + pragma Inline_Always (F_To_S); + pragma Inline_Always (G_To_D); + pragma Inline_Always (G_To_F); + pragma Inline_Always (G_To_Q); + pragma Inline_Always (G_To_T); + pragma Inline_Always (Q_To_F); + pragma Inline_Always (Q_To_G); + pragma Inline_Always (S_To_F); + pragma Inline_Always (T_To_G); + + pragma Inline_Always (Abs_F); + pragma Inline_Always (Abs_G); + pragma Inline_Always (Add_F); + pragma Inline_Always (Add_G); + pragma Inline_Always (Div_G); + pragma Inline_Always (Div_F); + pragma Inline_Always (Mul_F); + pragma Inline_Always (Mul_G); + pragma Inline_Always (Neg_G); + pragma Inline_Always (Neg_F); + pragma Inline_Always (Return_D); + pragma Inline_Always (Return_F); + pragma Inline_Always (Return_G); + pragma Inline_Always (Sub_F); + pragma Inline_Always (Sub_G); + + pragma Inline_Always (Eq_F); + pragma Inline_Always (Eq_G); + pragma Inline_Always (Le_F); + pragma Inline_Always (Le_G); + pragma Inline_Always (Lt_F); + pragma Inline_Always (Lt_G); + pragma Inline_Always (Ne_F); + pragma Inline_Always (Ne_G); + + pragma Inline_Always (Valid_D); + pragma Inline_Always (Valid_F); + pragma Inline_Always (Valid_G); end System.Vax_Float_Operations; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 21d620716f0..4f50dc01789 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -198,8 +198,8 @@ package body Sem_Aggr is -- quadratic in the size of the association list. procedure Check_Misspelled_Component - (Elements : Elist_Id; - Component : Node_Id); + (Elements : Elist_Id; + Component : Node_Id); -- Give possible misspelling diagnostic if Component is likely to be -- a misspelling of one of the components of the Assoc_List. -- This is called by Resolve_Aggr_Expr after producing @@ -414,6 +414,22 @@ package body Sem_Aggr is return; end if; + -- Ada 2005 (AI-230): Generate a conversion to an anonymous access + -- component's type to force the appropriate accessibility checks. + + -- Ada 2005 (AI-231): Generate conversion to the null-excluding + -- type to force the corresponding run-time check + + if Is_Access_Type (Check_Typ) + and then ((Is_Local_Anonymous_Access (Check_Typ)) + or else (Can_Never_Be_Null (Check_Typ) + and then not Can_Never_Be_Null (Exp_Typ))) + then + Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); + Analyze_And_Resolve (Exp, Check_Typ); + Check_Unset_Reference (Exp); + end if; + -- This is really expansion activity, so make sure that expansion -- is on and is allowed. @@ -486,20 +502,6 @@ package body Sem_Aggr is Check_Unset_Reference (Exp); end if; - -- Ada 2005 (AI-230): Generate a conversion to an anonymous access - -- component's type to force the appropriate accessibility checks. - - -- Ada 2005 (AI-231): Generate conversion to the null-excluding - -- type to force the corresponding run-time check - - elsif Is_Access_Type (Check_Typ) - and then ((Is_Local_Anonymous_Access (Check_Typ)) - or else (Can_Never_Be_Null (Check_Typ) - and then not Can_Never_Be_Null (Exp_Typ))) - then - Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); - Analyze_And_Resolve (Exp, Check_Typ); - Check_Unset_Reference (Exp); end if; end Aggregate_Constraint_Checks; @@ -716,8 +718,8 @@ package body Sem_Aggr is -------------------------------- procedure Check_Misspelled_Component - (Elements : Elist_Id; - Component : Node_Id) + (Elements : Elist_Id; + Component : Node_Id) is Max_Suggestions : constant := 2; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 0735740472f..14f9102d369 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -3501,6 +3501,13 @@ package body Sem_Attr is Error_Attr ("attribute % cannot apply to limited objects", P); end if; + if Is_Entity_Name (P) + and then Is_Constant_Object (Entity (P)) + then + Error_Msg_N + ("?attribute Old applied to constant has no effect", P); + end if; + -- Check that the expression does not refer to local entities Check_Local : declare @@ -5234,6 +5241,7 @@ package body Sem_Attr is -- subtype then get the type from the initial value. If the value has -- been expanded into assignments, there is no expression and the -- attribute reference remains dynamic. + -- We could do better here and retrieve the type ??? if Ekind (P_Entity) = E_Constant @@ -8090,27 +8098,61 @@ package body Sem_Attr is -- even if the array is packed and the slice itself is not -- addressable. Transform the prefix into an indexed component. + -- Note that the transformation is safe only if we know that + -- the slice is non-null. That is because a null slice can have + -- an out of bounds index value. + + -- Right now, gigi blows up if given 'Address on a slice as a + -- result of some incorrect freeze nodes generated by the front + -- end, and this covers up that bug in one case, but the bug is + -- likely still there in the cases not handled by this code ??? + + -- It's not clear what 'Address *should* return for a null + -- slice with out of bounds indexes, this might be worth an ARG + -- discussion ??? + + -- One approach would be to do a length check unconditionally, + -- and then do the transformation below unconditionally, but + -- analyze with checks off, avoiding the problem of the out of + -- bounds index. This approach would interpret the address of + -- an out of bounds null slice as being the address where the + -- array element would be if there was one, which is probably + -- as reasonable an interpretation as any ??? + declare Loc : constant Source_Ptr := Sloc (P); D : constant Node_Id := Discrete_Range (P); Lo : Node_Id; begin - if Is_Entity_Name (D) then + if Is_Entity_Name (D) + and then + Not_Null_Range + (Type_Low_Bound (Entity (D)), + Type_High_Bound (Entity (D))) + then Lo := Make_Attribute_Reference (Loc, Prefix => (New_Occurrence_Of (Entity (D), Loc)), Attribute_Name => Name_First); - else + + elsif Nkind (D) = N_Range + and then Not_Null_Range (Low_Bound (D), High_Bound (D)) + then Lo := Low_Bound (D); + + else + Lo := Empty; end if; - Rewrite (P, - Make_Indexed_Component (Loc, - Prefix => Relocate_Node (Prefix (P)), - Expressions => New_List (Lo))); + if Present (Lo) then + Rewrite (P, + Make_Indexed_Component (Loc, + Prefix => Relocate_Node (Prefix (P)), + Expressions => New_List (Lo))); - Analyze_And_Resolve (P); + Analyze_And_Resolve (P); + end if; end; end if; end Address_Attribute; diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index cc96974425a..3e4a036fb8d 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -28,7 +28,7 @@ with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; -with Exp_Util; use Exp_Util; +with Exp_Disp; use Exp_Disp; with Fname; use Fname; with Lib; use Lib; with Namet; use Namet; @@ -1516,6 +1516,7 @@ 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??? @@ -1739,9 +1740,13 @@ package body Sem_Cat is end if; end Is_Valid_Remote_Object_Type; + -- Local variables + Direct_Designated_Type : Entity_Id; Desig_Type : Entity_Id; + -- Start of processing for Validate_Remote_Access_Object_Type_Declaration + begin -- We are called from Analyze_Type_Declaration, and the Nkind of the -- given node is N_Access_To_Object_Definition. diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 75f4512c72c..4a7c91f1c95 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -9268,7 +9268,7 @@ package body Sem_Ch12 is -- Now verify that the actual includes all other ancestors of -- the formal. - Elmt := First_Elmt (Abstract_Interfaces (A_Gen_T)); + Elmt := First_Elmt (Interfaces (A_Gen_T)); while Present (Elmt) loop if not Interface_Present_In_Ancestor (Act_T, Get_Instance_Of (Node (Elmt))) @@ -9575,7 +9575,6 @@ package body Sem_Ch12 is function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean is - Interfaces : Elist_Id; Intfc_Elmt : Elmt_Id; begin @@ -9599,9 +9598,7 @@ package body Sem_Ch12 is -- progenitors. else - Interfaces := Abstract_Interfaces (T2); - - Intfc_Elmt := First_Elmt (Interfaces); + Intfc_Elmt := First_Elmt (Interfaces (T2)); while Present (Intfc_Elmt) loop if Is_Ancestor (T1, Node (Intfc_Elmt)) then return True; @@ -10806,7 +10803,11 @@ package body Sem_Ch12 is ------------------- procedure Remove_Parent (In_Body : Boolean := False) is - S : Entity_Id := Current_Scope; + S : Entity_Id := Current_Scope; + -- S is the scope containing the instantiation just completed. The + -- scope stack contains the parent instances of the instantiation, + -- followed by the original S. + E : Entity_Id; P : Entity_Id; Hidden : Elmt_Id; @@ -10824,7 +10825,6 @@ package body Sem_Ch12 is if In_Open_Scopes (P) then E := First_Entity (P); - while Present (E) loop Set_Is_Immediately_Visible (E, True); Next_Entity (E); @@ -10853,14 +10853,38 @@ package body Sem_Ch12 is and then not Parent_Unit_Visible) then Set_Is_Immediately_Visible (P, False); + + -- If the current scope is itself an instantiation of a generic + -- nested within P, and we are in the private part of body of + -- this instantiation, restore the full views of P, that were + -- removed in End_Package_Scope above. This obscure case can + -- occur when a subunit of a generic contains an instance of + -- of a child unit of its generic parent unit. + + elsif S = Current_Scope + and then Is_Generic_Instance (S) + then + declare + Par : constant Entity_Id := + Generic_Parent + (Specification (Unit_Declaration_Node (S))); + begin + if Present (Par) + and then P = Scope (Par) + and then (In_Package_Body (S) or else In_Private_Part (S)) + then + Set_In_Private_Part (P); + Install_Private_Declarations (P); + end if; + end; end if; end loop; -- Reset visibility of entities in the enclosing scope Set_Is_Hidden_Open_Scope (Current_Scope, False); - Hidden := First_Elmt (Hidden_Entities); + Hidden := First_Elmt (Hidden_Entities); while Present (Hidden) loop Set_Is_Immediately_Visible (Node (Hidden), True); Next_Elmt (Hidden); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 1b367373720..88a44138039 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -31,6 +31,7 @@ with Einfo; use Einfo; with Errout; use Errout; with Eval_Fat; use Eval_Fat; with Exp_Ch3; use Exp_Ch3; +with Exp_Disp; use Exp_Disp; with Exp_Dist; use Exp_Dist; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; @@ -253,9 +254,6 @@ package body Sem_Ch3 is -- view cannot itself have a full view (it would get clobbered during -- view exchanges). - procedure Check_Abstract_Interfaces (N : Node_Id; Def : Node_Id); - -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) - procedure Check_Access_Discriminant_Requires_Limited (D : Node_Id; Loc : Node_Id); @@ -289,6 +287,9 @@ package body Sem_Ch3 is -- Validate the initialization of an object declaration. T is the required -- type, and Exp is the initialization expression. + procedure Check_Interfaces (N : Node_Id; Def : Node_Id); + -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) + procedure Check_Or_Process_Discriminants (N : Node_Id; T : Entity_Id; @@ -486,14 +487,16 @@ package body Sem_Ch3 is -- appropriate semantic fields. If the full view of the parent is a record -- type, build constrained components of subtype. - procedure Derive_Interface_Subprograms + procedure Derive_Progenitor_Subprograms (Parent_Type : Entity_Id; - Tagged_Type : Entity_Id; - Ifaces_List : Elist_Id); - -- Ada 2005 (AI-251): Derive primitives of abstract interface types that - -- are not immediate ancestors of Tagged type and associate them their - -- aliased primitive. Ifaces_List contains the abstract interface - -- primitives that have been derived from Parent_Type. + Tagged_Type : Entity_Id); + -- Ada 2005 (AI-251): To complete type derivation, collect the primitive + -- operations of progenitors of Tagged_Type, and replace the subsidiary + -- subtypes with Tagged_Type, to build the specs of the inherited interface + -- primitives. The derived primitives are aliased to those of the + -- interface. This routine takes care also of transferring to the full-view + -- subprograms associated with the partial-view of Tagged_Type that cover + -- interface primitives. procedure Derived_Standard_Character (N : Node_Id; @@ -709,6 +712,10 @@ package body Sem_Ch3 is -- E is some record type. This routine computes E's Stored_Constraint -- from its Discriminant_Constraint. + procedure Diagnose_Interface (N : Node_Id; E : Entity_Id); + -- Check that an entity in a list of progenitors is an interface, + -- emit error otherwise. + ----------------------- -- Access_Definition -- ----------------------- @@ -1273,36 +1280,12 @@ package body Sem_Ch3 is procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); - Elmt : Elmt_Id; - Ext : Node_Id; L : List_Id; Last_Tag : Node_Id; - Comp : Node_Id; - - procedure Add_Sync_Iface_Tags (T : Entity_Id); - -- Local subprogram used to recursively climb through the parents - -- of T to add the tags of all the progenitor interfaces. procedure Add_Tag (Iface : Entity_Id); -- Add tag for one of the progenitor interfaces - ------------------------- - -- Add_Sync_Iface_Tags -- - ------------------------- - - procedure Add_Sync_Iface_Tags (T : Entity_Id) is - begin - if Etype (T) /= T then - Add_Sync_Iface_Tags (Etype (T)); - end if; - - Elmt := First_Elmt (Abstract_Interfaces (T)); - while Present (Elmt) loop - Add_Tag (Node (Elmt)); - Next_Elmt (Elmt); - end loop; - end Add_Sync_Iface_Tags; - ------------- -- Add_Tag -- ------------- @@ -1387,7 +1370,9 @@ package body Sem_Ch3 is -- Local variables - Iface_List : List_Id; + Elmt : Elmt_Id; + Ext : Node_Id; + Comp : Node_Id; -- Start of processing for Add_Interface_Tag_Components @@ -1403,8 +1388,8 @@ package body Sem_Ch3 is or else (Is_Concurrent_Record_Type (Typ) and then Is_Empty_List (Abstract_Interface_List (Typ))) or else (not Is_Concurrent_Record_Type (Typ) - and then No (Abstract_Interfaces (Typ)) - and then Is_Empty_Elmt_List (Abstract_Interfaces (Typ))) + and then No (Interfaces (Typ)) + and then Is_Empty_Elmt_List (Interfaces (Typ))) then return; end if; @@ -1458,16 +1443,8 @@ package body Sem_Ch3 is -- corresponding with all the interfaces that are not implemented -- by the parent. - if Is_Concurrent_Record_Type (Typ) then - Iface_List := Abstract_Interface_List (Typ); - - if Is_Non_Empty_List (Iface_List) then - Add_Sync_Iface_Tags (Etype (First (Iface_List))); - end if; - end if; - - if Present (Abstract_Interfaces (Typ)) then - Elmt := First_Elmt (Abstract_Interfaces (Typ)); + if Present (Interfaces (Typ)) then + Elmt := First_Elmt (Interfaces (Typ)); while Present (Elmt) loop Add_Tag (Node (Elmt)); Next_Elmt (Elmt); @@ -1993,18 +1970,18 @@ package body Sem_Ch3 is CW : constant Entity_Id := Class_Wide_Type (T); begin - Set_Is_Tagged_Type (T); + Set_Is_Tagged_Type (T); - Set_Is_Limited_Record (T, Limited_Present (Def) - or else Task_Present (Def) - or else Protected_Present (Def) - or else Synchronized_Present (Def)); + Set_Is_Limited_Record (T, Limited_Present (Def) + or else Task_Present (Def) + or else Protected_Present (Def) + or else Synchronized_Present (Def)); -- Type is abstract if full declaration carries keyword, or if previous -- partial view did. Set_Is_Abstract_Type (T); - Set_Is_Interface (T); + Set_Is_Interface (T); -- Type is a limited interface if it includes the keyword limited, task, -- protected, or synchronized. @@ -2015,8 +1992,8 @@ package body Sem_Ch3 is or else Synchronized_Present (Def) or else Task_Present (Def)); - Set_Is_Protected_Interface (T, Protected_Present (Def)); - Set_Is_Task_Interface (T, Task_Present (Def)); + Set_Is_Protected_Interface (T, Protected_Present (Def)); + Set_Is_Task_Interface (T, Task_Present (Def)); -- Type is a synchronized interface if it includes the keyword task, -- protected, or synchronized. @@ -2026,8 +2003,8 @@ package body Sem_Ch3 is or else Protected_Present (Def) or else Task_Present (Def)); - Set_Abstract_Interfaces (T, New_Elmt_List); - Set_Primitive_Operations (T, New_Elmt_List); + Set_Interfaces (T, New_Elmt_List); + Set_Primitive_Operations (T, New_Elmt_List); -- Complete the decoration of the class-wide entity if it was already -- built (i.e. during the creation of the limited view) @@ -3087,6 +3064,14 @@ package body Sem_Ch3 is then Set_In_Private_Part (Id); end if; + + -- Check for violation of No_Local_Timing_Events + + if Is_RTE (Etype (Id), RE_Timing_Event) + and then not Is_Library_Level_Entity (Id) + then + Check_Restriction (No_Local_Timing_Events, N); + end if; end Analyze_Object_Declaration; --------------------------- @@ -3125,10 +3110,7 @@ package body Sem_Ch3 is while Present (Intf) loop T := Find_Type_Of_Subtype_Indic (Intf); - if not Is_Interface (T) then - Error_Msg_NE ("(Ada 2005) & must be an interface", Intf, T); - end if; - + Diagnose_Interface (Intf, T); Next (Intf); end loop; end; @@ -3236,13 +3218,13 @@ package body Sem_Ch3 is -- The progenitors (if any) must be limited or synchronized -- interfaces. - if Present (Abstract_Interfaces (T)) then + if Present (Interfaces (T)) then declare Iface : Entity_Id; Iface_Elmt : Elmt_Id; begin - Iface_Elmt := First_Elmt (Abstract_Interfaces (T)); + Iface_Elmt := First_Elmt (Interfaces (T)); while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); @@ -6770,7 +6752,7 @@ package body Sem_Ch3 is Analyze_Interface_Declaration (Derived_Type, Type_Def); end if; - Set_Abstract_Interfaces (Derived_Type, No_Elist); + Set_Interfaces (Derived_Type, No_Elist); end if; -- Fields inherited from the Parent_Type @@ -6804,9 +6786,9 @@ package body Sem_Ch3 is if Is_Record_Type (Derived_Type) then Set_OK_To_Reorder_Components - (Derived_Type, OK_To_Reorder_Components (Parent_Base)); + (Derived_Type, OK_To_Reorder_Components (Parent_Base)); Set_Reverse_Bit_Order - (Derived_Type, Reverse_Bit_Order (Parent_Base)); + (Derived_Type, Reverse_Bit_Order (Parent_Base)); end if; -- Direct controlled types do not inherit Finalize_Storage_Only flag @@ -6896,16 +6878,17 @@ package body Sem_Ch3 is -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) - Check_Abstract_Interfaces (N, Type_Def); + Check_Interfaces (N, Type_Def); -- Ada 2005 (AI-251): Collect the list of progenitors that are -- not already in the parents. - Collect_Abstract_Interfaces - (T => Derived_Type, - Ifaces_List => Ifaces_List, - Exclude_Parent_Interfaces => True); - Set_Abstract_Interfaces (Derived_Type, Ifaces_List); + Collect_Interfaces + (T => Derived_Type, + Ifaces_List => Ifaces_List, + Exclude_Parents => True); + + Set_Interfaces (Derived_Type, Ifaces_List); end; end if; @@ -7003,7 +6986,7 @@ package body Sem_Ch3 is -- implemented interfaces if we are in expansion mode if Expander_Active - and then Has_Abstract_Interfaces (Derived_Type) + and then Has_Interfaces (Derived_Type) then Add_Interface_Tag_Components (N, Derived_Type); end if; @@ -7888,236 +7871,6 @@ package body Sem_Ch3 is end Build_Underlying_Full_View; ------------------------------- - -- Check_Abstract_Interfaces -- - ------------------------------- - - procedure Check_Abstract_Interfaces (N : Node_Id; Def : Node_Id) is - Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N)); - - Iface : Node_Id; - Iface_Def : Node_Id; - Iface_Typ : Entity_Id; - Parent_Node : Node_Id; - - Is_Task : Boolean := False; - -- Set True if parent type or any progenitor is a task interface - - Is_Protected : Boolean := False; - -- Set True if parent type or any progenitor is a protected interface - - procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id); - -- Check that a progenitor is compatible with declaration. - -- Error is posted on Error_Node. - - ------------------ - -- Check_Ifaces -- - ------------------ - - procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is - Iface_Id : constant Entity_Id := - Defining_Identifier (Parent (Iface_Def)); - Type_Def : Node_Id; - - begin - if Nkind (N) = N_Private_Extension_Declaration then - Type_Def := N; - else - Type_Def := Type_Definition (N); - end if; - - if Is_Task_Interface (Iface_Id) then - Is_Task := True; - - elsif Is_Protected_Interface (Iface_Id) then - Is_Protected := True; - end if; - - -- Check that the characteristics of the progenitor are compatible - -- with the explicit qualifier in the declaration. - -- The check only applies to qualifiers that come from source. - -- Limited_Present also appears in the declaration of corresponding - -- records, and the check does not apply to them. - - if Limited_Present (Type_Def) - and then not - Is_Concurrent_Record_Type (Defining_Identifier (N)) - then - if Is_Limited_Interface (Parent_Type) - and then not Is_Limited_Interface (Iface_Id) - then - Error_Msg_NE - ("progenitor& must be limited interface", - Error_Node, Iface_Id); - - elsif - (Task_Present (Iface_Def) - or else Protected_Present (Iface_Def) - or else Synchronized_Present (Iface_Def)) - and then Nkind (N) /= N_Private_Extension_Declaration - then - Error_Msg_NE - ("progenitor& must be limited interface", - Error_Node, Iface_Id); - end if; - - -- Protected interfaces can only inherit from limited, synchronized - -- or protected interfaces. - - elsif Nkind (N) = N_Full_Type_Declaration - and then Protected_Present (Type_Def) - then - if Limited_Present (Iface_Def) - or else Synchronized_Present (Iface_Def) - or else Protected_Present (Iface_Def) - then - null; - - elsif Task_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) protected interface cannot inherit" - & " from task interface", Error_Node); - - else - Error_Msg_N ("(Ada 2005) protected interface cannot inherit" - & " from non-limited interface", Error_Node); - end if; - - -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from - -- limited and synchronized. - - elsif Synchronized_Present (Type_Def) then - if Limited_Present (Iface_Def) - or else Synchronized_Present (Iface_Def) - then - null; - - elsif Protected_Present (Iface_Def) - and then Nkind (N) /= N_Private_Extension_Declaration - then - Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" - & " from protected interface", Error_Node); - - elsif Task_Present (Iface_Def) - and then Nkind (N) /= N_Private_Extension_Declaration - then - Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" - & " from task interface", Error_Node); - - elsif not Is_Limited_Interface (Iface_Id) then - Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" - & " from non-limited interface", Error_Node); - end if; - - -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, - -- synchronized or task interfaces. - - elsif Nkind (N) = N_Full_Type_Declaration - and then Task_Present (Type_Def) - then - if Limited_Present (Iface_Def) - or else Synchronized_Present (Iface_Def) - or else Task_Present (Iface_Def) - then - null; - - elsif Protected_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) task interface cannot inherit from" - & " protected interface", Error_Node); - - else - Error_Msg_N ("(Ada 2005) task interface cannot inherit from" - & " non-limited interface", Error_Node); - end if; - end if; - end Check_Ifaces; - - -- Start of processing for Check_Abstract_Interfaces - - begin - if Is_Interface (Parent_Type) then - if Is_Task_Interface (Parent_Type) then - Is_Task := True; - - elsif Is_Protected_Interface (Parent_Type) then - Is_Protected := True; - end if; - end if; - - if Nkind (N) = N_Private_Extension_Declaration then - - -- Check that progenitors are compatible with declaration - - Iface := First (Interface_List (Def)); - while Present (Iface) loop - Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); - - Parent_Node := Parent (Base_Type (Iface_Typ)); - Iface_Def := Type_Definition (Parent_Node); - - if not Is_Interface (Iface_Typ) then - Error_Msg_NE ("(Ada 2005) & must be an interface", - Iface, Iface_Typ); - - else - Check_Ifaces (Iface_Def, Iface); - end if; - - Next (Iface); - end loop; - - if Is_Task and Is_Protected then - Error_Msg_N - ("type cannot derive from task and protected interface", N); - end if; - - return; - end if; - - -- Full type declaration of derived type. - -- Check compatibility with parent if it is interface type - - if Nkind (Type_Definition (N)) = N_Derived_Type_Definition - and then Is_Interface (Parent_Type) - then - Parent_Node := Parent (Parent_Type); - - -- More detailed checks for interface varieties - - Check_Ifaces - (Iface_Def => Type_Definition (Parent_Node), - Error_Node => Subtype_Indication (Type_Definition (N))); - end if; - - Iface := First (Interface_List (Def)); - - while Present (Iface) loop - Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); - - Parent_Node := Parent (Base_Type (Iface_Typ)); - Iface_Def := Type_Definition (Parent_Node); - - if not Is_Interface (Iface_Typ) then - Error_Msg_NE ("(Ada 2005) & must be an interface", - Iface, Iface_Typ); - - else - -- "The declaration of a specific descendant of an interface - -- type freezes the interface type" RM 13.14 - - Freeze_Before (N, Iface_Typ); - Check_Ifaces (Iface_Def, Error_Node => Iface); - end if; - - Next (Iface); - end loop; - - if Is_Task and Is_Protected then - Error_Msg_N - ("type cannot derive from task and protected interface", N); - end if; - - end Check_Abstract_Interfaces; - - ------------------------------- -- Check_Abstract_Overriding -- ------------------------------- @@ -8162,13 +7915,20 @@ package body Sem_Ch3 is if Is_Null_Extension (T) and then Has_Controlling_Result (Subp) and then Ada_Version >= Ada_05 - and then Present (Alias (Subp)) + and then Present (Alias_Subp) and then not Comes_From_Source (Subp) - and then not Is_Abstract_Subprogram (Alias (Subp)) + and then not Is_Abstract_Subprogram (Alias_Subp) and then not Is_Access_Type (Etype (Subp)) then null; + -- Ada 2005 (AI-251): Internal entities of interfaces need no + -- processing because this check is done with the aliased + -- entity + + elsif Present (Interface_Alias (Subp)) then + null; + elsif (Is_Abstract_Subprogram (Subp) or else Requires_Overriding (Subp) or else @@ -8180,18 +7940,14 @@ package body Sem_Ch3 is and then not Is_TSS (Subp, TSS_Stream_Output) and then not Is_Abstract_Type (T) and then Convention (T) /= Convention_CIL - and then Chars (Subp) /= Name_uDisp_Asynchronous_Select - and then Chars (Subp) /= Name_uDisp_Conditional_Select - and then Chars (Subp) /= Name_uDisp_Get_Prim_Op_Kind - and then Chars (Subp) /= Name_uDisp_Requeue - and then Chars (Subp) /= Name_uDisp_Timed_Select + and then not Is_Predefined_Interface_Primitive (Subp) -- Ada 2005 (AI-251): Do not consider hidden entities associated -- with abstract interface types because the check will be done -- with the aliased entity (otherwise we generate a duplicated -- error message). - and then not Present (Abstract_Interface_Alias (Subp)) + and then not Present (Interface_Alias (Subp)) then if Present (Alias_Subp) then @@ -8222,13 +7978,15 @@ package body Sem_Ch3 is or else Requires_Overriding (Subp) or else Is_Access_Type (Etype (Subp))) then - -- The body of predefined primitives of tagged types derived - -- from interface types are generated later by Freeze_Type. - - if Is_Predefined_Dispatching_Operation (Subp) - and then Is_Abstract_Subprogram (Alias_Subp) - and then Is_Interface - (Root_Type (Find_Dispatching_Type (Subp))) + -- Avoid reporting error in case of abstract predefined + -- primitive inherited from interface type because the + -- body of internally generated predefined primitives + -- of tagged types are generated later by Freeze_Type + + if Is_Interface (Root_Type (T)) + and then Is_Abstract_Subprogram (Subp) + and then Is_Predefined_Dispatching_Operation (Subp) + and then not Comes_From_Source (Ultimate_Alias (Subp)) then null; @@ -8268,7 +8026,7 @@ package body Sem_Ch3 is -- abstract interfaces. elsif Is_Concurrent_Record_Type (T) - and then Present (Abstract_Interfaces (T)) + and then Present (Interfaces (T)) then -- The controlling formal of Subp must be of mode "out", -- "in out" or an access-to-variable to be overridden. @@ -8277,12 +8035,14 @@ package body Sem_Ch3 is -- in -gnatj mode) ??? if Ekind (First_Formal (Subp)) = E_In_Parameter then - Error_Msg_NE - ("first formal of & must be of mode `OUT`, `IN OUT` " & - "or access-to-variable", T, Subp); - Error_Msg_N - ("\to be overridden by protected procedure or " & - "entry (RM 9.4(11.9/2))", T); + if not Is_Predefined_Dispatching_Operation (Subp) then + Error_Msg_NE + ("first formal of & must be of mode `OUT`, " & + "`IN OUT` or access-to-variable", T, Subp); + Error_Msg_N + ("\to be overridden by protected procedure or " & + "entry (RM 9.4(11.9/2))", T); + end if; -- Some other kind of overriding failure @@ -8315,8 +8075,8 @@ package body Sem_Ch3 is if Ada_Version >= Ada_05 and then Is_Hidden (Subp) - and then Present (Abstract_Interface_Alias (Subp)) - and then Implemented_By_Entry (Abstract_Interface_Alias (Subp)) + and then Present (Interface_Alias (Subp)) + and then Implemented_By_Entry (Interface_Alias (Subp)) and then Present (Alias_Subp) and then (not Is_Primitive_Wrapper (Alias_Subp) @@ -8330,7 +8090,7 @@ package body Sem_Ch3 is Error_Ent := Corresponding_Concurrent_Type (Error_Ent); end if; - Error_Msg_Node_2 := Abstract_Interface_Alias (Subp); + Error_Msg_Node_2 := Interface_Alias (Subp); Error_Msg_NE ("type & must implement abstract subprogram & with an entry", Error_Ent, Error_Ent); @@ -8742,6 +8502,232 @@ package body Sem_Ch3 is end if; end Check_Initialization; + ---------------------- + -- Check_Interfaces -- + ---------------------- + + procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is + Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N)); + + Iface : Node_Id; + Iface_Def : Node_Id; + Iface_Typ : Entity_Id; + Parent_Node : Node_Id; + + Is_Task : Boolean := False; + -- Set True if parent type or any progenitor is a task interface + + Is_Protected : Boolean := False; + -- Set True if parent type or any progenitor is a protected interface + + procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id); + -- Check that a progenitor is compatible with declaration. + -- Error is posted on Error_Node. + + ------------------ + -- Check_Ifaces -- + ------------------ + + procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is + Iface_Id : constant Entity_Id := + Defining_Identifier (Parent (Iface_Def)); + Type_Def : Node_Id; + + begin + if Nkind (N) = N_Private_Extension_Declaration then + Type_Def := N; + else + Type_Def := Type_Definition (N); + end if; + + if Is_Task_Interface (Iface_Id) then + Is_Task := True; + + elsif Is_Protected_Interface (Iface_Id) then + Is_Protected := True; + end if; + + -- Check that the characteristics of the progenitor are compatible + -- with the explicit qualifier in the declaration. + -- The check only applies to qualifiers that come from source. + -- Limited_Present also appears in the declaration of corresponding + -- records, and the check does not apply to them. + + if Limited_Present (Type_Def) + and then not + Is_Concurrent_Record_Type (Defining_Identifier (N)) + then + if Is_Limited_Interface (Parent_Type) + and then not Is_Limited_Interface (Iface_Id) + then + Error_Msg_NE + ("progenitor& must be limited interface", + Error_Node, Iface_Id); + + elsif + (Task_Present (Iface_Def) + or else Protected_Present (Iface_Def) + or else Synchronized_Present (Iface_Def)) + and then Nkind (N) /= N_Private_Extension_Declaration + then + Error_Msg_NE + ("progenitor& must be limited interface", + Error_Node, Iface_Id); + end if; + + -- Protected interfaces can only inherit from limited, synchronized + -- or protected interfaces. + + elsif Nkind (N) = N_Full_Type_Declaration + and then Protected_Present (Type_Def) + then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Protected_Present (Iface_Def) + then + null; + + elsif Task_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) protected interface cannot inherit" + & " from task interface", Error_Node); + + else + Error_Msg_N ("(Ada 2005) protected interface cannot inherit" + & " from non-limited interface", Error_Node); + end if; + + -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from + -- limited and synchronized. + + elsif Synchronized_Present (Type_Def) then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + then + null; + + elsif Protected_Present (Iface_Def) + and then Nkind (N) /= N_Private_Extension_Declaration + then + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" + & " from protected interface", Error_Node); + + elsif Task_Present (Iface_Def) + and then Nkind (N) /= N_Private_Extension_Declaration + then + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" + & " from task interface", Error_Node); + + elsif not Is_Limited_Interface (Iface_Id) then + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" + & " from non-limited interface", Error_Node); + end if; + + -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, + -- synchronized or task interfaces. + + elsif Nkind (N) = N_Full_Type_Declaration + and then Task_Present (Type_Def) + then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Task_Present (Iface_Def) + then + null; + + elsif Protected_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) task interface cannot inherit from" + & " protected interface", Error_Node); + + else + Error_Msg_N ("(Ada 2005) task interface cannot inherit from" + & " non-limited interface", Error_Node); + end if; + end if; + end Check_Ifaces; + + -- Start of processing for Check_Interfaces + + begin + if Is_Interface (Parent_Type) then + if Is_Task_Interface (Parent_Type) then + Is_Task := True; + + elsif Is_Protected_Interface (Parent_Type) then + Is_Protected := True; + end if; + end if; + + if Nkind (N) = N_Private_Extension_Declaration then + + -- Check that progenitors are compatible with declaration + + Iface := First (Interface_List (Def)); + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + + Parent_Node := Parent (Base_Type (Iface_Typ)); + Iface_Def := Type_Definition (Parent_Node); + + if not Is_Interface (Iface_Typ) then + Diagnose_Interface (Iface, Iface_Typ); + + else + Check_Ifaces (Iface_Def, Iface); + end if; + + Next (Iface); + end loop; + + if Is_Task and Is_Protected then + Error_Msg_N + ("type cannot derive from task and protected interface", N); + end if; + + return; + end if; + + -- Full type declaration of derived type. + -- Check compatibility with parent if it is interface type + + if Nkind (Type_Definition (N)) = N_Derived_Type_Definition + and then Is_Interface (Parent_Type) + then + Parent_Node := Parent (Parent_Type); + + -- More detailed checks for interface varieties + + Check_Ifaces + (Iface_Def => Type_Definition (Parent_Node), + Error_Node => Subtype_Indication (Type_Definition (N))); + end if; + + Iface := First (Interface_List (Def)); + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + + Parent_Node := Parent (Base_Type (Iface_Typ)); + Iface_Def := Type_Definition (Parent_Node); + + if not Is_Interface (Iface_Typ) then + Diagnose_Interface (Iface, Iface_Typ); + + else + -- "The declaration of a specific descendant of an interface + -- type freezes the interface type" RM 13.14 + + Freeze_Before (N, Iface_Typ); + Check_Ifaces (Iface_Def, Error_Node => Iface); + end if; + + Next (Iface); + end loop; + + if Is_Task and Is_Protected then + Error_Msg_N + ("type cannot derive from task and protected interface", N); + end if; + end Check_Interfaces; + ------------------------------------ -- Check_Or_Process_Discriminants -- ------------------------------------ @@ -9871,7 +9857,6 @@ package body Sem_Ch3 is function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is D : Entity_Id; E : Elmt_Id; - G : Elmt_Id; begin -- The discriminant may be declared for the type, in which case we @@ -9901,14 +9886,15 @@ package body Sem_Ch3 is -- to one: one new discriminant can constrain several old ones. In -- that case, scan sequentially the stored_constraint, the list of -- discriminants of the parents, and the constraints. + -- Previous code checked for the present of the Stored_Constraint + -- list for the derived type, but did not use it at all. Should it + -- be present when the component is a discriminated task type? if Is_Derived_Type (Typ) - and then Present (Stored_Constraint (Typ)) and then Scope (Entity (Discrim)) = Etype (Typ) then D := First_Discriminant (Etype (Typ)); E := First_Elmt (Constraints); - G := First_Elmt (Stored_Constraint (Typ)); while Present (D) loop if D = Entity (Discrim) then return Node (E); @@ -9916,7 +9902,6 @@ package body Sem_Ch3 is Next_Discriminant (D); Next_Elmt (E); - Next_Elmt (G); end loop; end if; @@ -10207,7 +10192,9 @@ package body Sem_Ch3 is Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); end if; - Set_Etype (Def_Id, Any_Type); + -- Set Etype to the known type, to reduce chances of cascaded errors + + Set_Etype (Def_Id, E); Set_Error_Posted (Def_Id); end Fixup_Bad_Constraint; @@ -11188,8 +11175,6 @@ package body Sem_Ch3 is Scale_Val : Uint; Bound_Val : Ureal; - -- Start of processing for Decimal_Fixed_Point_Type_Declaration - begin Check_Restriction (No_Fixed_Point, Def); @@ -11331,222 +11316,132 @@ package body Sem_Ch3 is Set_Is_Constrained (T); end Decimal_Fixed_Point_Type_Declaration; - ---------------------------------- - -- Derive_Interface_Subprograms -- - ---------------------------------- + ----------------------------------- + -- Derive_Progenitor_Subprograms -- + ----------------------------------- - procedure Derive_Interface_Subprograms + procedure Derive_Progenitor_Subprograms (Parent_Type : Entity_Id; - Tagged_Type : Entity_Id; - Ifaces_List : Elist_Id) + Tagged_Type : Entity_Id) is - function Collect_Interface_Primitives - (Tagged_Type : Entity_Id) return Elist_Id; - -- Ada 2005 (AI-251): Collect the primitives of all the implemented - -- interfaces. - - function In_List (L : Elist_Id; Subp : Entity_Id) return Boolean; - -- Determine if Subp already in the list L + E : Entity_Id; + Elmt : Elmt_Id; + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + Iface_Subp : Entity_Id; + New_Subp : Entity_Id := Empty; + Prim_Elmt : Elmt_Id; + Subp : Entity_Id; + Typ : Entity_Id; - procedure Remove_Homonym (E : Entity_Id); - -- Removes E from the homonym chain + begin + pragma Assert (Ada_Version >= Ada_05 + and then Is_Record_Type (Tagged_Type) + and then Is_Tagged_Type (Tagged_Type) + and then Has_Interfaces (Tagged_Type)); + + -- Step 1: Transfer to the full-view primitives asociated with the + -- partial-view that cover interface primitives. Conceptually this + -- work should be done later by Process_Full_View; done here to + -- simplify its implementation at later stages. It can be safely + -- done here because interfaces must be visible in the partial and + -- private view (RM 7.3(7.3/2)). + + -- Small optimization: This work is only required if the parent is + -- abstract. If the tagged type is not abstract, it cannot have + -- abstract primitives (the only entities in the list of primitives of + -- non-abstract tagged types that can reference abstract primitives + -- through its Alias attribute are the internal entities that have + -- attribute Interface_Alias, and these entities are generated later + -- by Freeze_Record_Type). - ---------------------------------- - -- Collect_Interface_Primitives -- - ---------------------------------- + if In_Private_Part (Current_Scope) + and then Is_Abstract_Type (Parent_Type) + then + Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (Elmt) loop + Subp := Node (Elmt); - function Collect_Interface_Primitives - (Tagged_Type : Entity_Id) return Elist_Id - is - Op_List : constant Elist_Id := New_Elmt_List; - Elmt : Elmt_Id; - Ifaces_List : Elist_Id; - Iface_Elmt : Elmt_Id; - Prim : Entity_Id; + -- At this stage it is not possible to have entities in the list + -- of primitives that have attribute Interface_Alias - begin - pragma Assert (Is_Tagged_Type (Tagged_Type) - and then Has_Abstract_Interfaces (Tagged_Type)); + pragma Assert (No (Interface_Alias (Subp))); - Collect_Abstract_Interfaces (Tagged_Type, Ifaces_List); + Typ := Find_Dispatching_Type (Ultimate_Alias (Subp)); - Iface_Elmt := First_Elmt (Ifaces_List); - while Present (Iface_Elmt) loop - Elmt := First_Elmt (Primitive_Operations (Node (Iface_Elmt))); - while Present (Elmt) loop - Prim := Node (Elmt); + if Is_Interface (Typ) then + E := Find_Primitive_Covering_Interface + (Tagged_Type => Tagged_Type, + Iface_Prim => Subp); - if not Is_Predefined_Dispatching_Operation (Prim) then - Append_Elmt (Prim, Op_List); + if Present (E) + and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ + then + Replace_Elmt (Elmt, E); + Remove_Homonym (Subp); end if; - - Next_Elmt (Elmt); - end loop; - - Next_Elmt (Iface_Elmt); - end loop; - - return Op_List; - end Collect_Interface_Primitives; - - ------------- - -- In_List -- - ------------- - - function In_List (L : Elist_Id; Subp : Entity_Id) return Boolean is - Elmt : Elmt_Id; - - begin - Elmt := First_Elmt (L); - while Present (Elmt) loop - if Node (Elmt) = Subp then - return True; end if; Next_Elmt (Elmt); end loop; - - return False; - end In_List; - - -------------------- - -- Remove_Homonym -- - -------------------- - - procedure Remove_Homonym (E : Entity_Id) is - Prev : Entity_Id := Empty; - H : Entity_Id; - - begin - if E = Current_Entity (E) then - Set_Current_Entity (Homonym (E)); - else - H := Current_Entity (E); - while Present (H) and then H /= E loop - Prev := H; - H := Homonym (H); - end loop; - - Set_Homonym (Prev, Homonym (E)); - end if; - end Remove_Homonym; - - -- Local Variables - - E : Entity_Id; - Elmt : Elmt_Id; - Iface : Entity_Id; - Iface_Subp : Entity_Id; - New_Subp : Entity_Id := Empty; - Op_List : Elist_Id; - Parent_Base : Entity_Id; - Subp : Entity_Id; - - -- Start of processing for Derive_Interface_Subprograms - - begin - if Ada_Version < Ada_05 - or else not Is_Record_Type (Tagged_Type) - or else not Is_Tagged_Type (Tagged_Type) - or else not Has_Abstract_Interfaces (Tagged_Type) - then - return; end if; - -- Add to the list of interface subprograms all the primitives inherited - -- from abstract interfaces that are not immediate ancestors and also - -- add their derivation to the list of interface primitives. - - Op_List := Collect_Interface_Primitives (Tagged_Type); - - Elmt := First_Elmt (Op_List); - while Present (Elmt) loop - Subp := Node (Elmt); - Iface := Find_Dispatching_Type (Subp); - - if Is_Concurrent_Record_Type (Tagged_Type) then - if not Present (Abstract_Interface_Alias (Subp)) then - Derive_Subprogram (New_Subp, Subp, Tagged_Type, Iface); - Append_Elmt (New_Subp, Ifaces_List); - end if; + -- Step 2: Add primitives of progenitors that are not implemented by + -- parents of Tagged_Type - elsif not Is_Parent (Iface, Tagged_Type) then - Derive_Subprogram (New_Subp, Subp, Tagged_Type, Iface); - Append_Elmt (New_Subp, Ifaces_List); - end if; + if Present (Interfaces (Tagged_Type)) then + Iface_Elmt := First_Elmt (Interfaces (Tagged_Type)); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); - Next_Elmt (Elmt); - end loop; + Prim_Elmt := First_Elmt (Primitive_Operations (Iface)); + while Present (Prim_Elmt) loop + Iface_Subp := Node (Prim_Elmt); - -- Complete the derivation of the interface subprograms. Assign to each - -- entity associated with abstract interfaces their aliased entity and - -- complete their decoration as hidden interface entities that will be - -- used later to build the secondary dispatch tables. + -- Exclude derivation of predefined primitives except those + -- that come from source. Required to catch declarations of + -- equality operators of interfaces. For example: - if not Is_Empty_Elmt_List (Ifaces_List) then - if Ekind (Parent_Type) = E_Record_Type_With_Private - and then Has_Discriminants (Parent_Type) - and then Present (Full_View (Parent_Type)) - then - Parent_Base := Full_View (Parent_Type); - else - Parent_Base := Parent_Type; - end if; + -- type Iface is interface; + -- function "=" (Left, Right : Iface) return Boolean; - Elmt := First_Elmt (Ifaces_List); - while Present (Elmt) loop - Iface_Subp := Node (Elmt); - - -- Look for the first overriding entity in the homonym chain. - -- In this way if we are in the private part of a package spec - -- we get the last overriding subprogram. - - E := Current_Entity_In_Scope (Iface_Subp); - while Present (E) loop - if Is_Dispatching_Operation (E) - and then Scope (E) = Scope (Iface_Subp) - and then Type_Conformant (E, Iface_Subp) - and then not In_List (Ifaces_List, E) + if not Is_Predefined_Dispatching_Operation (Iface_Subp) + or else Comes_From_Source (Iface_Subp) then - exit; - end if; - - E := Homonym (E); - end loop; - - -- Create an overriding entity if not found in the homonym chain + E := Find_Primitive_Covering_Interface + (Tagged_Type => Tagged_Type, + Iface_Prim => Iface_Subp); - if not Present (E) then - Derive_Subprogram - (E, Alias (Iface_Subp), Tagged_Type, Parent_Base); - - elsif not In_List (Primitive_Operations (Tagged_Type), E) then - - -- Inherit the operation from the private view + -- If not found we derive a new primitive leaving its alias + -- attribute referencing the interface primitive - Append_Elmt (E, Primitive_Operations (Tagged_Type)); - end if; - - -- Complete the decoration of the hidden interface entity + if No (E) then + Derive_Subprogram + (New_Subp, Iface_Subp, Tagged_Type, Iface); - Set_Is_Hidden (Iface_Subp); - Set_Abstract_Interface_Alias (Iface_Subp, Alias (Iface_Subp)); - Set_Alias (Iface_Subp, E); - Set_Is_Abstract_Subprogram (Iface_Subp, - Is_Abstract_Subprogram (E)); - Remove_Homonym (Iface_Subp); + -- Propagate to the full view interface entities associated + -- with the partial view - -- Hidden entities associated with interfaces must have set the - -- Has_Delay_Freeze attribute to ensure that the corresponding - -- entry of the secondary dispatch table is filled when such - -- entity is frozen. + elsif In_Private_Part (Current_Scope) + and then Present (Alias (E)) + and then Alias (E) = Iface_Subp + and then + List_Containing (Parent (E)) /= + Private_Declarations + (Specification + (Unit_Declaration_Node (Current_Scope))) + then + Append_Elmt (E, Primitive_Operations (Tagged_Type)); + end if; + end if; - Set_Has_Delayed_Freeze (Iface_Subp); + Next_Elmt (Prim_Elmt); + end loop; - Next_Elmt (Elmt); + Next_Elmt (Iface_Elmt); end loop; end if; - end Derive_Interface_Subprograms; + end Derive_Progenitor_Subprograms; ----------------------- -- Derive_Subprogram -- @@ -11764,6 +11659,10 @@ package body Sem_Ch3 is end if; end Set_Derived_Name; + -- Local variables + + Parent_Overrides_Interface_Primitive : Boolean := False; + -- Start of processing for Derive_Subprogram begin @@ -11771,6 +11670,23 @@ package body Sem_Ch3 is New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); Set_Ekind (New_Subp, Ekind (Parent_Subp)); + -- Check whether the parent overrides an interface primitive + + if Is_Overriding_Operation (Parent_Subp) then + declare + E : Entity_Id := Parent_Subp; + begin + while Present (Overridden_Operation (E)) loop + E := Ultimate_Alias (Overridden_Operation (E)); + end loop; + + Parent_Overrides_Interface_Primitive := + Is_Dispatching_Operation (E) + and then Present (Find_Dispatching_Type (E)) + and then Is_Interface (Find_Dispatching_Type (E)); + end; + end if; + -- Check whether the inherited subprogram is a private operation that -- should be inherited but not yet made visible. Such subprograms can -- become visible at a later point (e.g., the private part of a public @@ -11816,10 +11732,11 @@ package body Sem_Ch3 is then Set_Derived_Name; - -- Ada 2005 (AI-251): Hidden entity associated with abstract interface - -- primitive + -- Ada 2005 (AI-251): Regular derivation if the parent subprogram + -- overrides an interface primitive because interface primitives + -- must be visible in the partial view of the parent (RM 7.3 (7.3/2)) - elsif Present (Abstract_Interface_Alias (Parent_Subp)) then + elsif Parent_Overrides_Interface_Primitive then Set_Derived_Name; -- The type is inheriting a private operation, so enter @@ -12035,17 +11952,102 @@ package body Sem_Ch3 is Derived_Type : Entity_Id; Generic_Actual : Entity_Id := Empty) is - Op_List : constant Elist_Id := - Collect_Primitive_Operations (Parent_Type); - Ifaces_List : constant Elist_Id := New_Elmt_List; - Predef_Prims : constant Elist_Id := New_Elmt_List; + Op_List : constant Elist_Id := + Collect_Primitive_Operations (Parent_Type); + + function Check_Derived_Type return Boolean; + -- Check that all primitive inherited from Parent_Type are found in + -- the list of primitives of Derived_Type exactly in the same order. + + function Check_Derived_Type return Boolean is + E : Entity_Id; + Elmt : Elmt_Id; + List : Elist_Id; + New_Subp : Entity_Id; + Op_Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + -- Traverse list of entities in the current scope searching for + -- an incomplete type whose full-view is derived type + + E := First_Entity (Scope (Derived_Type)); + while Present (E) + and then E /= Derived_Type + loop + if Ekind (E) = E_Incomplete_Type + and then Present (Full_View (E)) + and then Full_View (E) = Derived_Type + then + -- Disable this test if Derived_Type completes an incomplete + -- type because in such case more primitives can be added + -- later to the list of primitives of Derived_Type by routine + -- Process_Incomplete_Dependents + + return True; + end if; + + E := Next_Entity (E); + end loop; + + List := Collect_Primitive_Operations (Derived_Type); + Elmt := First_Elmt (List); + + Op_Elmt := First_Elmt (Op_List); + while Present (Op_Elmt) loop + Subp := Node (Op_Elmt); + New_Subp := Node (Elmt); + + -- At this early stage Derived_Type has no entities with attribute + -- Interface_Alias. In addition, such primitives are always + -- located at the end of the list of primitives of Parent_Type. + -- Therefore, if found we can safely stop processing pending + -- entities. + + exit when Present (Interface_Alias (Subp)); + + -- Handle hidden entities + + if not Is_Predefined_Dispatching_Operation (Subp) + and then Is_Hidden (Subp) + then + if Present (New_Subp) + and then Primitive_Names_Match (Subp, New_Subp) + then + Next_Elmt (Elmt); + end if; + + else + if not Present (New_Subp) + or else Ekind (Subp) /= Ekind (New_Subp) + or else not Primitive_Names_Match (Subp, New_Subp) + then + return False; + end if; + + Next_Elmt (Elmt); + end if; + + Next_Elmt (Op_Elmt); + end loop; + + return True; + end Check_Derived_Type; + + -- Local variables + + Alias_Subp : Entity_Id; Act_List : Elist_Id; - Act_Elmt : Elmt_Id; + Act_Elmt : Elmt_Id := No_Elmt; + Act_Subp : Entity_Id := Empty; Elmt : Elmt_Id; + Need_Search : Boolean := False; New_Subp : Entity_Id := Empty; Parent_Base : Entity_Id; Subp : Entity_Id; + -- Start of processing for Derive_Subprograms + begin if Ekind (Parent_Type) = E_Record_Type_With_Private and then Has_Discriminants (Parent_Type) @@ -12056,126 +12058,266 @@ package body Sem_Ch3 is Parent_Base := Parent_Type; end if; - -- Derive primitives inherited from the parent. Note that if the generic - -- actual is present, this is not really a type derivation, it is a - -- completion within an instance. - if Present (Generic_Actual) then Act_List := Collect_Primitive_Operations (Generic_Actual); Act_Elmt := First_Elmt (Act_List); - else - Act_Elmt := No_Elmt; end if; - -- Literals are derived earlier in the process of building the derived - -- type, and are skipped here. + -- Derive primitives inherited from the parent. Note that if the generic + -- actual is present, this is not really a type derivation, it is a + -- completion within an instance. + + -- Case 1: Derived_Type does not implement interfaces - Elmt := First_Elmt (Op_List); - while Present (Elmt) loop - Subp := Node (Elmt); + if not Is_Tagged_Type (Derived_Type) + or else (not Has_Interfaces (Derived_Type) + and then not (Present (Generic_Actual) + and then + Has_Interfaces (Generic_Actual))) + then + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + Subp := Node (Elmt); - if Ekind (Subp) /= E_Enumeration_Literal then + -- Literals are derived earlier in the process of building the + -- derived type, and are skipped here. - if Ada_Version >= Ada_05 - and then Present (Abstract_Interface_Alias (Subp)) - then + if Ekind (Subp) = E_Enumeration_Literal then null; - -- We derive predefined primitives in a later round to ensure that - -- they are always added to the list of primitives after user - -- defined primitives (because predefined primitives have to be - -- skipped when matching the operations of a parent interface to - -- those of a concrete type). However it is unclear why those - -- primitives would be needed in an instantiation??? + -- The actual is a direct descendant and the common primitive + -- operations appear in the same order. - elsif Is_Predefined_Dispatching_Operation (Subp) then - Append_Elmt (Subp, Predef_Prims); + -- If the generic parent type is present, the derived type is an + -- instance of a formal derived type, and within the instance its + -- operations are those of the actual. We derive from the formal + -- type but make the inherited operations aliases of the + -- corresponding operations of the actual. - elsif No (Generic_Actual) then - Derive_Subprogram (New_Subp, Subp, Derived_Type, Parent_Base); + else + Derive_Subprogram + (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); - -- Ada 2005 (AI-251): Add derivation of an abstract interface - -- primitive to the list of entities to which we have to - -- associate an aliased entity. + if Present (Act_Elmt) then + Next_Elmt (Act_Elmt); + end if; + end if; - if Ada_Version >= Ada_05 - and then Is_Dispatching_Operation (Subp) - and then Present (Find_Dispatching_Type (Subp)) - and then Is_Interface (Find_Dispatching_Type (Subp)) - then - Append_Elmt (New_Subp, Ifaces_List); + Next_Elmt (Elmt); + end loop; + + -- Case 2: Derived_Type implements interfaces + + else + -- If the parent type has no predefined primitives we remove + -- predefined primitives from the list of primitives of generic + -- actual to simplify the complexity of this algorithm. + + if Present (Generic_Actual) then + declare + Has_Predefined_Primitives : Boolean := False; + + begin + -- Check if the parent type has predefined primitives + + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + Subp := Node (Elmt); + + if Is_Predefined_Dispatching_Operation (Subp) + and then not Comes_From_Source (Ultimate_Alias (Subp)) + then + Has_Predefined_Primitives := True; + exit; + end if; + + Next_Elmt (Elmt); + end loop; + + -- Remove predefined primitives of Generic_Actual. We must use + -- an auxiliary list because in case of tagged types the value + -- returned by Collect_Primitive_Operations is the value stored + -- in its Primitive_Operations attribute (and we don't want to + -- modify its current contents). + + if not Has_Predefined_Primitives then + declare + Aux_List : constant Elist_Id := New_Elmt_List; + + begin + Elmt := First_Elmt (Act_List); + while Present (Elmt) loop + Subp := Node (Elmt); + + if not Is_Predefined_Dispatching_Operation (Subp) + or else Comes_From_Source (Subp) + then + Append_Elmt (Subp, Aux_List); + end if; + + Next_Elmt (Elmt); + end loop; + + Act_List := Aux_List; + end; end if; - else - -- If the generic parent type is present, the derived type - -- is an instance of a formal derived type, and within the - -- instance its operations are those of the actual. We derive - -- from the formal type but make the inherited operations - -- aliases of the corresponding operations of the actual. - - if Is_Interface (Parent_Type) - and then Root_Type (Derived_Type) /= Parent_Type + Act_Elmt := First_Elmt (Act_List); + Act_Subp := Node (Act_Elmt); + end; + end if; + + -- Stage 1: If the generic actual is not present we derive the + -- primitives inherited from the parent type. If the generic parent + -- type is present, the derived type is an instance of a formal + -- derived type, and within the instance its operations are those of + -- the actual. We derive from the formal type but make the inherited + -- operations aliases of the corresponding operations of the actual. + + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + Subp := Node (Elmt); + Alias_Subp := Ultimate_Alias (Subp); + + -- At this early stage Derived_Type has no entities with attribute + -- Interface_Alias. In addition, such primitives are always + -- located at the end of the list of primitives of Parent_Type. + -- Therefore, if found we can safely stop processing pending + -- entities. + + exit when Present (Interface_Alias (Subp)); + + -- If the generic actual is present find the corresponding + -- operation in the generic actual. If the parent type is a + -- direct ancestor of the derived type then, even if it is an + -- interface, the operations are inherited from the primary + -- dispatch table and are in the proper order. If we detect here + -- that primitives are not in the same order we traverse the list + -- of primitive operations of the actual to find the one that + -- implements the interface primitive. + + if Need_Search + or else + (Present (Generic_Actual) + and then Present (Act_Subp) + and then not Primitive_Names_Match (Subp, Act_Subp)) + then + pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual)); + pragma Assert (Is_Interface (Parent_Base)); + + -- Remember that we need searching for all the pending + -- primitives + + Need_Search := True; + + -- Handle entities associated with interface primitives + + if Present (Alias (Subp)) + and then Is_Interface (Find_Dispatching_Type (Alias (Subp))) + and then not Is_Predefined_Dispatching_Operation (Subp) then - -- Find the corresponding operation in the generic actual. - -- Given that the actual is not a direct descendant of the - -- parent, as in Ada 95, the primitives are not necessarily - -- in the same order, so we have to traverse the list of - -- primitive operations of the actual to find the one that - -- implements the interface operation. - - -- Note that if the parent type is the direct ancestor of - -- the derived type, then even if it is an interface the - -- operations are inherited from the primary dispatch table - -- and are in the proper order. + Act_Subp := + Find_Primitive_Covering_Interface + (Tagged_Type => Generic_Actual, + Iface_Prim => Subp); + + -- Handle predefined primitives plus the rest of user-defined + -- primitives + else Act_Elmt := First_Elmt (Act_List); while Present (Act_Elmt) loop - exit when - Abstract_Interface_Alias (Node (Act_Elmt)) = Subp; + Act_Subp := Node (Act_Elmt); + + exit when Primitive_Names_Match (Subp, Act_Subp) + and then Type_Conformant (Subp, Act_Subp, + Skip_Controlling_Formals => True) + and then No (Interface_Alias (Act_Subp)); + Next_Elmt (Act_Elmt); end loop; end if; + end if; - -- If the formal is not an interface, the actual is a direct - -- descendant and the common primitive operations appear in - -- the same order. + -- Case 1: If the parent is a limited interface then it has the + -- predefined primitives of synchronized interfaces. However, the + -- actual type may be a non-limited type and hence it does not + -- have such primitives. - Derive_Subprogram - (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); + if Present (Generic_Actual) + and then not Present (Act_Subp) + and then Is_Limited_Interface (Parent_Base) + and then Is_Predefined_Interface_Primitive (Subp) + then + null; - if Present (Act_Elmt) then - Next_Elmt (Act_Elmt); + -- Case 2: Inherit entities associated with interfaces that + -- were not covered by the parent type. We exclude here null + -- interface primitives because they do not need special + -- management. + + elsif Present (Alias (Subp)) + and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) + and then not + (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification + and then Null_Present (Parent (Alias_Subp))) + then + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Alias_Subp, + Derived_Type => Derived_Type, + Parent_Type => Find_Dispatching_Type (Alias_Subp), + Actual_Subp => Act_Subp); + + if No (Generic_Actual) then + Set_Alias (New_Subp, Subp); end if; - end if; - end if; - Next_Elmt (Elmt); - end loop; + -- Case 3: Common derivation - -- Inherit additional operations from progenitor interfaces. However, - -- if the derived type is a generic actual, there are not new primitive - -- operations for the type, because it has those of the actual, so - -- nothing needs to be done. The renamings generated above are not - -- primitive operations, and their purpose is simply to make the proper - -- operations visible within an instantiation. + else + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Subp, + Derived_Type => Derived_Type, + Parent_Type => Parent_Base, + Actual_Subp => Act_Subp); + end if; - if Ada_Version >= Ada_05 - and then Is_Tagged_Type (Derived_Type) - and then No (Generic_Actual) - then - Derive_Interface_Subprograms (Parent_Type, Derived_Type, Ifaces_List); - end if; + -- No need to update Act_Elm if we must search for the + -- corresponding operation in the generic actual - -- Derive predefined primitives + if not Need_Search + and then Present (Act_Elmt) + then + Next_Elmt (Act_Elmt); + Act_Subp := Node (Act_Elmt); + end if; - if not Is_Empty_Elmt_List (Predef_Prims) then - Elmt := First_Elmt (Predef_Prims); - while Present (Elmt) loop - Derive_Subprogram - (New_Subp, Node (Elmt), Derived_Type, Parent_Base); Next_Elmt (Elmt); end loop; + + -- Inherit additional operations from progenitors. If the derived + -- type is a generic actual, there are not new primitive operations + -- for the type because it has those of the actual, and therefore + -- nothing needs to be done. The renamings generated above are not + -- primitive operations, and their purpose is simply to make the + -- proper operations visible within an instantiation. + + if No (Generic_Actual) then + Derive_Progenitor_Subprograms (Parent_Base, Derived_Type); + end if; end if; + + -- Final check: Direct descendants must have their primitives in the + -- same order. We exclude from this test non-tagged types and instances + -- of formal derived types. We skip this test if we have already + -- reported serious errors in the sources. + + pragma Assert (not Is_Tagged_Type (Derived_Type) + or else Present (Generic_Actual) + or else Serious_Errors_Detected > 0 + or else Check_Derived_Type); end Derive_Subprograms; -------------------------------- @@ -12315,8 +12457,7 @@ package body Sem_Ch3 is if Interface_Present (Def) then if not Is_Interface (Parent_Type) then - Error_Msg_NE - ("(Ada 2005) & must be an interface", Indic, Parent_Type); + Diagnose_Interface (Indic, Parent_Type); else Parent_Node := Parent (Base_Type (Parent_Type)); @@ -12409,7 +12550,7 @@ package body Sem_Ch3 is T := Find_Type_Of_Subtype_Indic (Intf); if not Is_Interface (T) then - Error_Msg_NE ("(Ada 2005) & must be an interface", Intf, T); + Diagnose_Interface (Intf, T); -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow -- a limited type from having a nonlimited progenitor. @@ -12722,6 +12863,19 @@ package body Sem_Ch3 is end if; end Derived_Type_Declaration; + ------------------------ + -- Diagnose_Interface -- + ------------------------ + + procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is + begin + if not Is_Interface (E) + and then E /= Any_Type + then + Error_Msg_NE ("(Ada 2005) & must be an interface", N, E); + end if; + end Diagnose_Interface; + ---------------------------------- -- Enumeration_Type_Declaration -- ---------------------------------- @@ -12927,7 +13081,7 @@ package body Sem_Ch3 is Prev_Par : Node_Id; procedure Tag_Mismatch; - -- Diagnose a tagged partial view whose full view is untagged; + -- 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, @@ -13108,9 +13262,9 @@ package body Sem_Ch3 is end if; -- 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. This Ada95 usage is deprecated - -- in favor of incomplete tagged declarations but we check for it. + -- type due to use of the class attribute, and in this case the full + -- type must also be tagged. This Ada 95 usage is deprecated in favor + -- of incomplete tagged declarations, but we check for it. if Is_Type (Prev) and then (Is_Tagged_Type (Prev) @@ -13121,7 +13275,7 @@ package body Sem_Ch3 is -- type extension, otherwise this is an error. if Nkind_In (N, N_Task_Type_Declaration, - N_Protected_Type_Declaration) + N_Protected_Type_Declaration) then if No (Interface_List (N)) and then not Error_Posted (N) @@ -14046,48 +14200,9 @@ package body Sem_Ch3 is (Iface : Entity_Id; Typ : Entity_Id) return Boolean is - Iface_Elmt : Elmt_Id; - I_Name : Entity_Id; - begin - if No (Abstract_Interfaces (Typ)) then - return False; - - else - Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ)); - while Present (Iface_Elmt) loop - I_Name := Node (Iface_Elmt); - if Base_Type (I_Name) = Base_Type (Iface) then - return True; - - elsif Is_Derived_Type (I_Name) - and then Is_Ancestor (Iface, I_Name) - then - return True; - - else - Next_Elmt (Iface_Elmt); - end if; - end loop; - - -- For concurrent record types, they have the interfaces of the - -- parent synchronized type. However these have no ancestors that - -- implement anything, so assume it is a progenitor. - -- Should be cleaned up in Collect_Abstract_Interfaces??? - - if Is_Concurrent_Record_Type (Typ) then - return Present (Abstract_Interfaces (Typ)); - end if; - - -- If type is a derived type, check recursively its ancestors - - if Is_Derived_Type (Typ) then - return Etype (Typ) = Iface - or else Is_Progenitor (Iface, Etype (Typ)); - else - return False; - end if; - end if; + return Implements_Interface (Typ, Iface, + Exclude_Parents => True); end Is_Progenitor; ------------------------------ @@ -15366,8 +15481,8 @@ package body Sem_Ch3 is -- Handle entities in the list of abstract interfaces - if Present (Abstract_Interfaces (Typ)) then - Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ)); + if Present (Interfaces (Typ)) then + Iface_Elmt := First_Elmt (Interfaces (Typ)); while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); @@ -15697,6 +15812,9 @@ package body Sem_Ch3 is -- If the private view was tagged, copy the new primitive operations -- from the private view to the full view. + -- Note: Subprograms covering interface primitives were previously + -- propagated to the full view by Derive_Progenitor_Primitives + if Is_Tagged_Type (Full_T) and then not Is_Concurrent_Type (Full_T) then @@ -16529,7 +16647,8 @@ package body Sem_Ch3 is -- view of the type. function Designates_T (Subt : Node_Id) return Boolean; - -- Check whether a node designates the enclosing record type + -- Check whether a node designates the enclosing record type, or 'Class + -- of that type function Mentions_T (Acc_Def : Node_Id) return Boolean; -- Check whether an access definition includes a reference to @@ -16547,13 +16666,25 @@ package body Sem_Ch3 is Inc_T : Entity_Id; H : Entity_Id; + -- Is_Tagged indicates whether the type is tagged. It is tagged if + -- it's "is new ... with record" or else "is tagged record ...". + + Is_Tagged : constant Boolean := + (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition + and then + Present + (Record_Extension_Part (Type_Definition (Typ_Decl)))) + or else + (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition + and then Tagged_Present (Type_Definition (Typ_Decl))); + begin -- If there is a previous partial view, no need to create a new one -- If the partial view, given by Prev, is incomplete, If Prev is -- a private declaration, full declaration is flagged accordingly. if Prev /= Typ then - if Tagged_Present (Type_Definition (Typ_Decl)) then + if Is_Tagged then Make_Class_Wide_Type (Prev); Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev)); Set_Etype (Class_Wide_Type (Typ), Typ); @@ -16562,6 +16693,15 @@ package body Sem_Ch3 is return; elsif Has_Private_Declaration (Typ) then + + -- If we refer to T'Class inside T, and T is the completion of a + -- private type, then we need to make sure the class-wide type + -- exists. + + if Is_Tagged then + Make_Class_Wide_Type (Typ); + end if; + return; -- If there was a previous anonymous access type, the incomplete @@ -16603,14 +16743,9 @@ package body Sem_Ch3 is Analyze (Decl); Set_Full_View (Inc_T, Typ); - if (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition - and then - Present - (Record_Extension_Part (Type_Definition (Typ_Decl)))) - or else Tagged_Present (Type_Definition (Typ_Decl)) - then + if Is_Tagged then -- Create a common class-wide type for both views, and set - -- the etype of the class-wide type to the full view. + -- the Etype of the class-wide type to the full view. Make_Class_Wide_Type (Inc_T); Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); @@ -16902,11 +17037,11 @@ package body Sem_Ch3 is -- These flags must be initialized before calling Process_Discriminants -- because this routine makes use of them. - Set_Ekind (T, E_Record_Type); - Set_Etype (T, T); - Init_Size_Align (T); - Set_Abstract_Interfaces (T, No_Elist); - Set_Stored_Constraint (T, No_Elist); + Set_Ekind (T, E_Record_Type); + Set_Etype (T, T); + Init_Size_Align (T); + Set_Interfaces (T, No_Elist); + Set_Stored_Constraint (T, No_Elist); -- Normal case @@ -16952,7 +17087,7 @@ package body Sem_Ch3 is if Ada_Version >= Ada_05 and then Present (Interface_List (Def)) then - Check_Abstract_Interfaces (N, Def); + Check_Interfaces (N, Def); declare Ifaces_List : Elist_Id; @@ -16961,12 +17096,12 @@ package body Sem_Ch3 is -- Ada 2005 (AI-251): Collect the list of progenitors that are not -- already in the parents. - Collect_Abstract_Interfaces - (T => T, - Ifaces_List => Ifaces_List, - Exclude_Parent_Interfaces => True); + Collect_Interfaces + (T => T, + Ifaces_List => Ifaces_List, + Exclude_Parents => True); - Set_Abstract_Interfaces (T, Ifaces_List); + Set_Interfaces (T, Ifaces_List); end; end if; @@ -17013,7 +17148,7 @@ package body Sem_Ch3 is -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the -- implemented interfaces. - if Has_Abstract_Interfaces (T) then + if Has_Interfaces (T) then Add_Interface_Tag_Components (N, T); end if; end if; @@ -17050,11 +17185,7 @@ package body Sem_Ch3 is if Is_Tagged and then not Is_Empty_List (Interface_List (Def)) then - declare - Ifaces_List : constant Elist_Id := New_Elmt_List; - begin - Derive_Interface_Subprograms (T, T, Ifaces_List); - end; + Derive_Progenitor_Subprograms (T, T); end if; end Record_Type_Declaration; diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 0dff777a654..89b85fe2c23 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -26,7 +26,7 @@ with Nlists; use Nlists; with Types; use Types; -package Sem_Ch3 is +package Sem_Ch3 is procedure Analyze_Component_Declaration (N : Node_Id); procedure Analyze_Incomplete_Type_Decl (N : Node_Id); procedure Analyze_Itype_Reference (N : Node_Id); @@ -171,6 +171,7 @@ package Sem_Ch3 is -- family declaration or a loop iteration. The index is given by an -- index declaration (a 'box'), or by a discrete range. The later can -- be the name of a discrete type, or a subtype indication. + -- -- Related_Nod is the node where the potential generated implicit types -- will be inserted. The 2 last parameters are used for creating the name. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index db5c112f059..b59cd4b5186 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -3525,7 +3525,6 @@ package body Sem_Ch4 is Error_Msg_NE ("no selector& for}", N, Sel); Check_Misspelled_Selector (Type_To_Use, Sel); - end if; Set_Entity (Sel, Any_Id); @@ -6443,14 +6442,14 @@ package body Sem_Ch4 is -- primitive is also in this list of primitive operations and -- will be used instead. - if (Present (Abstract_Interface_Alias (Prim_Op)) - and then Is_Ancestor (Find_Dispatching_Type - (Alias (Prim_Op)), Corr_Type)) + if (Present (Interface_Alias (Prim_Op)) + and then Is_Ancestor (Find_Dispatching_Type + (Alias (Prim_Op)), Corr_Type)) or else - -- Do not consider hidden primitives unless the type is in an - -- open scope or we are within an instance, where visibility - -- is known to be correct. + -- Do not consider hidden primitives unless the type is + -- in an open scope or we are within an instance, where + -- visibility is known to be correct. (Is_Hidden (Prim_Op) and then not Is_Immediately_Visible (Obj_Type) diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index e5de05b3a58..11439419a25 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -582,9 +582,15 @@ package body Sem_Ch5 is -- Ada 2005 (AI-230 and AI-385): When the lhs type is an anonymous -- access type, apply an implicit conversion of the rhs to that type -- to force appropriate static and run-time accessibility checks. + -- This applies as well to anonymous access-to-subprogram types that + -- are component subtypes. if Ada_Version >= Ada_05 - and then Ekind (T1) = E_Anonymous_Access_Type + and then + Is_Access_Type (T1) + and then + (Is_Local_Anonymous_Access (T1) + or else Can_Never_Be_Null (T1)) then Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs))); Analyze_And_Resolve (Rhs, T1); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index b4b1dcf9e04..f376e955b37 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -33,6 +33,7 @@ with Expander; use Expander; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch9; use Exp_Ch9; +with Exp_Disp; use Exp_Disp; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Fname; use Fname; @@ -1601,6 +1602,7 @@ package body Sem_Ch6 is elsif Nkind (Parent (N)) = N_Compilation_Unit then Freeze_Before (N, Spec_Id); end if; + else Spec_Id := Corresponding_Spec (N); end if; @@ -1827,7 +1829,7 @@ package body Sem_Ch6 is and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type and then Is_Tagged_Type (Etype (First_Entity (Spec_Id))) and then - Present (Abstract_Interfaces (Etype (First_Entity (Spec_Id)))) + Present (Interfaces (Etype (First_Entity (Spec_Id)))) and then Present (Corresponding_Concurrent_Type @@ -2458,21 +2460,20 @@ package body Sem_Ch6 is Push_Scope (Designator); Process_Formals (Formals, N); - -- Ada 2005 (AI-345): Allow the overriding of interface primitives - -- by subprograms which belong to a concurrent type implementing an - -- interface. Set the parameter type of each controlling formal to - -- the corresponding record type. + -- Ada 2005 (AI-345): If this is an overriding operation of an + -- inherited interface operation, and the controlling type is + -- a synchronized type, replace the type with its corresponding + -- record, to match the proper signature of an overriding operation. if Ada_Version >= Ada_05 then Formal := First_Formal (Designator); while Present (Formal) loop Formal_Typ := Etype (Formal); - if (Ekind (Formal_Typ) = E_Protected_Type - or else Ekind (Formal_Typ) = E_Task_Type) + if Is_Concurrent_Type (Formal_Typ) and then Present (Corresponding_Record_Type (Formal_Typ)) - and then Present (Abstract_Interfaces - (Corresponding_Record_Type (Formal_Typ))) + and then Present (Interfaces + (Corresponding_Record_Type (Formal_Typ))) then Set_Etype (Formal, Corresponding_Record_Type (Formal_Typ)); @@ -3141,7 +3142,18 @@ package body Sem_Ch6 is if Old_Type /= Standard_Void_Type and then New_Type /= Standard_Void_Type then - if not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then + + -- If we are checking interface conformance we omit controlling + -- arguments and result, because we are only checking the conformance + -- of the remaining parameters. + + if Has_Controlling_Result (Old_Id) + and then Has_Controlling_Result (New_Id) + and then Skip_Controlling_Formals + then + null; + + elsif not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then Conformance_Error ("\return type does not match!", New_Id); return; end if; @@ -3506,18 +3518,9 @@ package body Sem_Ch6 is ----------------------- procedure Check_Conventions (Typ : Entity_Id) is + Ifaces_List : Elist_Id; - function Skip_Check (Op : Entity_Id) return Boolean; - pragma Inline (Skip_Check); - -- A small optimization: skip the predefined dispatching operations, - -- since they always have the same convention. Also do not consider - -- abstract primitives since those are left by an erroneous overriding. - -- This function returns True for any operation that is thus exempted - -- exempted from checking. - - procedure Check_Convention - (Op : Entity_Id; - Search_From : Elmt_Id); + procedure Check_Convention (Op : Entity_Id); -- Verify that the convention of inherited dispatching operation Op is -- consistent among all subprograms it overrides. In order to minimize -- the search, Search_From is utilized to designate a specific point in @@ -3527,89 +3530,62 @@ package body Sem_Ch6 is -- Check_Convention -- ---------------------- - procedure Check_Convention - (Op : Entity_Id; - Search_From : Elmt_Id) - is - procedure Error_Msg_Operation (Op : Entity_Id); - -- Emit a continuation to an error message depicting the kind, name, - -- convention and source location of subprogram Op. - - ------------------------- - -- Error_Msg_Operation -- - ------------------------- + procedure Check_Convention (Op : Entity_Id) is + Iface_Elmt : Elmt_Id; + Iface_Prim_Elmt : Elmt_Id; + Iface_Prim : Entity_Id; - procedure Error_Msg_Operation (Op : Entity_Id) is - begin - Error_Msg_Name_1 := Chars (Op); + begin + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + Iface_Prim_Elmt := + First_Elmt (Primitive_Operations (Node (Iface_Elmt))); + while Present (Iface_Prim_Elmt) loop + Iface_Prim := Node (Iface_Prim_Elmt); + + if Is_Interface_Conformant (Typ, Iface_Prim, Op) + and then Convention (Iface_Prim) /= Convention (Op) + then + Error_Msg_N + ("inconsistent conventions in primitive operations", Typ); - -- Error messages of primitive subprograms do not contain a - -- convention attribute since the convention may have been first - -- inherited from a parent subprogram, then changed by a pragma. + Error_Msg_Name_1 := Chars (Op); + Error_Msg_Name_2 := Get_Convention_Name (Convention (Op)); + Error_Msg_Sloc := Sloc (Op); - if Comes_From_Source (Op) then - Error_Msg_Sloc := Sloc (Op); - Error_Msg_N - ("\ primitive % defined #", Typ); + if Comes_From_Source (Op) then + if not Is_Overriding_Operation (Op) then + Error_Msg_N ("\\primitive % defined #", Typ); + else + Error_Msg_N ("\\overridding operation % with " & + "convention % defined #", Typ); + end if; - else - Error_Msg_Name_2 := Get_Convention_Name (Convention (Op)); + else pragma Assert (Present (Alias (Op))); + Error_Msg_Sloc := Sloc (Alias (Op)); + Error_Msg_N ("\\inherited operation % with " & + "convention % defined #", Typ); + end if; - if Present (Abstract_Interface_Alias (Op)) then - Error_Msg_Sloc := Sloc (Abstract_Interface_Alias (Op)); + Error_Msg_Name_1 := Chars (Op); + Error_Msg_Name_2 := + Get_Convention_Name (Convention (Iface_Prim)); + Error_Msg_Sloc := Sloc (Iface_Prim); Error_Msg_N ("\\overridden operation % with " & "convention % defined #", Typ); - else pragma Assert (Present (Alias (Op))); - Error_Msg_Sloc := Sloc (Alias (Op)); - Error_Msg_N ("\\inherited operation % with " & - "convention % defined #", Typ); - end if; - end if; - end Error_Msg_Operation; - - -- Local variables - - Second_Prim_Op : Entity_Id; - Second_Prim_Op_Elmt : Elmt_Id; - - -- Start of processing for Check_Convention + -- Avoid cascading errors - begin - Second_Prim_Op_Elmt := Next_Elmt (Search_From); - while Present (Second_Prim_Op_Elmt) loop - Second_Prim_Op := Node (Second_Prim_Op_Elmt); - - if not Skip_Check (Second_Prim_Op) - and then Chars (Second_Prim_Op) = Chars (Op) - and then Type_Conformant (Second_Prim_Op, Op) - and then Convention (Second_Prim_Op) /= Convention (Op) - then - Error_Msg_N - ("inconsistent conventions in primitive operations", Typ); - - Error_Msg_Operation (Op); - Error_Msg_Operation (Second_Prim_Op); - - -- Avoid cascading errors + return; + end if; - return; - end if; + Next_Elmt (Iface_Prim_Elmt); + end loop; - Next_Elmt (Second_Prim_Op_Elmt); + Next_Elmt (Iface_Elmt); end loop; end Check_Convention; - ---------------- - -- Skip_Check -- - ---------------- - - function Skip_Check (Op : Entity_Id) return Boolean is - begin - return Is_Predefined_Dispatching_Operation (Op) - or else Is_Abstract_Subprogram (Op); - end Skip_Check; - -- Local variables Prim_Op : Entity_Id; @@ -3618,6 +3594,12 @@ package body Sem_Ch6 is -- Start of processing for Check_Conventions begin + if not Has_Interfaces (Typ) then + return; + end if; + + Collect_Interfaces (Typ, Ifaces_List); + -- The algorithm checks every overriding dispatching operation against -- all the corresponding overridden dispatching operations, detecting -- differences in conventions. @@ -3627,13 +3609,10 @@ package body Sem_Ch6 is Prim_Op := Node (Prim_Op_Elmt); -- A small optimization: skip the predefined dispatching operations - -- since they always have the same convention. Also avoid processing - -- of abstract primitives left from an erroneous overriding. + -- since they always have the same convention. - if not Skip_Check (Prim_Op) then - Check_Convention - (Op => Prim_Op, - Search_From => Prim_Op_Elmt); + if not Is_Predefined_Dispatching_Operation (Prim_Op) then + Check_Convention (Prim_Op); end if; Next_Elmt (Prim_Op_Elmt); @@ -4497,15 +4476,17 @@ package body Sem_Ch6 is ------------------------------ procedure Check_Subtype_Conformant - (New_Id : Entity_Id; - Old_Id : Entity_Id; - Err_Loc : Node_Id := Empty) + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Err_Loc : Node_Id := Empty; + Skip_Controlling_Formals : Boolean := False) is Result : Boolean; pragma Warnings (Off, Result); begin Check_Conformance - (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc); + (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc, + Skip_Controlling_Formals => Skip_Controlling_Formals); end Check_Subtype_Conformant; --------------------------- @@ -5020,7 +5001,7 @@ package body Sem_Ch6 is -- can be called in a dispatching context and such calls must be -- handled like calls to a class-wide function. - if not Is_Constrained (Result_Subt) + if not Is_Constrained (Underlying_Type (Result_Subt)) or else Is_Tagged_Type (Underlying_Type (Result_Subt)) then Discard := @@ -5795,6 +5776,71 @@ package body Sem_Ch6 is end loop; end Install_Formals; + ----------------------------- + -- Is_Interface_Conformant -- + ----------------------------- + + function Is_Interface_Conformant + (Tagged_Type : Entity_Id; + Iface_Prim : Entity_Id; + Prim : Entity_Id) return Boolean + is + Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim); + Typ : constant Entity_Id := Find_Dispatching_Type (Prim); + + begin + pragma Assert (Is_Subprogram (Iface_Prim) + and then Is_Subprogram (Prim) + and then Is_Dispatching_Operation (Iface_Prim) + and then Is_Dispatching_Operation (Prim)); + + pragma Assert (Is_Interface (Iface) + or else (Present (Alias (Iface_Prim)) + and then + Is_Interface + (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim))))); + + if Prim = Iface_Prim + or else not Is_Subprogram (Prim) + or else Ekind (Prim) /= Ekind (Iface_Prim) + or else not Is_Dispatching_Operation (Prim) + or else Scope (Prim) /= Scope (Tagged_Type) + or else No (Typ) + or else Base_Type (Typ) /= Tagged_Type + or else not Primitive_Names_Match (Iface_Prim, Prim) + then + return False; + + -- Case of a procedure, or a function that does not have a controlling + -- result (I or access I). + + elsif Ekind (Iface_Prim) = E_Procedure + or else Etype (Prim) = Etype (Iface_Prim) + or else not Has_Controlling_Result (Prim) + then + return Type_Conformant (Prim, Iface_Prim, + Skip_Controlling_Formals => True); + + -- Case of a function returning an interface, or an access to one. + -- Check that the return types correspond. + + elsif Implements_Interface (Typ, Iface) then + if (Ekind (Etype (Prim)) = E_Anonymous_Access_Type) + /= + (Ekind (Etype (Iface_Prim)) = E_Anonymous_Access_Type) + then + return False; + else + return + Type_Conformant (Prim, Iface_Prim, + Skip_Controlling_Formals => True); + end if; + + else + return False; + end if; + end Is_Interface_Conformant; + --------------------------------- -- Is_Non_Overriding_Operation -- --------------------------------- @@ -6157,7 +6203,6 @@ package body Sem_Ch6 is procedure Check_Synchronized_Overriding (Def_Id : Entity_Id; - First_Hom : Entity_Id; Overridden_Subp : out Entity_Id); -- First determine if Def_Id is an entry or a subprogram either defined -- in the scope of a task or protected type, or is a primitive of such @@ -6352,22 +6397,198 @@ package body Sem_Ch6 is procedure Check_Synchronized_Overriding (Def_Id : Entity_Id; - First_Hom : Entity_Id; Overridden_Subp : out Entity_Id) is - Formal_Typ : Entity_Id; Ifaces_List : Elist_Id; In_Scope : Boolean; Typ : Entity_Id; + function Has_Correct_Formal_Mode + (Tag_Typ : Entity_Id; + Subp : Entity_Id) return Boolean; + -- For an overridden subprogram Subp, check whether the mode of its + -- first parameter is correct depending on the kind of Tag_Typ. + + function Matches_Prefixed_View_Profile + (Prim_Params : List_Id; + Iface_Params : List_Id) return Boolean; + -- Determine whether a subprogram's parameter profile Prim_Params + -- matches that of a potentially overridden interface subprogram + -- Iface_Params. Also determine if the type of first parameter of + -- Iface_Params is an implemented interface. + + ----------------------------- + -- Has_Correct_Formal_Mode -- + ----------------------------- + + function Has_Correct_Formal_Mode + (Tag_Typ : Entity_Id; + Subp : Entity_Id) return Boolean + is + Formal : constant Node_Id := First_Formal (Subp); + + begin + -- In order for an entry or a protected procedure to override, the + -- first parameter of the overridden routine must be of mode + -- "out", "in out" or access-to-variable. + + if (Ekind (Subp) = E_Entry + or else Ekind (Subp) = E_Procedure) + and then Is_Protected_Type (Tag_Typ) + and then Ekind (Formal) /= E_In_Out_Parameter + and then Ekind (Formal) /= E_Out_Parameter + and then Nkind (Parameter_Type (Parent (Formal))) /= + N_Access_Definition + then + return False; + end if; + + -- All other cases are OK since a task entry or routine does not + -- have a restriction on the mode of the first parameter of the + -- overridden interface routine. + + return True; + end Has_Correct_Formal_Mode; + + ----------------------------------- + -- Matches_Prefixed_View_Profile -- + ----------------------------------- + + function Matches_Prefixed_View_Profile + (Prim_Params : List_Id; + Iface_Params : List_Id) return Boolean + is + Iface_Id : Entity_Id; + Iface_Param : Node_Id; + Iface_Typ : Entity_Id; + Prim_Id : Entity_Id; + Prim_Param : Node_Id; + Prim_Typ : Entity_Id; + + function Is_Implemented + (Ifaces_List : Elist_Id; + Iface : Entity_Id) return Boolean; + -- Determine if Iface is implemented by the current task or + -- protected type. + + -------------------- + -- Is_Implemented -- + -------------------- + + function Is_Implemented + (Ifaces_List : Elist_Id; + Iface : Entity_Id) return Boolean + is + Iface_Elmt : Elmt_Id; + + begin + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + if Node (Iface_Elmt) = Iface then + return True; + end if; + + Next_Elmt (Iface_Elmt); + end loop; + + return False; + end Is_Implemented; + + -- Start of processing for Matches_Prefixed_View_Profile + + begin + Iface_Param := First (Iface_Params); + Iface_Typ := Etype (Defining_Identifier (Iface_Param)); + + if Is_Access_Type (Iface_Typ) then + Iface_Typ := Designated_Type (Iface_Typ); + end if; + + Prim_Param := First (Prim_Params); + + -- The first parameter of the potentially overridden subprogram + -- must be an interface implemented by Prim. + + if not Is_Interface (Iface_Typ) + or else not Is_Implemented (Ifaces_List, Iface_Typ) + then + return False; + end if; + + -- The checks on the object parameters are done, move onto the + -- rest of the parameters. + + if not In_Scope then + Prim_Param := Next (Prim_Param); + end if; + + Iface_Param := Next (Iface_Param); + while Present (Iface_Param) and then Present (Prim_Param) loop + Iface_Id := Defining_Identifier (Iface_Param); + Iface_Typ := Find_Parameter_Type (Iface_Param); + + if Is_Access_Type (Iface_Typ) then + Iface_Typ := Directly_Designated_Type (Iface_Typ); + end if; + + Prim_Id := Defining_Identifier (Prim_Param); + Prim_Typ := Find_Parameter_Type (Prim_Param); + + if Is_Access_Type (Prim_Typ) then + Prim_Typ := Directly_Designated_Type (Prim_Typ); + end if; + + -- Case of multiple interface types inside a parameter profile + + -- (Obj_Param : in out Iface; ...; Param : Iface) + + -- If the interface type is implemented, then the matching type + -- in the primitive should be the implementing record type. + + if Ekind (Iface_Typ) = E_Record_Type + and then Is_Interface (Iface_Typ) + and then Is_Implemented (Ifaces_List, Iface_Typ) + then + if Prim_Typ /= Typ then + return False; + end if; + + -- The two parameters must be both mode and subtype conformant + + elsif Ekind (Iface_Id) /= Ekind (Prim_Id) + or else not + Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant) + then + return False; + end if; + + Next (Iface_Param); + Next (Prim_Param); + end loop; + + -- One of the two lists contains more parameters than the other + + if Present (Iface_Param) or else Present (Prim_Param) then + return False; + end if; + + return True; + end Matches_Prefixed_View_Profile; + + -- Start of processing for Check_Synchronized_Overriding + begin Overridden_Subp := Empty; - -- Def_Id must be an entry or a subprogram + -- Def_Id must be an entry or a subprogram. We should skip predefined + -- primitives internally generated by the frontend; however at this + -- stage predefined primitives are still not fully decorated. As a + -- minor optimization we skip here internally generated subprograms. - if Ekind (Def_Id) /= E_Entry - and then Ekind (Def_Id) /= E_Function - and then Ekind (Def_Id) /= E_Procedure + if (Ekind (Def_Id) /= E_Entry + and then Ekind (Def_Id) /= E_Function + and then Ekind (Def_Id) /= E_Procedure) + or else not Comes_From_Source (Def_Id) then return; end if; @@ -6383,15 +6604,25 @@ package body Sem_Ch6 is Typ := Scope (Def_Id); In_Scope := True; - -- The subprogram may be a primitive of a concurrent type + -- The enclosing scope is not a synchronized type and the subprogram + -- has no formals + + elsif No (First_Formal (Def_Id)) then + return; + + -- The subprogram has formals and hence it may be a primitive of a + -- concurrent type + + else + Typ := Etype (First_Formal (Def_Id)); - elsif Present (First_Formal (Def_Id)) then - Formal_Typ := Etype (First_Formal (Def_Id)); + if Is_Access_Type (Typ) then + Typ := Directly_Designated_Type (Typ); + end if; - if Is_Concurrent_Type (Formal_Typ) - and then not Is_Generic_Actual_Type (Formal_Typ) + if Is_Concurrent_Type (Typ) + and then not Is_Generic_Actual_Type (Typ) then - Typ := Formal_Typ; In_Scope := False; -- This case occurs when the concurrent type is declared within @@ -6399,37 +6630,152 @@ package body Sem_Ch6 is -- built and used as the type of the first formal, we just have -- to retrieve the corresponding concurrent type. - elsif Is_Concurrent_Record_Type (Formal_Typ) - and then Present (Corresponding_Concurrent_Type (Formal_Typ)) + elsif Is_Concurrent_Record_Type (Typ) + and then Present (Corresponding_Concurrent_Type (Typ)) then - Typ := Corresponding_Concurrent_Type (Formal_Typ); + Typ := Corresponding_Concurrent_Type (Typ); In_Scope := False; else return; end if; - else + end if; + + -- There is no overriding to check if is an inherited operation in a + -- type derivation on for a generic actual. + + Collect_Interfaces (Typ, Ifaces_List); + + if Is_Empty_Elmt_List (Ifaces_List) then return; end if; - -- Gather all limited, protected and task interfaces that Typ - -- implements. There is no overriding to check if is an inherited - -- operation in a type derivation on for a generic actual. + -- Determine whether entry or subprogram Def_Id overrides a primitive + -- operation that belongs to one of the interfaces in Ifaces_List. - if Nkind (Parent (Typ)) /= N_Full_Type_Declaration - and then - not Nkind_In (Parent (Def_Id), N_Subtype_Declaration, - N_Task_Type_Declaration, - N_Protected_Type_Declaration) - then - Collect_Abstract_Interfaces (Typ, Ifaces_List); + declare + Candidate : Entity_Id := Empty; + Hom : Entity_Id := Empty; + Iface_Typ : Entity_Id; + Subp : Entity_Id := Empty; + + begin + -- Traverse the homonym chain, looking at a potentially + -- overridden subprogram that belongs to an implemented + -- interface. + + Hom := Current_Entity_In_Scope (Def_Id); + while Present (Hom) loop + Subp := Hom; + + -- Entries can override abstract or null interface + -- procedures + + if Ekind (Def_Id) = E_Entry + and then Ekind (Subp) = E_Procedure + and then Nkind (Parent (Subp)) = N_Procedure_Specification + and then (Is_Abstract_Subprogram (Subp) + or else Null_Present (Parent (Subp))) + then + while Present (Alias (Subp)) loop + Subp := Alias (Subp); + end loop; + + if Matches_Prefixed_View_Profile + (Parameter_Specifications (Parent (Def_Id)), + Parameter_Specifications (Parent (Subp))) + then + Candidate := Subp; + + -- Absolute match + + if Has_Correct_Formal_Mode (Typ, Candidate) then + Overridden_Subp := Candidate; + return; + end if; + end if; + + -- Procedures can override abstract or null interface + -- procedures + + elsif Ekind (Def_Id) = E_Procedure + and then Ekind (Subp) = E_Procedure + and then Nkind (Parent (Subp)) = N_Procedure_Specification + and then (Is_Abstract_Subprogram (Subp) + or else Null_Present (Parent (Subp))) + and then Matches_Prefixed_View_Profile + (Parameter_Specifications (Parent (Def_Id)), + Parameter_Specifications (Parent (Subp))) + then + Candidate := Subp; + + -- Absolute match + + if Has_Correct_Formal_Mode (Typ, Candidate) then + Overridden_Subp := Candidate; + return; + end if; - if not Is_Empty_Elmt_List (Ifaces_List) then - Overridden_Subp := - Find_Overridden_Synchronized_Primitive - (Def_Id, First_Hom, Ifaces_List, In_Scope); + -- Functions can override abstract interface functions + + elsif Ekind (Def_Id) = E_Function + and then Ekind (Subp) = E_Function + and then Nkind (Parent (Subp)) = N_Function_Specification + and then Is_Abstract_Subprogram (Subp) + and then Matches_Prefixed_View_Profile + (Parameter_Specifications (Parent (Def_Id)), + Parameter_Specifications (Parent (Subp))) + and then Etype (Result_Definition (Parent (Def_Id))) = + Etype (Result_Definition (Parent (Subp))) + then + Overridden_Subp := Subp; + return; + end if; + + Hom := Homonym (Hom); + end loop; + + -- After examining all candidates for overriding, we are + -- left with the best match which is a mode incompatible + -- interface routine. Do not emit an error if the Expander + -- is active since this error will be detected later on + -- after all concurrent types are expanded and all wrappers + -- are built. This check is meant for spec-only + -- compilations. + + if Present (Candidate) + and then not Expander_Active + then + Iface_Typ := + Find_Parameter_Type (Parent (First_Formal (Candidate))); + + -- Def_Id is primitive of a protected type, declared + -- inside the type, and the candidate is primitive of a + -- limited or synchronized interface. + + if In_Scope + and then Is_Protected_Type (Typ) + and then + (Is_Limited_Interface (Iface_Typ) + or else Is_Protected_Interface (Iface_Typ) + or else Is_Synchronized_Interface (Iface_Typ) + or else Is_Task_Interface (Iface_Typ)) + then + -- Must reword this message, comma before to in -gnatj + -- mode ??? + + Error_Msg_NE + ("first formal of & must be of mode `OUT`, `IN OUT`" + & " or access-to-variable", Typ, Candidate); + Error_Msg_N + ("\to be overridden by protected procedure or entry " + & "(RM 9.4(11.9/2))", Typ); + end if; end if; - end if; + + Overridden_Subp := Candidate; + return; + end; end Check_Synchronized_Overriding; ---------------------------- @@ -6482,7 +6828,7 @@ package body Sem_Ch6 is -- has an overriding indicator. if Comes_From_Source (S) then - Check_Synchronized_Overriding (S, Homonym (S), Overridden_Subp); + Check_Synchronized_Overriding (S, Overridden_Subp); Check_Overriding_Indicator (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp); end if; @@ -6555,12 +6901,11 @@ package body Sem_Ch6 is and then Is_Dispatching_Operation (Alias (S)) and then Present (Find_Dispatching_Type (Alias (S))) and then Is_Interface (Find_Dispatching_Type (Alias (S))) - and then not Is_Predefined_Dispatching_Operation (Alias (S)) then goto Add_New_Entity; end if; - Check_Synchronized_Overriding (S, E, Overridden_Subp); + Check_Synchronized_Overriding (S, Overridden_Subp); -- Loop through E and its homonyms to determine if any of them is -- the candidate for overriding by S. @@ -7669,10 +8014,15 @@ package body Sem_Ch6 is -- Subtype_Conformant -- ------------------------ - function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is + function Subtype_Conformant + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Skip_Controlling_Formals : Boolean := False) return Boolean + is Result : Boolean; begin - Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result); + Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result, + Skip_Controlling_Formals => Skip_Controlling_Formals); return Result; end Subtype_Conformant; diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index a535bd11883..689ac8b690a 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.ads @@ -111,9 +111,10 @@ package Sem_Ch6 is -- Is_Primitive indicates whether the subprogram is primitive. procedure Check_Subtype_Conformant - (New_Id : Entity_Id; - Old_Id : Entity_Id; - Err_Loc : Node_Id := Empty); + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Err_Loc : Node_Id := Empty; + Skip_Controlling_Formals : Boolean := False); -- Check that two callable entities (subprograms, entries, literals) -- are subtype conformant, post error message if not (RM 6.3.1(16)) -- the flag being placed on the Err_Loc node if it is specified, and @@ -173,6 +174,14 @@ package Sem_Ch6 is -- procedure is also used to get visibility to the formals when analyzing -- preconditions and postconditions appearing in the spec. + function Is_Interface_Conformant + (Tagged_Type : Entity_Id; + Iface_Prim : Entity_Id; + Prim : Entity_Id) return Boolean; + -- Returns true if both primitives have a matching name and they are also + -- type conformant. Special management is done for functions returning + -- interfaces. + function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean; -- Determine whether two callable entities (subprograms, entries, -- literals) are mode conformant (RM 6.3.1(15)) @@ -212,7 +221,10 @@ package Sem_Ch6 is procedure Set_Formal_Mode (Formal_Id : Entity_Id); -- Set proper Ekind to reflect formal mode (in, out, in out) - function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean; + function Subtype_Conformant + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Skip_Controlling_Formals : Boolean := False) return Boolean; -- Determine whether two callable entities (subprograms, entries, -- literals) are subtype conformant (RM6.3.1(16)). diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 9482b565feb..8a85b11e6ee 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -2417,16 +2417,16 @@ package body Sem_Ch9 is if Present (Interface_List (N)) or else (Is_Tagged_Type (Priv_T) - and then Has_Abstract_Interfaces - (Priv_T, Use_Full_View => False)) + and then Has_Interfaces + (Priv_T, Use_Full_View => False)) then if Is_Tagged_Type (Priv_T) then - Collect_Abstract_Interfaces + Collect_Interfaces (Priv_T, Priv_T_Ifaces, Use_Full_View => False); end if; if Is_Tagged_Type (T) then - Collect_Abstract_Interfaces (T, Full_T_Ifaces); + Collect_Interfaces (T, Full_T_Ifaces); end if; Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index c990800ac56..a8eb3df52e3 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -618,6 +618,19 @@ package body Sem_Disp is Tagged_Type := Corresponding_Record_Type (Tagged_Type); end if; + -- (AI-345): The task body procedure is not a primitive of the tagged + -- type + + if Present (Tagged_Type) + and then Is_Concurrent_Record_Type (Tagged_Type) + and then Present (Corresponding_Concurrent_Type (Tagged_Type)) + and then Is_Task_Type (Corresponding_Concurrent_Type (Tagged_Type)) + and then Subp = Get_Task_Body_Procedure + (Corresponding_Concurrent_Type (Tagged_Type)) + then + return; + end if; + -- If Subp is derived from a dispatching operation then it should -- always be treated as dispatching. In this case various checks -- below will be bypassed. Makes sure that late declarations for @@ -870,6 +883,10 @@ package body Sem_Disp is -- Now it should be a correct primitive operation, put it in the list if Present (Old_Subp) then + + -- If the type has interfaces we complete this check after we + -- set attribute Is_Dispatching_Operation + Check_Subtype_Conformant (Subp, Old_Subp); if (Chars (Subp) = Name_Initialize @@ -902,7 +919,7 @@ package body Sem_Disp is Prim := Node (Elmt); if Present (Alias (Prim)) - and then Present (Abstract_Interface_Alias (Prim)) + and then Present (Interface_Alias (Prim)) and then Alias (Prim) = Subp then Register_Primitive (Sloc (Prim), @@ -933,6 +950,78 @@ package body Sem_Disp is Set_Is_Dispatching_Operation (Subp, True); + -- Ada 2005 (AI-251): If the type implements interfaces we must check + -- subtype conformance against all the interfaces covered by this + -- primitive. + + if Present (Old_Subp) + and then Has_Interfaces (Tagged_Type) + then + declare + Ifaces_List : Elist_Id; + Iface_Elmt : Elmt_Id; + Iface_Prim_Elmt : Elmt_Id; + Iface_Prim : Entity_Id; + Ret_Typ : Entity_Id; + + begin + Collect_Interfaces (Tagged_Type, Ifaces_List); + + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + if not Is_Ancestor (Node (Iface_Elmt), Tagged_Type) then + Iface_Prim_Elmt := + First_Elmt (Primitive_Operations (Node (Iface_Elmt))); + while Present (Iface_Prim_Elmt) loop + Iface_Prim := Node (Iface_Prim_Elmt); + + if Is_Interface_Conformant + (Tagged_Type, Iface_Prim, Subp) + then + -- Handle procedures, functions whose return type + -- matches, or functions not returning interfaces + + if Ekind (Subp) = E_Procedure + or else Etype (Iface_Prim) = Etype (Subp) + or else not Is_Interface (Etype (Iface_Prim)) + then + Check_Subtype_Conformant + (New_Id => Subp, + Old_Id => Iface_Prim, + Err_Loc => Subp, + Skip_Controlling_Formals => True); + + -- Handle functions returning interfaces + + elsif Implements_Interface + (Etype (Subp), Etype (Iface_Prim)) + then + -- Temporarily force both entities to return the + -- same type. Required because Subtype_Conformant + -- does not handle this case. + + Ret_Typ := Etype (Iface_Prim); + Set_Etype (Iface_Prim, Etype (Subp)); + + Check_Subtype_Conformant + (New_Id => Subp, + Old_Id => Iface_Prim, + Err_Loc => Subp, + Skip_Controlling_Formals => True); + + Set_Etype (Iface_Prim, Ret_Typ); + end if; + end if; + + Next_Elmt (Iface_Prim_Elmt); + end loop; + end if; + + Next_Elmt (Iface_Elmt); + end loop; + end; + end if; + if not Body_Is_Last_Primitive then Set_DT_Position (Subp, No_Uint); @@ -1083,7 +1172,13 @@ package body Sem_Disp is if Derives_From (Node (Op1)) then if No (Prev) then - Prepend_Elmt (Subp, New_Prim); + + -- Avoid adding it to the list of primitives if already there! + + if Node (Op2) /= Subp then + Prepend_Elmt (Subp, New_Prim); + end if; + else Insert_Elmt_After (Subp, Prev); end if; @@ -1302,6 +1397,38 @@ package body Sem_Disp is return Empty; end Find_Dispatching_Type; + --------------------------------------- + -- Find_Primitive_Covering_Interface -- + --------------------------------------- + + function Find_Primitive_Covering_Interface + (Tagged_Type : Entity_Id; + Iface_Prim : Entity_Id) return Entity_Id + is + E : Entity_Id; + + begin + pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim)) + or else (Present (Alias (Iface_Prim)) + and then + Is_Interface + (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim))))); + + E := Current_Entity (Iface_Prim); + while Present (E) loop + if Is_Subprogram (E) + and then Is_Dispatching_Operation (E) + and then Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) + then + return E; + end if; + + E := Homonym (E); + end loop; + + return Empty; + end Find_Primitive_Covering_Interface; + --------------------------- -- Is_Dynamically_Tagged -- --------------------------- @@ -1425,7 +1552,7 @@ package body Sem_Disp is Replace_Elmt (Elmt, New_Op); if Ada_Version >= Ada_05 - and then Has_Abstract_Interfaces (Tagged_Type) + and then Has_Interfaces (Tagged_Type) then -- Ada 2005 (AI-251): Update the attribute alias of all the aliased -- entities of the overridden primitive to reference New_Op, and also @@ -1434,6 +1561,8 @@ package body Sem_Disp is -- operations that it implements (for operations inherited from the -- parent itself, this check is made when building the derived type). + -- Note: This code is only executed in case of late overriding + Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); while Present (Elmt) loop Prim := Node (Elmt); @@ -1445,14 +1574,14 @@ package body Sem_Disp is -- reading attributes in entities that are not yet fully decorated elsif Is_Subprogram (Prim) - and then Present (Abstract_Interface_Alias (Prim)) + and then Present (Interface_Alias (Prim)) and then Alias (Prim) = Prev_Op and then Present (Etype (New_Op)) then Set_Alias (Prim, New_Op); Check_Subtype_Conformant (New_Op, Prim); - Set_Is_Abstract_Subprogram - (Prim, Is_Abstract_Subprogram (New_Op)); + Set_Is_Abstract_Subprogram (Prim, + Is_Abstract_Subprogram (New_Op)); -- Ensure that this entity will be expanded to fill the -- corresponding entry in its dispatch table. diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads index 496a0034177..c0195ecd4fd 100644 --- a/gcc/ada/sem_disp.ads +++ b/gcc/ada/sem_disp.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- -- @@ -69,6 +69,14 @@ package Sem_Disp is -- Check whether a subprogram is dispatching, and find the tagged -- type of the controlling argument or arguments. + function Find_Primitive_Covering_Interface + (Tagged_Type : Entity_Id; + Iface_Prim : Entity_Id) return Entity_Id; + -- Search in the homonym chain for the primitive of Tagged_Type that + -- covers Iface_Prim. The homonym chain traversal is required to catch + -- primitives associated with the partial view of private types when + -- processing the corresponding full view. + function Is_Dynamically_Tagged (N : Node_Id) return Boolean; -- Used to determine whether a call is dispatching, i.e. if is an -- an expression of a class_Wide type, or a call to a function with diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index 0be68edc9f3..211bdddb49e 100644 --- a/gcc/ada/sem_dist.adb +++ b/gcc/ada/sem_dist.adb @@ -64,7 +64,9 @@ package body Sem_Dist is procedure Add_Stub_Constructs (N : Node_Id) is U : constant Node_Id := Unit (N); Spec : Entity_Id := Empty; - Exp : Node_Id := U; -- Unit that will be expanded + + Exp : Node_Id := U; + -- Unit that will be expanded begin pragma Assert (Distribution_Stub_Mode /= No_Stubs); @@ -84,7 +86,6 @@ package body Sem_Dist is or else Is_Remote_Call_Interface (Spec)); if Distribution_Stub_Mode = Generate_Caller_Stub_Body then - if Is_Shared_Passive (Spec) then null; elsif Nkind (U) = N_Package_Body then @@ -95,7 +96,6 @@ package body Sem_Dist is end if; else - if Is_Shared_Passive (Spec) then Build_Passive_Partition_Stub (Exp); else @@ -186,7 +186,6 @@ package body Sem_Dist is if Parent_Name /= No_String then Start_String (Parent_Name); Store_String_Char (Get_Char_Code ('.')); - else Start_String; end if; @@ -242,15 +241,13 @@ package body Sem_Dist is Par : Node_Id; begin - if (Nkind (N) = N_Function_Call - or else Nkind (N) = N_Procedure_Call_Statement) + if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) and then Nkind (Name (N)) in N_Has_Entity and then Is_Remote_Call_Interface (Entity (Name (N))) and then Has_All_Calls_Remote (Scope (Entity (Name (N)))) and then Comes_From_Source (N) then Par := Parent (Entity (Name (N))); - while Present (Par) and then (Nkind (Par) /= N_Package_Specification or else Is_Wrapper_Package (Defining_Entity (Par))) @@ -294,9 +291,10 @@ package body Sem_Dist is ------------------------------------ function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is - N : Node_Id := Parent (E); + N : Node_Id; begin + N := Parent (E); while Nkind (N) /= N_Package_Specification loop N := Parent (N); end loop; @@ -317,11 +315,10 @@ package body Sem_Dist is Typ : constant Entity_Id := Etype (N); begin - Ety := Entity (Prefix (N)); - -- In case prefix is not a library unit entity, get the entity -- of library unit. + Ety := Entity (Prefix (N)); while (Present (Scope (Ety)) and then Scope (Ety) /= Standard_Standard) and not Is_Child_Unit (Ety) @@ -363,7 +360,6 @@ package body Sem_Dist is else Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id); - end if; -- Replace the attribute node by a conversion of the function call @@ -426,10 +422,11 @@ package body Sem_Dist is Tick_Access_Conv_Call := Make_Function_Call (Loc, - Name => New_Occurrence_Of (Attribute_Subp, Loc), + Name => New_Occurrence_Of (Attribute_Subp, Loc), Parameter_Associations => New_List ( - Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)), + Make_String_Literal (Loc, + Strval => Full_Qualified_Name (RS_Pkg_E)), Build_Subprogram_Id (Loc, Remote_Subp), New_Occurrence_Of (Async_E, Loc), New_Occurrence_Of (All_Calls_Remote_E, Loc))); @@ -527,8 +524,7 @@ package body Sem_Dist is Append_To (Priv_Decls, Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Full_Obj_Type, + Defining_Identifier => Full_Obj_Type, Type_Definition => Make_Record_Definition (Loc, Abstract_Present => True, @@ -558,39 +554,33 @@ package body Sem_Dist is All_Present => True, Subtype_Indication => Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Obj_Type, Loc), - Attribute_Name => - Name_Class)))); + Prefix => New_Occurrence_Of (Obj_Type, Loc), + Attribute_Name => Name_Class)))); + Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI); Set_Is_Remote_Types (RACW_Type, Is_RT); Subpkg_Decl := Make_Package_Declaration (Loc, Make_Package_Specification (Loc, - Defining_Unit_Name => - Subpkg, - Visible_Declarations => - Vis_Decls, - Private_Declarations => - Priv_Decls, - End_Label => - New_Occurrence_Of (Subpkg, Loc))); + Defining_Unit_Name => Subpkg, + Visible_Declarations => Vis_Decls, + Private_Declarations => Priv_Decls, + End_Label => New_Occurrence_Of (Subpkg, Loc))); + Set_Is_Remote_Call_Interface (Subpkg, Is_RCI); Set_Is_Remote_Types (Subpkg, Is_RT); Insert_After_And_Analyze (N, Subpkg_Decl); -- Generate package body to receive RACW calling stubs - -- Note: Analyze_Declarations has an absolute requirement that - -- the declaration list be non-empty, so we provide a dummy null - -- statement here. + + -- Note: Analyze_Declarations has an absolute requirement that the + -- declaration list be non-empty, so provide dummy null statement here. Subpkg_Body := Make_Package_Body (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, Chars (Subpkg)), - Declarations => New_List ( - Make_Null_Statement (Loc))); + Defining_Unit_Name => Make_Defining_Identifier (Loc, Chars (Subpkg)), + Declarations => New_List (Make_Null_Statement (Loc))); Insert_After_And_Analyze (Subpkg_Decl, Subpkg_Body); -- Many parts of the analyzer and expander expect @@ -612,10 +602,10 @@ package body Sem_Dist is Make_Defining_Identifier (Loc, Name_Ras), Component_Definition => Make_Component_Definition (Loc, - Aliased_Present => - False, + Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (RACW_Type, Loc))))))); + Set_Equivalent_Type (User_Type, Fat_Type); Set_Corresponding_Remote_Type (Fat_Type, User_Type); Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl); @@ -656,7 +646,6 @@ package body Sem_Dist is end if; elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then - Params := Expressions (Deref_Subp_Call); if Present (Params) then @@ -681,13 +670,12 @@ package body Sem_Dist is if Ekind (Deref_Proc) = E_Function then Call_Node := Make_Function_Call (Loc, - Name => New_Occurrence_Of (Deref_Proc, Loc), + Name => New_Occurrence_Of (Deref_Proc, Loc), Parameter_Associations => Params); - else Call_Node := Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Deref_Proc, Loc), + Name => New_Occurrence_Of (Deref_Proc, Loc), Parameter_Associations => Params); end if; @@ -711,8 +699,8 @@ package body Sem_Dist is and then (Is_Remote_Call_Interface (ET) or else Is_Remote_Types (ET)) and then Present (Corresponding_Remote_Type (ET)) - and then (Nkind (Parent (Parent (P))) = N_Procedure_Call_Statement - or else Nkind (Parent (Parent (P))) = N_Indexed_Component) + and then Nkind_In (Parent (Parent (P)), N_Procedure_Call_Statement, + N_Indexed_Component) and then Expander_Active then RAS_E_Dereference (P); @@ -788,17 +776,14 @@ package body Sem_Dist is -- We do not have to handle this case return False; - end if; Rewrite (N, Make_Aggregate (Loc, Component_Associations => New_List ( Make_Component_Association (Loc, - Choices => New_List ( - Make_Identifier (Loc, Name_Ras)), - Expression => - Make_Null (Loc))))); + Choices => New_List (Make_Identifier (Loc, Name_Ras)), + Expression => Make_Null (Loc))))); Analyze_And_Resolve (N, Target_Type); return True; end Remote_AST_Null_Value; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index c03f11ab0af..15c3df81dc5 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -3388,7 +3388,7 @@ package body Sem_Eval is Rewrite (N, Make_Real_Literal (Loc, Realval => Val)); - -- Set link to original named number, for ASIS use. + -- Set link to original named number, for ASIS use Set_Original_Entity (N, Ent); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 15f4e181f7a..c58bc4c1a36 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -3194,6 +3194,10 @@ package body Sem_Prag is if Chars (Choice) = Chars (Formal) then Set_Mechanism_Value (Formal, Expression (Massoc)); + + -- Set entity on identifier for ASIS + Set_Entity (Choice, Formal); + exit; end if; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 9cc285f1100..b6c72b44cde 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5146,6 +5146,15 @@ package body Sem_Res is Check_Intrinsic_Call (N); end if; + -- Check for violation of restriction No_Specific_Termination_Handlers + + if Is_RTE (Nam, RE_Set_Specific_Handler) + or else + Is_RTE (Nam, RE_Specific_Handler) + then + Check_Restriction (No_Specific_Termination_Handlers, N); + end if; + -- All done, evaluate call and deal with elaboration issues Eval_Call (N); @@ -6561,7 +6570,7 @@ package body Sem_Res is procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is begin -- Handle restriction against anonymous null access values This - -- restriction can be turned off using -gnatdh. + -- restriction can be turned off using -gnatdj. -- Ada 2005 (AI-231): Remove restriction @@ -6571,7 +6580,7 @@ package body Sem_Res is and then Comes_From_Source (N) then -- In the common case of a call which uses an explicitly null - -- value for an access parameter, give specialized error msg + -- value for an access parameter, give specialized error message. if Nkind_In (Parent (N), N_Procedure_Call_Statement, N_Function_Call) @@ -9425,7 +9434,9 @@ package body Sem_Res is end if; end; - -- Subprogram access types + -- access to subprogram types. If the operand is an access parameter, + -- the type has a deeper accessibility that any master, and cannot + -- be assigned. elsif (Ekind (Target_Type) = E_Access_Subprogram_Type or else @@ -9434,6 +9445,8 @@ package body Sem_Res is then if Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type + and then Is_Entity_Name (Operand) + and then Ekind (Entity (Operand)) = E_In_Parameter then Error_Msg_N ("illegal attempt to store anonymous access to subprogram", @@ -9443,13 +9456,9 @@ package body Sem_Res is "(RM 3.10.2 (13))", Operand); - if Is_Entity_Name (Operand) - and then Ekind (Entity (Operand)) = E_In_Parameter - then - Error_Msg_NE - ("\use named access type for& instead of access parameter", - Operand, Entity (Operand)); - end if; + Error_Msg_NE + ("\use named access type for& instead of access parameter", + Operand, Entity (Operand)); end if; -- Check that the designated types are subtype conformant diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index c36125f52aa..4a170d82ce3 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -421,7 +421,7 @@ package body Sem_Type is elsif Is_Hidden (E) and then Is_Subprogram (E) - and then Present (Abstract_Interface_Alias (E)) + and then Present (Interface_Alias (E)) then -- Ada 2005 (AI-251): If this primitive operation corresponds with -- an immediate ancestor interface there is no need to add it to the @@ -431,10 +431,10 @@ package body Sem_Type is -- subprograms which are in fact the same. if not Is_Ancestor - (Find_Dispatching_Type (Abstract_Interface_Alias (E)), + (Find_Dispatching_Type (Interface_Alias (E)), Find_Dispatching_Type (E)) then - Add_One_Interp (N, Abstract_Interface_Alias (E), T); + Add_One_Interp (N, Interface_Alias (E), T); end if; return; @@ -783,7 +783,7 @@ package body Sem_Type is -- Literals are compatible with types in a given "class" - elsif (T2 = Universal_Integer and then Is_Integer_Type (T1)) + elsif (T2 = Universal_Integer and then Is_Integer_Type (T1)) or else (T2 = Universal_Real and then Is_Real_Type (T1)) or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1)) or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1)) @@ -849,9 +849,9 @@ package body Sem_Type is -- Note: test for presence of E is defense against previous error. if Present (E) - and then Present (Abstract_Interfaces (E)) + and then Present (Interfaces (E)) then - Elmt := First_Elmt (Abstract_Interfaces (E)); + Elmt := First_Elmt (Interfaces (E)); while Present (Elmt) loop if Is_Ancestor (Etype (T1), Node (Elmt)) then return True; @@ -1032,7 +1032,7 @@ package body Sem_Type is return True; elsif Is_Type (T1) - and then Is_Generic_Actual_Type (T1) + and then Is_Generic_Actual_Type (T1) and then Full_View_Covers (T2, T1) then return True; @@ -2251,11 +2251,11 @@ package body Sem_Type is end if; loop - if Present (Abstract_Interfaces (E)) - and then Present (Abstract_Interfaces (E)) - and then not Is_Empty_Elmt_List (Abstract_Interfaces (E)) + if Present (Interfaces (E)) + and then Present (Interfaces (E)) + and then not Is_Empty_Elmt_List (Interfaces (E)) then - Elmt := First_Elmt (Abstract_Interfaces (E)); + Elmt := First_Elmt (Interfaces (E)); while Present (Elmt) loop AI := Node (Elmt); @@ -2334,7 +2334,7 @@ package body Sem_Type is if Etype (AI) = Iface_Typ then return True; - elsif Present (Abstract_Interfaces (Etype (AI))) + elsif Present (Interfaces (Etype (AI))) and then Iface_Present_In_Ancestor (Etype (AI)) then return True; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 95fd0c59c9e..ddcc386b06b 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -29,6 +29,7 @@ with Checks; use Checks; with Debug; use Debug; with Errout; use Errout; with Elists; use Elists; +with Exp_Disp; use Exp_Disp; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Fname; use Fname; @@ -43,7 +44,6 @@ with Scans; use Scans; with Scn; use Scn; with Sem; use Sem; with Sem_Attr; use Sem_Attr; -with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; @@ -1235,48 +1235,20 @@ package body Sem_Util is end if; end Check_VMS; - --------------------------------- - -- Collect_Abstract_Interfaces -- - --------------------------------- + ------------------------ + -- Collect_Interfaces -- + ------------------------ - procedure Collect_Abstract_Interfaces - (T : Entity_Id; - Ifaces_List : out Elist_Id; - Exclude_Parent_Interfaces : Boolean := False; - Use_Full_View : Boolean := True) + procedure Collect_Interfaces + (T : Entity_Id; + Ifaces_List : out Elist_Id; + Exclude_Parents : Boolean := False; + Use_Full_View : Boolean := True) is - procedure Add_Interface (Iface : Entity_Id); - -- Add the interface it if is not already in the list - procedure Collect (Typ : Entity_Id); -- Subsidiary subprogram used to traverse the whole list -- of directly and indirectly implemented interfaces - function Interface_Present_In_Parent - (Typ : Entity_Id; - Iface : Entity_Id) return Boolean; - -- Typ must be a tagged record type/subtype and Iface must be an - -- abstract interface type. This function is used to check if Typ - -- or some parent of Typ implements Iface. - - ------------------- - -- Add_Interface -- - ------------------- - - procedure Add_Interface (Iface : Entity_Id) is - Elmt : Elmt_Id; - - begin - Elmt := First_Elmt (Ifaces_List); - while Present (Elmt) and then Node (Elmt) /= Iface loop - Next_Elmt (Elmt); - end loop; - - if No (Elmt) then - Append_Elmt (Iface, Ifaces_List); - end if; - end Add_Interface; - ------------- -- Collect -- ------------- @@ -1284,7 +1256,6 @@ package body Sem_Util is procedure Collect (Typ : Entity_Id) is Ancestor : Entity_Id; Full_T : Entity_Id; - Iface_List : List_Id; Id : Node_Id; Iface : Entity_Id; @@ -1300,27 +1271,10 @@ package body Sem_Util is Full_T := Full_View (Typ); end if; - Iface_List := Abstract_Interface_List (Full_T); - -- Include the ancestor if we are generating the whole list of -- abstract interfaces. - -- In concurrent types the ancestor interface (if any) is the - -- first element of the list of interface types. - - if Is_Concurrent_Type (Full_T) - or else Is_Concurrent_Record_Type (Full_T) - then - if Is_Non_Empty_List (Iface_List) then - Ancestor := Etype (First (Iface_List)); - Collect (Ancestor); - - if not Exclude_Parent_Interfaces then - Add_Interface (Ancestor); - end if; - end if; - - elsif Etype (Full_T) /= Typ + if Etype (Full_T) /= Typ -- Protect the frontend against wrong sources. For example: @@ -1339,27 +1293,16 @@ package body Sem_Util is Collect (Ancestor); if Is_Interface (Ancestor) - and then not Exclude_Parent_Interfaces + and then not Exclude_Parents then - Add_Interface (Ancestor); + Append_Unique_Elmt (Ancestor, Ifaces_List); end if; end if; -- Traverse the graph of ancestor interfaces - if Is_Non_Empty_List (Iface_List) then - Id := First (Iface_List); - - -- In concurrent types the ancestor interface (if any) is the - -- first element of the list of interface types and we have - -- already processed them while climbing to the root type. - - if Is_Concurrent_Type (Full_T) - or else Is_Concurrent_Record_Type (Full_T) - then - Next (Id); - end if; - + if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then + Id := First (Abstract_Interface_List (Full_T)); while Present (Id) loop Iface := Etype (Id); @@ -1369,13 +1312,14 @@ package body Sem_Util is -- type Wrong is new I and O with null record; -- ERROR if Is_Interface (Iface) then - if Exclude_Parent_Interfaces - and then Interface_Present_In_Parent (T, Iface) + if Exclude_Parents + and then Etype (T) /= T + and then Interface_Present_In_Ancestor (Etype (T), Iface) then null; else - Collect (Iface); - Add_Interface (Iface); + Collect (Iface); + Append_Unique_Elmt (Iface, Ifaces_List); end if; end if; @@ -1384,40 +1328,13 @@ package body Sem_Util is end if; end Collect; - --------------------------------- - -- Interface_Present_In_Parent -- - --------------------------------- - - function Interface_Present_In_Parent - (Typ : Entity_Id; - Iface : Entity_Id) return Boolean - is - Aux : Entity_Id := Typ; - Iface_List : List_Id; - - begin - if Is_Concurrent_Type (Typ) - or else Is_Concurrent_Record_Type (Typ) - then - Iface_List := Abstract_Interface_List (Typ); - - if Is_Non_Empty_List (Iface_List) then - Aux := Etype (First (Iface_List)); - else - return False; - end if; - end if; - - return Interface_Present_In_Ancestor (Aux, Iface); - end Interface_Present_In_Parent; - - -- Start of processing for Collect_Abstract_Interfaces + -- Start of processing for Collect_Interfaces begin pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T)); Ifaces_List := New_Elmt_List; Collect (T); - end Collect_Abstract_Interfaces; + end Collect_Interfaces; ---------------------------------- -- Collect_Interface_Components -- @@ -1526,7 +1443,7 @@ package body Sem_Util is -- Start of processing for Collect_Interfaces_Info begin - Collect_Abstract_Interfaces (T, Ifaces_List); + Collect_Interfaces (T, Ifaces_List); Collect_Interface_Components (T, Comps_List); -- Search for the record component and tag associated with each @@ -1542,7 +1459,7 @@ package body Sem_Util is -- Associate the primary tag component and the primary dispatch table -- with all the interfaces that are parents of T - if Is_Parent (Iface, T) then + if Is_Ancestor (Iface, T) then Append_Elmt (First_Tag_Component (T), Components_List); Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List); @@ -1555,7 +1472,7 @@ package body Sem_Util is Comp_Iface := Related_Type (Node (Comp_Elmt)); if Comp_Iface = Iface - or else Is_Parent (Iface, Comp_Iface) + or else Is_Ancestor (Iface, Comp_Iface) then Append_Elmt (Node (Comp_Elmt), Components_List); Append_Elmt (Search_Tag (Comp_Iface), Tags_List); @@ -2983,311 +2900,6 @@ package body Sem_Util is return Empty; end Find_Overlaid_Object; - -------------------------------------------- - -- Find_Overridden_Synchronized_Primitive -- - -------------------------------------------- - - function Find_Overridden_Synchronized_Primitive - (Def_Id : Entity_Id; - First_Hom : Entity_Id; - Ifaces_List : Elist_Id; - In_Scope : Boolean) return Entity_Id - is - Candidate : Entity_Id := Empty; - Hom : Entity_Id := Empty; - Iface_Typ : Entity_Id; - Subp : Entity_Id := Empty; - Tag_Typ : Entity_Id; - - function Has_Correct_Formal_Mode (Subp : Entity_Id) return Boolean; - -- For an overridden subprogram Subp, check whether the mode of its - -- first parameter is correct depending on the kind of Tag_Typ. - - function Matches_Prefixed_View_Profile - (Prim_Params : List_Id; - Iface_Params : List_Id) return Boolean; - -- Determine whether a subprogram's parameter profile Prim_Params - -- matches that of a potentially overridden interface subprogram - -- Iface_Params. Also determine if the type of first parameter of - -- Iface_Params is an implemented interface. - - ----------------------------- - -- Has_Correct_Formal_Mode -- - ----------------------------- - - function Has_Correct_Formal_Mode (Subp : Entity_Id) return Boolean is - Param : Node_Id; - - begin - Param := First_Formal (Subp); - - -- In order for an entry or a protected procedure to override, the - -- first parameter of the overridden routine must be of mode "out", - -- "in out" or access-to-variable. - - if (Ekind (Subp) = E_Entry - or else Ekind (Subp) = E_Procedure) - and then Is_Protected_Type (Tag_Typ) - and then Ekind (Param) /= E_In_Out_Parameter - and then Ekind (Param) /= E_Out_Parameter - and then Nkind (Parameter_Type (Parent (Param))) /= - N_Access_Definition - then - return False; - end if; - - -- All other cases are OK since a task entry or routine does not - -- have a restriction on the mode of the first parameter of the - -- overridden interface routine. - - return True; - end Has_Correct_Formal_Mode; - - ----------------------------------- - -- Matches_Prefixed_View_Profile -- - ----------------------------------- - - function Matches_Prefixed_View_Profile - (Prim_Params : List_Id; - Iface_Params : List_Id) return Boolean - is - Iface_Id : Entity_Id; - Iface_Param : Node_Id; - Iface_Typ : Entity_Id; - Prim_Id : Entity_Id; - Prim_Param : Node_Id; - Prim_Typ : Entity_Id; - - function Is_Implemented (Iface : Entity_Id) return Boolean; - -- Determine if Iface is implemented by the current task or - -- protected type. - - -------------------- - -- Is_Implemented -- - -------------------- - - function Is_Implemented (Iface : Entity_Id) return Boolean is - Iface_Elmt : Elmt_Id; - - begin - Iface_Elmt := First_Elmt (Ifaces_List); - while Present (Iface_Elmt) loop - if Node (Iface_Elmt) = Iface then - return True; - end if; - - Next_Elmt (Iface_Elmt); - end loop; - - return False; - end Is_Implemented; - - -- Start of processing for Matches_Prefixed_View_Profile - - begin - Iface_Param := First (Iface_Params); - - if Nkind (Parameter_Type (Iface_Param)) = N_Access_Definition then - Iface_Typ := - Designated_Type (Etype (Defining_Identifier (Iface_Param))); - else - Iface_Typ := Etype (Defining_Identifier (Iface_Param)); - end if; - - Prim_Param := First (Prim_Params); - - -- The first parameter of the potentially overridden subprogram - -- must be an interface implemented by Prim. - - if not Is_Interface (Iface_Typ) - or else not Is_Implemented (Iface_Typ) - then - return False; - end if; - - -- The checks on the object parameters are done, move onto the rest - -- of the parameters. - - if not In_Scope then - Prim_Param := Next (Prim_Param); - end if; - - Iface_Param := Next (Iface_Param); - while Present (Iface_Param) and then Present (Prim_Param) loop - Iface_Id := Defining_Identifier (Iface_Param); - Iface_Typ := Find_Parameter_Type (Iface_Param); - Prim_Id := Defining_Identifier (Prim_Param); - Prim_Typ := Find_Parameter_Type (Prim_Param); - - -- Case of multiple interface types inside a parameter profile - - -- (Obj_Param : in out Iface; ...; Param : Iface) - - -- If the interface type is implemented, then the matching type - -- in the primitive should be the implementing record type. - - if Ekind (Iface_Typ) = E_Record_Type - and then Is_Interface (Iface_Typ) - and then Is_Implemented (Iface_Typ) - then - if Prim_Typ /= Tag_Typ then - return False; - end if; - - -- The two parameters must be both mode and subtype conformant - - elsif Ekind (Iface_Id) /= Ekind (Prim_Id) - or else - not Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant) - then - return False; - end if; - - Next (Iface_Param); - Next (Prim_Param); - end loop; - - -- One of the two lists contains more parameters than the other - - if Present (Iface_Param) or else Present (Prim_Param) then - return False; - end if; - - return True; - end Matches_Prefixed_View_Profile; - - -- Start of processing for Find_Overridden_Synchronized_Primitive - - begin - -- At this point the caller should have collected the interfaces - -- implemented by the synchronized type. - - pragma Assert (Present (Ifaces_List)); - - -- Find the tagged type to which subprogram Def_Id is primitive. If the - -- subprogram was declared within a protected or a task type, the type - -- is the scope itself, otherwise it is the type of the first parameter. - - if In_Scope then - Tag_Typ := Scope (Def_Id); - - elsif Present (First_Formal (Def_Id)) then - Tag_Typ := Find_Parameter_Type (Parent (First_Formal (Def_Id))); - - -- A parameterless subprogram which is declared outside a synchronized - -- type cannot act as a primitive, thus it cannot override anything. - - else - return Empty; - end if; - - -- Traverse the homonym chain, looking at a potentially overridden - -- subprogram that belongs to an implemented interface. - - Hom := First_Hom; - while Present (Hom) loop - Subp := Hom; - - -- Entries can override abstract or null interface procedures - - if Ekind (Def_Id) = E_Entry - and then Ekind (Subp) = E_Procedure - and then Nkind (Parent (Subp)) = N_Procedure_Specification - and then (Is_Abstract_Subprogram (Subp) - or else Null_Present (Parent (Subp))) - then - while Present (Alias (Subp)) loop - Subp := Alias (Subp); - end loop; - - if Matches_Prefixed_View_Profile - (Parameter_Specifications (Parent (Def_Id)), - Parameter_Specifications (Parent (Subp))) - then - Candidate := Subp; - - -- Absolute match - - if Has_Correct_Formal_Mode (Candidate) then - return Candidate; - end if; - end if; - - -- Procedures can override abstract or null interface procedures - - elsif Ekind (Def_Id) = E_Procedure - and then Ekind (Subp) = E_Procedure - and then Nkind (Parent (Subp)) = N_Procedure_Specification - and then (Is_Abstract_Subprogram (Subp) - or else Null_Present (Parent (Subp))) - and then Matches_Prefixed_View_Profile - (Parameter_Specifications (Parent (Def_Id)), - Parameter_Specifications (Parent (Subp))) - then - Candidate := Subp; - - -- Absolute match - - if Has_Correct_Formal_Mode (Candidate) then - return Candidate; - end if; - - -- Functions can override abstract interface functions - - elsif Ekind (Def_Id) = E_Function - and then Ekind (Subp) = E_Function - and then Nkind (Parent (Subp)) = N_Function_Specification - and then Is_Abstract_Subprogram (Subp) - and then Matches_Prefixed_View_Profile - (Parameter_Specifications (Parent (Def_Id)), - Parameter_Specifications (Parent (Subp))) - and then Etype (Result_Definition (Parent (Def_Id))) = - Etype (Result_Definition (Parent (Subp))) - then - return Subp; - end if; - - Hom := Homonym (Hom); - end loop; - - -- After examining all candidates for overriding, we are left with - -- the best match which is a mode incompatible interface routine. - -- Do not emit an error if the Expander is active since this error - -- will be detected later on after all concurrent types are expanded - -- and all wrappers are built. This check is meant for spec-only - -- compilations. - - if Present (Candidate) - and then not Expander_Active - then - Iface_Typ := Find_Parameter_Type (Parent (First_Formal (Candidate))); - - -- Def_Id is primitive of a protected type, declared inside the type, - -- and the candidate is primitive of a limited or synchronized - -- interface. - - if In_Scope - and then Is_Protected_Type (Tag_Typ) - and then - (Is_Limited_Interface (Iface_Typ) - or else Is_Protected_Interface (Iface_Typ) - or else Is_Synchronized_Interface (Iface_Typ) - or else Is_Task_Interface (Iface_Typ)) - then - -- Must reword this message, comma before to in -gnatj mode ??? - - Error_Msg_NE - ("first formal of & must be of mode `OUT`, `IN OUT` or " & - "access-to-variable", Tag_Typ, Candidate); - Error_Msg_N - ("\to be overridden by protected procedure or entry " & - "(RM 9.4(11.9/2))", Tag_Typ); - end if; - end if; - - return Candidate; - end Find_Overridden_Synchronized_Primitive; - ------------------------- -- Find_Parameter_Type -- ------------------------- @@ -4085,83 +3697,6 @@ package body Sem_Util is return Task_Body_Procedure (Underlying_Type (Root_Type (E))); end Get_Task_Body_Procedure; - ----------------------------- - -- Has_Abstract_Interfaces -- - ----------------------------- - - function Has_Abstract_Interfaces - (T : Entity_Id; - Use_Full_View : Boolean := True) return Boolean - is - Typ : Entity_Id; - - begin - -- Handle concurrent types - - if Is_Concurrent_Type (T) then - Typ := Corresponding_Record_Type (T); - else - Typ := T; - end if; - - if not Present (Typ) - or else not Is_Tagged_Type (Typ) - then - return False; - end if; - - pragma Assert (Is_Record_Type (Typ)); - - -- Handle private types - - if Use_Full_View - and then Present (Full_View (Typ)) - then - Typ := Full_View (Typ); - end if; - - -- Handle concurrent record types - - if Is_Concurrent_Record_Type (Typ) - and then Is_Non_Empty_List (Abstract_Interface_List (Typ)) - then - return True; - end if; - - loop - if Is_Interface (Typ) - or else - (Is_Record_Type (Typ) - and then Present (Abstract_Interfaces (Typ)) - and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))) - then - return True; - end if; - - exit when Etype (Typ) = Typ - - -- Handle private types - - or else (Present (Full_View (Etype (Typ))) - and then Full_View (Etype (Typ)) = Typ) - - -- Protect the frontend against wrong source with cyclic - -- derivations - - or else Etype (Typ) = T; - - -- Climb to the ancestor type handling private types - - if Present (Full_View (Etype (Typ))) then - Typ := Full_View (Etype (Typ)); - else - Typ := Etype (Typ); - end if; - end loop; - - return False; - end Has_Abstract_Interfaces; - ----------------------- -- Has_Access_Values -- ----------------------- @@ -4616,6 +4151,82 @@ package body Sem_Util is and then Includes_Infinities (Scalar_Range (E)); end Has_Infinities; + -------------------- + -- Has_Interfaces -- + -------------------- + + function Has_Interfaces + (T : Entity_Id; + Use_Full_View : Boolean := True) return Boolean + is + Typ : Entity_Id; + + begin + -- Handle concurrent types + + if Is_Concurrent_Type (T) then + Typ := Corresponding_Record_Type (T); + else + Typ := T; + end if; + + if not Present (Typ) + or else not Is_Record_Type (Typ) + or else not Is_Tagged_Type (Typ) + then + return False; + end if; + + -- Handle private types + + if Use_Full_View + and then Present (Full_View (Typ)) + then + Typ := Full_View (Typ); + end if; + + -- Handle concurrent record types + + if Is_Concurrent_Record_Type (Typ) + and then Is_Non_Empty_List (Abstract_Interface_List (Typ)) + then + return True; + end if; + + loop + if Is_Interface (Typ) + or else + (Is_Record_Type (Typ) + and then Present (Interfaces (Typ)) + and then not Is_Empty_Elmt_List (Interfaces (Typ))) + then + return True; + end if; + + exit when Etype (Typ) = Typ + + -- Handle private types + + or else (Present (Full_View (Etype (Typ))) + and then Full_View (Etype (Typ)) = Typ) + + -- Protect the frontend against wrong source with cyclic + -- derivations + + or else Etype (Typ) = T; + + -- Climb to the ancestor type handling private types + + if Present (Full_View (Etype (Typ))) then + Typ := Full_View (Etype (Typ)); + else + Typ := Etype (Typ); + end if; + end loop; + + return False; + end Has_Interfaces; + ------------------------ -- Has_Null_Exclusion -- ------------------------ @@ -5219,6 +4830,56 @@ package body Sem_Util is end if; end Has_Tagged_Component; + -------------------------- + -- Implements_Interface -- + -------------------------- + + function Implements_Interface + (Typ_Ent : Entity_Id; + Iface_Ent : Entity_Id; + Exclude_Parents : Boolean := False) return Boolean + is + Ifaces_List : Elist_Id; + Elmt : Elmt_Id; + Iface : Entity_Id; + Typ : Entity_Id; + + begin + if Is_Class_Wide_Type (Typ_Ent) then + Typ := Etype (Typ_Ent); + else + Typ := Typ_Ent; + end if; + + if Is_Class_Wide_Type (Iface_Ent) then + Iface := Etype (Iface_Ent); + else + Iface := Iface_Ent; + end if; + + if not Has_Interfaces (Typ) then + return False; + end if; + + Collect_Interfaces (Typ, Ifaces_List); + + Elmt := First_Elmt (Ifaces_List); + while Present (Elmt) loop + if Is_Ancestor (Node (Elmt), Typ) + and then Exclude_Parents + then + null; + + elsif Node (Elmt) = Iface then + return True; + end if; + + Next_Elmt (Elmt); + end loop; + + return False; + end Implements_Interface; + ----------------- -- In_Instance -- ----------------- @@ -6524,33 +6185,6 @@ package body Sem_Util is end if; end Is_OK_Variable_For_Out_Formal; - --------------- - -- Is_Parent -- - --------------- - - function Is_Parent - (E1 : Entity_Id; - E2 : Entity_Id) return Boolean - is - Iface_List : List_Id; - T : Entity_Id := E2; - - begin - if Is_Concurrent_Type (T) - or else Is_Concurrent_Record_Type (T) - then - Iface_List := Abstract_Interface_List (E2); - - if Is_Empty_List (Iface_List) then - return False; - end if; - - T := Etype (First (Iface_List)); - end if; - - return Is_Ancestor (E1, T); - end Is_Parent; - ----------------------------------- -- Is_Partially_Initialized_Type -- ----------------------------------- @@ -8494,6 +8128,48 @@ package body Sem_Util is return Trace_Components (Type_Id, False); end Private_Component; + --------------------------- + -- Primitive_Names_Match -- + --------------------------- + + function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is + + function Non_Internal_Name (E : Entity_Id) return Name_Id; + -- Given an internal name, returns the corresponding non-internal name + + ------------------------ + -- Non_Internal_Name -- + ------------------------ + + function Non_Internal_Name (E : Entity_Id) return Name_Id is + begin + Get_Name_String (Chars (E)); + Name_Len := Name_Len - 1; + return Name_Find; + end Non_Internal_Name; + + -- Start of processing for Primitive_Names_Match + + begin + pragma Assert (Present (E1) and then Present (E2)); + + return Chars (E1) = Chars (E2) + or else + (not Is_Internal_Name (Chars (E1)) + and then Is_Internal_Name (Chars (E2)) + and then Non_Internal_Name (E2) = Chars (E1)) + or else + (not Is_Internal_Name (Chars (E2)) + and then Is_Internal_Name (Chars (E1)) + and then Non_Internal_Name (E1) = Chars (E2)) + or else + (Is_Predefined_Dispatching_Operation (E1) + and then Is_Predefined_Dispatching_Operation (E2) + and then Same_TSS (E1, E2)) + or else + (Is_Init_Proc (E1) and then Is_Init_Proc (E2)); + end Primitive_Names_Match; + ----------------------- -- Process_End_Label -- ----------------------- @@ -8703,6 +8379,32 @@ package body Sem_Util is return Token_Node; end Real_Convert; + -------------------- + -- Remove_Homonym -- + -------------------- + + procedure Remove_Homonym (E : Entity_Id) is + Prev : Entity_Id := Empty; + H : Entity_Id; + + begin + if E = Current_Entity (E) then + if Present (Homonym (E)) then + Set_Current_Entity (Homonym (E)); + else + Set_Name_Entity_Id (Chars (E), Empty); + end if; + else + H := Current_Entity (E); + while Present (H) and then H /= E loop + Prev := H; + H := Homonym (H); + end loop; + + Set_Homonym (Prev, Homonym (E)); + end if; + end Remove_Homonym; + --------------------- -- Rep_To_Pos_Flag -- --------------------- @@ -9745,6 +9447,22 @@ package body Sem_Util is return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); end Type_Access_Level; + -------------------- + -- Ultimate_Alias -- + -------------------- + -- To do: add occurrences calling this new subprogram + + function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is + E : Entity_Id := Prim; + + begin + while Present (Alias (E)) loop + E := Alias (E); + end loop; + + return E; + end Ultimate_Alias; + -------------------------- -- Unit_Declaration_Node -- -------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 175b3156cd8..bbd4c864a3e 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -152,14 +152,14 @@ package Sem_Util is -- with OpenVMS ports. The argument is the construct in question -- and is used to post the error message. - procedure Collect_Abstract_Interfaces - (T : Entity_Id; - Ifaces_List : out Elist_Id; - Exclude_Parent_Interfaces : Boolean := False; - Use_Full_View : Boolean := True); + procedure Collect_Interfaces + (T : Entity_Id; + Ifaces_List : out Elist_Id; + Exclude_Parents : Boolean := False; + Use_Full_View : Boolean := True); -- Ada 2005 (AI-251): Collect whole list of abstract interfaces that are - -- directly or indirectly implemented by T. Exclude_Parent_Interfaces is - -- used to avoid addition of inherited interfaces to the generated list. + -- directly or indirectly implemented by T. Exclude_Parents is used to + -- avoid the addition of inherited interfaces to the generated list. -- Use_Full_View is used to collect the interfaces using the full-view -- (if available). @@ -327,18 +327,6 @@ package Sem_Util is -- not an address representation clause, or if it is not possible to -- determine that the address is of this form, then Empty is returned. - function Find_Overridden_Synchronized_Primitive - (Def_Id : Entity_Id; - First_Hom : Entity_Id; - Ifaces_List : Elist_Id; - In_Scope : Boolean) return Entity_Id; - -- Determine whether entry or subprogram Def_Id overrides a primitive - -- operation that belongs to one of the interfaces in Ifaces_List. A - -- specific homonym chain can be specified by setting First_Hom. Flag - -- In_Scope is used to designate whether the entry or subprogram was - -- declared inside the scope of the synchronized type or after. Return - -- the overridden entity or Empty. - function Find_Parameter_Type (Param : Node_Id) return Entity_Id; -- Return the type of formal parameter Param as determined by its -- specification. @@ -498,14 +486,6 @@ package Sem_Util is -- as an access type internally, this function tests only for access types -- known to the programmer. See also Has_Tagged_Component. - function Has_Abstract_Interfaces - (T : Entity_Id; - Use_Full_View : Boolean := True) return Boolean; - -- Where T is a concurrent type or a record type, returns true if T covers - -- any abstract interface types. In case of private types the argument - -- Use_Full_View controls if the check is done using its full view (if - -- available). - type Alignment_Result is (Known_Compatible, Unknown, Known_Incompatible); -- Result of Has_Compatible_Alignment test, description found below. Note -- that the values are arranged in increasing order of problematicness. @@ -542,6 +522,14 @@ package Sem_Util is -- Determines if the range of the floating-point type E includes -- infinities. Returns False if E is not a floating-point type. + function Has_Interfaces + (T : Entity_Id; + Use_Full_View : Boolean := True) return Boolean; + -- Where T is a concurrent type or a record type, returns true if T covers + -- any abstract interface types. In case of private types the argument + -- Use_Full_View controls if the check is done using its full view (if + -- available). + function Has_Null_Exclusion (N : Node_Id) return Boolean; -- Determine whether node N has a null exclusion @@ -572,6 +560,12 @@ package Sem_Util is -- component is present. This function is used to check if '=' has to be -- expanded into a bunch component comparisons. + function Implements_Interface + (Typ_Ent : Entity_Id; + Iface_Ent : Entity_Id; + Exclude_Parents : Boolean := False) return Boolean; + -- Returns true if the Typ implements interface Iface + function In_Instance return Boolean; -- Returns True if the current scope is within a generic instance @@ -716,13 +710,6 @@ package Sem_Util is -- is a variable (in the Is_Variable sense) with a non-tagged type -- target are considered view conversions and hence variables. - function Is_Parent - (E1 : Entity_Id; - E2 : Entity_Id) return Boolean; - -- Determine whether E1 is a parent of E2. For a concurrent type, the - -- parent is the first element of its list of interface types; for other - -- types, this function provides the same result as Is_Ancestor. - function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean; -- Typ is a type entity. This function returns true if this type is -- partly initialized, meaning that an object of the type is at least @@ -951,6 +938,13 @@ package Sem_Util is -- For convenience, qualified expressions applied to object names -- are also allowed as actuals for this function. + function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean; + -- Returns True if the names of both entities correspond with matching + -- primitives. This routine includes support for the case in which one + -- or both entities correspond with entities built by Derive_Subprogram + -- with a special name to avoid being overriden (ie. return true in case + -- of entities with names "nameP" and "name" or viceversa). + function Private_Component (Type_Id : Entity_Id) return Entity_Id; -- Returns some private component (if any) of the given Type_Id. -- Used to enforce the rules on visibility of operations on composite @@ -974,6 +968,9 @@ package Sem_Util is -- S is a possibly signed syntactically valid real literal. The result -- returned is an N_Real_Literal node representing the literal value. + procedure Remove_Homonym (E : Entity_Id); + -- Removes E from the homonym chain + function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id; -- This is used to construct the second argument in a call to Rep_To_Pos -- which is Standard_True if range checks are enabled (E is an entity to @@ -1147,6 +1144,10 @@ package Sem_Util is function Type_Access_Level (Typ : Entity_Id) return Uint; -- Return the accessibility level of Typ + function Ultimate_Alias (Prim : Entity_Id) return Entity_Id; + -- Return the last entity in the chain of aliased entities of Prim. + -- If Prim has no alias return Prim. + function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id; -- Unit_Id is the simple name of a program unit, this function returns the -- corresponding xxx_Declaration node for the entity. Also applies to the diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 536118f9586..c2043b1153a 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1414,12 +1414,12 @@ package Sinfo is -- full details) -- No_Initialization (Flag13-Sem) - -- Present in N_Object_Declaration & N_Allocator to indicate that the + -- Present in N_Object_Declaration and N_Allocator to indicate that the -- object must not be initialized (by Initialize or call to an init -- proc). This is needed for controlled aggregates. When the Object -- declaration has an expression, this flag means that this expression -- should not be taken into account (needed for in place initialization - -- with aggregates) + -- with aggregates). -- No_Truncation (Flag17-Sem) -- Present in N_Unchecked_Type_Conversion node. This flag has an effect diff --git a/gcc/ada/sinput-p.adb b/gcc/ada/sinput-p.adb index 9719d1b646c..b57c73bf957 100644 --- a/gcc/ada/sinput-p.adb +++ b/gcc/ada/sinput-p.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- -- @@ -95,6 +95,11 @@ package body Sinput.P is begin Prj.Err.Scanner.Initialize_Scanner (X); + -- No error for special characters that are used for preprocessing + + Prj.Err.Scanner.Set_Special_Character ('#'); + Prj.Err.Scanner.Set_Special_Character ('$'); + -- We scan past junk to the first interesting compilation unit -- token, to see if it is SEPARATE. We ignore WITH keywords during -- this and also PRIVATE. The reason for ignoring PRIVATE is that @@ -108,6 +113,8 @@ package body Sinput.P is Prj.Err.Scanner.Scan; end loop; + Prj.Err.Scanner.Reset_Special_Characters; + return Token = Tok_Separate; end Source_File_Is_Subunit; diff --git a/gcc/ada/sinput-p.ads b/gcc/ada/sinput-p.ads index 54171fb3298..85ac35d331a 100644 --- a/gcc/ada/sinput-p.ads +++ b/gcc/ada/sinput-p.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- -- @@ -32,8 +32,8 @@ with Scans; use Scans; package Sinput.P is function Load_Project_File (Path : String) return Source_File_Index; - -- Load into memory the source of a project source file. - -- Initialize the Scans state. + -- Load into memory the source of a project source file. Initialize the + -- Scans state. procedure Reset_First; -- Indicate that the next project loaded should be considered as the first @@ -41,13 +41,13 @@ package Sinput.P is -- is to get the correct number of lines when error finalization is called. function Source_File_Is_Subunit (X : Source_File_Index) return Boolean; - -- This function determines if a source file represents a subunit. It - -- works by scanning for the first compilation unit token, and returning - -- True if it is the token SEPARATE. It will return False otherwise, - -- meaning that the file cannot possibly be a legal subunit. This - -- function does NOT do a complete parse of the file, or build a - -- tree. It is used in gnatmake to decide if a body without a spec - -- in a project file needs to be compiled or not. + -- This function determines if a source file represents a subunit. It works + -- by scanning for the first compilation unit token, and returning True if + -- it is the token SEPARATE. It will return False otherwise, meaning that + -- the file cannot possibly be a legal subunit. This function does NOT do a + -- complete parse of the file, or build a tree. It is used in gnatmake and + -- gprbuild to decide if a body without a spec in a project file needs to + -- be compiled or not. type Saved_Project_Scan_State is limited private; -- Used to save project scan state in following two routines @@ -55,14 +55,14 @@ package Sinput.P is procedure Save_Project_Scan_State (Saved_State : out Saved_Project_Scan_State); pragma Inline (Save_Project_Scan_State); - -- Save the Scans state, as well as the values of - -- Source and Current_Source_File. + -- Save the Scans state, as well as the values of Source and + -- Current_Source_File. procedure Restore_Project_Scan_State (Saved_State : Saved_Project_Scan_State); pragma Inline (Restore_Project_Scan_State); - -- Restore the Scans state and the values of - -- Source and Current_Source_File. + -- Restore the Scans state and the values of Source and + -- Current_Source_File. private diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index 84b24d26a4c..7d4cdddc479 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -767,6 +767,7 @@ package body Snames is "local_config_file#" & "local_configuration_pragmas#" & "locally_removed_files#" & + "map_file_option#" & "mapping_file_switches#" & "mapping_spec_suffix#" & "mapping_body_suffix#" & diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index 0b247e7f462..c2001e68aa4 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -1088,63 +1088,64 @@ package Snames is Name_Local_Config_File : constant Name_Id := N + 706; Name_Local_Configuration_Pragmas : constant Name_Id := N + 707; Name_Locally_Removed_Files : constant Name_Id := N + 708; - Name_Mapping_File_Switches : constant Name_Id := N + 709; - Name_Mapping_Spec_Suffix : constant Name_Id := N + 710; - Name_Mapping_Body_Suffix : constant Name_Id := N + 711; - Name_Metrics : constant Name_Id := N + 712; - Name_Naming : constant Name_Id := N + 713; - Name_Object_Generated : constant Name_Id := N + 714; - Name_Objects_Linked : constant Name_Id := N + 715; - Name_Objects_Path : constant Name_Id := N + 716; - Name_Objects_Path_File : constant Name_Id := N + 717; - Name_Object_Dir : constant Name_Id := N + 718; - Name_Pic_Option : constant Name_Id := N + 719; - Name_Pretty_Printer : constant Name_Id := N + 720; - Name_Prefix : constant Name_Id := N + 721; - Name_Project : constant Name_Id := N + 722; - Name_Roots : constant Name_Id := N + 723; - Name_Required_Switches : constant Name_Id := N + 724; - Name_Run_Path_Option : constant Name_Id := N + 725; - Name_Runtime_Project : constant Name_Id := N + 726; - Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 727; - Name_Shared_Library_Prefix : constant Name_Id := N + 728; - Name_Shared_Library_Suffix : constant Name_Id := N + 729; - Name_Separate_Suffix : constant Name_Id := N + 730; - Name_Source_Dirs : constant Name_Id := N + 731; - Name_Source_Files : constant Name_Id := N + 732; - Name_Source_List_File : constant Name_Id := N + 733; - Name_Spec : constant Name_Id := N + 734; - Name_Spec_Suffix : constant Name_Id := N + 735; - Name_Specification : constant Name_Id := N + 736; - Name_Specification_Exceptions : constant Name_Id := N + 737; - Name_Specification_Suffix : constant Name_Id := N + 738; - Name_Stack : constant Name_Id := N + 739; - Name_Switches : constant Name_Id := N + 740; - Name_Symbolic_Link_Supported : constant Name_Id := N + 741; - Name_Sync : constant Name_Id := N + 742; - Name_Synchronize : constant Name_Id := N + 743; - Name_Toolchain_Description : constant Name_Id := N + 744; - Name_Toolchain_Version : constant Name_Id := N + 745; - Name_Runtime_Library_Dir : constant Name_Id := N + 746; + Name_Map_File_Option : constant Name_Id := N + 709; + Name_Mapping_File_Switches : constant Name_Id := N + 710; + Name_Mapping_Spec_Suffix : constant Name_Id := N + 711; + Name_Mapping_Body_Suffix : constant Name_Id := N + 712; + Name_Metrics : constant Name_Id := N + 713; + Name_Naming : constant Name_Id := N + 714; + Name_Object_Generated : constant Name_Id := N + 715; + Name_Objects_Linked : constant Name_Id := N + 716; + Name_Objects_Path : constant Name_Id := N + 717; + Name_Objects_Path_File : constant Name_Id := N + 718; + Name_Object_Dir : constant Name_Id := N + 719; + Name_Pic_Option : constant Name_Id := N + 720; + Name_Pretty_Printer : constant Name_Id := N + 721; + Name_Prefix : constant Name_Id := N + 722; + Name_Project : constant Name_Id := N + 723; + Name_Roots : constant Name_Id := N + 724; + Name_Required_Switches : constant Name_Id := N + 725; + Name_Run_Path_Option : constant Name_Id := N + 726; + Name_Runtime_Project : constant Name_Id := N + 727; + Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 728; + Name_Shared_Library_Prefix : constant Name_Id := N + 729; + Name_Shared_Library_Suffix : constant Name_Id := N + 730; + Name_Separate_Suffix : constant Name_Id := N + 731; + Name_Source_Dirs : constant Name_Id := N + 732; + Name_Source_Files : constant Name_Id := N + 733; + Name_Source_List_File : constant Name_Id := N + 734; + Name_Spec : constant Name_Id := N + 735; + Name_Spec_Suffix : constant Name_Id := N + 736; + Name_Specification : constant Name_Id := N + 737; + Name_Specification_Exceptions : constant Name_Id := N + 738; + Name_Specification_Suffix : constant Name_Id := N + 739; + Name_Stack : constant Name_Id := N + 740; + Name_Switches : constant Name_Id := N + 741; + Name_Symbolic_Link_Supported : constant Name_Id := N + 742; + Name_Sync : constant Name_Id := N + 743; + Name_Synchronize : constant Name_Id := N + 744; + Name_Toolchain_Description : constant Name_Id := N + 745; + Name_Toolchain_Version : constant Name_Id := N + 746; + Name_Runtime_Library_Dir : constant Name_Id := N + 747; -- Other miscellaneous names used in front end - Name_Unaligned_Valid : constant Name_Id := N + 747; + Name_Unaligned_Valid : constant Name_Id := N + 748; -- Ada 2005 reserved words - First_2005_Reserved_Word : constant Name_Id := N + 748; - Name_Interface : constant Name_Id := N + 748; - Name_Overriding : constant Name_Id := N + 749; - Name_Synchronized : constant Name_Id := N + 750; - Last_2005_Reserved_Word : constant Name_Id := N + 750; + First_2005_Reserved_Word : constant Name_Id := N + 749; + Name_Interface : constant Name_Id := N + 749; + Name_Overriding : constant Name_Id := N + 750; + Name_Synchronized : constant Name_Id := N + 751; + Last_2005_Reserved_Word : constant Name_Id := N + 751; 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 + 750; + Last_Predefined_Name : constant Name_Id := N + 751; --------------------------------------- -- Subtypes Defining Name Categories -- diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 0545f2585cd..4306ce41450 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -1577,6 +1577,11 @@ package body Sprint is Write_Str_With_Col_Check_Sloc ("new "); Sprint_Node (Subtype_Mark (Node)); + if Present (Interface_List (Node)) then + Write_Str_With_Col_Check (" and "); + Sprint_And_List (Interface_List (Node)); + end if; + if Private_Present (Node) then Write_Str_With_Col_Check (" with private"); end if; @@ -2442,6 +2447,12 @@ package body Sprint is Write_Str_With_Col_Check (" is new "); Sprint_Node (Subtype_Indication (Node)); + + if Present (Interface_List (Node)) then + Write_Str_With_Col_Check (" and "); + Sprint_And_List (Interface_List (Node)); + end if; + Write_Str_With_Col_Check (" with private;"); when N_Procedure_Call_Statement => diff --git a/gcc/ada/system-darwin-ppc.ads b/gcc/ada/system-darwin-ppc.ads index fc93f93a92b..be25c474a3a 100644 --- a/gcc/ada/system-darwin-ppc.ads +++ b/gcc/ada/system-darwin-ppc.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Darwin/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 -- @@ -164,7 +164,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/system-darwin-x86.ads b/gcc/ada/system-darwin-x86.ads index 7bb91e76002..04cdbbcf94f 100644 --- a/gcc/ada/system-darwin-x86.ads +++ b/gcc/ada/system-darwin-x86.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Darwin/x86 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 -- @@ -164,7 +164,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/system-freebsd-x86.ads b/gcc/ada/system-freebsd-x86.ads index 3631b8575b7..1f727a4def7 100644 --- a/gcc/ada/system-freebsd-x86.ads +++ b/gcc/ada/system-freebsd-x86.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (FreeBSD/x86 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 -- @@ -138,7 +138,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/system-linux-ppc.ads b/gcc/ada/system-linux-ppc.ads index 08c08a36068..f74f5fa11b0 100644 --- a/gcc/ada/system-linux-ppc.ads +++ b/gcc/ada/system-linux-ppc.ads @@ -146,7 +146,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/system-linux-x86.ads b/gcc/ada/system-linux-x86.ads index f46da46fdaf..81c970d0262 100644 --- a/gcc/ada/system-linux-x86.ads +++ b/gcc/ada/system-linux-x86.ads @@ -146,7 +146,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/system-linux-x86_64.ads b/gcc/ada/system-linux-x86_64.ads index 7ee41803340..da8a2fd9f2c 100644 --- a/gcc/ada/system-linux-x86_64.ads +++ b/gcc/ada/system-linux-x86_64.ads @@ -146,7 +146,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/system-lynxos-ppc.ads b/gcc/ada/system-lynxos-ppc.ads index c508d140d6c..44a0405e2ee 100644 --- a/gcc/ada/system-lynxos-ppc.ads +++ b/gcc/ada/system-lynxos-ppc.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (LynxOS 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 -- @@ -152,7 +152,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; diff --git a/gcc/ada/system-lynxos-x86.ads b/gcc/ada/system-lynxos-x86.ads index c93c6d77d1c..e40bec84bdb 100644 --- a/gcc/ada/system-lynxos-x86.ads +++ b/gcc/ada/system-lynxos-x86.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (LynxOS x86 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 -- @@ -152,7 +152,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; diff --git a/gcc/ada/system-mingw.ads b/gcc/ada/system-mingw.ads index 56d0fea42fc..4d37001558d 100644 --- a/gcc/ada/system-mingw.ads +++ b/gcc/ada/system-mingw.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Windows 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 -- @@ -138,7 +138,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; diff --git a/gcc/ada/system-solaris-sparc.ads b/gcc/ada/system-solaris-sparc.ads index 712812c46c5..26ca7e4d43b 100644 --- a/gcc/ada/system-solaris-sparc.ads +++ b/gcc/ada/system-solaris-sparc.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (SUN Solaris 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 -- @@ -138,7 +138,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/system-solaris-sparcv9.ads b/gcc/ada/system-solaris-sparcv9.ads index 56a60ae9ce7..6da815ecc7e 100644 --- a/gcc/ada/system-solaris-sparcv9.ads +++ b/gcc/ada/system-solaris-sparcv9.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Solaris Sparcv9 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 -- @@ -138,7 +138,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/system-solaris-x86.ads b/gcc/ada/system-solaris-x86.ads index 59c3a360e73..dd7eb4b6728 100644 --- a/gcc/ada/system-solaris-x86.ads +++ b/gcc/ada/system-solaris-x86.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (x86 Solaris 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 -- @@ -138,7 +138,7 @@ private Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index 5f579e71b45..dda85c5658c 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -221,14 +221,14 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name, struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr, struct String_Entry *strings_ptr, Char_Code *string_chars_ptr, struct List_Header *list_headers_ptr, Nat number_file, - struct File_Info_Type *file_info_ptr ATTRIBUTE_UNUSED, + struct File_Info_Type *file_info_ptr, Entity_Id standard_integer, Entity_Id standard_long_long_float, Entity_Id standard_exception_type, Int gigi_operating_mode) { tree gnu_standard_long_long_float; tree gnu_standard_exception_type; struct elab_info *info; - int i ATTRIBUTE_UNUSED; + int i; max_gnat_nodes = max_gnat_node; number_names = number_name; @@ -920,7 +920,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) TREE_CONSTANT (gnu_expr) = 1; if (TREE_CODE (gnu_expr) == ADDR_EXPR) - TREE_STATIC (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1; + TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1; } /* For other address attributes applied to a nested function, diff --git a/gcc/ada/tree_io.ads b/gcc/ada/tree_io.ads index d243d726442..d0744bbcca4 100644 --- a/gcc/ada/tree_io.ads +++ b/gcc/ada/tree_io.ads @@ -46,7 +46,7 @@ package Tree_IO is Tree_Format_Error : exception; -- Raised if a format error is detected in the input file - ASIS_Version_Number : constant := 22; + ASIS_Version_Number : constant := 23; -- ASIS Version. This is used to check for consistency between the compiler -- used to generate trees and an ASIS application that is reading the -- trees. It must be incremented whenever a change is made to the tree diff --git a/gcc/ada/utils.c b/gcc/ada/utils.c index 7a984b23ad5..8dd445fd8cd 100644 --- a/gcc/ada/utils.c +++ b/gcc/ada/utils.c @@ -4763,8 +4763,8 @@ def_builtin_1 (enum built_in_function fncode, if (both_p) /* ??? This is normally further controlled by command-line options like -fno-builtin, but we don't have them for Ada. */ - add_builtin_function (libname, libtype, fncode, fnclass, - NULL, fnattrs); + add_builtin_function (libname, libtype, fncode, fnclass, + NULL, fnattrs); built_in_decls[(int) fncode] = decl; if (implicit_p) diff --git a/gcc/ada/xsnames.adb b/gcc/ada/xsnames.adb index e5579d805e8..d43631a258e 100644 --- a/gcc/ada/xsnames.adb +++ b/gcc/ada/xsnames.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- -- @@ -51,7 +51,6 @@ procedure XSnames is Line : VString := Nul; Name : VString := Nul; Name1 : VString := Nul; - Oname : VString := Nul; Oval : VString := Nul; Restl : VString := Nul; @@ -165,7 +164,6 @@ begin Create (OutH, Out_File, "snames.nh"); Anchored_Mode := True; - Oname := Nul; Val := 0; loop diff --git a/gcc/c-common.c b/gcc/c-common.c index a390abba957..bc043618200 100644 --- a/gcc/c-common.c +++ b/gcc/c-common.c @@ -4148,18 +4148,6 @@ self_promoting_args_p (const_tree parms) return 1; } -/* Recursively examines the array elements of TYPE, until a non-array - element type is found. */ - -tree -strip_array_types (tree type) -{ - while (TREE_CODE (type) == ARRAY_TYPE) - type = TREE_TYPE (type); - - return type; -} - /* Recursively remove any '*' or '&' operator from TYPE. */ tree strip_pointer_operator (tree t) diff --git a/gcc/c-common.h b/gcc/c-common.h index e99c498a238..8044c152180 100644 --- a/gcc/c-common.h +++ b/gcc/c-common.h @@ -262,8 +262,6 @@ extern c_language_kind c_language; #define c_dialect_cxx() (c_language & clk_cxx) #define c_dialect_objc() (c_language & clk_objc) -extern bool lang_fortran; - /* Information about a statement tree. */ struct stmt_tree_s GTY(()) { @@ -737,7 +735,6 @@ extern alias_set_type c_common_get_alias_set (tree); extern void c_register_builtin_type (tree, const char*); extern bool c_promoting_integer_type_p (const_tree); extern int self_promoting_args_p (const_tree); -extern tree strip_array_types (tree); extern tree strip_pointer_operator (tree); extern tree strip_pointer_or_array_types (tree); extern HOST_WIDE_INT c_common_to_target_charset (HOST_WIDE_INT); diff --git a/gcc/c-cppbuiltin.c b/gcc/c-cppbuiltin.c index 86c3f9cfff2..63e5ad4e41b 100644 --- a/gcc/c-cppbuiltin.c +++ b/gcc/c-cppbuiltin.c @@ -48,8 +48,6 @@ along with GCC; see the file COPYING3. If not see /* Non-static as some targets don't use it. */ void builtin_define_std (const char *) ATTRIBUTE_UNUSED; -static void builtin_define_with_value_n (const char *, const char *, - size_t); static void builtin_define_with_int_value (const char *, HOST_WIDE_INT); static void builtin_define_with_hex_fp_value (const char *, tree, int, const char *, @@ -375,40 +373,19 @@ builtin_define_fixed_point_constants (const char *name_prefix, static void define__GNUC__ (void) { - /* The format of the version string, enforced below, is - ([^0-9]*-)?[0-9]+[.][0-9]+([.][0-9]+)?([- ].*)? */ - const char *q, *v = version_string; - - while (*v && !ISDIGIT (*v)) - v++; - gcc_assert (*v && (v <= version_string || v[-1] == '-')); - - q = v; - while (ISDIGIT (*v)) - v++; - builtin_define_with_value_n ("__GNUC__", q, v - q); - if (c_dialect_cxx ()) - builtin_define_with_value_n ("__GNUG__", q, v - q); - - gcc_assert (*v == '.' && ISDIGIT (v[1])); - - q = ++v; - while (ISDIGIT (*v)) - v++; - builtin_define_with_value_n ("__GNUC_MINOR__", q, v - q); + int major, minor, patchlevel; - if (*v == '.') + if (sscanf (BASEVER, "%d.%d.%d", &major, &minor, &patchlevel) != 3) { - gcc_assert (ISDIGIT (v[1])); - q = ++v; - while (ISDIGIT (*v)) - v++; - builtin_define_with_value_n ("__GNUC_PATCHLEVEL__", q, v - q); + sscanf (BASEVER, "%d.%d", &major, &minor); + patchlevel = 0; } - else - builtin_define_with_value_n ("__GNUC_PATCHLEVEL__", "0", 1); + cpp_define_formatted (parse_in, "__GNUC__=%d", major); + cpp_define_formatted (parse_in, "__GNUC_MINOR__=%d", minor); + cpp_define_formatted (parse_in, "__GNUC_PATCHLEVEL__=%d", patchlevel); - gcc_assert (!*v || *v == ' ' || *v == '-'); + if (c_dialect_cxx ()) + cpp_define_formatted (parse_in, "__GNUG__=%d", major); } /* Define macros used by <stdint.h>. Currently only defines limits @@ -684,9 +661,6 @@ c_cpp_builtins (cpp_reader *pfile) if (flag_openmp) cpp_define (pfile, "_OPENMP=200505"); - if (lang_fortran) - cpp_define (pfile, "__GFORTRAN__=1"); - builtin_define_type_sizeof ("__SIZEOF_INT__", integer_type_node); builtin_define_type_sizeof ("__SIZEOF_LONG__", long_integer_type_node); builtin_define_type_sizeof ("__SIZEOF_LONG_LONG__", @@ -799,23 +773,6 @@ builtin_define_with_value (const char *macro, const char *expansion, int is_str) cpp_define (parse_in, buf); } -/* Pass an object-like macro and a value to define it to. The third - parameter is the length of the expansion. */ -static void -builtin_define_with_value_n (const char *macro, const char *expansion, size_t elen) -{ - char *buf; - size_t mlen = strlen (macro); - - /* Space for an = and a NUL. */ - buf = (char *) alloca (mlen + elen + 2); - memcpy (buf, macro, mlen); - buf[mlen] = '='; - memcpy (buf + mlen + 1, expansion, elen); - buf[mlen + elen + 1] = '\0'; - - cpp_define (parse_in, buf); -} /* Pass an object-like macro and an integer value to define it to. */ static void diff --git a/gcc/c-opts.c b/gcc/c-opts.c index eda0f48f949..2eef789978d 100644 --- a/gcc/c-opts.c +++ b/gcc/c-opts.c @@ -33,7 +33,7 @@ along with GCC; see the file COPYING3. If not see #include "diagnostic.h" #include "intl.h" #include "cppdefault.h" -#include "c-incpath.h" +#include "incpath.h" #include "debug.h" /* For debug_hooks. */ #include "opts.h" #include "options.h" @@ -72,9 +72,6 @@ static bool deps_seen; /* If -v seen. */ static bool verbose; -/* If -lang-fortran seen. */ -bool lang_fortran = false; - /* Dependency output file. */ static const char *deps_file; @@ -249,15 +246,6 @@ c_common_init_options (unsigned int argc, const char **argv) result |= CL_C | CL_ObjC | CL_CXX | CL_ObjCXX; break; } - -#ifdef CL_Fortran - for (i = 1; i < argc; i++) - if (! strcmp (argv[i], "-lang-fortran")) - { - result |= CL_Fortran; - break; - } -#endif } return result; @@ -288,10 +276,6 @@ c_common_handle_option (size_t scode, const char *arg, int value) result = 0; break; } -#ifdef CL_Fortran - if (lang_fortran && (cl_options[code].flags & (CL_Fortran))) - break; -#endif result = 0; break; @@ -891,10 +875,6 @@ c_common_handle_option (size_t scode, const char *arg, int value) cpp_opts->dollars_in_ident = false; break; - case OPT_lang_fortran: - lang_fortran = true; - break; - case OPT_lang_objc: cpp_opts->objc = 1; break; diff --git a/gcc/c.opt b/gcc/c.opt index 1df0666f660..9669f2ca6ba 100644 --- a/gcc/c.opt +++ b/gcc/c.opt @@ -195,6 +195,10 @@ Wendif-labels C ObjC C++ ObjC++ Warning Warn about stray tokens after #elif and #endif +Wenum-compare +C++ ObjC++ Var(warn_enum_compare) Init(1) Warning +Warn about comparison of different enum types + Werror C ObjC C++ ObjC++ ; Documented in common.opt @@ -864,9 +868,6 @@ C ObjC C++ ObjC++ Joined Separate lang-asm C Undocumented -lang-fortran -C Undocumented - lang-objc C ObjC C++ ObjC++ Undocumented diff --git a/gcc/caller-save.c b/gcc/caller-save.c index 7976fd5fd75..c6a685bde9c 100644 --- a/gcc/caller-save.c +++ b/gcc/caller-save.c @@ -704,6 +704,11 @@ insert_restore (struct insn_chain *chain, int before_p, int regno, mem = adjust_address (mem, save_mode[regno], 0); else mem = copy_rtx (mem); + + /* Verify that the alignment of spill space is equal to or greater + than required. */ + gcc_assert (GET_MODE_ALIGNMENT (GET_MODE (mem)) <= MEM_ALIGN (mem)); + pat = gen_rtx_SET (VOIDmode, gen_rtx_REG (GET_MODE (mem), regno), mem); @@ -776,6 +781,11 @@ insert_save (struct insn_chain *chain, int before_p, int regno, mem = adjust_address (mem, save_mode[regno], 0); else mem = copy_rtx (mem); + + /* Verify that the alignment of spill space is equal to or greater + than required. */ + gcc_assert (GET_MODE_ALIGNMENT (GET_MODE (mem)) <= MEM_ALIGN (mem)); + pat = gen_rtx_SET (VOIDmode, mem, gen_rtx_REG (GET_MODE (mem), regno)); diff --git a/gcc/cfgexpand.c b/gcc/cfgexpand.c index 69a911eac8e..ffe2366a108 100644 --- a/gcc/cfgexpand.c +++ b/gcc/cfgexpand.c @@ -86,10 +86,6 @@ failed: } -#ifndef LOCAL_ALIGNMENT -#define LOCAL_ALIGNMENT(TYPE, ALIGNMENT) ALIGNMENT -#endif - #ifndef STACK_ALIGNMENT_NEEDED #define STACK_ALIGNMENT_NEEDED 1 #endif diff --git a/gcc/cgraphbuild.c b/gcc/cgraphbuild.c index a5f74e0df43..b97c1f7a452 100644 --- a/gcc/cgraphbuild.c +++ b/gcc/cgraphbuild.c @@ -97,7 +97,7 @@ initialize_inline_failed (struct cgraph_node *node) "considered for inlining"); else if (!node->local.inlinable) e->inline_failed = N_("function not inlinable"); - else if (CALL_CANNOT_INLINE_P (e->call_stmt)) + else if (CALL_STMT_CANNOT_INLINE_P (e->call_stmt)) e->inline_failed = N_("mismatched arguments"); else e->inline_failed = N_("function not considered for inlining"); diff --git a/gcc/config.gcc b/gcc/config.gcc index efc3c4a84ef..3bef721391a 100644 --- a/gcc/config.gcc +++ b/gcc/config.gcc @@ -2171,7 +2171,7 @@ score-*-elf) ;; sh-*-elf* | sh[12346l]*-*-elf* | sh*-*-kaos* | \ sh-*-symbianelf* | sh[12346l]*-*-symbianelf* | \ - sh-*-linux* | sh[346lbe]*-*-linux* | \ + sh-*-linux* | sh[2346lbe]*-*-linux* | \ sh-*-netbsdelf* | shl*-*-netbsdelf* | sh5-*-netbsd* | sh5l*-*-netbsd* | \ sh64-*-netbsd* | sh64l*-*-netbsd*) tmake_file="${tmake_file} sh/t-sh sh/t-elf" @@ -3182,7 +3182,7 @@ case "${target}" in for which in arch tune; do eval "val=\$with_$which" case ${val} in - "" | g5 | g6 | z900 | z990 | z9-109 | z9-ec) + "" | g5 | g6 | z900 | z990 | z9-109 | z9-ec | z10) # OK ;; *) diff --git a/gcc/config/avr/avr.c b/gcc/config/avr/avr.c index 012a7e4fd1b..d2cc33a0293 100644 --- a/gcc/config/avr/avr.c +++ b/gcc/config/avr/avr.c @@ -682,7 +682,9 @@ expand_prologue (void) /* Prevent any attempt to delete the setting of ZERO_REG! */ emit_insn (gen_rtx_USE (VOIDmode, zero_reg_rtx)); } - if (minimize && (frame_pointer_needed || live_seq > 6)) + if (minimize && (frame_pointer_needed + || (AVR_2_BYTE_PC && live_seq > 6) + || live_seq > 7)) { insn = emit_move_insn (gen_rtx_REG (HImode, REG_X), gen_int_mode (size, HImode)); diff --git a/gcc/config/avr/avr.md b/gcc/config/avr/avr.md index 137d3258833..ffbbefa74ef 100644 --- a/gcc/config/avr/avr.md +++ b/gcc/config/avr/avr.md @@ -587,18 +587,6 @@ [(set_attr "length" "2") (set_attr "cc" "set_n")]) -(define_insn "*addhi3_zero_extend2" - [(set (match_operand:HI 0 "register_operand" "=r") - (plus:HI - (zero_extend:HI (match_operand:QI 1 "register_operand" "%0")) - (zero_extend:HI (match_operand:QI 2 "register_operand" "r"))))] - "" - "add %0,%2 - mov %B0,__zero_reg__ - adc %B0,__zero_reg__" - [(set_attr "length" "3") - (set_attr "cc" "set_n")]) - (define_insn "*addhi3_sp_R_pc2" [(set (match_operand:HI 1 "stack_register_operand" "=q") (plus:HI (match_operand:HI 2 "stack_register_operand" "q") @@ -2777,8 +2765,8 @@ (use (reg:HI REG_X)) (clobber (reg:HI REG_Z))] "" - "ldi r30,pm_lo8(1f) - ldi r31,pm_hi8(1f) + "ldi r30,lo8(gs(1f)) + ldi r31,hi8(gs(1f)) %~jmp __prologue_saves__+((18 - %0) * 2) 1:" [(set_attr_alternative "length" diff --git a/gcc/config/darwin-c.c b/gcc/config/darwin-c.c index 76ef5fa3684..ba0eca14ed0 100644 --- a/gcc/config/darwin-c.c +++ b/gcc/config/darwin-c.c @@ -26,7 +26,7 @@ along with GCC; see the file COPYING3. If not see #include "tree.h" #include "c-pragma.h" #include "c-tree.h" -#include "c-incpath.h" +#include "incpath.h" #include "c-common.h" #include "toplev.h" #include "flags.h" diff --git a/gcc/config/i386/i386-protos.h b/gcc/config/i386/i386-protos.h index aee90eb65bd..6fdea06c518 100644 --- a/gcc/config/i386/i386-protos.h +++ b/gcc/config/i386/i386-protos.h @@ -187,7 +187,8 @@ extern void function_arg_advance (CUMULATIVE_ARGS *, enum machine_mode, extern int ix86_return_pops_args (tree, tree, int); extern int ix86_data_alignment (tree, int); -extern int ix86_local_alignment (tree, int); +extern unsigned int ix86_local_alignment (tree, enum machine_mode, + unsigned int); extern int ix86_constant_alignment (tree, int); extern tree ix86_handle_shared_attribute (tree *, tree, tree, int, bool *); extern tree ix86_handle_selectany_attribute (tree *, tree, tree, int, bool *); diff --git a/gcc/config/i386/i386.c b/gcc/config/i386/i386.c index 0f140c8adf7..cbb122ab0dc 100644 --- a/gcc/config/i386/i386.c +++ b/gcc/config/i386/i386.c @@ -4638,7 +4638,12 @@ ix86_function_arg_boundary (enum machine_mode mode, tree type) { int align; if (type) - align = TYPE_ALIGN (type); + { + if (TYPE_STRUCTURAL_EQUALITY_P (type)) + align = TYPE_ALIGN (type); + else + align = TYPE_ALIGN (TYPE_CANONICAL (type)); + } else align = GET_MODE_ALIGNMENT (mode); if (align < PARM_BOUNDARY) @@ -10408,12 +10413,10 @@ ix86_expand_vector_move (enum machine_mode mode, rtx operands[]) && standard_sse_constant_p (op1) <= 0) op1 = validize_mem (force_const_mem (mode, op1)); - /* TDmode values are passed as TImode on the stack. TImode values - are moved via xmm registers, and moving them to stack can result in - unaligned memory access. Use ix86_expand_vector_move_misalign() - if memory operand is not aligned correctly. */ + /* We need to check memory alignment for SSE mode since attribute + can make operands unaligned. */ if (can_create_pseudo_p () - && (mode == TImode) && !TARGET_64BIT + && SSE_REG_MODE_P (mode) && ((MEM_P (op0) && (MEM_ALIGN (op0) < align)) || (MEM_P (op1) && (MEM_ALIGN (op1) < align)))) { @@ -16996,14 +16999,25 @@ ix86_data_alignment (tree type, int align) return align; } -/* Compute the alignment for a local variable. - TYPE is the data type, and ALIGN is the alignment that - the object would ordinarily have. The value of this macro is used - instead of that alignment to align the object. */ +/* Compute the alignment for a local variable or a stack slot. TYPE is + the data type, MODE is the widest mode available and ALIGN is the + alignment that the object would ordinarily have. The value of this + macro is used instead of that alignment to align the object. */ -int -ix86_local_alignment (tree type, int align) +unsigned int +ix86_local_alignment (tree type, enum machine_mode mode, + unsigned int align) { + /* If TYPE is NULL, we are allocating a stack slot for caller-save + register in MODE. We will return the largest alignment of XF + and DF. */ + if (!type) + { + if (mode == XFmode && align < GET_MODE_ALIGNMENT (DFmode)) + align = GET_MODE_ALIGNMENT (DFmode); + return align; + } + /* x86-64 ABI requires arrays greater than 16 bytes to be aligned to 16byte boundary. */ if (TARGET_64BIT) @@ -23225,8 +23239,7 @@ x86_field_alignment (tree field, int computed) if (TARGET_64BIT || TARGET_ALIGN_DOUBLE) return computed; - mode = TYPE_MODE (TREE_CODE (type) == ARRAY_TYPE - ? get_inner_array_type (type) : type); + mode = TYPE_MODE (strip_array_types (type)); if (mode == DFmode || mode == DCmode || GET_MODE_CLASS (mode) == MODE_INT || GET_MODE_CLASS (mode) == MODE_COMPLEX_INT) diff --git a/gcc/config/i386/i386.h b/gcc/config/i386/i386.h index 0b5ca139350..ef8da17af3f 100644 --- a/gcc/config/i386/i386.h +++ b/gcc/config/i386/i386.h @@ -902,7 +902,22 @@ enum target_cpu_default One use of this macro is to increase alignment of medium-size data to make it all fit in fewer cache lines. */ -#define LOCAL_ALIGNMENT(TYPE, ALIGN) ix86_local_alignment ((TYPE), (ALIGN)) +#define LOCAL_ALIGNMENT(TYPE, ALIGN) \ + ix86_local_alignment ((TYPE), VOIDmode, (ALIGN)) + +/* If defined, a C expression to compute the alignment for stack slot. + TYPE is the data type, MODE is the widest mode available, and ALIGN + is the alignment that the slot would ordinarily have. The value of + this macro is used instead of that alignment to align the slot. + + If this macro is not defined, then ALIGN is used when TYPE is NULL, + Otherwise, LOCAL_ALIGNMENT will be used. + + One use of this macro is to set alignment of stack slot to the + maximum alignment of all possible modes which the slot may have. */ + +#define STACK_SLOT_ALIGNMENT(TYPE, MODE, ALIGN) \ + ix86_local_alignment ((TYPE), (MODE), (ALIGN)) /* If defined, a C expression that gives the alignment boundary, in bits, of an argument with the specified mode and type. If it is diff --git a/gcc/config/i386/i386.md b/gcc/config/i386/i386.md index fa1bff74de1..885077d02b2 100644 --- a/gcc/config/i386/i386.md +++ b/gcc/config/i386/i386.md @@ -19707,7 +19707,7 @@ (set_attr "length" "5")]) (define_insn "allocate_stack_worker_64" - [(set (match_operand:DI 0 "register_operand" "=a") + [(set (match_operand:DI 0 "register_operand" "+a") (unspec_volatile:DI [(match_dup 0)] UNSPECV_STACK_PROBE)) (set (reg:DI SP_REG) (minus:DI (reg:DI SP_REG) (match_dup 0))) (clobber (reg:DI R10_REG)) diff --git a/gcc/config/mips/mips.c b/gcc/config/mips/mips.c index 6cb0d293dda..b12e2e24c62 100644 --- a/gcc/config/mips/mips.c +++ b/gcc/config/mips/mips.c @@ -584,6 +584,9 @@ static const struct mips_cpu_info mips_cpu_info_table[] = { { "r4600", PROCESSOR_R4600, 3, 0 }, { "orion", PROCESSOR_R4600, 3, 0 }, { "r4650", PROCESSOR_R4650, 3, 0 }, + /* ST Loongson 2E/2F processors. */ + { "loongson2e", PROCESSOR_LOONGSON_2E, 3, PTF_AVOID_BRANCHLIKELY }, + { "loongson2f", PROCESSOR_LOONGSON_2F, 3, PTF_AVOID_BRANCHLIKELY }, /* MIPS IV processors. */ { "r8000", PROCESSOR_R8000, 4, 0 }, @@ -832,6 +835,12 @@ static const struct mips_rtx_cost_data mips_rtx_cost_data[PROCESSOR_MAX] = { 1, /* branch_cost */ 4 /* memory_latency */ }, + { /* Loongson-2E */ + DEFAULT_COSTS + }, + { /* Loongson-2F */ + DEFAULT_COSTS + }, { /* M4k */ DEFAULT_COSTS }, diff --git a/gcc/config/mips/mips.h b/gcc/config/mips/mips.h index 6d3c18feb46..402cd579c5c 100644 --- a/gcc/config/mips/mips.h +++ b/gcc/config/mips/mips.h @@ -47,6 +47,8 @@ enum processor_type { PROCESSOR_74KF2_1, PROCESSOR_74KF1_1, PROCESSOR_74KF3_2, + PROCESSOR_LOONGSON_2E, + PROCESSOR_LOONGSON_2F, PROCESSOR_M4K, PROCESSOR_R3900, PROCESSOR_R6000, @@ -237,6 +239,9 @@ enum mips_code_readable_setting { #define TARGET_SB1 (mips_arch == PROCESSOR_SB1 \ || mips_arch == PROCESSOR_SB1A) #define TARGET_SR71K (mips_arch == PROCESSOR_SR71000) +#define TARGET_LOONGSON_2E (mips_arch == PROCESSOR_LOONGSON_2E) +#define TARGET_LOONGSON_2F (mips_arch == PROCESSOR_LOONGSON_2F) +#define TARGET_LOONGSON_2EF (TARGET_LOONGSON_2E || TARGET_LOONGSON_2F) /* Scheduling target defines. */ #define TUNE_MIPS3000 (mips_tune == PROCESSOR_R3000) @@ -646,7 +651,7 @@ enum mips_code_readable_setting { "%{" MIPS_ISA_LEVEL_OPTION_SPEC ":;: \ %{march=mips1|march=r2000|march=r3000|march=r3900:-mips1} \ %{march=mips2|march=r6000:-mips2} \ - %{march=mips3|march=r4*|march=vr4*|march=orion:-mips3} \ + %{march=mips3|march=r4*|march=vr4*|march=orion|march=loongson2*:-mips3} \ %{march=mips4|march=r8000|march=vr5*|march=rm7000|march=rm9000:-mips4} \ %{march=mips32|march=4kc|march=4km|march=4kp|march=4ksc:-mips32} \ %{march=mips32r2|march=m4k|march=4ke*|march=4ksd|march=24k* \ diff --git a/gcc/config/mips/mips.md b/gcc/config/mips/mips.md index 2b789eef8b6..592ad528042 100644 --- a/gcc/config/mips/mips.md +++ b/gcc/config/mips/mips.md @@ -415,7 +415,7 @@ ;; Attribute describing the processor. This attribute must match exactly ;; with the processor_type enumeration in mips.h. (define_attr "cpu" - "r3000,4kc,4kp,5kc,5kf,20kc,24kc,24kf2_1,24kf1_1,74kc,74kf2_1,74kf1_1,74kf3_2,m4k,r3900,r6000,r4000,r4100,r4111,r4120,r4130,r4300,r4600,r4650,r5000,r5400,r5500,r7000,r8000,r9000,sb1,sb1a,sr71000" + "r3000,4kc,4kp,5kc,5kf,20kc,24kc,24kf2_1,24kf1_1,74kc,74kf2_1,74kf1_1,74kf3_2,loongson2e,loongson2f,m4k,r3900,r6000,r4000,r4100,r4111,r4120,r4130,r4300,r4600,r4650,r5000,r5400,r5500,r7000,r8000,r9000,sb1,sb1a,sr71000" (const (symbol_ref "mips_tune"))) ;; The type of hardware hazard associated with this instruction. diff --git a/gcc/config/pa/pa.c b/gcc/config/pa/pa.c index 10c50ffcf12..009f5faf10c 100644 --- a/gcc/config/pa/pa.c +++ b/gcc/config/pa/pa.c @@ -1712,8 +1712,7 @@ emit_move_sequence (rtx *operands, enum machine_mode mode, rtx scratch_reg) decl = TREE_OPERAND (decl, 1); type = TREE_TYPE (decl); - if (TREE_CODE (type) == ARRAY_TYPE) - type = get_inner_array_type (type); + type = strip_array_types (type); if (POINTER_TYPE_P (type)) { diff --git a/gcc/config/pa/pa.md b/gcc/config/pa/pa.md index 5f1d73893fd..a5dc031c91c 100644 --- a/gcc/config/pa/pa.md +++ b/gcc/config/pa/pa.md @@ -9673,8 +9673,7 @@ add,l %2,%3,%3\;bv,n %%r0(%3)" "" "* { - extern int frame_pointer_needed; - + /* We need two different versions depending on whether or not we need a frame pointer. Also note that we return to the instruction immediately after the branch rather than two instructions after the @@ -9726,7 +9725,6 @@ add,l %2,%3,%3\;bv,n %%r0(%3)" "" "* { - extern int frame_pointer_needed; /* We need two different versions depending on whether or not we need a frame pointer. Also note that we return to the instruction diff --git a/gcc/config/rs6000/aix.h b/gcc/config/rs6000/aix.h index 99587bb9b95..09e0fe507cf 100644 --- a/gcc/config/rs6000/aix.h +++ b/gcc/config/rs6000/aix.h @@ -158,11 +158,10 @@ /* This now supports a natural alignment mode. */ /* AIX word-aligns FP doubles but doubleword-aligns 64-bit ints. */ #define ADJUST_FIELD_ALIGN(FIELD, COMPUTED) \ - (TARGET_ALIGN_NATURAL ? (COMPUTED) : \ - (TYPE_MODE (TREE_CODE (TREE_TYPE (FIELD)) == ARRAY_TYPE \ - ? get_inner_array_type (FIELD) \ - : TREE_TYPE (FIELD)) == DFmode \ - ? MIN ((COMPUTED), 32) : (COMPUTED))) + ((TARGET_ALIGN_NATURAL == 0 \ + && TYPE_MODE (strip_array_types (TREE_TYPE (FIELD))) == DFmode) \ + ? MIN ((COMPUTED), 32) \ + : (COMPUTED)) /* AIX increases natural record alignment to doubleword if the first field is an FP double while the FP fields remain word aligned. */ diff --git a/gcc/config/rs6000/linux64.h b/gcc/config/rs6000/linux64.h index eea5fd73e87..e83e0e9697a 100644 --- a/gcc/config/rs6000/linux64.h +++ b/gcc/config/rs6000/linux64.h @@ -217,9 +217,7 @@ extern int dot_symbols; ? 128 \ : (TARGET_64BIT \ && TARGET_ALIGN_NATURAL == 0 \ - && TYPE_MODE (TREE_CODE (TREE_TYPE (FIELD)) == ARRAY_TYPE \ - ? get_inner_array_type (FIELD) \ - : TREE_TYPE (FIELD)) == DFmode) \ + && TYPE_MODE (strip_array_types (TREE_TYPE (FIELD))) == DFmode) \ ? MIN ((COMPUTED), 32) \ : (COMPUTED)) diff --git a/gcc/config/rs6000/rs6000.c b/gcc/config/rs6000/rs6000.c index e90772b03ef..1eafc999fde 100644 --- a/gcc/config/rs6000/rs6000.c +++ b/gcc/config/rs6000/rs6000.c @@ -3897,14 +3897,18 @@ rs6000_legitimize_tls_address (rtx addr, enum tls_model model) if (model == TLS_MODEL_GLOBAL_DYNAMIC) { r3 = gen_rtx_REG (Pmode, 3); - if (TARGET_64BIT) - insn = gen_tls_gd_64 (r3, got, addr); + tga = rs6000_tls_get_addr (); + + if (DEFAULT_ABI == ABI_AIX && TARGET_64BIT) + insn = gen_tls_gd_aix64 (r3, got, addr, tga, const0_rtx); + else if (DEFAULT_ABI == ABI_AIX && !TARGET_64BIT) + insn = gen_tls_gd_aix32 (r3, got, addr, tga, const0_rtx); + else if (DEFAULT_ABI == ABI_V4) + insn = gen_tls_gd_sysvsi (r3, got, addr, tga, const0_rtx); else - insn = gen_tls_gd_32 (r3, got, addr); + gcc_unreachable (); + start_sequence (); - emit_insn (insn); - tga = gen_rtx_MEM (Pmode, rs6000_tls_get_addr ()); - insn = gen_call_value (r3, tga, const0_rtx, const0_rtx); insn = emit_call_insn (insn); RTL_CONST_CALL_P (insn) = 1; use_reg (&CALL_INSN_FUNCTION_USAGE (insn), r3); @@ -3915,14 +3919,18 @@ rs6000_legitimize_tls_address (rtx addr, enum tls_model model) else if (model == TLS_MODEL_LOCAL_DYNAMIC) { r3 = gen_rtx_REG (Pmode, 3); - if (TARGET_64BIT) - insn = gen_tls_ld_64 (r3, got); + tga = rs6000_tls_get_addr (); + + if (DEFAULT_ABI == ABI_AIX && TARGET_64BIT) + insn = gen_tls_ld_aix64 (r3, got, tga, const0_rtx); + else if (DEFAULT_ABI == ABI_AIX && !TARGET_64BIT) + insn = gen_tls_ld_aix32 (r3, got, tga, const0_rtx); + else if (DEFAULT_ABI == ABI_V4) + insn = gen_tls_ld_sysvsi (r3, got, tga, const0_rtx); else - insn = gen_tls_ld_32 (r3, got); + gcc_unreachable (); + start_sequence (); - emit_insn (insn); - tga = gen_rtx_MEM (Pmode, rs6000_tls_get_addr ()); - insn = gen_call_value (r3, tga, const0_rtx, const0_rtx); insn = emit_call_insn (insn); RTL_CONST_CALL_P (insn) = 1; use_reg (&CALL_INSN_FUNCTION_USAGE (insn), r3); diff --git a/gcc/config/rs6000/rs6000.md b/gcc/config/rs6000/rs6000.md index fc65c94f8ca..1f63454e694 100644 --- a/gcc/config/rs6000/rs6000.md +++ b/gcc/config/rs6000/rs6000.md @@ -10199,183 +10199,155 @@ ;; TLS support. -;; "b" output constraint here and on tls_ld to support tls linker optimization. -(define_insn "tls_gd_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=b") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSGD))] - "HAVE_AS_TLS && !TARGET_64BIT" - "addi %0,%1,%2@got@tlsgd") - -(define_insn "tls_gd_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=b") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSGD))] - "HAVE_AS_TLS && TARGET_64BIT" - "addi %0,%1,%2@got@tlsgd") - -(define_insn "tls_ld_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=b") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b")] - UNSPEC_TLSLD))] - "HAVE_AS_TLS && !TARGET_64BIT" - "addi %0,%1,%&@got@tlsld") - -(define_insn "tls_ld_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=b") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b")] - UNSPEC_TLSLD))] - "HAVE_AS_TLS && TARGET_64BIT" - "addi %0,%1,%&@got@tlsld") - -(define_insn "tls_dtprel_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=r") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSDTPREL))] - "HAVE_AS_TLS && !TARGET_64BIT" - "addi %0,%1,%2@dtprel") - -(define_insn "tls_dtprel_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=r") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSDTPREL))] - "HAVE_AS_TLS && TARGET_64BIT" - "addi %0,%1,%2@dtprel") - -(define_insn "tls_dtprel_ha_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=r") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSDTPRELHA))] - "HAVE_AS_TLS && !TARGET_64BIT" - "addis %0,%1,%2@dtprel@ha") +;; Mode attributes for different ABIs. +(define_mode_iterator TLSmode [(SI "! TARGET_64BIT") (DI "TARGET_64BIT")]) +(define_mode_attr tls_abi_suffix [(SI "32") (DI "64")]) +(define_mode_attr tls_sysv_suffix [(SI "si") (DI "di")]) +(define_mode_attr tls_insn_suffix [(SI "wz") (DI "d")]) + +(define_insn "tls_gd_aix<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=b") + (call (mem:TLSmode (match_operand:TLSmode 3 "symbol_ref_operand" "s")) + (match_operand 4 "" "g"))) + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSGD) + (clobber (reg:SI LR_REGNO))] + "HAVE_AS_TLS && DEFAULT_ABI == ABI_AIX" + "addi %0,%1,%2@got@tlsgd\;bl %z3\;%." + [(set_attr "type" "two") + (set_attr "length" "12")]) -(define_insn "tls_dtprel_ha_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=r") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSDTPRELHA))] - "HAVE_AS_TLS && TARGET_64BIT" - "addis %0,%1,%2@dtprel@ha") +(define_insn "tls_gd_sysv<TLSmode:tls_sysv_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=b") + (call (mem:TLSmode (match_operand:TLSmode 3 "symbol_ref_operand" "s")) + (match_operand 4 "" "g"))) + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSGD) + (clobber (reg:SI LR_REGNO))] + "HAVE_AS_TLS && DEFAULT_ABI == ABI_V4" +{ + if (flag_pic) + { + if (TARGET_SECURE_PLT && flag_pic == 2) + return "addi %0,%1,%2@got@tlsgd\;bl %z3+32768@plt"; + else + return "addi %0,%1,%2@got@tlsgd\;bl %z3@plt"; + } + else + return "addi %0,%1,%2@got@tlsgd\;bl %z3"; +} + [(set_attr "type" "two") + (set_attr "length" "8")]) -(define_insn "tls_dtprel_lo_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=r") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSDTPRELLO))] - "HAVE_AS_TLS && !TARGET_64BIT" - "addi %0,%1,%2@dtprel@l") +(define_insn "tls_ld_aix<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=b") + (call (mem:TLSmode (match_operand:TLSmode 2 "symbol_ref_operand" "s")) + (match_operand 3 "" "g"))) + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b")] + UNSPEC_TLSLD) + (clobber (reg:SI LR_REGNO))] + "HAVE_AS_TLS && DEFAULT_ABI == ABI_AIX" + "addi %0,%1,%&@got@tlsld\;bl %z2\;%." + [(set_attr "length" "12")]) -(define_insn "tls_dtprel_lo_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=r") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSDTPRELLO))] - "HAVE_AS_TLS && TARGET_64BIT" - "addi %0,%1,%2@dtprel@l") +(define_insn "tls_ld_sysv<TLSmode:tls_sysv_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=b") + (call (mem:TLSmode (match_operand:TLSmode 2 "symbol_ref_operand" "s")) + (match_operand 3 "" "g"))) + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b")] + UNSPEC_TLSLD) + (clobber (reg:SI LR_REGNO))] + "HAVE_AS_TLS && DEFAULT_ABI == ABI_V4" +{ + if (flag_pic) + { + if (TARGET_SECURE_PLT && flag_pic == 2) + return "addi %0,%1,%&@got@tlsld\;bl %z2+32768@plt"; + else + return "addi %0,%1,%&@got@tlsld\;bl %z2@plt"; + } + else + return "addi %0,%1,%&@got@tlsld\;bl %z2"; +} + [(set_attr "length" "8")]) -(define_insn "tls_got_dtprel_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=r") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSGOTDTPREL))] - "HAVE_AS_TLS && !TARGET_64BIT" - "lwz %0,%2@got@dtprel(%1)") +(define_insn "tls_dtprel_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=r") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSDTPREL))] + "HAVE_AS_TLS" + "addi %0,%1,%2@dtprel") -(define_insn "tls_got_dtprel_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=r") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSGOTDTPREL))] - "HAVE_AS_TLS && TARGET_64BIT" - "ld %0,%2@got@dtprel(%1)") +(define_insn "tls_dtprel_ha_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=r") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSDTPRELHA))] + "HAVE_AS_TLS" + "addis %0,%1,%2@dtprel@ha") -(define_insn "tls_tprel_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=r") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSTPREL))] - "HAVE_AS_TLS && !TARGET_64BIT" - "addi %0,%1,%2@tprel") +(define_insn "tls_dtprel_lo_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=r") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSDTPRELLO))] + "HAVE_AS_TLS" + "addi %0,%1,%2@dtprel@l") -(define_insn "tls_tprel_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=r") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSTPREL))] - "HAVE_AS_TLS && TARGET_64BIT" +(define_insn "tls_got_dtprel_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=r") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSGOTDTPREL))] + "HAVE_AS_TLS" + "l<TLSmode:tls_insn_suffix> %0,%2@got@dtprel(%1)") + +(define_insn "tls_tprel_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=r") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSTPREL))] + "HAVE_AS_TLS" "addi %0,%1,%2@tprel") -(define_insn "tls_tprel_ha_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=r") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSTPRELHA))] - "HAVE_AS_TLS && !TARGET_64BIT" - "addis %0,%1,%2@tprel@ha") - -(define_insn "tls_tprel_ha_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=r") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSTPRELHA))] - "HAVE_AS_TLS && TARGET_64BIT" +(define_insn "tls_tprel_ha_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=r") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSTPRELHA))] + "HAVE_AS_TLS" "addis %0,%1,%2@tprel@ha") -(define_insn "tls_tprel_lo_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=r") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSTPRELLO))] - "HAVE_AS_TLS && !TARGET_64BIT" - "addi %0,%1,%2@tprel@l") - -(define_insn "tls_tprel_lo_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=r") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSTPRELLO))] - "HAVE_AS_TLS && TARGET_64BIT" +(define_insn "tls_tprel_lo_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=r") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSTPRELLO))] + "HAVE_AS_TLS" "addi %0,%1,%2@tprel@l") ;; "b" output constraint here and on tls_tls input to support linker tls ;; optimization. The linker may edit the instructions emitted by a ;; tls_got_tprel/tls_tls pair to addis,addi. -(define_insn "tls_got_tprel_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=b") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSGOTTPREL))] - "HAVE_AS_TLS && !TARGET_64BIT" - "lwz %0,%2@got@tprel(%1)") - -(define_insn "tls_got_tprel_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=b") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSGOTTPREL))] - "HAVE_AS_TLS && TARGET_64BIT" - "ld %0,%2@got@tprel(%1)") - -(define_insn "tls_tls_32" - [(set (match_operand:SI 0 "gpc_reg_operand" "=r") - (unspec:SI [(match_operand:SI 1 "gpc_reg_operand" "b") - (match_operand:SI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSTLS))] - "HAVE_AS_TLS && !TARGET_64BIT" +(define_insn "tls_got_tprel_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=b") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSGOTTPREL))] + "HAVE_AS_TLS" + "l<TLSmode:tls_insn_suffix> %0,%2@got@tprel(%1)") + +(define_insn "tls_tls_<TLSmode:tls_abi_suffix>" + [(set (match_operand:TLSmode 0 "gpc_reg_operand" "=r") + (unspec:TLSmode [(match_operand:TLSmode 1 "gpc_reg_operand" "b") + (match_operand:TLSmode 2 "rs6000_tls_symbol_ref" "")] + UNSPEC_TLSTLS))] + "HAVE_AS_TLS" "add %0,%1,%2@tls") -(define_insn "tls_tls_64" - [(set (match_operand:DI 0 "gpc_reg_operand" "=r") - (unspec:DI [(match_operand:DI 1 "gpc_reg_operand" "b") - (match_operand:DI 2 "rs6000_tls_symbol_ref" "")] - UNSPEC_TLSTLS))] - "HAVE_AS_TLS && TARGET_64BIT" - "add %0,%1,%2@tls") ;; Next come insns related to the calling sequence. ;; diff --git a/gcc/config/s390/constraints.md b/gcc/config/s390/constraints.md index 92fd3254ca5..ad953080ff1 100644 --- a/gcc/config/s390/constraints.md +++ b/gcc/config/s390/constraints.md @@ -1,5 +1,5 @@ ;; Constraints definitions belonging to the gcc backend for IBM S/390. -;; Copyright (C) 2006, 2007 Free Software Foundation, Inc. +;; Copyright (C) 2006, 2007, 2008 Free Software Foundation, Inc. ;; Written by Wolfgang Gellerich, using code and information found in ;; files s390.md, s390.h, and s390.c. ;; @@ -24,10 +24,14 @@ ;; Special constraints for s/390 machine description: ;; ;; a -- Any address register from 1 to 15. +;; b -- Memory operand whose address is a symbol reference or a symbol +;; reference + constant which can be proven to be naturally aligned. ;; c -- Condition code register 33. ;; d -- Any register from 0 to 15. ;; f -- Floating point registers. ;; t -- Access registers 36 and 37. +;; C -- A signed 8-bit constant (-128..127) +;; D -- An unsigned 16-bit constant (0..65535) ;; G -- Const double zero operand ;; I -- An 8-bit constant (0..255). ;; J -- A 12-bit constant (0..4095). @@ -102,6 +106,19 @@ ;; General constraints for constants. ;; +(define_constraint "C" + "@internal + An 8-bit signed immediate constant (-128..127)" + (and (match_code "const_int") + (match_test "ival >= -128 && ival <= 127"))) + + +(define_constraint "D" + "An unsigned 16-bit constant (0..65535)" + (and (match_code "const_int") + (match_test "ival >= 0 && ival <= 65535"))) + + (define_constraint "G" "@internal Const double zero operand" @@ -127,7 +144,6 @@ (match_test "ival >= -32768 && ival <= 32767"))) - (define_constraint "L" "Value appropriate as displacement. (0..4095) for short displacement @@ -355,7 +371,6 @@ (match_test "s390_mem_constraint (\"Q\", op)")) - (define_memory_constraint "R" "Memory reference with index register and short displacement" (match_test "s390_mem_constraint (\"R\", op)")) @@ -371,6 +386,27 @@ (match_test "s390_mem_constraint (\"T\", op)")) +(define_memory_constraint "b" + "Memory reference whose address is a naturally aligned symbol reference." + (match_test "MEM_P (op) + && s390_check_symref_alignment (XEXP (op, 0), + GET_MODE_SIZE (GET_MODE (op)))")) + +(define_memory_constraint "e" + "Matches all memory references available on the current architecture +level. This constraint will never be used and using it in an inline +assembly is *always* a bug since there is no instruction accepting all +those addresses. It just serves as a placeholder for a generic memory +constraint." + (match_test "legitimate_address_p (GET_MODE (op), op, 1)")) + +; This defines 'm' as normal memory constraint. This is only possible +; since the standard memory constraint is re-defined in s390.h using +; the TARGET_MEM_CONSTRAINT macro. +(define_memory_constraint "m" + "Matches the most general memory address for pre-z10 machines." + (match_test "s390_mem_constraint (\"R\", op) + || s390_mem_constraint (\"T\", op)")) (define_memory_constraint "AQ" "@internal @@ -425,7 +461,6 @@ (match_test "s390_mem_constraint (\"BT\", op)")) - (define_address_constraint "U" "Pointer with short displacement" (match_test "s390_mem_constraint (\"U\", op)")) diff --git a/gcc/config/s390/predicates.md b/gcc/config/s390/predicates.md index 50bf0c1eda9..ca5d17556a5 100644 --- a/gcc/config/s390/predicates.md +++ b/gcc/config/s390/predicates.md @@ -1,5 +1,5 @@ ;; Predicate definitions for S/390 and zSeries. -;; Copyright (C) 2005, 2007 Free Software Foundation, Inc. +;; Copyright (C) 2005, 2007, 2008 Free Software Foundation, Inc. ;; Contributed by Hartmut Penner (hpenner@de.ibm.com) and ;; Ulrich Weigand (uweigand@de.ibm.com). ;; @@ -110,7 +110,7 @@ if (GET_CODE (op) == LABEL_REF) return true; if (GET_CODE (op) == SYMBOL_REF) - return ((SYMBOL_REF_FLAGS (op) & SYMBOL_FLAG_ALIGN1) == 0 + return (!SYMBOL_REF_ALIGN1_P (op) && SYMBOL_REF_TLS_MODEL (op) == 0 && (!flag_pic || SYMBOL_REF_LOCAL_P (op))); @@ -172,6 +172,18 @@ return (s390_branch_condition_mask (op) >= 0); }) +(define_predicate "s390_signed_integer_comparison" + (match_code "eq, ne, lt, gt, le, ge") +{ + return (s390_compare_and_branch_condition_mask (op) >= 0); +}) + +(define_predicate "s390_unsigned_integer_comparison" + (match_code "eq, ne, ltu, gtu, leu, geu") +{ + return (s390_compare_and_branch_condition_mask (op) >= 0); +}) + ;; Return nonzero if OP is a valid comparison operator ;; for an ALC condition. diff --git a/gcc/config/s390/s390-protos.h b/gcc/config/s390/s390-protos.h index 7e329f2a565..76f73f9dd2c 100644 --- a/gcc/config/s390/s390-protos.h +++ b/gcc/config/s390/s390-protos.h @@ -1,5 +1,7 @@ /* Definitions of target machine for GNU compiler, for IBM S/390. - Copyright (C) 2000, 2002, 2003, 2004, 2005, 2007 Free Software Foundation, Inc. + Copyright (C) 2000, 2002, 2003, 2004, 2005, 2007, 2008 Free + Software Foundation, Inc. + Contributed by Hartmut Penner (hpenner@de.ibm.com) This file is part of GCC. @@ -27,7 +29,7 @@ extern int s390_mem_constraint (const char *str, rtx op); extern int s390_O_constraint_str (const char c, HOST_WIDE_INT value); extern int s390_N_constraint_str (const char *str, HOST_WIDE_INT value); extern int s390_float_const_zero_p (rtx value); - +extern bool s390_check_symref_alignment (rtx addr, HOST_WIDE_INT alignment); /* Declare functions in s390.c. */ @@ -51,6 +53,7 @@ extern int s390_const_ok_for_constraint_p (HOST_WIDE_INT, int, const char *); extern int s390_const_double_ok_for_constraint_p (rtx, int, const char *); extern int s390_single_part (rtx, enum machine_mode, enum machine_mode, int); extern unsigned HOST_WIDE_INT s390_extract_part (rtx, enum machine_mode, int); +extern bool s390_contiguous_bitmask_p (unsigned HOST_WIDE_INT, int, int *, int *); extern bool s390_split_ok_p (rtx, rtx, enum machine_mode, int); extern bool s390_overlap_p (rtx, rtx, HOST_WIDE_INT); extern bool s390_offset_p (rtx, rtx, rtx); @@ -80,6 +83,8 @@ extern enum reg_class s390_secondary_input_reload_class (enum reg_class, extern enum reg_class s390_secondary_output_reload_class (enum reg_class, enum machine_mode, rtx); +extern void s390_reload_larl_operand (rtx , rtx , rtx); +extern void s390_reload_symref_address (rtx , rtx , rtx , bool); extern void s390_expand_plus_operand (rtx, rtx, rtx); extern void emit_symbolic_move (rtx *); extern void s390_load_address (rtx, rtx); @@ -113,6 +118,7 @@ extern void s390_emit_tpf_eh_return (rtx); extern bool s390_legitimate_address_without_index_p (rtx); extern bool s390_decompose_shift_count (rtx, rtx *, HOST_WIDE_INT *); extern int s390_branch_condition_mask (rtx); +extern int s390_compare_and_branch_condition_mask (rtx); #endif /* RTX_CODE */ diff --git a/gcc/config/s390/s390.c b/gcc/config/s390/s390.c index 95fee4d63c4..5ffbcaef338 100644 --- a/gcc/config/s390/s390.c +++ b/gcc/config/s390/s390.c @@ -1,8 +1,9 @@ /* Subroutines used for code generation on IBM S/390 and zSeries Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, - 2007 Free Software Foundation, Inc. + 2007, 2008 Free Software Foundation, Inc. Contributed by Hartmut Penner (hpenner@de.ibm.com) and - Ulrich Weigand (uweigand@de.ibm.com). + Ulrich Weigand (uweigand@de.ibm.com) and + Andreas Krebbel (Andreas.Krebbel@de.ibm.com). This file is part of GCC. @@ -188,6 +189,38 @@ struct processor_costs z9_109_cost = COSTS_N_INSNS (24), /* DSGR */ }; +static const +struct processor_costs z10_cost = +{ + COSTS_N_INSNS (4), /* M */ + COSTS_N_INSNS (2), /* MGHI */ + COSTS_N_INSNS (2), /* MH */ + COSTS_N_INSNS (2), /* MHI */ + COSTS_N_INSNS (4), /* ML */ + COSTS_N_INSNS (4), /* MR */ + COSTS_N_INSNS (5), /* MS */ + COSTS_N_INSNS (6), /* MSG */ + COSTS_N_INSNS (4), /* MSGF */ + COSTS_N_INSNS (4), /* MSGFR */ + COSTS_N_INSNS (4), /* MSGR */ + COSTS_N_INSNS (4), /* MSR */ + COSTS_N_INSNS (1), /* multiplication in DFmode */ + COSTS_N_INSNS (28), /* MXBR */ + COSTS_N_INSNS (130), /* SQXBR */ + COSTS_N_INSNS (66), /* SQDBR */ + COSTS_N_INSNS (38), /* SQEBR */ + COSTS_N_INSNS (1), /* MADBR */ + COSTS_N_INSNS (1), /* MAEBR */ + COSTS_N_INSNS (60), /* DXBR */ + COSTS_N_INSNS (40), /* DDBR */ + COSTS_N_INSNS (26), /* DEBR */ + COSTS_N_INSNS (30), /* DLGR */ + COSTS_N_INSNS (23), /* DLR */ + COSTS_N_INSNS (23), /* DR */ + COSTS_N_INSNS (24), /* DSGFR */ + COSTS_N_INSNS (24), /* DSGR */ +}; + extern int reload_completed; /* Save information from a "cmpxx" operation until the branch or scc is @@ -1029,6 +1062,41 @@ s390_branch_condition_mask (rtx code) } } + +/* Return branch condition mask to implement a compare and branch + specified by CODE. Return -1 for invalid comparisons. */ + +int +s390_compare_and_branch_condition_mask (rtx code) +{ + const int CC0 = 1 << 3; + const int CC1 = 1 << 2; + const int CC2 = 1 << 1; + + switch (GET_CODE (code)) + { + case EQ: + return CC0; + case NE: + return CC1 | CC2; + case LT: + case LTU: + return CC1; + case GT: + case GTU: + return CC2; + case LE: + case LEU: + return CC0 | CC1; + case GE: + case GEU: + return CC0 | CC2; + default: + gcc_unreachable (); + } + return -1; +} + /* If INV is false, return assembler mnemonic string to implement a branch specified by CODE. If INV is true, return mnemonic for the corresponding inverted branch. */ @@ -1036,6 +1104,8 @@ s390_branch_condition_mask (rtx code) static const char * s390_branch_condition_mnemonic (rtx code, int inv) { + int mask; + static const char *const mnemonic[16] = { NULL, "o", "h", "nle", @@ -1044,7 +1114,13 @@ s390_branch_condition_mnemonic (rtx code, int inv) "le", "nh", "no", NULL }; - int mask = s390_branch_condition_mask (code); + if (GET_CODE (XEXP (code, 0)) == REG + && REGNO (XEXP (code, 0)) == CC_REGNUM + && XEXP (code, 1) == const0_rtx) + mask = s390_branch_condition_mask (code); + else + mask = s390_compare_and_branch_condition_mask (code); + gcc_assert (mask >= 0); if (inv) @@ -1121,6 +1197,67 @@ s390_single_part (rtx op, return part == -1 ? -1 : n_parts - 1 - part; } +/* Return true if IN contains a contiguous bitfield in the lower SIZE + bits and no other bits are set in IN. POS and LENGTH can be used + to obtain the start position and the length of the bitfield. + + POS gives the position of the first bit of the bitfield counting + from the lowest order bit starting with zero. In order to use this + value for S/390 instructions this has to be converted to "bits big + endian" style. */ + +bool +s390_contiguous_bitmask_p (unsigned HOST_WIDE_INT in, int size, + int *pos, int *length) +{ + int tmp_pos = 0; + int tmp_length = 0; + int i; + unsigned HOST_WIDE_INT mask = 1ULL; + bool contiguous = false; + + for (i = 0; i < size; mask <<= 1, i++) + { + if (contiguous) + { + if (mask & in) + tmp_length++; + else + break; + } + else + { + if (mask & in) + { + contiguous = true; + tmp_length++; + } + else + tmp_pos++; + } + } + + if (!tmp_length) + return false; + + /* Calculate a mask for all bits beyond the contiguous bits. */ + mask = (-1LL & ~(((1ULL << (tmp_length + tmp_pos - 1)) << 1) - 1)); + + if (mask & in) + return false; + + if (tmp_length + tmp_pos - 1 > size) + return false; + + if (length) + *length = tmp_length; + + if (pos) + *pos = tmp_pos; + + return true; +} + /* Check whether we can (and want to) split a double-word move in mode MODE from SRC to DST into two single-word moves, moving the subword FIRST_SUBWORD first. */ @@ -1365,6 +1502,8 @@ s390_handle_arch_option (const char *arg, | PF_LONG_DISPLACEMENT | PF_EXTIMM}, {"z9-ec", PROCESSOR_2094_Z9_109, PF_IEEE_FLOAT | PF_ZARCH | PF_LONG_DISPLACEMENT | PF_EXTIMM | PF_DFP }, + {"z10", PROCESSOR_2097_Z10, PF_IEEE_FLOAT | PF_ZARCH + | PF_LONG_DISPLACEMENT | PF_EXTIMM | PF_DFP | PF_Z10}, }; size_t i; @@ -1472,13 +1611,21 @@ override_options (void) } /* Set processor cost function. */ - if (s390_tune == PROCESSOR_2094_Z9_109) - s390_cost = &z9_109_cost; - else if (s390_tune == PROCESSOR_2084_Z990) - s390_cost = &z990_cost; - else - s390_cost = &z900_cost; - + switch (s390_tune) + { + case PROCESSOR_2084_Z990: + s390_cost = &z990_cost; + break; + case PROCESSOR_2094_Z9_109: + s390_cost = &z9_109_cost; + break; + case PROCESSOR_2097_Z10: + s390_cost = &z10_cost; + break; + default: + s390_cost = &z900_cost; + } + if (TARGET_BACKCHAIN && TARGET_PACKED_STACK && TARGET_HARD_FLOAT) error ("-mbackchain -mpacked-stack -mhard-float are not supported " "in combination"); @@ -1992,10 +2139,9 @@ s390_mem_constraint (const char *str, rtx op) return 0; if (GET_CODE (op) != MEM) return 0; - /* Any invalid address here will be fixed up by reload, - so accept it for the most generic constraint. */ - if (s390_decompose_address (XEXP (op, 0), &addr) - && s390_short_displacement (addr.disp)) + if (!s390_decompose_address (XEXP (op, 0), &addr)) + return 0; + if (s390_short_displacement (addr.disp)) return 0; break; @@ -2012,10 +2158,9 @@ s390_mem_constraint (const char *str, rtx op) case 'W': if (!TARGET_LONG_DISPLACEMENT) return 0; - /* Any invalid address here will be fixed up by reload, - so accept it for the most generic constraint. */ - if (s390_decompose_address (op, &addr) - && s390_short_displacement (addr.disp)) + if (!s390_decompose_address (op, &addr)) + return 0; + if (s390_short_displacement (addr.disp)) return 0; break; @@ -2651,6 +2796,132 @@ s390_preferred_reload_class (rtx op, enum reg_class class) return class; } +/* Return true if ADDR is of kind symbol_ref or symbol_ref + const_int + and return these parts in SYMREF and ADDEND. You can pass NULL in + SYMREF and/or ADDEND if you are not interested in these values. */ + +static bool +s390_symref_operand_p (rtx addr, rtx *symref, HOST_WIDE_INT *addend) +{ + HOST_WIDE_INT tmpaddend = 0; + + if (GET_CODE (addr) == CONST) + addr = XEXP (addr, 0); + + if (GET_CODE (addr) == PLUS) + { + if (GET_CODE (XEXP (addr, 0)) == SYMBOL_REF + && CONST_INT_P (XEXP (addr, 1))) + { + tmpaddend = INTVAL (XEXP (addr, 1)); + addr = XEXP (addr, 0); + } + else + return false; + } + else + if (GET_CODE (addr) != SYMBOL_REF) + return false; + + if (symref) + *symref = addr; + if (addend) + *addend = tmpaddend; + + return true; +} + +/* Return true if ADDR is SYMBOL_REF + addend with addend being a + multiple of ALIGNMENT and the SYMBOL_REF being naturally + aligned. */ + +bool +s390_check_symref_alignment (rtx addr, HOST_WIDE_INT alignment) +{ + HOST_WIDE_INT addend; + rtx symref; + + if (!s390_symref_operand_p (addr, &symref, &addend)) + return false; + + return (!SYMBOL_REF_NOT_NATURALLY_ALIGNED_P (symref) + && !(addend & (alignment - 1))); +} + +/* ADDR is moved into REG using larl. If ADDR isn't a valid larl + operand SCRATCH is used to reload the even part of the address and + adding one. */ + +void +s390_reload_larl_operand (rtx reg, rtx addr, rtx scratch) +{ + HOST_WIDE_INT addend; + rtx symref; + + if (!s390_symref_operand_p (addr, &symref, &addend)) + gcc_unreachable (); + + if (!(addend & 1)) + /* Easy case. The addend is even so larl will do fine. */ + emit_move_insn (reg, addr); + else + { + /* We can leave the scratch register untouched if the target + register is a valid base register. */ + if (REGNO (reg) < FIRST_PSEUDO_REGISTER + && REGNO_REG_CLASS (REGNO (reg)) == ADDR_REGS) + scratch = reg; + + gcc_assert (REGNO (scratch) < FIRST_PSEUDO_REGISTER); + gcc_assert (REGNO_REG_CLASS (REGNO (scratch)) == ADDR_REGS); + + if (addend != 1) + emit_move_insn (scratch, + gen_rtx_CONST (Pmode, + gen_rtx_PLUS (Pmode, symref, + GEN_INT (addend - 1)))); + else + emit_move_insn (scratch, symref); + + /* Increment the address using la in order to avoid clobbering cc. */ + emit_move_insn (reg, gen_rtx_PLUS (Pmode, scratch, const1_rtx)); + } +} + +/* Generate what is necessary to move between REG and MEM using + SCRATCH. The direction is given by TOMEM. */ + +void +s390_reload_symref_address (rtx reg, rtx mem, rtx scratch, bool tomem) +{ + /* Reload might have pulled a constant out of the literal pool. + Force it back in. */ + if (CONST_INT_P (mem) || GET_CODE (mem) == CONST_DOUBLE + || GET_CODE (mem) == CONST) + mem = force_const_mem (GET_MODE (reg), mem); + + gcc_assert (MEM_P (mem)); + + /* For a load from memory we can leave the scratch register + untouched if the target register is a valid base register. */ + if (!tomem + && REGNO (reg) < FIRST_PSEUDO_REGISTER + && REGNO_REG_CLASS (REGNO (reg)) == ADDR_REGS + && GET_MODE (reg) == GET_MODE (scratch)) + scratch = reg; + + /* Load address into scratch register. Since we can't have a + secondary reload for a secondary reload we have to cover the case + where larl would need a secondary reload here as well. */ + s390_reload_larl_operand (scratch, XEXP (mem, 0), scratch); + + /* Now we can use a standard load/store to do the move. */ + if (tomem) + emit_move_insn (replace_equiv_address (mem, scratch), reg); + else + emit_move_insn (reg, replace_equiv_address (mem, scratch)); +} + /* Inform reload about cases where moving X with a mode MODE to a register in CLASS requires an extra scratch or immediate register. Return the class needed for the immediate register. */ @@ -2663,6 +2934,60 @@ s390_secondary_reload (bool in_p, rtx x, enum reg_class class, if (reg_classes_intersect_p (CC_REGS, class)) return GENERAL_REGS; + if (TARGET_Z10) + { + /* On z10 several optimizer steps may generate larl operands with + an odd addend. */ + if (in_p + && s390_symref_operand_p (x, NULL, NULL) + && mode == Pmode + && !s390_check_symref_alignment (x, 2)) + sri->icode = ((mode == DImode) ? CODE_FOR_reloaddi_larl_odd_addend_z10 + : CODE_FOR_reloadsi_larl_odd_addend_z10); + + /* On z10 we need a scratch register when moving QI, TI or floating + point mode values from or to a memory location with a SYMBOL_REF + or if the symref addend of a SI or DI move is not aligned to the + width of the access. */ + if (MEM_P (x) + && s390_symref_operand_p (XEXP (x, 0), NULL, NULL) + && (mode == QImode || mode == TImode || FLOAT_MODE_P (mode) + || (!TARGET_64BIT && mode == DImode) + || ((mode == HImode || mode == SImode || mode == DImode) + && (!s390_check_symref_alignment (XEXP (x, 0), + GET_MODE_SIZE (mode)))))) + { +#define __SECONDARY_RELOAD_CASE(M,m) \ + case M##mode: \ + if (TARGET_64BIT) \ + sri->icode = in_p ? CODE_FOR_reload##m##di_toreg_z10 : \ + CODE_FOR_reload##m##di_tomem_z10; \ + else \ + sri->icode = in_p ? CODE_FOR_reload##m##si_toreg_z10 : \ + CODE_FOR_reload##m##si_tomem_z10; \ + break; + + switch (GET_MODE (x)) + { + __SECONDARY_RELOAD_CASE (QI, qi); + __SECONDARY_RELOAD_CASE (HI, hi); + __SECONDARY_RELOAD_CASE (SI, si); + __SECONDARY_RELOAD_CASE (DI, di); + __SECONDARY_RELOAD_CASE (TI, ti); + __SECONDARY_RELOAD_CASE (SF, sf); + __SECONDARY_RELOAD_CASE (DF, df); + __SECONDARY_RELOAD_CASE (TF, tf); + __SECONDARY_RELOAD_CASE (SD, sd); + __SECONDARY_RELOAD_CASE (DD, dd); + __SECONDARY_RELOAD_CASE (TD, td); + + default: + gcc_unreachable (); + } +#undef __SECONDARY_RELOAD_CASE + } + } + /* We need a scratch register when loading a PLUS expression which is not a legitimate operand of the LOAD ADDRESS instruction. */ if (in_p && s390_plus_operand (x, mode)) @@ -2769,10 +3094,16 @@ s390_expand_plus_operand (rtx target, rtx src, STRICT specifies whether strict register checking applies. */ bool -legitimate_address_p (enum machine_mode mode ATTRIBUTE_UNUSED, - rtx addr, int strict) +legitimate_address_p (enum machine_mode mode, rtx addr, int strict) { struct s390_address ad; + + if (TARGET_Z10 + && larl_operand (addr, VOIDmode) + && (mode == VOIDmode + || s390_check_symref_alignment (addr, GET_MODE_SIZE (mode)))) + return true; + if (!s390_decompose_address (addr, &ad)) return false; @@ -4010,14 +4341,31 @@ s390_expand_addcc (enum rtx_code cmp_code, rtx cmp_op0, rtx cmp_op1, return false; } -/* Expand code for the insv template. Return true if successful, false else. */ +/* Expand code for the insv template. Return true if successful. */ -bool +bool s390_expand_insv (rtx dest, rtx op1, rtx op2, rtx src) { int bitsize = INTVAL (op1); int bitpos = INTVAL (op2); + /* On z10 we can use the risbg instruction to implement insv. */ + if (TARGET_Z10 + && ((GET_MODE (dest) == DImode && GET_MODE (src) == DImode) + || (GET_MODE (dest) == SImode && GET_MODE (src) == SImode))) + { + rtx op; + rtx clobber; + + op = gen_rtx_SET (GET_MODE(src), + gen_rtx_ZERO_EXTRACT (GET_MODE (dest), dest, op1, op2), + src); + clobber = gen_rtx_CLOBBER (VOIDmode, gen_rtx_REG (CCmode, CC_REGNUM)); + emit_insn (gen_rtx_PARALLEL (VOIDmode, gen_rtvec (2, op, clobber))); + + return true; + } + /* We need byte alignment. */ if (bitsize % BITS_PER_UNIT) return false; @@ -4554,6 +4902,13 @@ print_operand_address (FILE *file, rtx addr) { struct s390_address ad; + if (s390_symref_operand_p (addr, NULL, NULL)) + { + gcc_assert (TARGET_Z10); + output_addr_const (file, addr); + return; + } + if (!s390_decompose_address (addr, &ad) || (ad.base && !REGNO_OK_FOR_BASE_P (REGNO (ad.base))) || (ad.indx && !REGNO_OK_FOR_INDEX_P (REGNO (ad.indx)))) @@ -4587,6 +4942,7 @@ print_operand_address (FILE *file, rtx addr) 'Y': print shift count operand. 'b': print integer X as if it's an unsigned byte. + 'c': print integer X as if it's an signed byte. 'x': print integer X as if it's an unsigned halfword. 'h': print integer X as if it's a signed halfword. 'i': print the first nonzero HImode part of X. @@ -4732,6 +5088,8 @@ print_operand (FILE *file, rtx x, int code) case CONST_INT: if (code == 'b') fprintf (file, HOST_WIDE_INT_PRINT_DEC, INTVAL (x) & 0xff); + else if (code == 'c') + fprintf (file, HOST_WIDE_INT_PRINT_DEC, ((INTVAL (x) & 0xff) ^ 0x80) - 0x80); else if (code == 'x') fprintf (file, HOST_WIDE_INT_PRINT_DEC, INTVAL (x) & 0xffff); else if (code == 'h') @@ -4930,10 +5288,16 @@ s390_adjust_priority (rtx insn ATTRIBUTE_UNUSED, int priority) static int s390_issue_rate (void) { - if (s390_tune == PROCESSOR_2084_Z990 - || s390_tune == PROCESSOR_2094_Z9_109) - return 3; - return 1; + switch (s390_tune) + { + case PROCESSOR_2084_Z990: + case PROCESSOR_2094_Z9_109: + return 3; + case PROCESSOR_2097_Z10: + return 2; + default: + return 1; + } } static int @@ -8515,11 +8879,30 @@ s390_encode_section_info (tree decl, rtx rtl, int first) { default_encode_section_info (decl, rtl, first); - /* If a variable has a forced alignment to < 2 bytes, mark it with - SYMBOL_FLAG_ALIGN1 to prevent it from being used as LARL operand. */ - if (TREE_CODE (decl) == VAR_DECL - && DECL_USER_ALIGN (decl) && DECL_ALIGN (decl) < 16) - SYMBOL_REF_FLAGS (XEXP (rtl, 0)) |= SYMBOL_FLAG_ALIGN1; + if (TREE_CODE (decl) == VAR_DECL) + { + /* If a variable has a forced alignment to < 2 bytes, mark it + with SYMBOL_FLAG_ALIGN1 to prevent it from being used as LARL + operand. */ + if (DECL_USER_ALIGN (decl) && DECL_ALIGN (decl) < 16) + SYMBOL_REF_FLAGS (XEXP (rtl, 0)) |= SYMBOL_FLAG_ALIGN1; + if (!DECL_SIZE (decl) + || !DECL_ALIGN (decl) + || !host_integerp (DECL_SIZE (decl), 0) + || (DECL_ALIGN (decl) <= 64 + && DECL_ALIGN (decl) != tree_low_cst (DECL_SIZE (decl), 0))) + SYMBOL_REF_FLAGS (XEXP (rtl, 0)) |= SYMBOL_FLAG_NOT_NATURALLY_ALIGNED; + } + + /* Literal pool references don't have a decl so they are handled + differently here. We rely on the information in the MEM_ALIGN + entry to decide upon natural alignment. */ + if (MEM_P (rtl) + && GET_CODE (XEXP (rtl, 0)) == SYMBOL_REF + && TREE_CONSTANT_POOL_ADDRESS_P (XEXP (rtl, 0)) + && (MEM_ALIGN (rtl) == 0 + || MEM_ALIGN (rtl) < GET_MODE_BITSIZE (GET_MODE (rtl)))) + SYMBOL_REF_FLAGS (XEXP (rtl, 0)) |= SYMBOL_FLAG_NOT_NATURALLY_ALIGNED; } /* Output thunk to FILE that implements a C++ virtual function call (with diff --git a/gcc/config/s390/s390.h b/gcc/config/s390/s390.h index bec01200677..79286d5a9bc 100644 --- a/gcc/config/s390/s390.h +++ b/gcc/config/s390/s390.h @@ -1,8 +1,9 @@ /* Definitions of target machine for GNU compiler, for IBM S/390 Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, - 2007 Free Software Foundation, Inc. + 2007, 2008 Free Software Foundation, Inc. Contributed by Hartmut Penner (hpenner@de.ibm.com) and Ulrich Weigand (uweigand@de.ibm.com). + Andreas Krebbel (Andreas.Krebbel@de.ibm.com) This file is part of GCC. @@ -40,6 +41,7 @@ enum processor_type PROCESSOR_2064_Z900, PROCESSOR_2084_Z990, PROCESSOR_2094_Z9_109, + PROCESSOR_2097_Z10, PROCESSOR_max }; @@ -51,7 +53,8 @@ enum processor_flags PF_ZARCH = 2, PF_LONG_DISPLACEMENT = 4, PF_EXTIMM = 8, - PF_DFP = 16 + PF_DFP = 16, + PF_Z10 = 32 }; extern enum processor_type s390_tune; @@ -60,6 +63,10 @@ extern enum processor_flags s390_tune_flags; extern enum processor_type s390_arch; extern enum processor_flags s390_arch_flags; +/* These flags indicate that the generated code should run on a cpu + providing the respective hardware facility regardless of the + current cpu mode (ESA or z/Architecture). */ + #define TARGET_CPU_IEEE_FLOAT \ (s390_arch_flags & PF_IEEE_FLOAT) #define TARGET_CPU_ZARCH \ @@ -70,6 +77,12 @@ extern enum processor_flags s390_arch_flags; (s390_arch_flags & PF_EXTIMM) #define TARGET_CPU_DFP \ (s390_arch_flags & PF_DFP) +#define TARGET_CPU_Z10 \ + (s390_arch_flags & PF_Z10) + +/* These flags indicate that the generated code should run on a cpu + providing the respective hardware facility when run in + z/Architecture mode. */ #define TARGET_LONG_DISPLACEMENT \ (TARGET_ZARCH && TARGET_CPU_LONG_DISPLACEMENT) @@ -77,6 +90,8 @@ extern enum processor_flags s390_arch_flags; (TARGET_ZARCH && TARGET_CPU_EXTIMM) #define TARGET_DFP \ (TARGET_ZARCH && TARGET_CPU_DFP) +#define TARGET_Z10 \ + (TARGET_ZARCH && TARGET_CPU_Z10) /* Run-time target specification. */ @@ -485,11 +500,14 @@ extern const enum reg_class regclass_map[FIRST_PSEUDO_REGISTER]; #define PREFERRED_RELOAD_CLASS(X, CLASS) \ s390_preferred_reload_class ((X), (CLASS)) -/* We need secondary memory to move data between GPRs and FPRs. */ +/* We need secondary memory to move data between GPRs and FPRs. With + DFP the ldgr lgdr instructions are available. But these + instructions do not handle GPR pairs so it is not possible for 31 + bit. */ #define SECONDARY_MEMORY_NEEDED(CLASS1, CLASS2, MODE) \ ((CLASS1) != (CLASS2) \ && ((CLASS1) == FP_REGS || (CLASS2) == FP_REGS) \ - && (!TARGET_DFP || GET_MODE_SIZE (MODE) != 8)) + && (!TARGET_DFP || !TARGET_64BIT || GET_MODE_SIZE (MODE) != 8)) /* Get_secondary_mem widens its argument to BITS_PER_WORD which loses on 64bit because the movsi and movsf patterns don't handle r/f moves. */ @@ -687,6 +705,13 @@ CUMULATIVE_ARGS; /* Maximum number of registers that can appear in a valid memory address. */ #define MAX_REGS_PER_ADDRESS 2 +/* This definition replaces the formerly used 'm' constraint with a +different constraint letter in order to avoid changing semantics of +the 'm' constraint when accepting new address formats in +legitimate_address_p. The constraint letter defined here must not be +used in insn definitions or inline assemblies. */ +#define TARGET_MEM_CONSTRAINT 'e' + /* S/390 has no mode dependent addresses. */ #define GO_IF_MODE_DEPENDENT_ADDRESS(ADDR, LABEL) @@ -953,7 +978,12 @@ do { \ #define CLZ_DEFINED_VALUE_AT_ZERO(MODE, VALUE) ((VALUE) = 64, 1) /* Machine-specific symbol_ref flags. */ -#define SYMBOL_FLAG_ALIGN1 (SYMBOL_FLAG_MACH_DEP << 0) +#define SYMBOL_FLAG_ALIGN1 (SYMBOL_FLAG_MACH_DEP << 0) +#define SYMBOL_REF_ALIGN1_P(X) \ + ((SYMBOL_REF_FLAGS (X) & SYMBOL_FLAG_ALIGN1)) +#define SYMBOL_FLAG_NOT_NATURALLY_ALIGNED (SYMBOL_FLAG_MACH_DEP << 1) +#define SYMBOL_REF_NOT_NATURALLY_ALIGNED_P(X) \ + ((SYMBOL_REF_FLAGS (X) & SYMBOL_FLAG_NOT_NATURALLY_ALIGNED)) /* Check whether integer displacement is in range. */ #define DISP_IN_RANGE(d) \ diff --git a/gcc/config/s390/s390.md b/gcc/config/s390/s390.md index 5ffa72884a0..f97e756518f 100644 --- a/gcc/config/s390/s390.md +++ b/gcc/config/s390/s390.md @@ -1,8 +1,9 @@ ;;- Machine description for GNU compiler -- S/390 / zSeries version. -;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 +;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 ;; Free Software Foundation, Inc. ;; Contributed by Hartmut Penner (hpenner@de.ibm.com) and -;; Ulrich Weigand (uweigand@de.ibm.com). +;; Ulrich Weigand (uweigand@de.ibm.com) and +;; Andreas Krebbel (Andreas.Krebbel@de.ibm.com) ;; This file is part of GCC. @@ -38,6 +39,7 @@ ;; %Y: print shift count operand. ;; ;; %b: print integer X as if it's an unsigned byte. +;; %c: print integer X as if it's an signed byte. ;; %x: print integer X as if it's an unsigned halfword. ;; %h: print integer X as if it's a signed halfword. ;; %i: print the first nonzero HImode part of X. @@ -189,7 +191,7 @@ ;; Used to determine defaults for length and other attribute values. (define_attr "op_type" - "NN,E,RR,RRE,RX,RS,RSI,RI,SI,S,SS,SSE,RXE,RSE,RIL,RIE,RXY,RSY,SIY,RRF,RRR" + "NN,E,RR,RRE,RX,RS,RSI,RI,SI,S,SS,SSE,RXE,RSE,RIL,RIE,RXY,RSY,SIY,RRF,RRR,SIL,RRS,RIS" (const_string "NN")) ;; Instruction type attribute used for scheduling. @@ -218,8 +220,8 @@ ;; Length in bytes. (define_attr "length" "" - (cond [(eq_attr "op_type" "E,RR") (const_int 2) - (eq_attr "op_type" "RX,RI,RRE,RS,RSI,S,SI") (const_int 4)] + (cond [(eq_attr "op_type" "E,RR") (const_int 2) + (eq_attr "op_type" "RX,RI,RRE,RS,RSI,S,SI,RRF,RRR") (const_int 4)] (const_int 6))) @@ -228,9 +230,41 @@ ;; distinguish between g5 and g6, but there are differences between the two ;; CPUs could in theory be modeled. -(define_attr "cpu" "g5,g6,z900,z990,z9_109" +(define_attr "cpu" "g5,g6,z900,z990,z9_109,z10" (const (symbol_ref "s390_tune"))) +(define_attr "cpu_facility" "standard,ieee,zarch,longdisp,extimm,dfp,z10" + (const_string "standard")) + +(define_attr "enabled" "" + (cond [(eq_attr "cpu_facility" "standard") + (const_int 1) + + (and (eq_attr "cpu_facility" "ieee") + (ne (symbol_ref "TARGET_CPU_IEEE_FLOAT") (const_int 0))) + (const_int 1) + + (and (eq_attr "cpu_facility" "zarch") + (ne (symbol_ref "TARGET_ZARCH") (const_int 0))) + (const_int 1) + + (and (eq_attr "cpu_facility" "longdisp") + (ne (symbol_ref "TARGET_LONG_DISPLACEMENT") (const_int 0))) + (const_int 1) + + (and (eq_attr "cpu_facility" "extimm") + (ne (symbol_ref "TARGET_EXTIMM") (const_int 0))) + (const_int 1) + + (and (eq_attr "cpu_facility" "dfp") + (ne (symbol_ref "TARGET_DFP") (const_int 0))) + (const_int 1) + + (and (eq_attr "cpu_facility" "z10") + (ne (symbol_ref "TARGET_Z10") (const_int 0))) + (const_int 1)] + (const_int 0))) + ;; Pipeline description for z900. For lack of anything better, ;; this description is also used for the g5 and g6. (include "2064.md") @@ -254,6 +288,7 @@ (define_mode_iterator FP_ALL [TF DF SF (TD "TARGET_HARD_DFP") (DD "TARGET_HARD_DFP") (SD "TARGET_HARD_DFP")]) (define_mode_iterator FP [TF DF SF (TD "TARGET_HARD_DFP") (DD "TARGET_HARD_DFP")]) +(define_mode_iterator FPALL [TF DF SF TD DD SD]) (define_mode_iterator BFP [TF DF SF]) (define_mode_iterator DFP [TD DD]) (define_mode_iterator DFP_ALL [TD DD SD]) @@ -283,6 +318,7 @@ ;; This mode iterator allows the integer patterns to be defined from the ;; same template. (define_mode_iterator INT [(DI "TARGET_64BIT") SI HI QI]) +(define_mode_iterator INTALL [TI DI SI HI QI]) ;; This iterator allows to unify all 'bCOND' expander patterns. (define_code_iterator COMPARE [eq ne gt gtu lt ltu ge geu le leu unordered @@ -425,7 +461,6 @@ ;; Maximum unsigned integer that fits in MODE. (define_mode_attr max_uint [(HI "65535") (QI "255")]) - ;; ;;- Compare instructions. ;; @@ -511,19 +546,24 @@ (define_insn "*tstdi_sign" [(set (reg CC_REGNUM) - (compare (ashiftrt:DI (ashift:DI (subreg:DI (match_operand:SI 0 "register_operand" "d") 0) - (const_int 32)) (const_int 32)) - (match_operand:DI 1 "const0_operand" ""))) - (set (match_operand:DI 2 "register_operand" "=d") + (compare + (ashiftrt:DI + (ashift:DI + (subreg:DI (match_operand:SI 0 "nonimmediate_operand" "d,RT") 0) + (const_int 32)) (const_int 32)) + (match_operand:DI 1 "const0_operand" ""))) + (set (match_operand:DI 2 "register_operand" "=d,d") (sign_extend:DI (match_dup 0)))] "s390_match_ccmode(insn, CCSmode) && TARGET_64BIT" - "ltgfr\t%2,%0" - [(set_attr "op_type" "RRE")]) + "ltgfr\t%2,%0 + ltgf\t%2,%0" + [(set_attr "op_type" "RRE,RXY") + (set_attr "cpu_facility" "*,z10")]) ; ltr, lt, ltgr, ltg (define_insn "*tst<mode>_extimm" [(set (reg CC_REGNUM) - (compare (match_operand:GPR 0 "nonimmediate_operand" "d,m") + (compare (match_operand:GPR 0 "nonimmediate_operand" "d,RT") (match_operand:GPR 1 "const0_operand" ""))) (set (match_operand:GPR 2 "register_operand" "=d,d") (match_dup 0))] @@ -536,7 +576,7 @@ ; ltr, lt, ltgr, ltg (define_insn "*tst<mode>_cconly_extimm" [(set (reg CC_REGNUM) - (compare (match_operand:GPR 0 "nonimmediate_operand" "d,m") + (compare (match_operand:GPR 0 "nonimmediate_operand" "d,RT") (match_operand:GPR 1 "const0_operand" ""))) (clobber (match_scratch:GPR 2 "=X,d"))] "s390_match_ccmode(insn, CCSmode) && TARGET_EXTIMM" @@ -665,7 +705,7 @@ (define_insn "*cmpdi_cct" [(set (reg CC_REGNUM) (compare (match_operand:DI 0 "nonimmediate_operand" "%d,d,d,d,Q") - (match_operand:DI 1 "general_operand" "d,K,Os,m,BQ")))] + (match_operand:DI 1 "general_operand" "d,K,Os,RT,BQ")))] "s390_match_ccmode (insn, CCTmode) && TARGET_64BIT" "@ cgr\t%0,%1 @@ -694,90 +734,159 @@ (define_insn "*cmpdi_ccs_sign" [(set (reg CC_REGNUM) - (compare (sign_extend:DI (match_operand:SI 1 "nonimmediate_operand" "d,m")) - (match_operand:DI 0 "register_operand" "d,d")))] + (compare (sign_extend:DI (match_operand:SI 1 "nonimmediate_operand" + "d,RT,b")) + (match_operand:DI 0 "register_operand" "d, d,d")))] "s390_match_ccmode(insn, CCSRmode) && TARGET_64BIT" "@ cgfr\t%0,%1 - cgf\t%0,%1" - [(set_attr "op_type" "RRE,RXY")]) + cgf\t%0,%1 + cgfrl\t%0,%1" + [(set_attr "op_type" "RRE,RXY,RIL") + (set_attr "cpu_facility" "*,*,z10") + (set_attr "type" "*,*,larl")]) (define_insn "*cmpsi_ccs_sign" [(set (reg CC_REGNUM) - (compare (sign_extend:SI (match_operand:HI 1 "memory_operand" "R,T")) - (match_operand:SI 0 "register_operand" "d,d")))] + (compare (sign_extend:SI (match_operand:HI 1 "memory_operand" "R,T,b")) + (match_operand:SI 0 "register_operand" "d,d,d")))] "s390_match_ccmode(insn, CCSRmode)" "@ ch\t%0,%1 - chy\t%0,%1" - [(set_attr "op_type" "RX,RXY")]) + chy\t%0,%1 + chrl\t%0,%1" + [(set_attr "op_type" "RX,RXY,RIL") + (set_attr "cpu_facility" "*,*,z10") + (set_attr "type" "*,*,larl")]) -; cr, chi, cfi, c, cy, cgr, cghi, cgfi, cg +(define_insn "*cmphi_ccs_z10" + [(set (reg CC_REGNUM) + (compare (match_operand:HI 0 "s_operand" "Q") + (match_operand:HI 1 "immediate_operand" "K")))] + "s390_match_ccmode(insn, CCSmode) && TARGET_Z10" + "chhsi\t%0,%1" + [(set_attr "op_type" "SIL")]) + +(define_insn "*cmpdi_ccs_signhi_rl" + [(set (reg CC_REGNUM) + (compare (sign_extend:DI (match_operand:HI 1 "memory_operand" "RT,b")) + (match_operand:GPR 0 "register_operand" "d,d")))] + "s390_match_ccmode(insn, CCSRmode) && TARGET_Z10" + "@ + cgh\t%0,%1 + cghrl\t%0,%1" + [(set_attr "op_type" "RXY,RIL") + (set_attr "type" "*,larl")]) + +; cr, chi, cfi, c, cy, cgr, cghi, cgfi, cg, chsi, cghsi, crl, cgrl (define_insn "*cmp<mode>_ccs" [(set (reg CC_REGNUM) - (compare (match_operand:GPR 0 "register_operand" "d,d,d,d,d") - (match_operand:GPR 1 "general_operand" "d,K,Os,R,T")))] + (compare (match_operand:GPR 0 "nonimmediate_operand" + "d,d,Q, d,d,d,d") + (match_operand:GPR 1 "general_operand" + "d,K,K,Os,R,T,b")))] "s390_match_ccmode(insn, CCSmode)" "@ c<g>r\t%0,%1 c<g>hi\t%0,%h1 + c<g>hsi\t%0,%h1 c<g>fi\t%0,%1 c<g>\t%0,%1 - c<y>\t%0,%1" - [(set_attr "op_type" "RR<E>,RI,RIL,RX<Y>,RXY")]) + c<y>\t%0,%1 + c<g>rl\t%0,%1" + [(set_attr "op_type" "RR<E>,RI,SIL,RIL,RX<Y>,RXY,RIL") + (set_attr "cpu_facility" "*,*,z10,extimm,*,*,z10") + (set_attr "type" "*,*,*,*,*,*,larl")]) ; Compare (unsigned) instructions +(define_insn "*cmpsi_ccu_zerohi_rlsi" + [(set (reg CC_REGNUM) + (compare (zero_extend:SI (mem:HI (match_operand:SI 1 + "larl_operand" "X"))) + (match_operand:SI 0 "register_operand" "d")))] + "s390_match_ccmode(insn, CCURmode) && TARGET_Z10" + "clhrl\t%0,%1" + [(set_attr "op_type" "RIL") + (set_attr "type" "larl")]) + +; clhrl, clghrl +(define_insn "*cmp<GPR:mode>_ccu_zerohi_rldi" + [(set (reg CC_REGNUM) + (compare (zero_extend:GPR (mem:HI (match_operand:DI 1 + "larl_operand" "X"))) + (match_operand:GPR 0 "register_operand" "d")))] + "s390_match_ccmode(insn, CCURmode) && TARGET_Z10" + "cl<g>hrl\t%0,%1" + [(set_attr "op_type" "RIL") + (set_attr "type" "larl")]) + (define_insn "*cmpdi_ccu_zero" [(set (reg CC_REGNUM) - (compare (zero_extend:DI (match_operand:SI 1 "nonimmediate_operand" "d,m")) - (match_operand:DI 0 "register_operand" "d,d")))] + (compare (zero_extend:DI (match_operand:SI 1 "nonimmediate_operand" + "d,RT,b")) + (match_operand:DI 0 "register_operand" "d, d,d")))] "s390_match_ccmode (insn, CCURmode) && TARGET_64BIT" "@ clgfr\t%0,%1 - clgf\t%0,%1" - [(set_attr "op_type" "RRE,RXY")]) + clgf\t%0,%1 + clgfrl\t%0,%1" + [(set_attr "op_type" "RRE,RXY,RIL") + (set_attr "cpu_facility" "*,*,z10") + (set_attr "type" "*,*,larl")]) (define_insn "*cmpdi_ccu" [(set (reg CC_REGNUM) - (compare (match_operand:DI 0 "nonimmediate_operand" "d,d,d,Q,BQ") - (match_operand:DI 1 "general_operand" "d,Op,m,BQ,Q")))] + (compare (match_operand:DI 0 "nonimmediate_operand" + "d, d,d,Q, d, Q,BQ") + (match_operand:DI 1 "general_operand" + "d,Op,b,D,RT,BQ,Q")))] "s390_match_ccmode (insn, CCUmode) && TARGET_64BIT" "@ clgr\t%0,%1 clgfi\t%0,%1 + clgrl\t%0,%1 + clghsi\t%0,%x1 clg\t%0,%1 # #" - [(set_attr "op_type" "RRE,RIL,RXY,SS,SS")]) + [(set_attr "op_type" "RRE,RIL,RIL,SIL,RXY,SS,SS") + (set_attr "cpu_facility" "*,extimm,z10,z10,*,*,*") + (set_attr "type" "*,*,larl,*,*,*,*")]) (define_insn "*cmpsi_ccu" [(set (reg CC_REGNUM) - (compare (match_operand:SI 0 "nonimmediate_operand" "d,d,d,d,Q,BQ") - (match_operand:SI 1 "general_operand" "d,Os,R,T,BQ,Q")))] + (compare (match_operand:SI 0 "nonimmediate_operand" "d, d,d,Q,d,d, Q,BQ") + (match_operand:SI 1 "general_operand" "d,Os,b,D,R,T,BQ, Q")))] "s390_match_ccmode (insn, CCUmode)" "@ clr\t%0,%1 clfi\t%0,%o1 + clrl\t%0,%1 + clfhsi\t%0,%x1 cl\t%0,%1 cly\t%0,%1 # #" - [(set_attr "op_type" "RR,RIL,RX,RXY,SS,SS")]) + [(set_attr "op_type" "RR,RIL,RIL,SIL,RX,RXY,SS,SS") + (set_attr "cpu_facility" "*,extimm,z10,z10,*,*,*,*") + (set_attr "type" "*,*,larl,*,*,*,*,*")]) (define_insn "*cmphi_ccu" [(set (reg CC_REGNUM) - (compare (match_operand:HI 0 "nonimmediate_operand" "d,d,Q,BQ") - (match_operand:HI 1 "general_operand" "Q,S,BQ,Q")))] + (compare (match_operand:HI 0 "nonimmediate_operand" "d,d,Q,Q,BQ") + (match_operand:HI 1 "general_operand" "Q,S,D,BQ,Q")))] "s390_match_ccmode (insn, CCUmode) && !register_operand (operands[1], HImode)" "@ clm\t%0,3,%S1 clmy\t%0,3,%S1 + clhhsi\t%0,%1 # #" - [(set_attr "op_type" "RS,RSY,SS,SS")]) + [(set_attr "op_type" "RS,RSY,SIL,SS,SS") + (set_attr "cpu_facility" "*,*,z10,*,*")]) (define_insn "*cmpqi_ccu" [(set (reg CC_REGNUM) @@ -853,6 +962,59 @@ [(set_attr "op_type" "RRE,RXE") (set_attr "type" "fsimp<bfp>")]) + +; Compare and Branch instructions + +; cij, cgij, crj, cgrj, cfi, cgfi, cr, cgr +(define_insn "*cmp_and_br_signed_<mode>" + [(set (pc) + (if_then_else (match_operator 0 "s390_signed_integer_comparison" + [(match_operand:GPR 1 "register_operand" "d,d") + (match_operand:GPR 2 "nonmemory_operand" "d,C")]) + (label_ref (match_operand 3 "" "")) + (pc))) + (clobber (reg:CC CC_REGNUM))] + "TARGET_Z10" +{ + if (get_attr_length (insn) == 6) + return which_alternative ? + "c<g>ij%C0\t%1,%c2,%l3" : "c<g>rj%C0\t%1,%2,%l3"; + else + return which_alternative ? + "c<g>fi\t%1,%c2\;jg%C0\t%l3" : "c<g>r\t%1,%2\;jg%C0\t%l3"; +} + [(set_attr "op_type" "RIE") + (set_attr "type" "branch") + (set (attr "length") + (if_then_else (lt (abs (minus (pc) (match_dup 3))) (const_int 60000)) + (const_int 6) (const_int 12)))]) ; 8 byte for cr/jg + ; 10 byte for cgr/jg + +; clij, clgij, clrj, clgrj, clfi, clgfi, clr, clgr +(define_insn "*cmp_and_br_unsigned_<mode>" + [(set (pc) + (if_then_else (match_operator 0 "s390_unsigned_integer_comparison" + [(match_operand:GPR 1 "register_operand" "d,d") + (match_operand:GPR 2 "nonmemory_operand" "d,I")]) + (label_ref (match_operand 3 "" "")) + (pc))) + (clobber (reg:CC CC_REGNUM))] + "TARGET_Z10" +{ + if (get_attr_length (insn) == 6) + return which_alternative ? + "cl<g>ij%C0\t%1,%b2,%l3" : "cl<g>rj%C0\t%1,%2,%l3"; + else + return which_alternative ? + "cl<g>fi\t%1,%b2\;jg%C0\t%l3" : "cl<g>r\t%1,%2\;jg%C0\t%l3"; +} + [(set_attr "op_type" "RIE") + (set_attr "type" "branch") + (set (attr "length") + (if_then_else (lt (abs (minus (pc) (match_dup 3))) (const_int 60000)) + (const_int 6) (const_int 12)))]) ; 8 byte for clr/jg + ; 10 byte for clgr/jg + ;; ;;- Move instructions. ;; @@ -863,7 +1025,7 @@ (define_insn "movti" [(set (match_operand:TI 0 "nonimmediate_operand" "=d,QS,d,o,Q") - (match_operand:TI 1 "general_operand" "QS,d,dPm,d,Q"))] + (match_operand:TI 1 "general_operand" "QS,d,dPRT,d,Q"))] "TARGET_64BIT" "@ lmg\t%0,%N0,%S1 @@ -919,6 +1081,60 @@ ; Patterns used for secondary reloads ; +; z10 provides move instructions accepting larl memory operands. +; Unfortunately there is no such variant for QI, TI and FP mode moves. +; These patterns are also used for unaligned SI and DI accesses. + +(define_expand "reload<INTALL:mode><P:mode>_tomem_z10" + [(parallel [(match_operand:INTALL 0 "memory_operand" "") + (match_operand:INTALL 1 "register_operand" "=d") + (match_operand:P 2 "register_operand" "=&a")])] + "TARGET_Z10" +{ + s390_reload_symref_address (operands[1], operands[0], operands[2], 1); + DONE; +}) + +(define_expand "reload<INTALL:mode><P:mode>_toreg_z10" + [(parallel [(match_operand:INTALL 0 "register_operand" "=d") + (match_operand:INTALL 1 "memory_operand" "") + (match_operand:P 2 "register_operand" "=a")])] + "TARGET_Z10" +{ + s390_reload_symref_address (operands[0], operands[1], operands[2], 0); + DONE; +}) + +(define_expand "reload<FPALL:mode><P:mode>_tomem_z10" + [(parallel [(match_operand:FPALL 0 "memory_operand" "") + (match_operand:FPALL 1 "register_operand" "=d") + (match_operand:P 2 "register_operand" "=&a")])] + "TARGET_Z10" +{ + s390_reload_symref_address (operands[1], operands[0], operands[2], 1); + DONE; +}) + +(define_expand "reload<FPALL:mode><P:mode>_toreg_z10" + [(parallel [(match_operand:FPALL 0 "register_operand" "=d") + (match_operand:FPALL 1 "memory_operand" "") + (match_operand:P 2 "register_operand" "=a")])] + "TARGET_Z10" +{ + s390_reload_symref_address (operands[0], operands[1], operands[2], 0); + DONE; +}) + +(define_expand "reload<P:mode>_larl_odd_addend_z10" + [(parallel [(match_operand:P 0 "register_operand" "=d") + (match_operand:P 1 "larl_operand" "") + (match_operand:P 2 "register_operand" "=a")])] + "TARGET_Z10" +{ + s390_reload_larl_operand (operands[0], operands[1], operands[2]); + DONE; +}) + ; Handles loading a PLUS (load address) expression (define_expand "reload<mode>_plus" @@ -986,14 +1202,14 @@ [(set_attr "op_type" "RIL") (set_attr "type" "larl")]) -(define_insn "*movdi_64dfp" +(define_insn "*movdi_64" [(set (match_operand:DI 0 "nonimmediate_operand" - "=d,d,d,d,d,d,d,d,f,d,d,d,d, - m,!*f,!*f,!*f,!R,!T,d,t,Q,t,?Q") + "=d,d,d,d,d,d,d,d,f,d,d,d,d,d, + RT,!*f,!*f,!*f,!R,!T,b,Q,d,t,Q,t,?Q") (match_operand:DI 1 "general_operand" - "K,N0HD0,N1HD0,N2HD0,N3HD0,Os,N0SD0,N1SD0,d,f,L,d,m, - d,*f,R,T,*f,*f,t,d,t,Q,?Q"))] - "TARGET_64BIT && TARGET_DFP" + "K,N0HD0,N1HD0,N2HD0,N3HD0,Os,N0SD0,N1SD0,d,f,L,b,d,RT, + d,*f,R,T,*f,*f,d,K,t,d,t,Q,?Q"))] + "TARGET_64BIT" "@ lghi\t%0,%h1 llihh\t%0,%i1 @@ -1006,6 +1222,7 @@ ldgr\t%0,%1 lgdr\t%0,%1 lay\t%0,%a1 + lgrl\t%0,%1 lgr\t%0,%1 lg\t%0,%1 stg\t%1,%0 @@ -1014,80 +1231,21 @@ ldy\t%0,%1 std\t%1,%0 stdy\t%1,%0 + stgrl\t%1,%0 + mvghi\t%0,%1 # # stam\t%1,%N1,%S0 lam\t%0,%N0,%S1 #" - [(set_attr "op_type" "RI,RI,RI,RI,RI,RIL,RIL,RIL,RRE,RRE,RXY,RRE,RXY,RXY, - RR,RX,RXY,RX,RXY,*,*,RS,RS,SS") - (set_attr "type" "*,*,*,*,*,*,*,*,floaddf,floaddf,la,lr,load,store, - floaddf,floaddf,floaddf,fstoredf,fstoredf,*,*,*,*,*")]) - -(define_insn "*movdi_64extimm" - [(set (match_operand:DI 0 "nonimmediate_operand" - "=d,d,d,d,d,d,d,d,d,d,d,m,!*f,!*f,!*f,!R,!T,d,t,Q,t,?Q") - (match_operand:DI 1 "general_operand" - "K,N0HD0,N1HD0,N2HD0,N3HD0,Os,N0SD0,N1SD0,L,d,m,d,*f,R,T,*f,*f,t,d,t,Q,?Q"))] - "TARGET_64BIT && TARGET_EXTIMM" - "@ - lghi\t%0,%h1 - llihh\t%0,%i1 - llihl\t%0,%i1 - llilh\t%0,%i1 - llill\t%0,%i1 - lgfi\t%0,%1 - llihf\t%0,%k1 - llilf\t%0,%k1 - lay\t%0,%a1 - lgr\t%0,%1 - lg\t%0,%1 - stg\t%1,%0 - ldr\t%0,%1 - ld\t%0,%1 - ldy\t%0,%1 - std\t%1,%0 - stdy\t%1,%0 - # - # - stam\t%1,%N1,%S0 - lam\t%0,%N0,%S1 - #" - [(set_attr "op_type" "RI,RI,RI,RI,RI,RIL,RIL,RIL,RXY,RRE,RXY,RXY, - RR,RX,RXY,RX,RXY,*,*,RS,RS,SS") - (set_attr "type" "*,*,*,*,*,*,*,*,la,lr,load,store, - floaddf,floaddf,floaddf,fstoredf,fstoredf,*,*,*,*,*")]) - -(define_insn "*movdi_64" - [(set (match_operand:DI 0 "nonimmediate_operand" - "=d,d,d,d,d,d,d,d,m,!*f,!*f,!*f,!R,!T,d,t,Q,t,?Q") - (match_operand:DI 1 "general_operand" - "K,N0HD0,N1HD0,N2HD0,N3HD0,L,d,m,d,*f,R,T,*f,*f,t,d,t,Q,?Q"))] - "TARGET_64BIT && !TARGET_EXTIMM" - "@ - lghi\t%0,%h1 - llihh\t%0,%i1 - llihl\t%0,%i1 - llilh\t%0,%i1 - llill\t%0,%i1 - lay\t%0,%a1 - lgr\t%0,%1 - lg\t%0,%1 - stg\t%1,%0 - ldr\t%0,%1 - ld\t%0,%1 - ldy\t%0,%1 - std\t%1,%0 - stdy\t%1,%0 - # - # - stam\t%1,%N1,%S0 - lam\t%0,%N0,%S1 - #" - [(set_attr "op_type" "RI,RI,RI,RI,RI,RXY,RRE,RXY,RXY, - RR,RX,RXY,RX,RXY,*,*,RS,RS,SS") - (set_attr "type" "*,*,*,*,*,la,lr,load,store, - floaddf,floaddf,floaddf,fstoredf,fstoredf,*,*,*,*,*")]) + [(set_attr "op_type" "RI,RI,RI,RI,RI,RIL,RIL,RIL,RRE,RRE,RXY,RIL,RRE,RXY, + RXY,RR,RX,RXY,RX,RXY,RIL,SIL,*,*,RS,RS,SS") + (set_attr "type" "*,*,*,*,*,*,*,*,floaddf,floaddf,la,larl,lr,load,store, + floaddf,floaddf,floaddf,fstoredf,fstoredf,larl,*,*,*, + *,*,*") + (set_attr "cpu_facility" "*,*,*,*,*,extimm,extimm,extimm,dfp,dfp,longdisp, + z10,*,*,*,*,*,longdisp,*,longdisp, + z10,z10,*,*,*,*,*")]) (define_split [(set (match_operand:DI 0 "register_operand" "") @@ -1123,8 +1281,10 @@ s390_split_access_reg (operands[0], &operands[3], &operands[4]);") (define_insn "*movdi_31" - [(set (match_operand:DI 0 "nonimmediate_operand" "=d,d,Q,S,d,o,!*f,!*f,!*f,!R,!T,Q") - (match_operand:DI 1 "general_operand" "Q,S,d,d,dPm,d,*f,R,T,*f,*f,Q"))] + [(set (match_operand:DI 0 "nonimmediate_operand" + "=d,d,Q,S,d ,o,!*f,!*f,!*f,!R,!T,Q,d") + (match_operand:DI 1 "general_operand" + " Q,S,d,d,dPRT,d, *f, R, T,*f,*f,Q,b"))] "!TARGET_64BIT" "@ lm\t%0,%N0,%S1 @@ -1138,9 +1298,26 @@ ldy\t%0,%1 std\t%1,%0 stdy\t%1,%0 + # #" - [(set_attr "op_type" "RS,RSY,RS,RSY,*,*,RR,RX,RXY,RX,RXY,SS") - (set_attr "type" "lm,lm,stm,stm,*,*,floaddf,floaddf,floaddf,fstoredf,fstoredf,*")]) + [(set_attr "op_type" "RS,RSY,RS,RSY,*,*,RR,RX,RXY,RX,RXY,SS,*") + (set_attr "type" "lm,lm,stm,stm,*,*,floaddf,floaddf,floaddf,fstoredf,fstoredf,*,*") + (set_attr "cpu_facility" "*,*,*,*,*,*,*,*,*,*,*,*,z10")]) + +; For a load from a symbol ref we can use one of the target registers +; together with larl to load the address. +(define_split + [(set (match_operand:DI 0 "register_operand" "") + (match_operand:DI 1 "memory_operand" ""))] + "!TARGET_64BIT && reload_completed && TARGET_Z10 + && larl_operand (XEXP (operands[1], 0), SImode)" + [(set (match_dup 2) (match_dup 3)) + (set (match_dup 0) (match_dup 1))] +{ + operands[2] = operand_subword (operands[0], 1, 0, DImode); + operands[3] = XEXP (operands[1], 0); + operands[1] = replace_equiv_address (operands[1], operands[2]); +}) (define_split [(set (match_operand:DI 0 "nonimmediate_operand" "") @@ -1258,9 +1435,9 @@ (define_insn "*movsi_zarch" [(set (match_operand:SI 0 "nonimmediate_operand" - "=d,d,d,d,d,d,d,d,R,T,!*f,!*f,!*f,!R,!T,d,t,Q,t,?Q") + "=d,d,d,d,d,d,d,d,d,R,T,!*f,!*f,!*f,!R,!T,d,t,Q,b,Q,t,?Q") (match_operand:SI 1 "general_operand" - "K,N0HS0,N1HS0,Os,L,d,R,T,d,d,*f,R,T,*f,*f,t,d,t,Q,?Q"))] + "K,N0HS0,N1HS0,Os,L,b,d,R,T,d,d,*f,R,T,*f,*f,t,d,t,d,K,Q,?Q"))] "TARGET_ZARCH" "@ lhi\t%0,%h1 @@ -1268,6 +1445,7 @@ llill\t%0,%i1 iilf\t%0,%o1 lay\t%0,%a1 + lrl\t%0,%1 lr\t%0,%1 l\t%0,%1 ly\t%0,%1 @@ -1281,12 +1459,16 @@ ear\t%0,%1 sar\t%0,%1 stam\t%1,%1,%S0 + strl\t%1,%0 + mvhi\t%0,%1 lam\t%0,%0,%S1 #" - [(set_attr "op_type" "RI,RI,RI,RIL,RXY,RR,RX,RXY,RX,RXY, - RR,RX,RXY,RX,RXY,RRE,RRE,RS,RS,SS") - (set_attr "type" "*,*,*,*,la,lr,load,load,store,store, - floadsf,floadsf,floadsf,fstoresf,fstoresf,*,*,*,*,*")]) + [(set_attr "op_type" "RI,RI,RI,RIL,RXY,RIL,RR,RX,RXY,RX,RXY, + RR,RX,RXY,RX,RXY,RRE,RRE,RS,RIL,SIL,RS,SS") + (set_attr "type" "*,*,*,*,la,larl,lr,load,load,store,store, + floadsf,floadsf,floadsf,fstoresf,fstoresf,*,*,*,larl,*,*,*") + (set_attr "cpu_facility" "*,*,*,extimm,longdisp,z10,*,*,longdisp,*,longdisp, + *,*,longdisp,*,longdisp,*,*,*,z10,z10,*,*")]) (define_insn "*movsi_esa" [(set (match_operand:SI 0 "nonimmediate_operand" "=d,d,d,R,!*f,!*f,!R,d,t,Q,t,?Q") @@ -1412,19 +1594,23 @@ }) (define_insn "*movhi" - [(set (match_operand:HI 0 "nonimmediate_operand" "=d,d,d,d,R,T,?Q") - (match_operand:HI 1 "general_operand" "d,n,R,T,d,d,?Q"))] + [(set (match_operand:HI 0 "nonimmediate_operand" "=d,d,d,d,d,R,T,b,Q,?Q") + (match_operand:HI 1 "general_operand" " d,n,R,T,b,d,d,d,K,?Q"))] "" "@ lr\t%0,%1 lhi\t%0,%h1 lh\t%0,%1 lhy\t%0,%1 + lhrl\t%0,%1 sth\t%1,%0 sthy\t%1,%0 + sthrl\t%1,%0 + mvhhi\t%0,%1 #" - [(set_attr "op_type" "RR,RI,RX,RXY,RX,RXY,SS") - (set_attr "type" "lr,*,*,*,store,store,*")]) + [(set_attr "op_type" "RR,RI,RX,RXY,RIL,RX,RXY,RIL,SIL,SS") + (set_attr "type" "lr,*,*,*,larl,store,store,store,*,*") + (set_attr "cpu_facility" "*,*,*,*,z10,*,*,z10,z10,*")]) (define_peephole2 [(set (match_operand:HI 0 "register_operand" "") @@ -1540,7 +1726,7 @@ (define_insn "*mov<mode>_64" [(set (match_operand:TD_TF 0 "nonimmediate_operand" "=f,f,f,o, d,QS, d,o,Q") - (match_operand:TD_TF 1 "general_operand" " G,f,o,f,QS, d,dm,d,Q"))] + (match_operand:TD_TF 1 "general_operand" " G,f,o,f,QS, d,dRT,d,Q"))] "TARGET_64BIT" "@ lzxr\t%0 @@ -1657,9 +1843,9 @@ (define_insn "*mov<mode>_64dfp" [(set (match_operand:DD_DF 0 "nonimmediate_operand" - "=f,f,f,d,f,f,R,T,d,d,m,?Q") + "=f,f,f,d,f,f,R,T,d,d,RT,?Q") (match_operand:DD_DF 1 "general_operand" - "G,f,d,f,R,T,f,f,d,m,d,?Q"))] + "G,f,d,f,R,T,f,f,d,RT,d,?Q"))] "TARGET_64BIT && TARGET_DFP" "@ lzdr\t%0 @@ -1679,8 +1865,8 @@ fstoredf,fstoredf,lr,load,store,*")]) (define_insn "*mov<mode>_64" - [(set (match_operand:DD_DF 0 "nonimmediate_operand" "=f,f,f,f,R,T,d,d,m,?Q") - (match_operand:DD_DF 1 "general_operand" "G,f,R,T,f,f,d,m,d,?Q"))] + [(set (match_operand:DD_DF 0 "nonimmediate_operand" "=f,f,f,f,R,T,d, d,RT,?Q") + (match_operand:DD_DF 1 "general_operand" "G,f,R,T,f,f,d,RT, d,?Q"))] "TARGET_64BIT" "@ lzdr\t%0 @@ -1699,9 +1885,9 @@ (define_insn "*mov<mode>_31" [(set (match_operand:DD_DF 0 "nonimmediate_operand" - "=f,f,f,f,R,T,d,d,Q,S, d,o,Q") + "=f,f,f,f,R,T,d,d,Q,S, d,o,Q") (match_operand:DD_DF 1 "general_operand" - " G,f,R,T,f,f,Q,S,d,d,dPm,d,Q"))] + " G,f,R,T,f,f,Q,S,d,d,dPRT,d,Q"))] "!TARGET_64BIT" "@ lzdr\t%0 @@ -2045,6 +2231,17 @@ ;; String instructions. ;; +(define_insn "*execute_rl" + [(match_parallel 0 "" + [(unspec [(match_operand 1 "register_operand" "a") + (match_operand 2 "" "") + (match_operand:SI 3 "larl_operand" "X")] UNSPEC_EXECUTE)])] + "TARGET_Z10 && GET_MODE_CLASS (GET_MODE (operands[1])) == MODE_INT + && GET_MODE_SIZE (GET_MODE (operands[1])) <= UNITS_PER_WORD" + "exrl\t%1,%3" + [(set_attr "op_type" "RIL") + (set_attr "type" "cs")]) + (define_insn "*execute" [(match_parallel 0 "" [(unspec [(match_operand 1 "register_operand" "a") @@ -2189,9 +2386,9 @@ ; (define_expand "movmem<mode>" - [(set (match_operand:BLK 0 "memory_operand" "") - (match_operand:BLK 1 "memory_operand" "")) - (use (match_operand:GPR 2 "general_operand" "")) + [(set (match_operand:BLK 0 "memory_operand" "") ; destination + (match_operand:BLK 1 "memory_operand" "")) ; source + (use (match_operand:GPR 2 "general_operand" "")) ; count (match_operand 3 "" "")] "" "s390_expand_movmem (operands[0], operands[1], operands[2]); DONE;") @@ -2210,15 +2407,16 @@ "operands[3] = gen_rtx_SCRATCH (Pmode);") (define_insn "*movmem_short" - [(set (match_operand:BLK 0 "memory_operand" "=Q,Q,Q") - (match_operand:BLK 1 "memory_operand" "Q,Q,Q")) - (use (match_operand 2 "nonmemory_operand" "n,a,a")) - (use (match_operand 3 "immediate_operand" "X,R,X")) - (clobber (match_scratch 4 "=X,X,&a"))] + [(set (match_operand:BLK 0 "memory_operand" "=Q,Q,Q,Q") + (match_operand:BLK 1 "memory_operand" "Q,Q,Q,Q")) + (use (match_operand 2 "nonmemory_operand" "n,a,a,a")) + (use (match_operand 3 "immediate_operand" "X,R,X,X")) + (clobber (match_scratch 4 "=X,X,X,&a"))] "(GET_MODE (operands[2]) == Pmode || GET_MODE (operands[2]) == VOIDmode) && GET_MODE (operands[4]) == Pmode" "#" - [(set_attr "type" "cs")]) + [(set_attr "type" "cs") + (set_attr "cpu_facility" "*,*,z10,*")]) (define_split [(set (match_operand:BLK 0 "memory_operand" "") @@ -2251,6 +2449,20 @@ (match_operand:BLK 1 "memory_operand" "")) (use (match_operand 2 "register_operand" "")) (use (const:BLK (unspec:BLK [(const_int 0)] UNSPEC_INSN))) + (clobber (scratch))] + "TARGET_Z10 && reload_completed" + [(parallel + [(unspec [(match_dup 2) (const_int 0) + (label_ref (match_dup 3))] UNSPEC_EXECUTE) + (set (match_dup 0) (match_dup 1)) + (use (const_int 1))])] + "operands[3] = gen_label_rtx ();") + +(define_split + [(set (match_operand:BLK 0 "memory_operand" "") + (match_operand:BLK 1 "memory_operand" "")) + (use (match_operand 2 "register_operand" "")) + (use (const:BLK (unspec:BLK [(const_int 0)] UNSPEC_INSN))) (clobber (match_operand 3 "register_operand" ""))] "reload_completed && TARGET_CPU_ZARCH" [(set (match_dup 3) (label_ref (match_dup 4))) @@ -2389,16 +2601,17 @@ "operands[2] = gen_rtx_SCRATCH (Pmode);") (define_insn "*clrmem_short" - [(set (match_operand:BLK 0 "memory_operand" "=Q,Q,Q") + [(set (match_operand:BLK 0 "memory_operand" "=Q,Q,Q,Q") (const_int 0)) - (use (match_operand 1 "nonmemory_operand" "n,a,a")) - (use (match_operand 2 "immediate_operand" "X,R,X")) - (clobber (match_scratch 3 "=X,X,&a")) + (use (match_operand 1 "nonmemory_operand" "n,a,a,a")) + (use (match_operand 2 "immediate_operand" "X,R,X,X")) + (clobber (match_scratch 3 "=X,X,X,&a")) (clobber (reg:CC CC_REGNUM))] "(GET_MODE (operands[1]) == Pmode || GET_MODE (operands[1]) == VOIDmode) && GET_MODE (operands[3]) == Pmode" "#" - [(set_attr "type" "cs")]) + [(set_attr "type" "cs") + (set_attr "cpu_facility" "*,*,z10,*")]) (define_split [(set (match_operand:BLK 0 "memory_operand" "") @@ -2435,6 +2648,22 @@ (const_int 0)) (use (match_operand 1 "register_operand" "")) (use (const:BLK (unspec:BLK [(const_int 0)] UNSPEC_INSN))) + (clobber (scratch)) + (clobber (reg:CC CC_REGNUM))] + "TARGET_Z10 && reload_completed" + [(parallel + [(unspec [(match_dup 1) (const_int 0) + (label_ref (match_dup 3))] UNSPEC_EXECUTE) + (set (match_dup 0) (const_int 0)) + (use (const_int 1)) + (clobber (reg:CC CC_REGNUM))])] + "operands[3] = gen_label_rtx ();") + +(define_split + [(set (match_operand:BLK 0 "memory_operand" "") + (const_int 0)) + (use (match_operand 1 "register_operand" "")) + (use (const:BLK (unspec:BLK [(const_int 0)] UNSPEC_INSN))) (clobber (match_operand 2 "register_operand" "")) (clobber (reg:CC CC_REGNUM))] "reload_completed && TARGET_CPU_ZARCH" @@ -2530,15 +2759,16 @@ (define_insn "*cmpmem_short" [(set (reg:CCU CC_REGNUM) - (compare:CCU (match_operand:BLK 0 "memory_operand" "Q,Q,Q") - (match_operand:BLK 1 "memory_operand" "Q,Q,Q"))) - (use (match_operand 2 "nonmemory_operand" "n,a,a")) - (use (match_operand 3 "immediate_operand" "X,R,X")) - (clobber (match_scratch 4 "=X,X,&a"))] + (compare:CCU (match_operand:BLK 0 "memory_operand" "Q,Q,Q,Q") + (match_operand:BLK 1 "memory_operand" "Q,Q,Q,Q"))) + (use (match_operand 2 "nonmemory_operand" "n,a,a,a")) + (use (match_operand 3 "immediate_operand" "X,R,X,X")) + (clobber (match_scratch 4 "=X,X,X,&a"))] "(GET_MODE (operands[2]) == Pmode || GET_MODE (operands[2]) == VOIDmode) && GET_MODE (operands[4]) == Pmode" "#" - [(set_attr "type" "cs")]) + [(set_attr "type" "cs") + (set_attr "cpu_facility" "*,*,z10,*")]) (define_split [(set (reg:CCU CC_REGNUM) @@ -2574,6 +2804,21 @@ (match_operand:BLK 1 "memory_operand" ""))) (use (match_operand 2 "register_operand" "")) (use (const:BLK (unspec:BLK [(const_int 0)] UNSPEC_INSN))) + (clobber (scratch))] + "TARGET_Z10 && reload_completed" + [(parallel + [(unspec [(match_dup 2) (const_int 0) + (label_ref (match_dup 4))] UNSPEC_EXECUTE) + (set (reg:CCU CC_REGNUM) (compare:CCU (match_dup 0) (match_dup 1))) + (use (const_int 1))])] + "operands[4] = gen_label_rtx ();") + +(define_split + [(set (reg:CCU CC_REGNUM) + (compare:CCU (match_operand:BLK 0 "memory_operand" "") + (match_operand:BLK 1 "memory_operand" ""))) + (use (match_operand 2 "register_operand" "")) + (use (const:BLK (unspec:BLK [(const_int 0)] UNSPEC_INSN))) (clobber (match_operand 3 "register_operand" ""))] "reload_completed && TARGET_CPU_ZARCH" [(set (match_dup 3) (label_ref (match_dup 4))) @@ -2807,6 +3052,83 @@ FAIL; }) +(define_insn "*insv<mode>_z10" + [(set (zero_extract:GPR (match_operand:GPR 0 "nonimmediate_operand" "+d") + (match_operand 1 "const_int_operand" "I") + (match_operand 2 "const_int_operand" "I")) + (match_operand:GPR 3 "nonimmediate_operand" "d")) + (clobber (reg:CC CC_REGNUM))] + "TARGET_Z10 + && (INTVAL (operands[1]) + INTVAL (operands[2])) <= + GET_MODE_BITSIZE (<MODE>mode)" +{ + int start = INTVAL (operands[2]); + int size = INTVAL (operands[1]); + int offset = 64 - GET_MODE_BITSIZE (<MODE>mode); + + operands[2] = GEN_INT (offset + start); /* start bit position */ + operands[1] = GEN_INT (offset + start + size - 1); /* end bit position */ + operands[4] = GEN_INT (GET_MODE_BITSIZE (<MODE>mode) - + start - size); /* left shift count */ + + return "risbg\t%0,%3,%b2,%b1,%b4"; +} + [(set_attr "op_type" "RIE")]) + +; and op1 with a mask being 1 for the selected bits and 0 for the rest +; and op3=op0 with a mask being 0 for the selected bits and 1 for the rest +(define_insn "*insv<mode>_z10_noshift" + [(set (match_operand:GPR 0 "nonimmediate_operand" "=d") + (ior:GPR (and:GPR (match_operand:GPR 1 "nonimmediate_operand" "d") + (match_operand 2 "const_int_operand" "n")) + (and:GPR (match_operand:GPR 3 "nonimmediate_operand" "0") + (match_operand 4 "const_int_operand" "n")))) + (clobber (reg:CC CC_REGNUM))] + "TARGET_Z10 + && s390_contiguous_bitmask_p (INTVAL (operands[2]), + GET_MODE_BITSIZE (<MODE>mode), NULL, NULL) + && INTVAL (operands[2]) == ~(INTVAL (operands[4]))" + +{ + int start; + int size; + + s390_contiguous_bitmask_p (INTVAL (operands[2]), + GET_MODE_BITSIZE (<MODE>mode), &start, &size); + + operands[5] = GEN_INT (64 - start - size); /* start bit position */ + operands[6] = GEN_INT (64 - 1 - start); /* end bit position */ + operands[7] = const0_rtx; /* left shift count */ + + return "risbg\t%0,%1,%b5,%b6,%b7"; +} + [(set_attr "op_type" "RIE")]) + +; and op1 with a mask being 1 for the selected bits and 0 for the rest +(define_insn "*insv<mode>_or_z10_noshift" + [(set (match_operand:GPR 0 "nonimmediate_operand" "=d") + (ior:GPR (and:GPR (match_operand:GPR 1 "nonimmediate_operand" "d") + (match_operand 2 "const_int_operand" "n")) + (match_operand:GPR 3 "nonimmediate_operand" "0"))) + (clobber (reg:CC CC_REGNUM))] + "TARGET_Z10 + && s390_contiguous_bitmask_p (INTVAL (operands[2]), + GET_MODE_BITSIZE (<MODE>mode), NULL, NULL)" +{ + int start; + int size; + + s390_contiguous_bitmask_p (INTVAL (operands[2]), + GET_MODE_BITSIZE (<MODE>mode), &start, &size); + + operands[4] = GEN_INT (64 - start - size); /* start bit position */ + operands[5] = GEN_INT (64 - 1 - start); /* end bit position */ + operands[6] = const0_rtx; /* left shift count */ + + return "rosbg\t%0,%1,%b4,%b5,%b6"; +} + [(set_attr "op_type" "RIE")]) + (define_insn "*insv<mode>_mem_reg" [(set (zero_extract:P (match_operand:QI 0 "memory_operand" "+Q,S") (match_operand 1 "const_int_operand" "n,n") @@ -2902,13 +3224,16 @@ }) (define_insn "*extendsidi2" - [(set (match_operand:DI 0 "register_operand" "=d,d") - (sign_extend:DI (match_operand:SI 1 "nonimmediate_operand" "d,m")))] + [(set (match_operand:DI 0 "register_operand" "=d,d,d") + (sign_extend:DI (match_operand:SI 1 "nonimmediate_operand" "d,RT,b")))] "TARGET_64BIT" "@ lgfr\t%0,%1 - lgf\t%0,%1" - [(set_attr "op_type" "RRE,RXY")]) + lgf\t%0,%1 + lgfrl\t%0,%1" + [(set_attr "op_type" "RRE,RXY,RIL") + (set_attr "type" "*,*,larl") + (set_attr "cpu_facility" "*,*,z10")]) ; ; extend(hi|qi)(si|di)2 instruction pattern(s). @@ -2943,17 +3268,20 @@ ; (define_insn "*extendhidi2_extimm" - [(set (match_operand:DI 0 "register_operand" "=d,d") - (sign_extend:DI (match_operand:HI 1 "nonimmediate_operand" "d,m")))] + [(set (match_operand:DI 0 "register_operand" "=d,d,d") + (sign_extend:DI (match_operand:HI 1 "general_operand" "d,RT,b")))] "TARGET_64BIT && TARGET_EXTIMM" "@ lghr\t%0,%1 - lgh\t%0,%1" - [(set_attr "op_type" "RRE,RXY")]) + lgh\t%0,%1 + lghrl\t%0,%1" + [(set_attr "op_type" "RRE,RXY,RIL") + (set_attr "type" "*,*,larl") + (set_attr "cpu_facility" "extimm,extimm,z10")]) (define_insn "*extendhidi2" [(set (match_operand:DI 0 "register_operand" "=d") - (sign_extend:DI (match_operand:HI 1 "memory_operand" "m")))] + (sign_extend:DI (match_operand:HI 1 "memory_operand" "RT")))] "TARGET_64BIT" "lgh\t%0,%1" [(set_attr "op_type" "RXY")]) @@ -2963,14 +3291,17 @@ ; (define_insn "*extendhisi2_extimm" - [(set (match_operand:SI 0 "register_operand" "=d,d,d") - (sign_extend:SI (match_operand:HI 1 "nonimmediate_operand" "d,R,T")))] + [(set (match_operand:SI 0 "register_operand" "=d,d,d,d") + (sign_extend:SI (match_operand:HI 1 "nonimmediate_operand" " d,R,T,b")))] "TARGET_EXTIMM" "@ lhr\t%0,%1 lh\t%0,%1 - lhy\t%0,%1" - [(set_attr "op_type" "RRE,RX,RXY")]) + lhy\t%0,%1 + lhrl\t%0,%1" + [(set_attr "op_type" "RRE,RX,RXY,RIL") + (set_attr "type" "*,*,*,larl") + (set_attr "cpu_facility" "extimm,extimm,extimm,z10")]) (define_insn "*extendhisi2" [(set (match_operand:SI 0 "register_operand" "=d,d") @@ -2988,7 +3319,7 @@ ; lbr, lgbr, lb, lgb (define_insn "*extendqi<mode>2_extimm" [(set (match_operand:GPR 0 "register_operand" "=d,d") - (sign_extend:GPR (match_operand:QI 1 "nonimmediate_operand" "d,m")))] + (sign_extend:GPR (match_operand:QI 1 "nonimmediate_operand" "d,RT")))] "TARGET_EXTIMM" "@ l<g>br\t%0,%1 @@ -2998,7 +3329,7 @@ ; lb, lgb (define_insn "*extendqi<mode>2" [(set (match_operand:GPR 0 "register_operand" "=d") - (sign_extend:GPR (match_operand:QI 1 "memory_operand" "m")))] + (sign_extend:GPR (match_operand:QI 1 "memory_operand" "RT")))] "!TARGET_EXTIMM && TARGET_LONG_DISPLACEMENT" "l<g>b\t%0,%1" [(set_attr "op_type" "RXY")]) @@ -3042,13 +3373,16 @@ }) (define_insn "*zero_extendsidi2" - [(set (match_operand:DI 0 "register_operand" "=d,d") - (zero_extend:DI (match_operand:SI 1 "nonimmediate_operand" "d,m")))] + [(set (match_operand:DI 0 "register_operand" "=d,d,d") + (zero_extend:DI (match_operand:SI 1 "nonimmediate_operand" "d,RT,b")))] "TARGET_64BIT" "@ llgfr\t%0,%1 - llgf\t%0,%1" - [(set_attr "op_type" "RRE,RXY")]) + llgf\t%0,%1 + llgfrl\t%0,%1" + [(set_attr "op_type" "RRE,RXY,RIL") + (set_attr "type" "*,*,larl") + (set_attr "cpu_facility" "*,*,z10")]) ; ; LLGT-type instructions (zero-extend from 31 bit to 64 bit). @@ -3056,7 +3390,7 @@ (define_insn "*llgt_sidi" [(set (match_operand:DI 0 "register_operand" "=d") - (and:DI (subreg:DI (match_operand:SI 1 "memory_operand" "m") 0) + (and:DI (subreg:DI (match_operand:SI 1 "memory_operand" "RT") 0) (const_int 2147483647)))] "TARGET_64BIT" "llgt\t%0,%1" @@ -3064,7 +3398,7 @@ (define_insn_and_split "*llgt_sidi_split" [(set (match_operand:DI 0 "register_operand" "=d") - (and:DI (subreg:DI (match_operand:SI 1 "memory_operand" "m") 0) + (and:DI (subreg:DI (match_operand:SI 1 "memory_operand" "RT") 0) (const_int 2147483647))) (clobber (reg:CC CC_REGNUM))] "TARGET_64BIT" @@ -3077,7 +3411,7 @@ (define_insn "*llgt_sisi" [(set (match_operand:SI 0 "register_operand" "=d,d") - (and:SI (match_operand:SI 1 "nonimmediate_operand" "d,m") + (and:SI (match_operand:SI 1 "nonimmediate_operand" "d,RT") (const_int 2147483647)))] "TARGET_ZARCH" "@ @@ -3147,10 +3481,23 @@ } }) +; llhrl, llghrl +(define_insn "*zero_extendhi<mode>2_z10" + [(set (match_operand:GPR 0 "register_operand" "=d,d,d") + (zero_extend:GPR (match_operand:HI 1 "nonimmediate_operand" "d,RT,b")))] + "TARGET_Z10" + "@ + ll<g>hr\t%0,%1 + ll<g>h\t%0,%1 + ll<g>hrl\t%0,%1" + [(set_attr "op_type" "RXY,RRE,RIL") + (set_attr "type" "*,*,larl") + (set_attr "cpu_facility" "*,*,z10")]) + ; llhr, llcr, llghr, llgcr, llh, llc, llgh, llgc (define_insn "*zero_extend<HQI:mode><GPR:mode>2_extimm" [(set (match_operand:GPR 0 "register_operand" "=d,d") - (zero_extend:GPR (match_operand:HQI 1 "nonimmediate_operand" "d,m")))] + (zero_extend:GPR (match_operand:HQI 1 "nonimmediate_operand" "d,RT")))] "TARGET_EXTIMM" "@ ll<g><hc>r\t%0,%1 @@ -3160,7 +3507,7 @@ ; llgh, llgc (define_insn "*zero_extend<HQI:mode><GPR:mode>2" [(set (match_operand:GPR 0 "register_operand" "=d") - (zero_extend:GPR (match_operand:HQI 1 "memory_operand" "m")))] + (zero_extend:GPR (match_operand:HQI 1 "memory_operand" "RT")))] "TARGET_ZARCH && !TARGET_EXTIMM" "llg<hc>\t%0,%1" [(set_attr "op_type" "RXY")]) @@ -3180,7 +3527,7 @@ (define_insn_and_split "*zero_extendqisi2_31" [(set (match_operand:SI 0 "register_operand" "=&d") - (zero_extend:SI (match_operand:QI 1 "memory_operand" "m")))] + (zero_extend:SI (match_operand:QI 1 "memory_operand" "RT")))] "!TARGET_ZARCH" "#" "&& reload_completed" @@ -3204,14 +3551,14 @@ (define_insn "*zero_extendqihi2_64" [(set (match_operand:HI 0 "register_operand" "=d") - (zero_extend:HI (match_operand:QI 1 "memory_operand" "m")))] + (zero_extend:HI (match_operand:QI 1 "memory_operand" "RT")))] "TARGET_ZARCH && !TARGET_EXTIMM" "llgc\t%0,%1" [(set_attr "op_type" "RXY")]) (define_insn_and_split "*zero_extendqihi2_31" [(set (match_operand:HI 0 "register_operand" "=&d") - (zero_extend:HI (match_operand:QI 1 "memory_operand" "m")))] + (zero_extend:HI (match_operand:QI 1 "memory_operand" "RT")))] "!TARGET_ZARCH" "#" "&& reload_completed" @@ -3659,7 +4006,7 @@ (define_expand "adddi3" [(parallel - [(set (match_operand:DI 0 "register_operand" "") + [(set (match_operand:DI 0 "nonimmediate_operand" "") (plus:DI (match_operand:DI 1 "nonimmediate_operand" "") (match_operand:DI 2 "general_operand" ""))) (clobber (reg:CC CC_REGNUM))])] @@ -3668,7 +4015,7 @@ (define_insn "*adddi3_sign" [(set (match_operand:DI 0 "register_operand" "=d,d") - (plus:DI (sign_extend:DI (match_operand:SI 2 "general_operand" "d,m")) + (plus:DI (sign_extend:DI (match_operand:SI 2 "general_operand" "d,RT")) (match_operand:DI 1 "register_operand" "0,0"))) (clobber (reg:CC CC_REGNUM))] "TARGET_64BIT" @@ -3679,7 +4026,7 @@ (define_insn "*adddi3_zero_cc" [(set (reg CC_REGNUM) - (compare (plus:DI (zero_extend:DI (match_operand:SI 2 "general_operand" "d,m")) + (compare (plus:DI (zero_extend:DI (match_operand:SI 2 "general_operand" "d,RT")) (match_operand:DI 1 "register_operand" "0,0")) (const_int 0))) (set (match_operand:DI 0 "register_operand" "=d,d") @@ -3692,7 +4039,7 @@ (define_insn "*adddi3_zero_cconly" [(set (reg CC_REGNUM) - (compare (plus:DI (zero_extend:DI (match_operand:SI 2 "general_operand" "d,m")) + (compare (plus:DI (zero_extend:DI (match_operand:SI 2 "general_operand" "d,RT")) (match_operand:DI 1 "register_operand" "0,0")) (const_int 0))) (clobber (match_scratch:DI 0 "=d,d"))] @@ -3704,7 +4051,7 @@ (define_insn "*adddi3_zero" [(set (match_operand:DI 0 "register_operand" "=d,d") - (plus:DI (zero_extend:DI (match_operand:SI 2 "general_operand" "d,m")) + (plus:DI (zero_extend:DI (match_operand:SI 2 "general_operand" "d,RT")) (match_operand:DI 1 "register_operand" "0,0"))) (clobber (reg:CC CC_REGNUM))] "TARGET_64BIT" @@ -3714,7 +4061,7 @@ [(set_attr "op_type" "RRE,RXY")]) (define_insn_and_split "*adddi3_31z" - [(set (match_operand:DI 0 "register_operand" "=&d") + [(set (match_operand:DI 0 "nonimmediate_operand" "=&d") (plus:DI (match_operand:DI 1 "nonimmediate_operand" "%0") (match_operand:DI 2 "general_operand" "do") ) ) (clobber (reg:CC CC_REGNUM))] @@ -3739,7 +4086,7 @@ operands[8] = operand_subword (operands[2], 1, 0, DImode);") (define_insn_and_split "*adddi3_31" - [(set (match_operand:DI 0 "register_operand" "=&d") + [(set (match_operand:DI 0 "nonimmediate_operand" "=&d") (plus:DI (match_operand:DI 1 "nonimmediate_operand" "%0") (match_operand:DI 2 "general_operand" "do") ) ) (clobber (reg:CC CC_REGNUM))] @@ -3776,7 +4123,7 @@ (define_expand "addsi3" [(parallel - [(set (match_operand:SI 0 "register_operand" "") + [(set (match_operand:SI 0 "nonimmediate_operand" "") (plus:SI (match_operand:SI 1 "nonimmediate_operand" "") (match_operand:SI 2 "general_operand" ""))) (clobber (reg:CC CC_REGNUM))])] @@ -3798,11 +4145,11 @@ ; add(di|si)3 instruction pattern(s). ; -; ar, ahi, alfi, slfi, a, ay, agr, aghi, algfi, slgfi, ag +; ar, ahi, alfi, slfi, a, ay, agr, aghi, algfi, slgfi, ag, asi, agsi (define_insn "*add<mode>3" - [(set (match_operand:GPR 0 "register_operand" "=d,d,d,d,d,d") - (plus:GPR (match_operand:GPR 1 "nonimmediate_operand" "%0,0,0,0,0,0") - (match_operand:GPR 2 "general_operand" "d,K,Op,On,R,T") ) ) + [(set (match_operand:GPR 0 "nonimmediate_operand" "=d,d,d,d,d,d,QS") + (plus:GPR (match_operand:GPR 1 "nonimmediate_operand" "%0,0,0,0,0,0,0") + (match_operand:GPR 2 "general_operand" "d,K,Op,On,R,T,C") ) ) (clobber (reg:CC CC_REGNUM))] "" "@ @@ -3811,16 +4158,18 @@ al<g>fi\t%0,%2 sl<g>fi\t%0,%n2 a<g>\t%0,%2 - a<y>\t%0,%2" - [(set_attr "op_type" "RR<E>,RI,RIL,RIL,RX<Y>,RXY")]) + a<y>\t%0,%2 + a<g>si\t%0,%c2" + [(set_attr "op_type" "RR<E>,RI,RIL,RIL,RX<Y>,RXY,SIY") + (set_attr "cpu_facility" "*,*,extimm,extimm,*,*,z10")]) -; alr, alfi, slfi, al, aly, algr, algfi, slgfi, alg +; alr, alfi, slfi, al, aly, algr, algfi, slgfi, alg, alsi, algsi (define_insn "*add<mode>3_carry1_cc" [(set (reg CC_REGNUM) - (compare (plus:GPR (match_operand:GPR 1 "nonimmediate_operand" "%0,0,0,0,0") - (match_operand:GPR 2 "general_operand" "d,Op,On,R,T")) + (compare (plus:GPR (match_operand:GPR 1 "nonimmediate_operand" "%0,0,0,0,0,0") + (match_operand:GPR 2 "general_operand" "d,Op,On,R,T,C")) (match_dup 1))) - (set (match_operand:GPR 0 "register_operand" "=d,d,d,d,d") + (set (match_operand:GPR 0 "nonimmediate_operand" "=d,d,d,d,d,d") (plus:GPR (match_dup 1) (match_dup 2)))] "s390_match_ccmode (insn, CCL1mode)" "@ @@ -3828,8 +4177,10 @@ al<g>fi\t%0,%2 sl<g>fi\t%0,%n2 al<g>\t%0,%2 - al<y>\t%0,%2" - [(set_attr "op_type" "RR<E>,RIL,RIL,RX<Y>,RXY")]) + al<y>\t%0,%2 + al<g>si\t%0,%c2" + [(set_attr "op_type" "RR<E>,RIL,RIL,RX<Y>,RXY,SIY") + (set_attr "cpu_facility" "*,extimm,extimm,*,*,z10")]) ; alr, al, aly, algr, alg (define_insn "*add<mode>3_carry1_cconly" @@ -3845,13 +4196,13 @@ al<y>\t%0,%2" [(set_attr "op_type" "RR<E>,RX<Y>,RXY")]) -; alr, alfi, slfi, al, aly, algr, algfi, slgfi, alg +; alr, alfi, slfi, al, aly, algr, algfi, slgfi, alg, alsi, algsi (define_insn "*add<mode>3_carry2_cc" [(set (reg CC_REGNUM) - (compare (plus:GPR (match_operand:GPR 1 "nonimmediate_operand" "%0,0,0,0,0") - (match_operand:GPR 2 "general_operand" "d,Op,On,R,T")) + (compare (plus:GPR (match_operand:GPR 1 "nonimmediate_operand" "%0,0,0,0,0,0") + (match_operand:GPR 2 "general_operand" "d,Op,On,R,T,C")) (match_dup 2))) - (set (match_operand:GPR 0 "register_operand" "=d,d,d,d,d") + (set (match_operand:GPR 0 "nonimmediate_operand" "=d,d,d,d,d,RS") (plus:GPR (match_dup 1) (match_dup 2)))] "s390_match_ccmode (insn, CCL1mode)" "@ @@ -3859,8 +4210,10 @@ al<g>fi\t%0,%2 sl<g>fi\t%0,%n2 al<g>\t%0,%2 - al<y>\t%0,%2" - [(set_attr "op_type" "RR<E>,RIL,RIL,RX<Y>,RXY")]) + al<y>\t%0,%2 + al<g>si\t%0,%c2" + [(set_attr "op_type" "RR<E>,RIL,RIL,RX<Y>,RXY,SIY") + (set_attr "cpu_facility" "*,extimm,extimm,*,*,z10")]) ; alr, al, aly, algr, alg (define_insn "*add<mode>3_carry2_cconly" @@ -3876,13 +4229,13 @@ al<y>\t%0,%2" [(set_attr "op_type" "RR<E>,RX<Y>,RXY")]) -; alr, alfi, slfi, al, aly, algr, algfi, slgfi, alg +; alr, alfi, slfi, al, aly, algr, algfi, slgfi, alg, alsi, algsi (define_insn "*add<mode>3_cc" [(set (reg CC_REGNUM) - (compare (plus:GPR (match_operand:GPR 1 "nonimmediate_operand" "%0,0,0,0,0") - (match_operand:GPR 2 "general_operand" "d,Op,On,R,T")) + (compare (plus:GPR (match_operand:GPR 1 "nonimmediate_operand" "%0,0,0,0,0,0") + (match_operand:GPR 2 "general_operand" "d,Op,On,R,T,C")) (const_int 0))) - (set (match_operand:GPR 0 "register_operand" "=d,d,d,d,d") + (set (match_operand:GPR 0 "nonimmediate_operand" "=d,d,d,d,d,RS") (plus:GPR (match_dup 1) (match_dup 2)))] "s390_match_ccmode (insn, CCLmode)" "@ @@ -3890,8 +4243,10 @@ al<g>fi\t%0,%2 sl<g>fi\t%0,%n2 al<g>\t%0,%2 - al<y>\t%0,%2" - [(set_attr "op_type" "RR<E>,RIL,RIL,RX<Y>,RXY")]) + al<y>\t%0,%2 + al<g>si\t%0,%c2" + [(set_attr "op_type" "RR<E>,RIL,RIL,RX<Y>,RXY,SIY") + (set_attr "cpu_facility" "*,extimm,extimm,*,*,z10")]) ; alr, al, aly, algr, alg (define_insn "*add<mode>3_cconly" @@ -3920,22 +4275,25 @@ al<y>\t%0,%2" [(set_attr "op_type" "RR<E>,RX<Y>,RXY")]) -; ahi, afi, aghi, agfi +; ahi, afi, aghi, agfi, asi, agsi (define_insn "*add<mode>3_imm_cc" [(set (reg CC_REGNUM) - (compare (plus:GPR (match_operand:GPR 1 "nonimmediate_operand" "0,0") - (match_operand:GPR 2 "const_int_operand" "K,Os")) + (compare (plus:GPR (match_operand:GPR 1 "nonimmediate_operand" "0,0,0") + (match_operand:GPR 2 "const_int_operand" "K,Os,C")) (const_int 0))) - (set (match_operand:GPR 0 "register_operand" "=d,d") + (set (match_operand:GPR 0 "nonimmediate_operand" "=d,d,QS") (plus:GPR (match_dup 1) (match_dup 2)))] "s390_match_ccmode (insn, CCAmode) && (CONST_OK_FOR_CONSTRAINT_P (INTVAL (operands[2]), 'K', \"K\") - || CONST_OK_FOR_CONSTRAINT_P (INTVAL (operands[2]), 'O', \"Os\")) + || CONST_OK_FOR_CONSTRAINT_P (INTVAL (operands[2]), 'O', \"Os\") + || CONST_OK_FOR_CONSTRAINT_P (INTVAL (operands[2]), 'C', \"C\")) && INTVAL (operands[2]) != -((HOST_WIDE_INT)1 << (GET_MODE_BITSIZE(<MODE>mode) - 1))" "@ a<g>hi\t%0,%h2 - a<g>fi\t%0,%2" - [(set_attr "op_type" "RI,RIL")]) + a<g>fi\t%0,%2 + a<g>si\t%0,%c2" + [(set_attr "op_type" "RI,RIL,SIY") + (set_attr "cpu_facility" "*,extimm,z10")]) ; ; add(tf|df|sf|td|dd)3 instruction pattern(s). @@ -4032,7 +4390,7 @@ (define_insn "*subdi3_sign" [(set (match_operand:DI 0 "register_operand" "=d,d") (minus:DI (match_operand:DI 1 "register_operand" "0,0") - (sign_extend:DI (match_operand:SI 2 "general_operand" "d,m")))) + (sign_extend:DI (match_operand:SI 2 "general_operand" "d,RT")))) (clobber (reg:CC CC_REGNUM))] "TARGET_64BIT" "@ @@ -4043,7 +4401,7 @@ (define_insn "*subdi3_zero_cc" [(set (reg CC_REGNUM) (compare (minus:DI (match_operand:DI 1 "register_operand" "0,0") - (zero_extend:DI (match_operand:SI 2 "general_operand" "d,m"))) + (zero_extend:DI (match_operand:SI 2 "general_operand" "d,RT"))) (const_int 0))) (set (match_operand:DI 0 "register_operand" "=d,d") (minus:DI (match_dup 1) (zero_extend:DI (match_dup 2))))] @@ -4056,7 +4414,7 @@ (define_insn "*subdi3_zero_cconly" [(set (reg CC_REGNUM) (compare (minus:DI (match_operand:DI 1 "register_operand" "0,0") - (zero_extend:DI (match_operand:SI 2 "general_operand" "d,m"))) + (zero_extend:DI (match_operand:SI 2 "general_operand" "d,RT"))) (const_int 0))) (clobber (match_scratch:DI 0 "=d,d"))] "s390_match_ccmode (insn, CCLmode) && TARGET_64BIT" @@ -4068,7 +4426,7 @@ (define_insn "*subdi3_zero" [(set (match_operand:DI 0 "register_operand" "=d,d") (minus:DI (match_operand:DI 1 "register_operand" "0,0") - (zero_extend:DI (match_operand:SI 2 "general_operand" "d,m")))) + (zero_extend:DI (match_operand:SI 2 "general_operand" "d,RT")))) (clobber (reg:CC CC_REGNUM))] "TARGET_64BIT" "@ @@ -4324,7 +4682,7 @@ (compare (plus:GPR (plus:GPR (match_operand:GPR 3 "s390_alc_comparison" "") (match_operand:GPR 1 "nonimmediate_operand" "%0,0")) - (match_operand:GPR 2 "general_operand" "d,m")) + (match_operand:GPR 2 "general_operand" "d,RT")) (match_dup 1))) (set (match_operand:GPR 0 "register_operand" "=d,d") (plus:GPR (plus:GPR (match_dup 3) (match_dup 1)) (match_dup 2)))] @@ -4340,7 +4698,7 @@ (compare (plus:GPR (plus:GPR (match_operand:GPR 3 "s390_alc_comparison" "") (match_operand:GPR 1 "nonimmediate_operand" "%0,0")) - (match_operand:GPR 2 "general_operand" "d,m")) + (match_operand:GPR 2 "general_operand" "d,RT")) (match_dup 1))) (clobber (match_scratch:GPR 0 "=d,d"))] "s390_match_ccmode (insn, CCL1mode) && TARGET_CPU_ZARCH" @@ -4357,7 +4715,7 @@ (compare (plus:GPR (plus:GPR (match_operand:GPR 3 "s390_alc_comparison" "") (match_operand:GPR 1 "nonimmediate_operand" "%0,0")) - (match_operand:GPR 2 "general_operand" "d,m")) + (match_operand:GPR 2 "general_operand" "d,RT")) (match_dup 2))) (set (match_operand:GPR 0 "register_operand" "=d,d") (plus:GPR (plus:GPR (match_dup 3) (match_dup 1)) (match_dup 2)))] @@ -4373,7 +4731,7 @@ (compare (plus:GPR (plus:GPR (match_operand:GPR 3 "s390_alc_comparison" "") (match_operand:GPR 1 "nonimmediate_operand" "%0,0")) - (match_operand:GPR 2 "general_operand" "d,m")) + (match_operand:GPR 2 "general_operand" "d,RT")) (match_dup 2))) (clobber (match_scratch:GPR 0 "=d,d"))] "s390_match_ccmode (insn, CCL1mode) && TARGET_CPU_ZARCH" @@ -4388,7 +4746,7 @@ (compare (plus:GPR (plus:GPR (match_operand:GPR 3 "s390_alc_comparison" "") (match_operand:GPR 1 "nonimmediate_operand" "%0,0")) - (match_operand:GPR 2 "general_operand" "d,m")) + (match_operand:GPR 2 "general_operand" "d,RT")) (const_int 0))) (set (match_operand:GPR 0 "register_operand" "=d,d") (plus:GPR (plus:GPR (match_dup 3) (match_dup 1)) (match_dup 2)))] @@ -4403,7 +4761,7 @@ [(set (match_operand:GPR 0 "register_operand" "=d,d") (plus:GPR (plus:GPR (match_operand:GPR 3 "s390_alc_comparison" "") (match_operand:GPR 1 "nonimmediate_operand" "%0,0")) - (match_operand:GPR 2 "general_operand" "d,m"))) + (match_operand:GPR 2 "general_operand" "d,RT"))) (clobber (reg:CC CC_REGNUM))] "TARGET_CPU_ZARCH" "@ @@ -4416,7 +4774,7 @@ [(set (reg CC_REGNUM) (compare (minus:GPR (minus:GPR (match_operand:GPR 1 "nonimmediate_operand" "0,0") - (match_operand:GPR 2 "general_operand" "d,m")) + (match_operand:GPR 2 "general_operand" "d,RT")) (match_operand:GPR 3 "s390_slb_comparison" "")) (const_int 0))) (set (match_operand:GPR 0 "register_operand" "=d,d") @@ -4431,7 +4789,7 @@ (define_insn "*sub<mode>3_slb" [(set (match_operand:GPR 0 "register_operand" "=d,d") (minus:GPR (minus:GPR (match_operand:GPR 1 "nonimmediate_operand" "0,0") - (match_operand:GPR 2 "general_operand" "d,m")) + (match_operand:GPR 2 "general_operand" "d,RT")) (match_operand:GPR 3 "s390_slb_comparison" ""))) (clobber (reg:CC CC_REGNUM))] "TARGET_CPU_ZARCH" @@ -4534,69 +4892,78 @@ (define_insn "*muldi3_sign" [(set (match_operand:DI 0 "register_operand" "=d,d") - (mult:DI (sign_extend:DI (match_operand:SI 2 "nonimmediate_operand" "d,m")) + (mult:DI (sign_extend:DI (match_operand:SI 2 "general_operand" "d,RT")) (match_operand:DI 1 "register_operand" "0,0")))] "TARGET_64BIT" "@ msgfr\t%0,%2 msgf\t%0,%2" - [(set_attr "op_type" "RRE,RXY") - (set_attr "type" "imuldi")]) + [(set_attr "op_type" "RRE,RXY") + (set_attr "type" "imuldi")]) (define_insn "muldi3" - [(set (match_operand:DI 0 "register_operand" "=d,d,d") - (mult:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0,0") - (match_operand:DI 2 "general_operand" "d,K,m")))] + [(set (match_operand:DI 0 "register_operand" "=d,d,d,d") + (mult:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0,0,0") + (match_operand:DI 2 "general_operand" "d,K,RT,Os")))] "TARGET_64BIT" "@ msgr\t%0,%2 mghi\t%0,%h2 - msg\t%0,%2" - [(set_attr "op_type" "RRE,RI,RXY") - (set_attr "type" "imuldi")]) + msg\t%0,%2 + msgfi\t%0,%2" + [(set_attr "op_type" "RRE,RI,RXY,RIL") + (set_attr "type" "imuldi") + (set_attr "cpu_facility" "*,*,*,z10")]) ; ; mulsi3 instruction pattern(s). ; (define_insn "*mulsi3_sign" - [(set (match_operand:SI 0 "register_operand" "=d") - (mult:SI (sign_extend:SI (match_operand:HI 2 "memory_operand" "R")) - (match_operand:SI 1 "register_operand" "0")))] + [(set (match_operand:SI 0 "register_operand" "=d,d") + (mult:SI (sign_extend:SI (match_operand:HI 2 "memory_operand" "R,T")) + (match_operand:SI 1 "register_operand" "0,0")))] "" - "mh\t%0,%2" - [(set_attr "op_type" "RX") - (set_attr "type" "imulhi")]) + "@ + mh\t%0,%2 + mhy\t%0,%2" + [(set_attr "op_type" "RX,RXY") + (set_attr "type" "imulhi") + (set_attr "cpu_facility" "*,z10")]) (define_insn "mulsi3" - [(set (match_operand:SI 0 "register_operand" "=d,d,d,d") - (mult:SI (match_operand:SI 1 "nonimmediate_operand" "%0,0,0,0") - (match_operand:SI 2 "general_operand" "d,K,R,T")))] + [(set (match_operand:SI 0 "register_operand" "=d,d,d,d,d") + (mult:SI (match_operand:SI 1 "nonimmediate_operand" "%0,0,0,0,0") + (match_operand:SI 2 "general_operand" "d,K,R,T,Os")))] "" "@ msr\t%0,%2 mhi\t%0,%h2 ms\t%0,%2 - msy\t%0,%2" - [(set_attr "op_type" "RRE,RI,RX,RXY") - (set_attr "type" "imulsi,imulhi,imulsi,imulsi")]) + msy\t%0,%2 + msfi\t%0,%2" + [(set_attr "op_type" "RRE,RI,RX,RXY,RIL") + (set_attr "type" "imulsi,imulhi,imulsi,imulsi,imulsi") + (set_attr "cpu_facility" "*,*,*,*,z10")]) ; ; mulsidi3 instruction pattern(s). ; (define_insn "mulsidi3" - [(set (match_operand:DI 0 "register_operand" "=d,d") + [(set (match_operand:DI 0 "register_operand" "=d,d,d") (mult:DI (sign_extend:DI - (match_operand:SI 1 "register_operand" "%0,0")) + (match_operand:SI 1 "register_operand" "%0,0,0")) (sign_extend:DI - (match_operand:SI 2 "nonimmediate_operand" "d,R"))))] + (match_operand:SI 2 "nonimmediate_operand" "d,R,T"))))] "!TARGET_64BIT" "@ mr\t%0,%2 - m\t%0,%2" - [(set_attr "op_type" "RR,RX") - (set_attr "type" "imulsi")]) + m\t%0,%2 + mfy\t%0,%2" + [(set_attr "op_type" "RR,RX,RXY") + (set_attr "type" "imulsi") + (set_attr "cpu_facility" "*,*,z10")]) ; ; umulsidi3 instruction pattern(s). @@ -4607,7 +4974,7 @@ (mult:DI (zero_extend:DI (match_operand:SI 1 "register_operand" "%0,0")) (zero_extend:DI - (match_operand:SI 2 "nonimmediate_operand" "d,m"))))] + (match_operand:SI 2 "nonimmediate_operand" "d,RT"))))] "!TARGET_64BIT && TARGET_CPU_ZARCH" "@ mlr\t%0,%2 @@ -4697,7 +5064,7 @@ (ashift:TI (zero_extend:TI (mod:DI (match_operand:DI 1 "register_operand" "0,0") - (match_operand:DI 2 "general_operand" "d,m"))) + (match_operand:DI 2 "general_operand" "d,RT"))) (const_int 64)) (zero_extend:TI (div:DI (match_dup 1) (match_dup 2)))))] "TARGET_64BIT" @@ -4714,7 +5081,7 @@ (zero_extend:TI (mod:DI (match_operand:DI 1 "register_operand" "0,0") (sign_extend:DI - (match_operand:SI 2 "nonimmediate_operand" "d,m")))) + (match_operand:SI 2 "nonimmediate_operand" "d,RT")))) (const_int 64)) (zero_extend:TI (div:DI (match_dup 1) (sign_extend:DI (match_dup 2))))))] @@ -4773,7 +5140,7 @@ (truncate:DI (umod:TI (match_operand:TI 1 "register_operand" "0,0") (zero_extend:TI - (match_operand:DI 2 "nonimmediate_operand" "d,m"))))) + (match_operand:DI 2 "nonimmediate_operand" "d,RT"))))) (const_int 64)) (zero_extend:TI (truncate:DI @@ -4891,7 +5258,7 @@ (truncate:SI (umod:DI (match_operand:DI 1 "register_operand" "0,0") (zero_extend:DI - (match_operand:SI 2 "nonimmediate_operand" "d,m"))))) + (match_operand:SI 2 "nonimmediate_operand" "d,RT"))))) (const_int 32)) (zero_extend:DI (truncate:SI @@ -5111,7 +5478,7 @@ (define_insn "*anddi3_cc" [(set (reg CC_REGNUM) (compare (and:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0") - (match_operand:DI 2 "general_operand" "d,m")) + (match_operand:DI 2 "general_operand" "d,RT")) (const_int 0))) (set (match_operand:DI 0 "register_operand" "=d,d") (and:DI (match_dup 1) (match_dup 2)))] @@ -5124,7 +5491,7 @@ (define_insn "*anddi3_cconly" [(set (reg CC_REGNUM) (compare (and:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0") - (match_operand:DI 2 "general_operand" "d,m")) + (match_operand:DI 2 "general_operand" "d,RT")) (const_int 0))) (clobber (match_scratch:DI 0 "=d,d"))] "s390_match_ccmode(insn, CCTmode) && TARGET_64BIT @@ -5135,14 +5502,14 @@ ng\t%0,%2" [(set_attr "op_type" "RRE,RXY")]) -(define_insn "*anddi3_extimm" +(define_insn "*anddi3" [(set (match_operand:DI 0 "nonimmediate_operand" "=d,d,d,d,d,d,d,d,d,d,AQ,Q") (and:DI (match_operand:DI 1 "nonimmediate_operand" "%d,o,0,0,0,0,0,0,0,0,0,0") (match_operand:DI 2 "general_operand" - "M,M,N0HDF,N1HDF,N2HDF,N3HDF,N0SDF,N1SDF,d,m,NxQDF,Q"))) + "M,M,N0HDF,N1HDF,N2HDF,N3HDF,N0SDF,N1SDF,d,RT,NxQDF,Q"))) (clobber (reg:CC CC_REGNUM))] - "TARGET_64BIT && TARGET_EXTIMM && s390_logical_operator_ok_p (operands)" + "TARGET_64BIT && s390_logical_operator_ok_p (operands)" "@ # # @@ -5156,28 +5523,8 @@ ng\t%0,%2 # #" - [(set_attr "op_type" "RRE,RXE,RI,RI,RI,RI,RIL,RIL,RRE,RXY,SI,SS")]) - -(define_insn "*anddi3" - [(set (match_operand:DI 0 "nonimmediate_operand" "=d,d,d,d,d,d,d,d,AQ,Q") - (and:DI (match_operand:DI 1 "nonimmediate_operand" - "%d,o,0,0,0,0,0,0,0,0") - (match_operand:DI 2 "general_operand" - "M,M,N0HDF,N1HDF,N2HDF,N3HDF,d,m,NxQDF,Q"))) - (clobber (reg:CC CC_REGNUM))] - "TARGET_64BIT && !TARGET_EXTIMM && s390_logical_operator_ok_p (operands)" - "@ - # - # - nihh\t%0,%j2 - nihl\t%0,%j2 - nilh\t%0,%j2 - nill\t%0,%j2 - ngr\t%0,%2 - ng\t%0,%2 - # - #" - [(set_attr "op_type" "RRE,RXE,RI,RI,RI,RI,RRE,RXY,SI,SS")]) + [(set_attr "op_type" "RRE,RXE,RI,RI,RI,RI,RIL,RIL,RRE,RXY,SI,SS") + (set_attr "cpu_facility" "*,*,*,*,*,*,extimm,extimm,*,*,*,*")]) (define_split [(set (match_operand:DI 0 "s_operand" "") @@ -5416,7 +5763,7 @@ (define_insn "*iordi3_cc" [(set (reg CC_REGNUM) (compare (ior:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0") - (match_operand:DI 2 "general_operand" "d,m")) + (match_operand:DI 2 "general_operand" "d,RT")) (const_int 0))) (set (match_operand:DI 0 "register_operand" "=d,d") (ior:DI (match_dup 1) (match_dup 2)))] @@ -5429,7 +5776,7 @@ (define_insn "*iordi3_cconly" [(set (reg CC_REGNUM) (compare (ior:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0") - (match_operand:DI 2 "general_operand" "d,m")) + (match_operand:DI 2 "general_operand" "d,RT")) (const_int 0))) (clobber (match_scratch:DI 0 "=d,d"))] "s390_match_ccmode(insn, CCTmode) && TARGET_64BIT" @@ -5438,13 +5785,13 @@ og\t%0,%2" [(set_attr "op_type" "RRE,RXY")]) -(define_insn "*iordi3_extimm" +(define_insn "*iordi3" [(set (match_operand:DI 0 "nonimmediate_operand" "=d,d,d,d,d,d,d,d,AQ,Q") (ior:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0,0,0,0,0,0,0,0,0") (match_operand:DI 2 "general_operand" - "N0HD0,N1HD0,N2HD0,N3HD0,N0SD0,N1SD0,d,m,NxQD0,Q"))) + "N0HD0,N1HD0,N2HD0,N3HD0,N0SD0,N1SD0,d,RT,NxQD0,Q"))) (clobber (reg:CC CC_REGNUM))] - "TARGET_64BIT && TARGET_EXTIMM && s390_logical_operator_ok_p (operands)" + "TARGET_64BIT && s390_logical_operator_ok_p (operands)" "@ oihh\t%0,%i2 oihl\t%0,%i2 @@ -5456,25 +5803,8 @@ og\t%0,%2 # #" - [(set_attr "op_type" "RI,RI,RI,RI,RIL,RIL,RRE,RXY,SI,SS")]) - -(define_insn "*iordi3" - [(set (match_operand:DI 0 "nonimmediate_operand" "=d,d,d,d,d,d,AQ,Q") - (ior:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0,0,0,0,0,0,0") - (match_operand:DI 2 "general_operand" - "N0HD0,N1HD0,N2HD0,N3HD0,d,m,NxQD0,Q"))) - (clobber (reg:CC CC_REGNUM))] - "TARGET_64BIT && !TARGET_EXTIMM && s390_logical_operator_ok_p (operands)" - "@ - oihh\t%0,%i2 - oihl\t%0,%i2 - oilh\t%0,%i2 - oill\t%0,%i2 - ogr\t%0,%2 - og\t%0,%2 - # - #" - [(set_attr "op_type" "RI,RI,RI,RI,RRE,RXY,SI,SS")]) + [(set_attr "op_type" "RI,RI,RI,RI,RIL,RIL,RRE,RXY,SI,SS") + (set_attr "cpu_facility" "*,*,*,*,extimm,extimm,*,*,*,*")]) (define_split [(set (match_operand:DI 0 "s_operand" "") @@ -5706,7 +6036,7 @@ (define_insn "*xordi3_cc" [(set (reg CC_REGNUM) (compare (xor:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0") - (match_operand:DI 2 "general_operand" "d,m")) + (match_operand:DI 2 "general_operand" "d,RT")) (const_int 0))) (set (match_operand:DI 0 "register_operand" "=d,d") (xor:DI (match_dup 1) (match_dup 2)))] @@ -5719,7 +6049,7 @@ (define_insn "*xordi3_cconly" [(set (reg CC_REGNUM) (compare (xor:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0") - (match_operand:DI 2 "general_operand" "d,m")) + (match_operand:DI 2 "general_operand" "d,RT")) (const_int 0))) (clobber (match_scratch:DI 0 "=d,d"))] "s390_match_ccmode(insn, CCTmode) && TARGET_64BIT" @@ -5728,12 +6058,12 @@ xg\t%0,%2" [(set_attr "op_type" "RRE,RXY")]) -(define_insn "*xordi3_extimm" +(define_insn "*xordi3" [(set (match_operand:DI 0 "nonimmediate_operand" "=d,d,d,d,AQ,Q") (xor:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0,0,0,0,0") - (match_operand:DI 2 "general_operand" "N0SD0,N1SD0,d,m,NxQD0,Q"))) + (match_operand:DI 2 "general_operand" "N0SD0,N1SD0,d,RT,NxQD0,Q"))) (clobber (reg:CC CC_REGNUM))] - "TARGET_64BIT && TARGET_EXTIMM && s390_logical_operator_ok_p (operands)" + "TARGET_64BIT && s390_logical_operator_ok_p (operands)" "@ xihf\t%0,%k2 xilf\t%0,%k2 @@ -5741,20 +6071,8 @@ xg\t%0,%2 # #" - [(set_attr "op_type" "RIL,RIL,RRE,RXY,SI,SS")]) - -(define_insn "*xordi3" - [(set (match_operand:DI 0 "nonimmediate_operand" "=d,d,AQ,Q") - (xor:DI (match_operand:DI 1 "nonimmediate_operand" "%0,0,0,0") - (match_operand:DI 2 "general_operand" "d,m,NxQD0,Q"))) - (clobber (reg:CC CC_REGNUM))] - "TARGET_64BIT && !TARGET_EXTIMM && s390_logical_operator_ok_p (operands)" - "@ - xgr\t%0,%2 - xg\t%0,%2 - # - #" - [(set_attr "op_type" "RRE,RXY,SI,SS")]) + [(set_attr "op_type" "RIL,RIL,RRE,RXY,SI,SS") + (set_attr "cpu_facility" "extimm,extimm,*,*,*,*")]) (define_split [(set (match_operand:DI 0 "s_operand" "") @@ -6842,6 +7160,32 @@ [(set_attr "op_type" "RI") (set_attr "type" "branch")]) +; crt, cgrt, cit, cgit +(define_insn "*cmp_and_trap_signed_int<mode>" + [(trap_if (match_operator 0 "s390_signed_integer_comparison" + [(match_operand:GPR 1 "register_operand" "d,d") + (match_operand:GPR 2 "nonmemory_operand" "d,K")]) + (const_int 0))] + "TARGET_Z10" + "@ + c<g>rt%C0\t%1,%2 + c<g>it%C0\t%1,%h2" + [(set_attr "op_type" "RRF,RIE") + (set_attr "type" "branch")]) + +; clrt, clgrt, clfit, clgit +(define_insn "*cmp_and_trap_unsigned_int<mode>" + [(trap_if (match_operator 0 "s390_unsigned_integer_comparison" + [(match_operand:GPR 1 "register_operand" "d,d") + (match_operand:GPR 2 "nonmemory_operand" "d,D")]) + (const_int 0))] + "TARGET_Z10" + "@ + cl<g>rt%C0\t%1,%2 + cl<gf>it%C0\t%1,%x2" + [(set_attr "op_type" "RRF,RIE") + (set_attr "type" "branch")]) + ;; ;;- Loop instructions. ;; @@ -7411,7 +7755,7 @@ (define_insn "*tls_load_64" [(set (match_operand:DI 0 "register_operand" "=d") - (unspec:DI [(match_operand:DI 1 "memory_operand" "m") + (unspec:DI [(match_operand:DI 1 "memory_operand" "RT") (match_operand:DI 2 "" "")] UNSPEC_TLS_LOAD))] "TARGET_64BIT" @@ -7988,3 +8332,30 @@ "" "" [(set_attr "length" "0")]) + + +; +; Data prefetch patterns +; + +(define_insn "prefetch" + [(prefetch (match_operand 0 "address_operand" "UW,X") + (match_operand:SI 1 "const_int_operand" "n,n") + (match_operand:SI 2 "const_int_operand" "n,n"))] + "TARGET_Z10" +{ + if (larl_operand (operands[0], Pmode)) + return INTVAL (operands[1]) == 1 ? "pfdrl\t2,%a0" : "pfdrl\t1,%a0"; + + if (s390_mem_constraint ("W", operands[0]) + || s390_mem_constraint ("U", operands[0])) + return INTVAL (operands[1]) == 1 ? "pfd\t2,%a0" : "pfd\t1,%a0"; + + /* This point might be reached if op0 is a larl operand with an + uneven addend. In this case we simply omit issuing a prefetch + instruction. */ + + return ""; + +} [(set_attr "type" "load,larl") + (set_attr "op_type" "RXY,RIL")]) diff --git a/gcc/config/spu/divmodti4.c b/gcc/config/spu/divmodti4.c new file mode 100644 index 00000000000..ca643cc33bf --- /dev/null +++ b/gcc/config/spu/divmodti4.c @@ -0,0 +1,168 @@ +/* Copyright (C) 2008 Free Software Foundation, Inc. + + This file 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. + + This file 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 file; 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, if you link this library with files compiled with + GCC to produce an executable, this does not cause the resulting executable + to be covered by the GNU General Public License. The exception does not + however invalidate any other reasons why the executable file might be covered + by the GNU General Public License. */ + +#include <spu_intrinsics.h> + +typedef unsigned int UTItype __attribute__ ((mode (TI))); +typedef int TItype __attribute__ ((mode (TI))); +TItype __divti3 (TItype u, TItype v); +TItype __modti3 (TItype u, TItype v); +UTItype __udivti3 (UTItype u, UTItype v); +UTItype __umodti3 (UTItype u, UTItype v); +UTItype __udivmodti4 (UTItype u, UTItype v, UTItype *w); + +inline static unsigned int +count_leading_zeros (UTItype x) +{ + qword c = si_clz (*(qword *) & x); + qword cmp0 = si_cgti (c, 31); + qword cmp1 = si_and (cmp0, si_shlqbyi (cmp0, 4)); + qword cmp2 = si_and (cmp1, si_shlqbyi (cmp0, 8)); + qword s = si_a (c, si_and (cmp0, si_shlqbyi (c, 4))); + s = si_a (s, si_and (cmp1, si_shlqbyi (c, 8))); + s = si_a (s, si_and (cmp2, si_shlqbyi (c, 12))); + return si_to_uint (s); +} + +/* Based on implementation of udivmodsi4, which is essentially + * an optimized version of gcc/config/udivmodsi4.c + clz %7,%2 + clz %4,%1 + il %5,1 + fsmbi %0,0 + sf %7,%4,%7 + ori %3,%1,0 + shl %5,%5,%7 + shl %4,%2,%7 +1: or %8,%0,%5 + rotmi %5,%5,-1 + clgt %6,%4,%3 + sf %7,%4,%3 + rotmi %4,%4,-1 + selb %0,%8,%0,%6 + selb %3,%7,%3,%6 +3: brnz %5,1b + */ + +UTItype +__udivmodti4 (UTItype num, UTItype den, UTItype * rp) +{ + qword shift = + si_from_uint (count_leading_zeros (den) - count_leading_zeros (num)); + qword n0 = *(qword *) & num; + qword d0 = *(qword *) & den; + qword bit = si_andi (si_fsmbi (1), 1); + qword r0 = si_il (0); + qword m1 = si_fsmbi (0x000f); + qword mask, r1, n1; + + d0 = si_shlqbybi (si_shlqbi (d0, shift), shift); + bit = si_shlqbybi (si_shlqbi (bit, shift), shift); + + do + { + r1 = si_or (r0, bit); + + // n1 = n0 - d0 in TImode + n1 = si_bg (d0, n0); + n1 = si_shlqbyi (n1, 4); + n1 = si_sf (m1, n1); + n1 = si_bgx (d0, n0, n1); + n1 = si_shlqbyi (n1, 4); + n1 = si_sf (m1, n1); + n1 = si_bgx (d0, n0, n1); + n1 = si_shlqbyi (n1, 4); + n1 = si_sf (m1, n1); + n1 = si_sfx (d0, n0, n1); + + mask = si_fsm (si_cgti (n1, -1)); + r0 = si_selb (r0, r1, mask); + n0 = si_selb (n0, n1, mask); + bit = si_rotqmbii (bit, -1); + d0 = si_rotqmbii (d0, -1); + } + while (si_to_uint (si_orx (bit))); + if (rp) + *rp = *(UTItype *) & n0; + return *(UTItype *) & r0; +} + +UTItype +__udivti3 (UTItype n, UTItype d) +{ + return __udivmodti4 (n, d, (UTItype *)0); +} + +UTItype +__umodti3 (UTItype n, UTItype d) +{ + UTItype w; + __udivmodti4 (n, d, &w); + return w; +} + +TItype +__divti3 (TItype n, TItype d) +{ + int c = 0; + TItype w; + + if (n < 0) + { + c = ~c; + n = -n; + } + if (d < 0) + { + c = ~c; + d = -d; + } + + w = __udivmodti4 (n, d, (UTItype *)0); + if (c) + w = -w; + return w; +} + +TItype +__modti3 (TItype n, TItype d) +{ + int c = 0; + TItype w; + + if (n < 0) + { + c = ~c; + n = -n; + } + if (d < 0) + { + c = ~c; + d = -d; + } + + __udivmodti4 (n, d, (UTItype *) &w); + if (c) + w = -w; + return w; +} diff --git a/gcc/config/spu/multi3.c b/gcc/config/spu/multi3.c new file mode 100644 index 00000000000..6998ed026f8 --- /dev/null +++ b/gcc/config/spu/multi3.c @@ -0,0 +1,99 @@ +/* Copyright (C) 2008 Free Software Foundation, Inc. + + This file 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. + + This file 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 file; 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, if you link this library with files compiled with + GCC to produce an executable, this does not cause the resulting executable + to be covered by the GNU General Public License. The exception does not + however invalidate any other reasons why the executable file might be covered + by the GNU General Public License. */ + +#include <spu_intrinsics.h> + +typedef int TItype __attribute__ ((mode (TI))); + +/* A straight forward vectorization and unrolling of + * short l[8], r[8]; + * TItype total = 0; + * for (i = 0; i < 8; i++) + * for (j = 0; j < 8; j++) + * total += (TItype)((l[7-i] * r[7-j]) << (16 * (i + j))); + */ +TItype +__multi3 (TItype l, TItype r) +{ + qword u = *(qword *) & l; + qword v = *(qword *) & r; + qword splat0 = si_shufb (v, v, si_ilh (0x0001)); + qword splat1 = si_shufb (v, v, si_ilh (0x0203)); + qword splat2 = si_shufb (v, v, si_ilh (0x0405)); + qword splat3 = si_shufb (v, v, si_ilh (0x0607)); + qword splat4 = si_shufb (v, v, si_ilh (0x0809)); + qword splat5 = si_shufb (v, v, si_ilh (0x0a0b)); + qword splat6 = si_shufb (v, v, si_ilh (0x0c0d)); + qword splat7 = si_shufb (v, v, si_ilh (0x0e0f)); + + qword part0l = si_shlqbyi (si_mpyu (u, splat0), 14); + qword part1h = si_shlqbyi (si_mpyhhu (u, splat1), 14); + qword part1l = si_shlqbyi (si_mpyu (u, splat1), 12); + qword part2h = si_shlqbyi (si_mpyhhu (u, splat2), 12); + qword part2l = si_shlqbyi (si_mpyu (u, splat2), 10); + qword part3h = si_shlqbyi (si_mpyhhu (u, splat3), 10); + qword part3l = si_shlqbyi (si_mpyu (u, splat3), 8); + qword part4h = si_shlqbyi (si_mpyhhu (u, splat4), 8); + qword part4l = si_shlqbyi (si_mpyu (u, splat4), 6); + qword part5h = si_shlqbyi (si_mpyhhu (u, splat5), 6); + qword part5l = si_shlqbyi (si_mpyu (u, splat5), 4); + qword part6h = si_shlqbyi (si_mpyhhu (u, splat6), 4); + qword part6l = si_shlqbyi (si_mpyu (u, splat6), 2); + qword part7h = si_shlqbyi (si_mpyhhu (u, splat7), 2); + qword part7l = si_mpyu (u, splat7); + + qword carry, total0, total1, total2, total3, total4; + qword total5, total6, total7, total8, total9, total10; + qword total; + + total0 = si_a (si_a (si_a (part0l, part1h), si_a (part1l, part2h)), part7l); + total1 = si_a (part2l, part3h); + total2 = si_a (part3l, part4h); + total3 = si_a (part4l, part5h); + total4 = si_a (part5l, part6h); + total5 = si_a (part6l, part7h); + total6 = si_a (total0, total1); + total7 = si_a (total2, total3); + total8 = si_a (total4, total5); + total9 = si_a (total6, total7); + total10 = si_a (total8, total9); + + carry = si_cg (part2l, part3h); + carry = si_a (carry, si_cg (part3l, part4h)); + carry = si_a (carry, si_cg (part4l, part5h)); + carry = si_a (carry, si_cg (part5l, part6h)); + carry = si_a (carry, si_cg (part6l, part7h)); + carry = si_a (carry, si_cg (total0, total1)); + carry = si_a (carry, si_cg (total2, total3)); + carry = si_a (carry, si_cg (total4, total5)); + carry = si_a (carry, si_cg (total6, total7)); + carry = si_a (carry, si_cg (total8, total9)); + carry = si_shlqbyi (carry, 4); + + total = si_cg (total10, carry); + total = si_shlqbyi (total, 4); + total = si_cgx (total10, carry, total); + total = si_shlqbyi (total, 4); + total = si_addx (total10, carry, total); + return *(TItype *) & total; +} diff --git a/gcc/config/spu/spu.c b/gcc/config/spu/spu.c index 692a8dae34f..de307ab32ed 100644 --- a/gcc/config/spu/spu.c +++ b/gcc/config/spu/spu.c @@ -4422,6 +4422,13 @@ spu_init_libfuncs (void) set_conv_libfunc (ufloat_optab, DFmode, SImode, "__float_unssidf"); set_conv_libfunc (ufloat_optab, DFmode, DImode, "__float_unsdidf"); + + set_optab_libfunc (smul_optab, TImode, "__multi3"); + set_optab_libfunc (sdiv_optab, TImode, "__divti3"); + set_optab_libfunc (smod_optab, TImode, "__modti3"); + set_optab_libfunc (udiv_optab, TImode, "__udivti3"); + set_optab_libfunc (umod_optab, TImode, "__umodti3"); + set_optab_libfunc (udivmod_optab, TImode, "__udivmodti4"); } /* Make a subreg, stripping any existing subreg. We could possibly just @@ -4473,7 +4480,7 @@ spu_init_builtins (void) unsigned_V4SI_type_node = build_vector_type (unsigned_intSI_type_node, 4); unsigned_V2DI_type_node = build_vector_type (unsigned_intDI_type_node, 2); - spu_builtin_types[SPU_BTI_QUADWORD] = V16QI_type_node; + spu_builtin_types[SPU_BTI_QUADWORD] = intTI_type_node; spu_builtin_types[SPU_BTI_7] = global_trees[TI_INTSI_TYPE]; spu_builtin_types[SPU_BTI_S7] = global_trees[TI_INTSI_TYPE]; @@ -5368,7 +5375,8 @@ spu_expand_builtin_1 (struct spu_builtin_description *d, if (VECTOR_MODE_P (mode) && (GET_CODE (ops[i]) == CONST_INT || GET_MODE_CLASS (GET_MODE (ops[i])) == MODE_INT - || GET_MODE_CLASS (GET_MODE (ops[i])) == MODE_FLOAT)) + || GET_MODE_CLASS (GET_MODE (ops[i])) == MODE_FLOAT) + && d->parm[i] != SPU_BTI_QUADWORD) { if (GET_CODE (ops[i]) == CONST_INT) ops[i] = spu_const (mode, INTVAL (ops[i])); diff --git a/gcc/config/spu/t-spu-elf b/gcc/config/spu/t-spu-elf index b9550a3d082..ea9825ac497 100644 --- a/gcc/config/spu/t-spu-elf +++ b/gcc/config/spu/t-spu-elf @@ -29,7 +29,9 @@ LIB2FUNCS_STATIC_EXTRA = $(srcdir)/config/spu/float_unssidf.c \ $(srcdir)/config/spu/mfc_tag_reserve.c \ $(srcdir)/config/spu/mfc_tag_release.c \ $(srcdir)/config/spu/mfc_multi_tag_reserve.c \ - $(srcdir)/config/spu/mfc_multi_tag_release.c + $(srcdir)/config/spu/mfc_multi_tag_release.c \ + $(srcdir)/config/spu/multi3.c \ + $(srcdir)/config/spu/divmodti4.c LIB2ADDEH = $(srcdir)/unwind-dw2.c $(srcdir)/unwind-dw2-fde.c \ $(srcdir)/unwind-sjlj.c $(srcdir)/unwind-c.c diff --git a/gcc/config/t-darwin b/gcc/config/t-darwin index 2949e6baad0..d43ce5068a7 100644 --- a/gcc/config/t-darwin +++ b/gcc/config/t-darwin @@ -7,7 +7,7 @@ darwin.o: $(srcdir)/config/darwin.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ darwin-c.o: $(srcdir)/config/darwin-c.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TM_H) $(CPPLIB_H) $(TREE_H) c-pragma.h $(C_TREE_H) toplev.h $(TM_P_H) \ - c-incpath.h flags.h $(C_COMMON_H) + incpath.h flags.h $(C_COMMON_H) $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $(srcdir)/config/darwin-c.c $(PREPROCESSOR_DEFINES) gt-darwin.h : s-gtype ; @true diff --git a/gcc/configure b/gcc/configure index 15c408b9044..d2caab933b9 100755 --- a/gcc/configure +++ b/gcc/configure @@ -1089,7 +1089,7 @@ Optional Packages: use sysroot as the system root during the build --with-sysroot=DIR Search for usr/lib, usr/include, et al, within DIR. --with-pkgversion=PKG Use PKG in the version string in place of "lto - merged with rev 135852" + merged with rev 136135" --with-bugurl=URL Direct users to URL to report a bug --with-gnu-ld assume the C compiler uses GNU ld default=no --with-libiconv-prefix[=DIR] search for libiconv in DIR/include and DIR/lib @@ -8058,7 +8058,7 @@ echo "$as_me: error: package version not specified" >&2;} *) PKGVERSION="($withval) " ;; esac else - PKGVERSION="(lto merged with rev 135852) " + PKGVERSION="(lto merged with rev 136135) " fi; diff --git a/gcc/configure.ac b/gcc/configure.ac index f4f1690a8b2..a8f926985e1 100644 --- a/gcc/configure.ac +++ b/gcc/configure.ac @@ -771,7 +771,7 @@ esac], [onestep=""]) AC_SUBST(onestep) -ACX_PKGVERSION([lto merged with rev 135852]) +ACX_PKGVERSION([lto merged with rev 136135]) ACX_BUGURL([http://gcc.gnu.org/bugs.html]) # Sanity check enable_languages in case someone does not run the toplevel diff --git a/gcc/cp/ChangeLog b/gcc/cp/ChangeLog index b4cf3d40460..f371d8ca0c3 100644 --- a/gcc/cp/ChangeLog +++ b/gcc/cp/ChangeLog @@ -1,3 +1,19 @@ +2008-05-27 Michael Matz <matz@suse.de> + + PR c++/27975 + * call.c (build_new_op): Make warning conditional on + OPT_Wenum_compare. + +2008-05-27 Alexandre Oliva <aoliva@redhat.com> + + PR c++/35909 + * call.c (convert_like_real): Convert bitfield to desired type + before creating temporary. + +2008-05-26 Daniel Franke <franke.daniel@gmail.com> + + * Makefile.in: Adjusted dependencies on c-incpath.o. + 2008-05-23 Jakub Jelinek <jakub@redhat.com> PR c++/36237 diff --git a/gcc/cp/Make-lang.in b/gcc/cp/Make-lang.in index e1447b02e1e..c1336df2e8e 100644 --- a/gcc/cp/Make-lang.in +++ b/gcc/cp/Make-lang.in @@ -72,7 +72,7 @@ g++-cross$(exeext): g++$(exeext) # Shared with C front end: CXX_C_OBJS = attribs.o c-common.o c-format.o c-pragma.o c-semantics.o c-lex.o \ c-dump.o $(CXX_TARGET_OBJS) c-pretty-print.o c-opts.o c-pch.o \ - c-incpath.o cppdefault.o c-ppoutput.o c-cppbuiltin.o prefix.o \ + incpath.o cppdefault.o c-ppoutput.o c-cppbuiltin.o prefix.o \ c-gimplify.o c-omp.o tree-inline.o # Language-specific object files for C++ and Objective C++. diff --git a/gcc/cp/call.c b/gcc/cp/call.c index b83ad3a2eef..0948c790c41 100644 --- a/gcc/cp/call.c +++ b/gcc/cp/call.c @@ -4004,7 +4004,8 @@ build_new_op (enum tree_code code, int flags, tree arg1, tree arg2, tree arg3, != TYPE_MAIN_VARIANT (TREE_TYPE (arg2))) && (complain & tf_warning)) { - warning (0, "comparison between %q#T and %q#T", + warning (OPT_Wenum_compare, + "comparison between %q#T and %q#T", TREE_TYPE (arg1), TREE_TYPE (arg2)); } break; @@ -4580,7 +4581,10 @@ convert_like_real (conversion *convs, tree expr, tree fn, int argnum, return error_mark_node; } if (lvalue & clk_bitfield) - expr = convert_bitfield_to_declared_type (expr); + { + expr = convert_bitfield_to_declared_type (expr); + expr = fold_convert (type, expr); + } expr = build_target_expr_with_type (expr, type); } diff --git a/gcc/defaults.h b/gcc/defaults.h index ff5b5c01cf3..3eecd8db81a 100644 --- a/gcc/defaults.h +++ b/gcc/defaults.h @@ -902,6 +902,10 @@ along with GCC; see the file COPYING3. If not see #define LEGITIMATE_PIC_OPERAND_P(X) 1 #endif +#ifndef TARGET_MEM_CONSTRAINT +#define TARGET_MEM_CONSTRAINT 'm' +#endif + #ifndef REVERSIBLE_CC_MODE #define REVERSIBLE_CC_MODE(MODE) 0 #endif @@ -940,4 +944,13 @@ along with GCC; see the file COPYING3. If not see #define OUTGOING_REG_PARM_STACK_SPACE(FNTYPE) 0 #endif +#ifndef LOCAL_ALIGNMENT +#define LOCAL_ALIGNMENT(TYPE, ALIGNMENT) ALIGNMENT +#endif + +#ifndef STACK_SLOT_ALIGNMENT +#define STACK_SLOT_ALIGNMENT(TYPE,MODE,ALIGN) \ + ((TYPE) ? LOCAL_ALIGNMENT ((TYPE), (ALIGN)) : (ALIGN)) +#endif + #endif /* ! GCC_DEFAULTS_H */ diff --git a/gcc/doc/invoke.texi b/gcc/doc/invoke.texi index 4ef73c1cd1e..6dbd19ea2f9 100644 --- a/gcc/doc/invoke.texi +++ b/gcc/doc/invoke.texi @@ -232,7 +232,7 @@ Objective-C and Objective-C++ Dialects}. -Wchar-subscripts -Wclobbered -Wcomment @gol -Wconversion -Wcoverage-mismatch -Wno-deprecated @gol -Wno-deprecated-declarations -Wdisabled-optimization -Wno-div-by-zero @gol --Wempty-body -Wno-endif-labels @gol +-Wempty-body -Wenum-compare -Wno-endif-labels @gol -Werror -Werror=* @gol -Wfatal-errors -Wfloat-equal -Wformat -Wformat=2 @gol -Wno-format-contains-nul -Wno-format-extra-args -Wformat-nonliteral @gol @@ -1008,7 +1008,7 @@ objective-c objective-c-header objective-c-cpp-output objective-c++ objective-c++-header objective-c++-cpp-output assembler assembler-with-cpp ada -f95 f95-cpp-input +f77 f77-cpp-input f95 f95-cpp-input java @end smallexample @@ -3658,6 +3658,11 @@ while} statement. Additionally, in C++, warn when an empty body occurs in a @samp{while} or @samp{for} statement with no whitespacing before the semicolon. This warning is also enabled by @option{-Wextra}. +@item -Wenum-compare @r{(C++ and Objective-C++ only)} +@opindex Wenum-compare +@opindex Wno-enum-compare +Warn about a comparison between values of different enum types. + @item -Wsign-compare @opindex Wsign-compare @opindex Wno-sign-compare @@ -11931,6 +11936,7 @@ The processor names are: @samp{24kec}, @samp{24kef2_1}, @samp{24kef1_1}, @samp{34kc}, @samp{34kf2_1}, @samp{34kf1_1}, @samp{74kc}, @samp{74kf2_1}, @samp{74kf1_1}, @samp{74kf3_2}, +@samp{loongson2e}, @samp{loongson2f}, @samp{m4k}, @samp{orion}, @samp{r2000}, @samp{r3000}, @samp{r3900}, @samp{r4000}, @samp{r4400}, diff --git a/gcc/doc/md.texi b/gcc/doc/md.texi index a8e43ead2fd..05b1754b818 100644 --- a/gcc/doc/md.texi +++ b/gcc/doc/md.texi @@ -1050,6 +1050,7 @@ have. Constraints can also require two operands to match. * Multi-Alternative:: When an insn has two alternative constraint-patterns. * Class Preferences:: Constraints guide which hard register to put things in. * Modifiers:: More precise control over effects of constraints. +* Disable Insn Alternatives:: Disable insn alternatives using the @code{enabled} attribute. * Machine Constraints:: Existing constraints for some particular machines. * Define Constraints:: How to define machine-specific constraints. * C Constraint Interface:: How to test constraints from C code. @@ -1085,6 +1086,8 @@ number of constraints and modifiers. @item @samp{m} A memory operand is allowed, with any kind of address that the machine supports in general. +Note that the letter used for the general memory constraint can be +re-defined by a back end using the @code{TARGET_MEM_CONSTRAINT} macro. @cindex offsettable address @cindex @samp{o} in constraint @@ -3087,6 +3090,99 @@ Unsigned constant valid for BccUI instructions @end table @ifset INTERNALS +@node Disable Insn Alternatives +@subsection Disable insn alternatives using the @code{enabled} attribute +@cindex enabled + +The @code{enabled} insn attribute may be used to disable certain insn +alternatives for machine-specific reasons. This is useful when adding +new instructions to an existing pattern which are only available for +certain cpu architecture levels as specified with the @code{-march=} +option. + +If an insn alternative is disabled, then it will never be used. The +compiler treats the constraints for the disabled alternative as +unsatisfiable. + +In order to make use of the @code{enabled} attribute a back end has to add +in the machine description files: + +@enumerate +@item +A definition of the @code{enabled} insn attribute. The attribute is +defined as usual using the @code{define_attr} command. This +definition should be based on other insn attributes and/or target flags. +The @code{enabled} attribute is a numeric attribute and should evaluate to +@code{(const_int 1)} for an enabled alternative and to +@code{(const_int 0)} otherwise. +@item +A definition of another insn attribute used to describe for what +reason an insn alternative might be available or +not. E.g. @code{cpu_facility} as in the example below. +@item +An assignement for the second attribute to each insn definition +combining instructions which are not all available under the same +circumstances. (Note: It obviously only makes sense for definitions +with more than one alternative. Otherwise the insn pattern should be +disabled or enabled using the insn condition.) +@end enumerate + +E.g. the following two patterns could easily be merged using the @code{enabled} +attribute: + +@smallexample + +(define_insn "*movdi_old" + [(set (match_operand:DI 0 "register_operand" "=d") + (match_operand:DI 1 "register_operand" " d"))] + "!TARGET_NEW" + "lgr %0,%1") + +(define_insn "*movdi_new" + [(set (match_operand:DI 0 "register_operand" "=d,f,d") + (match_operand:DI 1 "register_operand" " d,d,f"))] + "TARGET_NEW" + "@@ + lgr %0,%1 + ldgr %0,%1 + lgdr %0,%1") + +@end smallexample + +to: + +@smallexample + +(define_insn "*movdi_combined" + [(set (match_operand:DI 0 "register_operand" "=d,f,d") + (match_operand:DI 1 "register_operand" " d,d,f"))] + "" + "@@ + lgr %0,%1 + ldgr %0,%1 + lgdr %0,%1" + [(set_attr "cpu_facility" "*,new,new")]) + +@end smallexample + +with the @code{enabled} attribute defined like this: + +@smallexample + +(define_attr "cpu_facility" "standard,new" (const_string "standard")) + +(define_attr "enabled" "" + (cond [(eq_attr "cpu_facility" "standard") (const_int 1) + (and (eq_attr "cpu_facility" "new") + (ne (symbol_ref "TARGET_NEW") (const_int 0))) + (const_int 1)] + (const_int 0))) + +@end smallexample + +@end ifset + +@ifset INTERNALS @node Define Constraints @subsection Defining Machine-Specific Constraints @cindex defining constraints @@ -6519,6 +6615,22 @@ If the attribute takes numeric values, no @code{enum} type will be defined and the function to obtain the attribute's value will return @code{int}. +There are attributes which are tied to a specific meaning. These +attributes are not free to use for other purposes: + +@table @code +@item length +The @code{length} attribute is used to calculate the length of emitted +code chunks. This is especially important when verifying branch +distances. @xref{Insn Lengths}. + +@item enabled +The @code{enabled} attribute can be defined to prevent certain +alternatives of an insn definition from being used during code +generation. @xref{Disable Insn Alternatives}. + +@end table + @end ifset @ifset INTERNALS @node Expressions diff --git a/gcc/doc/tm.texi b/gcc/doc/tm.texi index 8c0de3b41de..3e4d2b7b5bf 100644 --- a/gcc/doc/tm.texi +++ b/gcc/doc/tm.texi @@ -1172,6 +1172,21 @@ One use of this macro is to increase alignment of medium-size data to make it all fit in fewer cache lines. @end defmac +@defmac STACK_SLOT_ALIGNMENT (@var{type}, @var{mode}, @var{basic-align}) +If defined, a C expression to compute the alignment for stack slot. +@var{type} is the data type, @var{mode} is the widest mode available, +and @var{basic-align} is the alignment that the slot would ordinarily +have. The value of this macro is used instead of that alignment to +align the slot. + +If this macro is not defined, then @var{basic-align} is used when +@var{type} is @code{NULL}. Otherwise, @code{LOCAL_ALIGNMENT} will +be used. + +This macro is to set alignment of stack slot to the maximum alignment +of all possible modes which the slot may have. +@end defmac + @defmac EMPTY_FIELD_BOUNDARY Alignment in bits to be given to a structure bit-field that follows an empty field such as @code{int : 0;}. @@ -5300,6 +5315,17 @@ into the @code{symbol_ref}, and then check for it here. When you see a Format}. @end defmac +@defmac TARGET_MEM_CONSTRAINT +A single character to be used instead of the default @code{'m'} +character for general memory addresses. This defines the constraint +letter which matches the memory addresses accepted by +@code{GO_IF_LEGITIMATE_ADDRESS_P}. Define this macro if you want to +support new address formats in your back end without changing the +semantics of the @code{'m'} constraint. This is necessary in order to +preserve functionality of inline assembly constructs using the +@code{'m'} constraint. +@end defmac + @defmac FIND_BASE_TERM (@var{x}) A C expression to determine the base term of address @var{x}. This macro is used in only one place: `find_base_term' in alias.c. diff --git a/gcc/dwarf2out.c b/gcc/dwarf2out.c index 954114af58a..28db471c4c8 100644 --- a/gcc/dwarf2out.c +++ b/gcc/dwarf2out.c @@ -322,6 +322,14 @@ static GTY(()) unsigned fde_table_in_use; fde_table. */ #define FDE_TABLE_INCREMENT 256 +/* Get the current fde_table entry we should use. */ + +static inline dw_fde_ref +current_fde (void) +{ + return fde_table_in_use ? &fde_table[fde_table_in_use - 1] : NULL; +} + /* A list of call frame insns for the CIE. */ static GTY(()) dw_cfi_ref cie_cfi_head; @@ -648,7 +656,9 @@ add_fde_cfi (const char *label, dw_cfi_ref cfi) { if (label) { - dw_fde_ref fde = &fde_table[fde_table_in_use - 1]; + dw_fde_ref fde = current_fde (); + + gcc_assert (fde != NULL); if (*label == 0) label = dwarf2out_cfi_label (); @@ -720,6 +730,7 @@ static void lookup_cfa (dw_cfa_location *loc) { dw_cfi_ref cfi; + dw_fde_ref fde; loc->reg = INVALID_REGNUM; loc->offset = 0; @@ -729,12 +740,10 @@ lookup_cfa (dw_cfa_location *loc) for (cfi = cie_cfi_head; cfi; cfi = cfi->dw_cfi_next) lookup_cfa_1 (cfi, loc); - if (fde_table_in_use) - { - dw_fde_ref fde = &fde_table[fde_table_in_use - 1]; - for (cfi = fde->dw_fde_cfi; cfi; cfi = cfi->dw_cfi_next) - lookup_cfa_1 (cfi, loc); - } + fde = current_fde (); + if (fde) + for (cfi = fde->dw_fde_cfi; cfi; cfi = cfi->dw_cfi_next) + lookup_cfa_1 (cfi, loc); } /* The current rule for calculating the DWARF2 canonical frame address. */ @@ -2693,7 +2702,8 @@ dwarf2out_end_epilogue (unsigned int line ATTRIBUTE_UNUSED, ASM_GENERATE_INTERNAL_LABEL (label, FUNC_END_LABEL, current_function_funcdef_no); ASM_OUTPUT_LABEL (asm_out_file, label); - fde = &fde_table[fde_table_in_use - 1]; + fde = current_fde (); + gcc_assert (fde != NULL); fde->dw_fde_end = xstrdup (label); } @@ -2746,11 +2756,10 @@ dwarf2out_note_section_used (void) void dwarf2out_switch_text_section (void) { - dw_fde_ref fde; + dw_fde_ref fde = current_fde (); - gcc_assert (cfun); + gcc_assert (cfun && fde); - fde = &fde_table[fde_table_in_use - 1]; fde->dw_fde_switched_sections = true; fde->dw_fde_hot_section_label = crtl->subsections.hot_section_label; fde->dw_fde_hot_section_end_label = crtl->subsections.hot_section_end_label; @@ -11028,7 +11037,8 @@ convert_cfa_to_fb_loc_list (HOST_WIDE_INT offset) dw_cfa_location last_cfa, next_cfa; const char *start_label, *last_label, *section; - fde = &fde_table[fde_table_in_use - 1]; + fde = current_fde (); + gcc_assert (fde != NULL); section = secname_for_decl (current_function_decl); list_tail = &list; diff --git a/gcc/final.c b/gcc/final.c index b3185811ad6..5d19e2d2aba 100644 --- a/gcc/final.c +++ b/gcc/final.c @@ -178,12 +178,6 @@ CC_STATUS cc_status; CC_STATUS cc_prev_status; #endif -/* Nonzero means current function must be given a frame pointer. - Initialized in function.c to 0. Set only in reload1.c as per - the needs of the function. */ - -int frame_pointer_needed; - /* Number of unmatched NOTE_INSN_BLOCK_BEG notes we have seen. */ static int block_depth; diff --git a/gcc/fix-header.c b/gcc/fix-header.c index ac8a9bb0034..f691e4eae70 100644 --- a/gcc/fix-header.c +++ b/gcc/fix-header.c @@ -78,7 +78,7 @@ #include "obstack.h" #include "scan.h" #include "cpplib.h" -#include "c-incpath.h" +#include "incpath.h" #include "errors.h" #ifdef TARGET_EXTRA_INCLUDES diff --git a/gcc/flags.h b/gcc/flags.h index a9f5d19d77a..1be595105f8 100644 --- a/gcc/flags.h +++ b/gcc/flags.h @@ -230,12 +230,6 @@ extern int flag_dump_rtl_in_asm; /* Other basic status info about current function. */ -/* Nonzero means current function must be given a frame pointer. - Set in stmt.c if anything is allocated on the stack there. - Set in reload1.c if anything is allocated on the stack there. */ - -extern int frame_pointer_needed; - /* Nonzero if subexpressions must be evaluated from left-to-right. */ extern int flag_evaluation_order; diff --git a/gcc/fold-const.c b/gcc/fold-const.c index 4113dc45b21..25756bbb9c9 100644 --- a/gcc/fold-const.c +++ b/gcc/fold-const.c @@ -5736,17 +5736,17 @@ extract_muldiv_1 (tree t, tree c, enum tree_code code, tree wide_type, || BINARY_CLASS_P (op0) || VL_EXP_CLASS_P (op0) || EXPRESSION_CLASS_P (op0)) - /* ... and is unsigned, and its type is smaller than ctype, - then we cannot pass through as widening. */ - && ((TYPE_UNSIGNED (TREE_TYPE (op0)) + /* ... and has wrapping overflow, and its type is smaller + than ctype, then we cannot pass through as widening. */ + && ((TYPE_OVERFLOW_WRAPS (TREE_TYPE (op0)) && ! (TREE_CODE (TREE_TYPE (op0)) == INTEGER_TYPE && TYPE_IS_SIZETYPE (TREE_TYPE (op0))) - && (GET_MODE_SIZE (TYPE_MODE (ctype)) - > GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (op0))))) + && (TYPE_PRECISION (ctype) + > TYPE_PRECISION (TREE_TYPE (op0)))) /* ... or this is a truncation (t is narrower than op0), then we cannot pass through this narrowing. */ - || (GET_MODE_SIZE (TYPE_MODE (type)) - < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (op0)))) + || (TYPE_PRECISION (type) + < TYPE_PRECISION (TREE_TYPE (op0))) /* ... or signedness changes for division or modulus, then we cannot pass through this conversion. */ || (code != MULT_EXPR diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0161a2a79c9..cf05afcf665 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,85 @@ +2008-05-28 Janus Weil <janus@gcc.gnu.org> + + PR fortran/36325 + PR fortran/35830 + * interface.c (gfc_procedure_use): Enable argument checking for + external procedures with explicit interface. + * symbol.c (check_conflict): Fix conflict checking for externals. + (copy_formal_args): Fix handling of arrays. + * resolve.c (resolve_specific_f0, resolve_specific_s0): Fix handling + of intrinsics. + * parse.c (parse_interface): Non-abstract INTERFACE statement implies + EXTERNAL attribute. + +2008-05-28 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/36319 + * intrinsic.c (gfc_convert_chartype): Don't mark conversion + function as pure. + * trans-array.c (gfc_trans_array_ctor_element): Divide element + size by the size of one character to obtain length. + * iresolve.c (gfc_resolve_cshift): Call the _char4 variant when + appropriate. + (gfc_resolve_eoshift): Likewise. + * trans-intrinsic.c (gfc_conv_intrinsic_ctime): Minor beautification. + (gfc_conv_intrinsic_fdate): Minor beautification. + (gfc_conv_intrinsic_ttynam): Minor beautification. + (gfc_conv_intrinsic_minmax_char): Allow all character kinds. + (size_of_string_in_bytes): New function. + (gfc_conv_intrinsic_size): Call size_of_string_in_bytes for + character expressions. + (gfc_conv_intrinsic_sizeof): Likewise. + (gfc_conv_intrinsic_array_transfer): Likewise. + (gfc_conv_intrinsic_trim): Allow all character kinds. Minor + beautification. + (gfc_conv_intrinsic_repeat): Fix comment typo. + * simplify.c (gfc_convert_char_constant): Take care of conversion + of array constructors. + +2008-05-27 Tobias Burnus <burnus@net-b.de> + + PR fortran/36316 + * trans-array.c (gfc_set_loop_bounds_from_array_spec): + Add missing fold_convert. + +2008-05-26 Daniel Franke <franke.daniel@gmail.com> + + * fortran/cpp.c (cpp_define_builtins): Remove usage of TARGET_* macros, + added FIXME instead. + +2008-05-26 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/18428 + * lang.opt (A, C, CC, D, E, H, P, U, cpp, d, fworking-directory, + imultilib, iprefix, iquote, isysroot, isystem, nocpp, nostdinc, + o, undef, v): New options. + * options.c (gfc_init_options): Also initialize preprocessor + options. + (gfc_post_options): Also handle post-initialization of preprocessor + options. + (gfc_handle_option): Check if option is a preprocessor option. + If yes, let gfc_cpp_handle_option() handle the option. + * lang-specs.h: Reorganized to handle new options. + * scanner.c (gfc_new_file): Read temporary file instead of + input source if preprocessing is enabled. + * f95-lang.c (gfc_init): Initialize preprocessor. + (gfc_finish): Clean up preprocessor. + * cpp.c: New. + * cpp.h: New. + * Make-lang.in: Added new objects and dependencies. + * gfortran.texi: Updated section "Preprocessing and + conditional compilation". + * invoke.texi: Added new section "Preprocessing Options", + listed and documented the preprocessing options handled + by gfortran. + +2008-05-25 Tobias Burnus <burnus@net-b.de> + + PR fortran/32600 + * trans-expr.c (gfc_conv_function_call): Remove library + call for c_f_pointer with scalar Fortran pointers and for + c_f_procpointer. + 2008-05-21 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> PR fortran/36257 diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in index bc9947b3942..dbbed88bd60 100644 --- a/gcc/fortran/Make-lang.in +++ b/gcc/fortran/Make-lang.in @@ -53,9 +53,9 @@ fortran-warn = $(STRICT_WARN) # from the parse tree to GENERIC F95_PARSER_OBJS = fortran/arith.o fortran/array.o fortran/bbt.o \ - fortran/check.o fortran/data.o fortran/decl.o fortran/dump-parse-tree.o \ - fortran/error.o fortran/expr.o fortran/interface.o \ - fortran/intrinsic.o fortran/io.o fortran/iresolve.o \ + fortran/check.o fortran/cpp.o fortran/data.o fortran/decl.o \ + fortran/dump-parse-tree.o fortran/error.o fortran/expr.o \ + fortran/interface.o fortran/intrinsic.o fortran/io.o fortran/iresolve.o \ fortran/match.o fortran/matchexp.o fortran/misc.o fortran/module.o \ fortran/openmp.o fortran/options.o fortran/parse.o fortran/primary.o \ fortran/resolve.o fortran/scanner.o fortran/simplify.o fortran/st.o \ @@ -306,9 +306,9 @@ GFORTRAN_TRANS_DEPS = fortran/gfortran.h fortran/libgfortran.h \ $(CONFIG_H) $(SYSTEM_H) $(TREE_H) $(TM_H) coretypes.h $(GGC_H) fortran/f95-lang.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \ - gt-fortran-f95-lang.h gtype-fortran.h $(CGRAPH_H) $(TARGET_H) \ + gt-fortran-f95-lang.h gtype-fortran.h $(CGRAPH_H) $(TARGET_H) fortran/cpp.h \ $(BUILTINS_DEF) fortran/types.def -fortran/scanner.o: toplev.h +fortran/scanner.o: toplev.h fortran/cpp.h fortran/convert.o: $(GFORTRAN_TRANS_DEPS) fortran/trans.o: $(GFORTRAN_TRANS_DEPS) fortran/trans-decl.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-decl.h \ @@ -329,4 +329,7 @@ fortran/dependency.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h fortran/trans-common.o: $(GFORTRAN_TRANS_DEPS) $(TARGET_H) $(RTL_H) fortran/resolve.o: fortran/dependency.h fortran/data.h fortran/target-memory.h fortran/data.o: fortran/data.h -fortran/options.o: $(PARAMS_H) $(TARGET_H) +fortran/options.o: $(PARAMS_H) $(TARGET_H) fortran/cpp.h +fortran/cpp.o: fortran/cpp.c $(BASEVER) incpath.h incpath.o + $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) -DBASEVER=$(BASEVER_s) \ + $< $(OUTPUT_OPTION) diff --git a/gcc/fortran/cpp.c b/gcc/fortran/cpp.c new file mode 100644 index 00000000000..865e2efc79d --- /dev/null +++ b/gcc/fortran/cpp.c @@ -0,0 +1,1010 @@ +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "tree.h" +#include "version.h" +#include "flags.h" + + +#include "options.h" +#include "gfortran.h" +#include "tm_p.h" /* Target prototypes. */ +#include "target.h" +#include "toplev.h" +#include "diagnostic.h" + +#include "../../libcpp/internal.h" +#include "cpp.h" +#include "incpath.h" + +#ifndef TARGET_OS_CPP_BUILTINS +# define TARGET_OS_CPP_BUILTINS() +#endif + +#ifndef TARGET_OBJFMT_CPP_BUILTINS +# define TARGET_OBJFMT_CPP_BUILTINS() +#endif + + +/* Holds switches parsed by gfc_cpp_handle_option (), but whose + handling is deferred to gfc_cpp_init (). */ +typedef struct +{ + enum opt_code code; + const char *arg; +} +gfc_cpp_deferred_opt_t; + + +/* Defined and undefined macros being queued for output with -dU at + the next newline. */ +typedef struct gfc_cpp_macro_queue +{ + struct gfc_cpp_macro_queue *next; /* Next macro in the list. */ + char *macro; /* The name of the macro if not + defined, the full definition if + defined. */ +} gfc_cpp_macro_queue; +static gfc_cpp_macro_queue *cpp_define_queue, *cpp_undefine_queue; + +struct +{ + /* Argument of -cpp, implied by SPEC; + if NULL, preprocessing disabled. */ + const char *temporary_filename; + + const char *output_filename; /* -o <arg> */ + int preprocess_only; /* -E */ + int discard_comments; /* -C */ + int discard_comments_in_macro_exp; /* -CC */ + int print_include_names; /* -H */ + int no_line_commands; /* -P */ + char dump_macros; /* -d[DMNU] */ + int dump_includes; /* -dI */ + int working_directory; /* -fworking-directory */ + int no_predefined; /* -undef */ + int standard_include_paths; /* -nostdinc */ + int verbose; /* -v */ + + const char *multilib; /* -imultilib <dir> */ + const char *prefix; /* -iprefix <dir> */ + const char *sysroot; /* -isysroot <dir> */ + + /* Options whose handling needs to be deferred until the + appropriate cpp-objects are created: + -A predicate=answer + -D <macro>[=<val>] + -U <macro> */ + gfc_cpp_deferred_opt_t *deferred_opt; + int deferred_opt_count; +} +gfc_cpp_option; + +/* Structures used with libcpp: */ +static cpp_options *cpp_option = NULL; +static cpp_reader *cpp_in = NULL; + +/* Defined in toplev.c. */ +extern const char *asm_file_name; + + + + +/* Encapsulates state used to convert a stream of cpp-tokens into + a text file. */ +static struct +{ + FILE *outf; /* Stream to write to. */ + const cpp_token *prev; /* Previous token. */ + const cpp_token *source; /* Source token for spacing. */ + int src_line; /* Line number currently being written. */ + unsigned char printed; /* Nonzero if something output at line. */ + bool first_time; /* cb_file_change hasn't been called yet. */ +} print; + +/* General output routines. */ +static void scan_translation_unit (cpp_reader *); +static void scan_translation_unit_trad (cpp_reader *); + +/* Callback routines for the parser. Most of these are active only + in specific modes. */ +static void cb_file_change (cpp_reader *, const struct line_map *); +static void cb_line_change (cpp_reader *, const cpp_token *, int); +static void cb_define (cpp_reader *, source_location, cpp_hashnode *); +static void cb_undef (cpp_reader *, source_location, cpp_hashnode *); +static void cb_def_pragma (cpp_reader *, source_location); +static void cb_include (cpp_reader *, source_location, const unsigned char *, + const char *, int, const cpp_token **); +static void cb_ident (cpp_reader *, source_location, const cpp_string *); +static void cb_used_define (cpp_reader *, source_location, cpp_hashnode *); +static void cb_used_undef (cpp_reader *, source_location, cpp_hashnode *); +void pp_dir_change (cpp_reader *, const char *); + +static int dump_macro (cpp_reader *, cpp_hashnode *, void *); +static void dump_queued_macros (cpp_reader *); + + +static void +cpp_define_builtins (cpp_reader *pfile) +{ + int major, minor, patchlevel; + + /* Initialize CPP built-ins; '1' corresponds to 'flag_hosted' + in C, defines __STDC_HOSTED__?! */ + cpp_init_builtins (pfile, 0); + + /* Initialize GFORTRAN specific builtins. + These are documented. */ + if (sscanf (BASEVER, "%d.%d.%d", &major, &minor, &patchlevel) != 3) + { + sscanf (BASEVER, "%d.%d", &major, &minor); + patchlevel = 0; + } + cpp_define_formatted (pfile, "__GNUC__=%d", major); + cpp_define_formatted (pfile, "__GNUC_MINOR__=%d", minor); + cpp_define_formatted (pfile, "__GNUC_PATCHLEVEL__=%d", patchlevel); + + cpp_define (pfile, "__GFORTRAN__=1"); + cpp_define (pfile, "_LANGUAGE_FORTRAN=1"); + + if (gfc_option.flag_openmp) + cpp_define (pfile, "_OPENMP=200505"); + + + /* More builtins that might be useful, but are not documented + (in no particular order). */ + cpp_define_formatted (pfile, "__VERSION__=\"%s\"", version_string); + + if (flag_pic) + { + cpp_define_formatted (pfile, "__pic__=%d", flag_pic); + cpp_define_formatted (pfile, "__PIC__=%d", flag_pic); + } + if (flag_pie) + { + cpp_define_formatted (pfile, "__pie__=%d", flag_pie); + cpp_define_formatted (pfile, "__PIE__=%d", flag_pie); + } + + if (optimize_size) + cpp_define (pfile, "__OPTIMIZE_SIZE__"); + if (optimize) + cpp_define (pfile, "__OPTIMIZE__"); + + if (fast_math_flags_set_p ()) + cpp_define (pfile, "__FAST_MATH__"); + if (flag_signaling_nans) + cpp_define (pfile, "__SUPPORT_SNAN__"); + + cpp_define_formatted (pfile, "__FINITE_MATH_ONLY__=%d", flag_finite_math_only); + + /* Definitions for LP64 model. */ + if (TYPE_PRECISION (long_integer_type_node) == 64 + && POINTER_SIZE == 64 + && TYPE_PRECISION (integer_type_node) == 32) + { + cpp_define (pfile, "_LP64"); + cpp_define (pfile, "__LP64__"); + } + + /* Define NAME with value TYPE size_unit. + The C-side also defines __SIZEOF_WCHAR_T__, __SIZEOF_WINT_T__ + __SIZEOF_PTRDIFF_T__, however, fortran seems to lack the + appropriate type nodes. */ + +#define define_type_sizeof(NAME, TYPE) \ + cpp_define_formatted (pfile, NAME"="HOST_WIDE_INT_PRINT_DEC, \ + tree_low_cst (TYPE_SIZE_UNIT (TYPE), 1)) + + define_type_sizeof ("__SIZEOF_INT__", integer_type_node); + define_type_sizeof ("__SIZEOF_LONG__", long_integer_type_node); + define_type_sizeof ("__SIZEOF_LONG_LONG__", long_long_integer_type_node); + define_type_sizeof ("__SIZEOF_SHORT__", short_integer_type_node); + define_type_sizeof ("__SIZEOF_FLOAT__", float_type_node); + define_type_sizeof ("__SIZEOF_DOUBLE__", double_type_node); + define_type_sizeof ("__SIZEOF_LONG_DOUBLE__", long_double_type_node); + define_type_sizeof ("__SIZEOF_SIZE_T__", size_type_node); + +#undef define_type_sizeof + + /* The defines below are necessary for the TARGET_* macros. + + FIXME: Note that builtin_define_std() actually is a function + in c-cppbuiltin.c which uses flags undefined for Fortran. + Let's skip this for now. If needed, one needs to look into it + once more. */ + +# define builtin_define(TXT) cpp_define (pfile, TXT) +# define builtin_define_std(TXT) +# define builtin_assert(TXT) cpp_assert (pfile, TXT) + + /* FIXME: Pandora's Box + Using the macros below results in multiple breakages: + - mingw will fail to compile this file as dependent macros + assume to be used in c-cppbuiltin.c only. Further, they use + flags only valid/defined in C (same as noted above). + [config/i386/mingw32.h, config/i386/cygming.h] + - other platforms (not as popular) break similarly + [grep for 'builtin_define_with_int_value' in gcc/config/] + + TARGET_CPU_CPP_BUILTINS (); + TARGET_OS_CPP_BUILTINS (); + TARGET_OBJFMT_CPP_BUILTINS (); */ + +#undef builtin_define +#undef builtin_define_std +#undef builtin_assert +} + +bool +gfc_cpp_enabled (void) +{ + return gfc_cpp_option.temporary_filename != NULL; +} + +bool +gfc_cpp_preprocess_only (void) +{ + return gfc_cpp_option.preprocess_only; +} + +const char * +gfc_cpp_temporary_file (void) +{ + return gfc_cpp_option.temporary_filename; +} + +void +gfc_cpp_init_options (unsigned int argc, + const char **argv ATTRIBUTE_UNUSED) +{ + /* Do not create any objects from libcpp here. If no + preprocessing is requested, this would be wasted + time and effort. + + See gfc_cpp_post_options() instead. */ + + gfc_cpp_option.temporary_filename = NULL; + gfc_cpp_option.output_filename = NULL; + gfc_cpp_option.preprocess_only = 0; + gfc_cpp_option.discard_comments = 1; + gfc_cpp_option.discard_comments_in_macro_exp = 1; + gfc_cpp_option.print_include_names = 0; + gfc_cpp_option.no_line_commands = 0; + gfc_cpp_option.dump_macros = '\0'; + gfc_cpp_option.dump_includes = 0; + gfc_cpp_option.working_directory = -1; + gfc_cpp_option.no_predefined = 0; + gfc_cpp_option.standard_include_paths = 1; + gfc_cpp_option.verbose = 0; + + gfc_cpp_option.multilib = NULL; + gfc_cpp_option.prefix = NULL; + gfc_cpp_option.sysroot = NULL; + + gfc_cpp_option.deferred_opt = XNEWVEC (gfc_cpp_deferred_opt_t, argc); + gfc_cpp_option.deferred_opt_count = 0; +} + +int +gfc_cpp_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED) +{ + int result = 1; + enum opt_code code = (enum opt_code) scode; + + switch (code) + { + default: + result = 0; + break; + + case OPT_cpp: + gfc_cpp_option.temporary_filename = arg; + break; + + case OPT_nocpp: + gfc_cpp_option.temporary_filename = 0L; + break; + + case OPT_d: + for ( ; *arg; ++arg) + switch (*arg) + { + case 'D': + case 'M': + case 'N': + case 'U': + gfc_cpp_option.dump_macros = *arg; + break; + + case 'I': + gfc_cpp_option.dump_includes = 1; + break; + } + break; + + case OPT_fworking_directory: + gfc_cpp_option.working_directory = value; + break; + + case OPT_imultilib: + gfc_cpp_option.multilib = arg; + break; + + case OPT_iprefix: + gfc_cpp_option.prefix = arg; + break; + + case OPT_isysroot: + gfc_cpp_option.sysroot = arg; + break; + + case OPT_iquote: + case OPT_isystem: + gfc_cpp_add_include_path (xstrdup(arg), true); + break; + + case OPT_nostdinc: + gfc_cpp_option.standard_include_paths = value; + break; + + case OPT_o: + if (!gfc_cpp_option.output_filename) + gfc_cpp_option.output_filename = arg; + else + gfc_fatal_error ("output filename specified twice"); + break; + + case OPT_undef: + gfc_cpp_option.no_predefined = value; + break; + + case OPT_v: + gfc_cpp_option.verbose = value; + break; + + case OPT_A: + case OPT_D: + case OPT_U: + gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].code = code; + gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].arg = arg; + gfc_cpp_option.deferred_opt_count++; + break; + + case OPT_C: + gfc_cpp_option.discard_comments = 0; + break; + + case OPT_CC: + gfc_cpp_option.discard_comments = 0; + gfc_cpp_option.discard_comments_in_macro_exp = 0; + break; + + case OPT_E: + gfc_cpp_option.preprocess_only = 1; + break; + + case OPT_H: + gfc_cpp_option.print_include_names = 1; + break; + + case OPT_P: + gfc_cpp_option.no_line_commands = 1; + break; + } + + return result; +} + + +void +gfc_cpp_post_options (void) +{ + /* Any preprocessing-related option without '-cpp' is considered + an error. */ + if (!gfc_cpp_enabled () + && (gfc_cpp_preprocess_only () + || !gfc_cpp_option.discard_comments + || !gfc_cpp_option.discard_comments_in_macro_exp + || gfc_cpp_option.print_include_names + || gfc_cpp_option.no_line_commands + || gfc_cpp_option.dump_macros + || gfc_cpp_option.dump_includes)) + gfc_fatal_error("To enable preprocessing, use -cpp"); + + cpp_in = cpp_create_reader (CLK_GNUC89, NULL, line_table); + if (!gfc_cpp_enabled()) + return; + + gcc_assert (cpp_in); + + /* The cpp_options-structure defines far more flags than those set here. + If any other is implemented, see c-opt.c (sanitize_cpp_opts) for + inter-option dependencies that may need to be enforced. */ + cpp_option = cpp_get_options (cpp_in); + gcc_assert (cpp_option); + + /* TODO: allow non-traditional modes, e.g. by -cpp-std=...? */ + cpp_option->traditional = 1; + cpp_option->cplusplus_comments = 0; + + cpp_option->pedantic = pedantic; + cpp_option->inhibit_warnings = inhibit_warnings; + + cpp_option->dollars_in_ident = gfc_option.flag_dollar_ok; + cpp_option->discard_comments = gfc_cpp_option.discard_comments; + cpp_option->discard_comments_in_macro_exp = gfc_cpp_option.discard_comments_in_macro_exp; + cpp_option->print_include_names = gfc_cpp_option.print_include_names; + cpp_option->preprocessed = gfc_option.flag_preprocessed; + + if (gfc_cpp_option.working_directory == -1) + gfc_cpp_option.working_directory = (debug_info_level != DINFO_LEVEL_NONE); + + cpp_post_options (cpp_in); + + /* If an error has occurred in cpplib, note it so we fail immediately. */ + errorcount += cpp_errors (cpp_in); + + gfc_cpp_register_include_paths (); +} + + +void +gfc_cpp_init_0 (void) +{ + struct cpp_callbacks *cb; + + cb = cpp_get_callbacks (cpp_in); + cb->file_change = cb_file_change; + cb->line_change = cb_line_change; + cb->ident = cb_ident; + cb->def_pragma = cb_def_pragma; + + if (gfc_cpp_option.dump_includes) + cb->include = cb_include; + + if ((gfc_cpp_option.dump_macros == 'D') + || (gfc_cpp_option.dump_macros == 'N')) + { + cb->define = cb_define; + cb->undef = cb_undef; + } + + if (gfc_cpp_option.dump_macros == 'U') + { + cb->before_define = dump_queued_macros; + cb->used_define = cb_used_define; + cb->used_undef = cb_used_undef; + } + + /* Initialize the print structure. Setting print.src_line to -1 here is + a trick to guarantee that the first token of the file will cause + a linemarker to be output by maybe_print_line. */ + print.src_line = -1; + print.printed = 0; + print.prev = 0; + print.first_time = 1; + + if (gfc_cpp_preprocess_only ()) + { + if (gfc_cpp_option.output_filename) + { + /* This needs cheating: with "-E -o <file>", the user wants the + preprocessed output in <file>. However, if nothing is done + about it <file> is also used for assembler output. Hence, it + is necessary to redirect assembler output (actually nothing + as -E implies -fsyntax-only) to another file, otherwise the + output from preprocessing is lost. */ + asm_file_name = gfc_cpp_option.temporary_filename; + + print.outf = fopen (gfc_cpp_option.output_filename, "w"); + if (print.outf == NULL) + gfc_fatal_error ("opening output file %s: %s", + gfc_cpp_option.output_filename, strerror(errno)); + } + else + print.outf = stdout; + } + else + { + print.outf = fopen (gfc_cpp_option.temporary_filename, "w"); + if (print.outf == NULL) + gfc_fatal_error ("opening output file %s: %s", + gfc_cpp_option.temporary_filename, strerror(errno)); + } + + gcc_assert(cpp_in); + if (!cpp_read_main_file (cpp_in, gfc_source_file)) + errorcount++; +} + +void +gfc_cpp_init (void) +{ + int i; + + cpp_change_file (cpp_in, LC_RENAME, _("<built-in>")); + if (!gfc_cpp_option.no_predefined) + cpp_define_builtins (cpp_in); + + /* Handle deferred options from command-line. */ + cpp_change_file (cpp_in, LC_RENAME, _("<command-line>")); + + for (i = 0; i < gfc_cpp_option.deferred_opt_count; i++) + { + gfc_cpp_deferred_opt_t *opt = &gfc_cpp_option.deferred_opt[i]; + + if (opt->code == OPT_D) + cpp_define (cpp_in, opt->arg); + else if (opt->code == OPT_U) + cpp_undef (cpp_in, opt->arg); + else if (opt->code == OPT_A) + { + if (opt->arg[0] == '-') + cpp_unassert (cpp_in, opt->arg + 1); + else + cpp_assert (cpp_in, opt->arg); + } + } + + if (gfc_cpp_option.working_directory + && gfc_cpp_option.preprocess_only && !gfc_cpp_option.no_line_commands) + pp_dir_change (cpp_in, get_src_pwd ()); +} + +try +gfc_cpp_preprocess (const char *source_file) +{ + if (!gfc_cpp_enabled ()) + return FAILURE; + + cpp_change_file (cpp_in, LC_RENAME, source_file); + + if (cpp_option->traditional) + scan_translation_unit_trad (cpp_in); + else + scan_translation_unit (cpp_in); + + /* -dM command line option. */ + if (gfc_cpp_preprocess_only () && + gfc_cpp_option.dump_macros == 'M') + { + putc ('\n', print.outf); + cpp_forall_identifiers (cpp_in, dump_macro, NULL); + } + + if (!gfc_cpp_preprocess_only () + || (gfc_cpp_preprocess_only () && gfc_cpp_option.output_filename)) + fclose (print.outf); + + return SUCCESS; +} + +void +gfc_cpp_done (void) +{ + if (!gfc_cpp_enabled ()) + return; + + /* TODO: if dependency tracking was enabled, call + cpp_finish() here to write dependencies. + + Use cpp_get_deps() to access the current source's + dependencies during parsing. Add dependencies using + the mkdeps-interface (defined in libcpp). */ + + gcc_assert (cpp_in); + cpp_undef_all (cpp_in); + cpp_clear_file_cache (cpp_in); +} + +/* PATH must be malloc-ed and NULL-terminated. */ +void +gfc_cpp_add_include_path (char *path, bool user_supplied) +{ + /* CHAIN sets cpp_dir->sysp which differs from 0 if PATH is a system + include path. Fortran does not define any system include paths. */ + int chain = 0; + int cxx_aware = 0; + + add_path (path, chain, cxx_aware, user_supplied); +} + +void +gfc_cpp_register_include_paths (void) +{ + int cxx_stdinc = 0; + register_include_chains (cpp_in, gfc_cpp_option.sysroot, + gfc_cpp_option.prefix, gfc_cpp_option.multilib, + gfc_cpp_option.standard_include_paths, cxx_stdinc, + gfc_cpp_option.verbose); +} + + + +static void scan_translation_unit_trad (cpp_reader *); +static void account_for_newlines (const unsigned char *, size_t); +static int dump_macro (cpp_reader *, cpp_hashnode *, void *); + +static void print_line (source_location, const char *); +static void maybe_print_line (source_location); + + +/* Writes out the preprocessed file, handling spacing and paste + avoidance issues. */ +static void +scan_translation_unit (cpp_reader *pfile) +{ + bool avoid_paste = false; + + print.source = NULL; + for (;;) + { + const cpp_token *token = cpp_get_token (pfile); + + if (token->type == CPP_PADDING) + { + avoid_paste = true; + if (print.source == NULL + || (!(print.source->flags & PREV_WHITE) + && token->val.source == NULL)) + print.source = token->val.source; + continue; + } + + if (token->type == CPP_EOF) + break; + + /* Subtle logic to output a space if and only if necessary. */ + if (avoid_paste) + { + if (print.source == NULL) + print.source = token; + if (print.source->flags & PREV_WHITE + || (print.prev + && cpp_avoid_paste (pfile, print.prev, token)) + || (print.prev == NULL && token->type == CPP_HASH)) + putc (' ', print.outf); + } + else if (token->flags & PREV_WHITE) + putc (' ', print.outf); + + avoid_paste = false; + print.source = NULL; + print.prev = token; + cpp_output_token (token, print.outf); + + if (token->type == CPP_COMMENT) + account_for_newlines (token->val.str.text, token->val.str.len); + } +} + +/* Adjust print.src_line for newlines embedded in output. */ +static void +account_for_newlines (const unsigned char *str, size_t len) +{ + while (len--) + if (*str++ == '\n') + print.src_line++; +} + +/* Writes out a traditionally preprocessed file. */ +static void +scan_translation_unit_trad (cpp_reader *pfile) +{ + while (_cpp_read_logical_line_trad (pfile)) + { + size_t len = pfile->out.cur - pfile->out.base; + maybe_print_line (pfile->out.first_line); + fwrite (pfile->out.base, 1, len, print.outf); + print.printed = 1; + if (!CPP_OPTION (pfile, discard_comments)) + account_for_newlines (pfile->out.base, len); + } +} + +/* If the token read on logical line LINE needs to be output on a + different line to the current one, output the required newlines or + a line marker. */ +static void +maybe_print_line (source_location src_loc) +{ + const struct line_map *map = linemap_lookup (line_table, src_loc); + int src_line = SOURCE_LINE (map, src_loc); + + /* End the previous line of text. */ + if (print.printed) + { + putc ('\n', print.outf); + print.src_line++; + print.printed = 0; + } + + if (src_line >= print.src_line && src_line < print.src_line + 8) + { + while (src_line > print.src_line) + { + putc ('\n', print.outf); + print.src_line++; + } + } + else + print_line (src_loc, ""); +} + +/* Output a line marker for logical line LINE. Special flags are "1" + or "2" indicating entering or leaving a file. */ +static void +print_line (source_location src_loc, const char *special_flags) +{ + /* End any previous line of text. */ + if (print.printed) + putc ('\n', print.outf); + print.printed = 0; + + if (!gfc_cpp_option.no_line_commands) + { + const struct line_map *map = linemap_lookup (line_table, src_loc); + + size_t to_file_len = strlen (map->to_file); + unsigned char *to_file_quoted = + (unsigned char *) alloca (to_file_len * 4 + 1); + unsigned char *p; + + print.src_line = SOURCE_LINE (map, src_loc); + + /* cpp_quote_string does not nul-terminate, so we have to do it + ourselves. */ + p = cpp_quote_string (to_file_quoted, + (const unsigned char *) map->to_file, to_file_len); + *p = '\0'; + fprintf (print.outf, "# %u \"%s\"%s", + print.src_line == 0 ? 1 : print.src_line, + to_file_quoted, special_flags); + + if (map->sysp == 2) + fputs (" 3 4", print.outf); + else if (map->sysp == 1) + fputs (" 3", print.outf); + + putc ('\n', print.outf); + } +} + +static void +cb_file_change (cpp_reader * ARG_UNUSED (pfile), const struct line_map *map) +{ + const char *flags = ""; + + if (gfc_cpp_option.no_line_commands) + return; + + if (!map) + return; + + if (print.first_time) + { + /* Avoid printing foo.i when the main file is foo.c. */ + if (!cpp_get_options (cpp_in)->preprocessed) + print_line (map->start_location, flags); + print.first_time = 0; + } + else + { + /* Bring current file to correct line when entering a new file. */ + if (map->reason == LC_ENTER) + { + const struct line_map *from = INCLUDED_FROM (line_table, map); + maybe_print_line (LAST_SOURCE_LINE_LOCATION (from)); + } + if (map->reason == LC_ENTER) + flags = " 1"; + else if (map->reason == LC_LEAVE) + flags = " 2"; + print_line (map->start_location, flags); + } + +} + +/* Called when a line of output is started. TOKEN is the first token + of the line, and at end of file will be CPP_EOF. */ +static void +cb_line_change (cpp_reader *pfile, const cpp_token *token, + int parsing_args) +{ + source_location src_loc = token->src_loc; + + if (token->type == CPP_EOF || parsing_args) + return; + + maybe_print_line (src_loc); + print.prev = 0; + print.source = 0; + + /* Supply enough spaces to put this token in its original column, + one space per column greater than 2, since scan_translation_unit + will provide a space if PREV_WHITE. Don't bother trying to + reconstruct tabs; we can't get it right in general, and nothing + ought to care. Some things do care; the fault lies with them. */ + if (!CPP_OPTION (pfile, traditional)) + { + const struct line_map *map = linemap_lookup (line_table, src_loc); + int spaces = SOURCE_COLUMN (map, src_loc) - 2; + print.printed = 1; + + while (-- spaces >= 0) + putc (' ', print.outf); + } +} + +static void +cb_ident (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line, + const cpp_string *str) +{ + maybe_print_line (line); + fprintf (print.outf, "#ident %s\n", str->text); + print.src_line++; +} + +static void +cb_define (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line, + cpp_hashnode *node ATTRIBUTE_UNUSED) +{ + maybe_print_line (line); + fputs ("#define ", print.outf); + + /* 'D' is whole definition; 'N' is name only. */ + if (gfc_cpp_option.dump_macros == 'D') + fputs ((const char *) cpp_macro_definition (pfile, node), + print.outf); + else + fputs ((const char *) NODE_NAME (node), print.outf); + + putc ('\n', print.outf); + if (linemap_lookup (line_table, line)->to_line != 0) + print.src_line++; +} + +static void +cb_undef (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line, + cpp_hashnode *node) +{ + maybe_print_line (line); + fprintf (print.outf, "#undef %s\n", NODE_NAME (node)); + print.src_line++; +} + +static void +cb_include (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line, + const unsigned char *dir, const char *header, int angle_brackets, + const cpp_token **comments) +{ + maybe_print_line (line); + if (angle_brackets) + fprintf (print.outf, "#%s <%s>", dir, header); + else + fprintf (print.outf, "#%s \"%s\"", dir, header); + + if (comments != NULL) + { + while (*comments != NULL) + { + if ((*comments)->flags & PREV_WHITE) + putc (' ', print.outf); + cpp_output_token (*comments, print.outf); + ++comments; + } + } + + putc ('\n', print.outf); + print.src_line++; +} + +/* Dump out the hash table. */ +static int +dump_macro (cpp_reader *pfile, cpp_hashnode *node, void *v ATTRIBUTE_UNUSED) +{ + if (node->type == NT_MACRO && !(node->flags & NODE_BUILTIN)) + { + fputs ("#define ", print.outf); + fputs ((const char *) cpp_macro_definition (pfile, node), + print.outf); + putc ('\n', print.outf); + print.src_line++; + } + + return 1; +} + +static void +cb_used_define (cpp_reader *pfile, source_location line ATTRIBUTE_UNUSED, + cpp_hashnode *node) +{ + gfc_cpp_macro_queue *q; + q = XNEW (gfc_cpp_macro_queue); + q->macro = xstrdup ((const char *) cpp_macro_definition (pfile, node)); + q->next = cpp_define_queue; + cpp_define_queue = q; +} + + +/* Callback called when -fworking-director and -E to emit working + directory in cpp output file. */ + +void +pp_dir_change (cpp_reader *pfile ATTRIBUTE_UNUSED, const char *dir) +{ + size_t to_file_len = strlen (dir); + unsigned char *to_file_quoted = + (unsigned char *) alloca (to_file_len * 4 + 1); + unsigned char *p; + + /* cpp_quote_string does not nul-terminate, so we have to do it ourselves. */ + p = cpp_quote_string (to_file_quoted, (const unsigned char *) dir, to_file_len); + *p = '\0'; + fprintf (print.outf, "# 1 \"%s//\"\n", to_file_quoted); +} + +/* Copy a #pragma directive to the preprocessed output. */ +static void +cb_def_pragma (cpp_reader *pfile, source_location line) +{ + maybe_print_line (line); + fputs ("#pragma ", print.outf); + cpp_output_line (pfile, print.outf); + print.src_line++; +} + +static void +cb_used_undef (cpp_reader *pfile ATTRIBUTE_UNUSED, + source_location line ATTRIBUTE_UNUSED, + cpp_hashnode *node) +{ + gfc_cpp_macro_queue *q; + q = XNEW (gfc_cpp_macro_queue); + q->macro = xstrdup ((const char *) NODE_NAME (node)); + q->next = cpp_undefine_queue; + cpp_undefine_queue = q; +} + +static void +dump_queued_macros (cpp_reader *pfile ATTRIBUTE_UNUSED) +{ + gfc_cpp_macro_queue *q; + + /* End the previous line of text. */ + if (print.printed) + { + putc ('\n', print.outf); + print.src_line++; + print.printed = 0; + } + + for (q = cpp_define_queue; q;) + { + gfc_cpp_macro_queue *oq; + fputs ("#define ", print.outf); + fputs (q->macro, print.outf); + putc ('\n', print.outf); + print.src_line++; + oq = q; + q = q->next; + gfc_free (oq->macro); + gfc_free (oq); + } + cpp_define_queue = NULL; + for (q = cpp_undefine_queue; q;) + { + gfc_cpp_macro_queue *oq; + fprintf (print.outf, "#undef %s\n", q->macro); + print.src_line++; + oq = q; + q = q->next; + gfc_free (oq->macro); + gfc_free (oq); + } + cpp_undefine_queue = NULL; +} + + diff --git a/gcc/fortran/cpp.h b/gcc/fortran/cpp.h new file mode 100644 index 00000000000..e82b3cd1d43 --- /dev/null +++ b/gcc/fortran/cpp.h @@ -0,0 +1,29 @@ +#ifndef GFC_CPP_H +#define GFC_CPP_H + +/* Returns true if preprocessing is enabled, false otherwise. */ +bool gfc_cpp_enabled (void); + +bool gfc_cpp_preprocess_only (void); + +const char *gfc_cpp_temporary_file (void); + + +void gfc_cpp_init_0 (void); +void gfc_cpp_init (void); + +void gfc_cpp_init_options (unsigned int argc, const char **argv); + +int gfc_cpp_handle_option(size_t scode, const char *arg, int value); + +void gfc_cpp_post_options (void); + +try gfc_cpp_preprocess (const char *source_file); + +void gfc_cpp_done (void); + +void gfc_cpp_add_include_path (char *path, bool user_supplied); + +void gfc_cpp_register_include_paths (void); + +#endif /* GFC_CPP_H */ diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index 58e31279156..63c380b61ea 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -45,6 +45,7 @@ along with GCC; see the file COPYING3. If not see #include "cgraph.h" #include "gfortran.h" +#include "cpp.h" #include "trans.h" #include "trans-types.h" #include "trans-const.h" @@ -275,18 +276,25 @@ gfc_be_parse_file (int set_yydebug ATTRIBUTE_UNUSED) static bool gfc_init (void) { - linemap_add (line_table, LC_ENTER, false, gfc_source_file, 1); - linemap_add (line_table, LC_RENAME, false, "<built-in>", 0); + if (!gfc_cpp_enabled ()) + { + linemap_add (line_table, LC_ENTER, false, gfc_source_file, 1); + linemap_add (line_table, LC_RENAME, false, "<built-in>", 0); + } + else + gfc_cpp_init_0 (); - /* First initialize the backend. */ gfc_init_decl_processing (); gfc_static_ctors = NULL_TREE; - /* Then the frontend. */ + if (gfc_cpp_enabled ()) + gfc_cpp_init (); + gfc_init_1 (); if (gfc_new_file () != SUCCESS) fatal_error ("can't open input file: %s", gfc_source_file); + return true; } @@ -294,6 +302,7 @@ gfc_init (void) static void gfc_finish (void) { + gfc_cpp_done (); gfc_done_1 (); gfc_release_include_path (); return; diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 085de7668da..c47f22fcfa0 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -408,11 +408,11 @@ through a C preprocessor (CPP; sometimes also called the Fortran preprocessor, FPP) to allow for conditional compilation. In the case of GNU Fortran, this is the GNU C Preprocessor in the traditional mode. On systems with case-preserving file names, the preprocessor is automatically invoked if the -file extension is @code{.F}, @code{.FOR}, @code{.FTN}, @code{.F90}, -@code{.F95}, @code{.F03} or @code{.F08}; otherwise use for fixed-format -code the option @code{-x f77-cpp-input} and for free-format code @code{-x -f95-cpp-input}. Invocation of the preprocessor can be suppressed using -@code{-x f77} or @code{-x f95}. +filename extension is @code{.F}, @code{.FOR}, @code{.FTN}, @code{.fpp}, +@code{.FPP}, @code{.F90}, @code{.F95}, @code{.F03} or @code{.F08}. To manually +invoke the preprocessor on any file, use @option{-cpp}, to disable +preprocessing on files where the preprocessor is run automatically, use +@option{-nocpp}. If the GNU Fortran invoked the preprocessor, @code{__GFORTRAN__} is defined and @code{__GNUC__}, @code{__GNUC_MINOR__} and diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index f70cedba949..f2ad4f6734e 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2421,8 +2421,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) } } - if (sym->attr.external - || sym->attr.if_source == IFSRC_UNKNOWN) + if (sym->attr.if_source == IFSRC_UNKNOWN) { gfc_actual_arglist *a; for (a = *ap; a; a = a->next) diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index e902f693f6b..62ee442a19c 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -3807,7 +3807,6 @@ gfc_convert_chartype (gfc_expr *expr, gfc_typespec *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); diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 88ede3b2a13..1494c04013e 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -94,6 +94,7 @@ one is not the default. without explanations. * Fortran Dialect Options:: Controlling the variant of Fortran language compiled. +* Preprocessing Options:: Enable and customize preprocessing. * Error and Warning Options:: How picky should the compiler be? * Debugging Options:: Symbol tables, measurements, and debugging dumps. * Directory Options:: Where to find module files @@ -123,6 +124,14 @@ by type. Explanations are in the following sections. -fdefault-double-8 -fdefault-integer-8 -fdefault-real-8 @gol -fcray-pointer -fopenmp -fno-range-check -fbackslash -fmodule-private} +@item Preprocessing Options +@xref{Preprocessing Options,,Enable and customize preprocessing}. +@gccoptlist{-cpp -dD -dI -dM -dN -dU -fworking-directory @gol +-imultilib @var{dir} -iprefix @var{file} -isysroot @var{dir} @gol +-iquote -isystem @var{dir} -nocpp -nostdinc -undef @gol +-A@var{question}=@var{answer} -A-@var{question}@r{[}=@var{answer}@r{]} @gol +-C -CC -D@var{macro}@r{[}=@var{defn}@r{]} -U@var{macro} -H -P} + @item Error and Warning Options @xref{Error and Warning Options,,Options to request or suppress errors and warnings}. @@ -164,6 +173,7 @@ and warnings}. @menu * Fortran Dialect Options:: Controlling the variant of Fortran language compiled. +* Preprocessing Options:: Enable and customize preprocessing. * Error and Warning Options:: How picky should the compiler be? * Debugging Options:: Symbol tables, measurements, and debugging dumps. * Directory Options:: Where to find module files @@ -341,6 +351,238 @@ that are permitted but obsolescent in later standards. @end table +@node Preprocessing Options +@section Enable and customize preprocessing +@cindex preprocessor +@cindex options, preprocessor +@cindex CPP + +Preprocessor related options. See section +@ref{Preprocessing and conditional compilation} for more detailed +information on preprocessing in @command{gfortran}. + +@table @gcctabopt +@item -cpp +@item -nocpp +@opindex @code{cpp} +@opindex @code{fpp} +@cindex preprocessor, enable +@cindex preprocessor, disable +Enable preprocessing. The preprocessor is automatically invoked if +the file extension is @file{.fpp}, @file{.FPP}, @file{.F}, @file{.FOR}, +@file{.FTN}, @file{.F90}, @file{.F95}, @file{.F03} or @file{.F08}. Use +this option to manually enable preprocessing of any kind of Fortran file. + +To disable preprocessing of files with any of the above listed extensions, +use the negative form: @option{-nocpp}. + +The preprocessor is run in traditional mode, be aware that any +restrictions of the file-format, e.g. fixed-form line width, +apply for preprocessed output as well. + +@item -dM +@opindex @code{dM} +@cindex preprocessor, debugging +@cindex debugging, preprocessor +Instead of the normal output, generate a list of @code{'#define'} +directives for all the macros defined during the execution of the +preprocessor, including predefined macros. This gives you a way +of finding out what is predefined in your version of the preprocessor. +Assuming you have no file @file{foo.f90}, the command +@smallexample + touch foo.f90; gfortran -cpp -dM foo.f90 +@end smallexample +will show all the predefined macros. + +@item -dD +@opindex @code{dD} +@cindex preprocessor, debugging +@cindex debugging, preprocessor +Like @option{-dM} except in two respects: it does not include the +predefined macros, and it outputs both the @code{#define} directives +and the result of preprocessing. Both kinds of output go to the +standard output file. + +@item -dN +@opindex @code{dN} +@cindex preprocessor, debugging +@cindex debugging, preprocessor +Like @option{-dD}, but emit only the macro names, not their expansions. + +@item -dU +@opindex @code{dU} +@cindex preprocessor, debugging +@cindex debugging, preprocessor +Like @option{dD} except that only macros that are expanded, or whose +definedness is tested in preprocessor directives, are output; the +output is delayed until the use or test of the macro; and @code{'#undef'} +directives are also output for macros tested but undefined at the time. + +@item -dI +@opindex @code{dI} +@cindex preprocessor, debugging +@cindex debugging, preprocessor +Output @code{'#include'} directives in addition to the result +of preprocessing. + +@item -fworking-directory +@opindex @code{fworking-directory} +@cindex preprocessor, working directory +Enable generation of linemarkers in the preprocessor output that will +let the compiler know the current working directory at the time of +preprocessing. When this option is enabled, the preprocessor will emit, +after the initial linemarker, a second linemarker with the current +working directory followed by two slashes. GCC will use this directory, +when it's present in the preprocessed input, as the directory emitted +as the current working directory in some debugging information formats. +This option is implicitly enabled if debugging information is enabled, +but this can be inhibited with the negated form +@option{-fno-working-directory}. If the @option{-P} flag is present +in the command line, this option has no effect, since no @code{#line} +directives are emitted whatsoever. + +@item -imultilib @var{dir} +@opindex @code{imultilib @var{dir}} +@cindex preprocessing, include path +Use @var{dir} as a subdirectory of the directory containing target-specific +C++ headers. + +@item -iprefix @var{prefix} +@opindex @code{iprefix @var{prefix}} +@cindex preprocessing, include path +Specify @var{prefix} as the prefix for subsequent @option{-iwithprefix} +options. If the @var{prefix} represents a directory, you should include +the final @code{'/'}. + +@item -isysroot @var{dir} +@opindex @code{isysroot @var{dir}} +@cindex preprocessing, include path +This option is like the @option{--sysroot} option, but applies only to +header files. See the @option{--sysroot} option for more information. + +@item -iquote @var{dir} +@opindex @code{iquote @var{dir}} +@cindex preprocessing, include path +Search @var{dir} only for header files requested with @code{#include "file"}; +they are not searched for @code{#include <file>}, before all directories +specified by @option{-I} and before the standard system directories. If +@var{dir} begins with @code{=}, then the @code{=} will be replaced by the +sysroot prefix; see @option{--sysroot} and @option{-isysroot}. + +@item -isystem @var{dir} +@opindex @code{isystem @var{dir}} +@cindex preprocessing, include path +Search @var{dir} for header files, after all directories specified by +@option{-I} but before the standard system directories. Mark it as a +system directory, so that it gets the same special treatment as is +applied to the standard system directories. If @var{dir} begins with +@code{=}, then the @code{=} will be replaced by the sysroot prefix; +see @option{--sysroot} and @option{-isysroot}. + +@item -nostdinc +@opindex @code{nostdinc} +Do not search the standard system directories for header files. Only +the directories you have specified with @option{-I} options (and the +directory of the current file, if appropriate) are searched. + +@item -undef +@opindex @code{undef} +Do not predefine any system-specific or GCC-specific macros. +The standard predefined macros remain defined. + +@item -A@var{predicate}=@var{answer} +@opindex @code{A@var{predicate}=@var{answer}} +@cindex preprocessing, assertation +Make an assertion with the predicate @var{predicate} and answer @var{answer}. +This form is preferred to the older form -A predicate(answer), which is still +supported, because it does not use shell special characters. + +@item -A-@var{predicate}=@var{answer} +@opindex @code{A-@var{predicate}=@var{answer}} +@cindex preprocessing, assertation +Cancel an assertion with the predicate @var{predicate} and answer @var{answer}. + +@item -C +@opindex @code{C} +@cindex preprocessing, keep comments +Do not discard comments. All comments are passed through to the output +file, except for comments in processed directives, which are deleted +along with the directive. + +You should be prepared for side effects when using @option{-C}; it causes +the preprocessor to treat comments as tokens in their own right. For example, +comments appearing at the start of what would be a directive line have the +effect of turning that line into an ordinary source line, since the first +token on the line is no longer a @code{'#'}. + +Warning: this currently handles C-Style comments only. The preprocessor +does not yet recognize Fortran-style comments. + +@item -CC +@opindex @code{CC} +@cindex preprocessing, keep comments +Do not discard comments, including during macro expansion. This is like +@option{-C}, except that comments contained within macros are also passed +through to the output file where the macro is expanded. + +In addition to the side-effects of the @option{-C} option, the @option{-CC} +option causes all C++-style comments inside a macro to be converted to C-style +comments. This is to prevent later use of that macro from inadvertently +commenting out the remainder of the source line. The @option{-CC} option +is generally used to support lint comments. + +Warning: this currently handles C- and C++-Style comments only. The +preprocessor does not yet recognize Fortran-style comments. + +@item -D@var{name} +@opindex @code{D@var{name}} +@cindex preprocessing, define macros +Predefine name as a macro, with definition @code{1}. + +@item -D@var{name}=@var{definition} +@opindex @code{D@var{name}=@var{definition}} +@cindex preprocessing, define macros +The contents of @var{definition} are tokenized and processed as if they +appeared during translation phase three in a @code{'#define'} directive. +In particular, the definition will be truncated by embedded newline +characters. + +If you are invoking the preprocessor from a shell or shell-like program +you may need to use the shell's quoting syntax to protect characters such +as spaces that have a meaning in the shell syntax. + +If you wish to define a function-like macro on the command line, write +its argument list with surrounding parentheses before the equals sign +(if any). Parentheses are meaningful to most shells, so you will need +to quote the option. With sh and csh, @code{-D'name(args...)=definition'} +works. + +@option{-D} and @option{-U} options are processed in the order they are +given on the command line. All -imacros file and -include file options +are processed after all -D and -U options. + +@item -H +@opindex @code{H} +Print the name of each header file used, in addition to other normal +activities. Each name is indented to show how deep in the @code{'#include'} +stack it is. + +@item -P +@opindex @code{P} +@cindex preprocessing, no linemarkers +Inhibit generation of linemarkers in the output from the preprocessor. +This might be useful when running the preprocessor on something that +is not C code, and will be sent to a program which might be confused +by the linemarkers. + +@item -U@var{name} +@opindex @code{U@var{name}} +@cindex preprocessing, undefine macros +Cancel any previous definition of @var{name}, either built in or provided +with a @option{-D} option. +@end table + + @node Error and Warning Options @section Options to request or suppress errors and warnings @cindex options, warnings diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 94ed4a67baf..acbf5becff0 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -627,9 +627,19 @@ gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, } } - f->value.function.name - = gfc_get_string (PREFIX ("cshift%d_%d%s"), n, shift->ts.kind, - array->ts.type == BT_CHARACTER ? "_char" : ""); + if (array->ts.type == BT_CHARACTER) + { + if (array->ts.kind == gfc_default_character_kind) + f->value.function.name + = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind); + else + f->value.function.name + = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind, + array->ts.kind); + } + else + f->value.function.name + = gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind); } @@ -768,9 +778,19 @@ gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, } } - f->value.function.name - = gfc_get_string (PREFIX ("eoshift%d_%d%s"), n, shift->ts.kind, - array->ts.type == BT_CHARACTER ? "_char" : ""); + if (array->ts.type == BT_CHARACTER) + { + if (array->ts.kind == gfc_default_character_kind) + f->value.function.name + = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind); + else + f->value.function.name + = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind, + array->ts.kind); + } + else + f->value.function.name + = gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind); } diff --git a/gcc/fortran/lang-specs.h b/gcc/fortran/lang-specs.h index e5c54ae0011..e4bd0509c8b 100644 --- a/gcc/fortran/lang-specs.h +++ b/gcc/fortran/lang-specs.h @@ -20,35 +20,45 @@ /* This is the contribution to the `default_compilers' array in gcc.c for the f95 language. */ + +#define F951_CPP_OPTIONS "%{!nocpp: -cpp %g.f90 %(cpp_options)\ + %{E|M|MM:%(cpp_debug_options) -fsyntax-only} %{E}}" +#define F951_OPTIONS "%(cc1_options) %{J*} %{I*}\ + %{!nostdinc:-fintrinsic-modules-path finclude%s}\ + %{!fsyntax-only:%(invoke_as)}" +#define F951_SOURCE_FORM "%{!ffree-form:-ffixed-form}" + + {".F", "@f77-cpp-input", 0, 0, 0}, {".FOR", "@f77-cpp-input", 0, 0, 0}, {".FTN", "@f77-cpp-input", 0, 0, 0}, {".fpp", "@f77-cpp-input", 0, 0, 0}, {".FPP", "@f77-cpp-input", 0, 0, 0}, {"@f77-cpp-input", - "cc1 -E -lang-fortran -traditional-cpp -D_LANGUAGE_FORTRAN %(cpp_options) \ - %{E|M|MM:%(cpp_debug_options)}\ - %{!M:%{!MM:%{!E: -o %|.f |\n\ - f951 %|.f %{!ffree-form:-ffixed-form} %(cc1_options) %{J*} %{I*}\ - -fpreprocessed %{!nostdinc:-fintrinsic-modules-path finclude%s} %{!fsyntax-only:%(invoke_as)}}}}", 0, 0, 0}, + "f951 %i " F951_SOURCE_FORM " " \ + F951_CPP_OPTIONS " %{!E:" F951_OPTIONS "}", 0, 0, 0}, +{".f", "@f77", 0, 0, 0}, +{".for", "@f77", 0, 0, 0}, +{".ftn", "@f77", 0, 0, 0}, +{"@f77", + "f951 %i " F951_SOURCE_FORM " \ + %{E:%{!cpp:%egfortran does not support -E without -cpp}} \ + %{cpp:" F951_CPP_OPTIONS "} %{!E:" F951_OPTIONS "}", 0, 0, 0}, {".F90", "@f95-cpp-input", 0, 0, 0}, {".F95", "@f95-cpp-input", 0, 0, 0}, {".F03", "@f95-cpp-input", 0, 0, 0}, {".F08", "@f95-cpp-input", 0, 0, 0}, {"@f95-cpp-input", - "cc1 -E -lang-fortran -traditional-cpp -D_LANGUAGE_FORTRAN %(cpp_options) \ - %{E|M|MM:%(cpp_debug_options)}\ - %{!M:%{!MM:%{!E: -o %|.f95 |\n\ - f951 %|.f95 %{!ffixed-form:-ffree-form} %(cc1_options) %{J*} %{I*}\ - -fpreprocessed %{!nostdinc:-fintrinsic-modules-path finclude%s} %{!fsyntax-only:%(invoke_as)}}}}", 0, 0, 0}, + "f951 %i " F951_CPP_OPTIONS " %{!E:" F951_OPTIONS "}", 0, 0, 0}, {".f90", "@f95", 0, 0, 0}, {".f95", "@f95", 0, 0, 0}, {".f03", "@f95", 0, 0, 0}, {".f08", "@f95", 0, 0, 0}, -{"@f95", "%{!E:f951 %i %(cc1_options) %{J*} %{I*}\ - %{!nostdinc:-fintrinsic-modules-path finclude%s} %{!fsyntax-only:%(invoke_as)}}", 0, 0, 0}, -{".f", "@f77", 0, 0, 0}, -{".for", "@f77", 0, 0, 0}, -{".ftn", "@f77", 0, 0, 0}, -{"@f77", "%{!E:f951 %i %{!ffree-form:-ffixed-form} %(cc1_options) %{J*} %{I*}\ - %{!nostdinc:-fintrinsic-modules-path finclude%s} %{!fsyntax-only:%(invoke_as)}}", 0, 0, 0}, +{"@f95", + "f951 %i %{E:%{!cpp:%egfortran does not support -E without -cpp}}\ + %{cpp:" F951_CPP_OPTIONS "} %{!E:" F951_OPTIONS "}", 0, 0, 0}, + + +#undef F951_SOURCE_FORM +#undef F951_CPP_OPTIONS +#undef F951_OPTIONS diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index a3761925f01..f0f6c6a756d 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -25,6 +25,29 @@ Language Fortran +A +Fortran Joined Separate +; Documented in C + +C +Fortran +; Documented in C + +CC +Fortran +; Documented in C + +D +Fortran Joined Separate +; Documented in C + +E +Fortran Undocumented + +H +Fortran +; Documented in C + I Fortran Joined Separate -I<directory> Add a directory for INCLUDE and MODULE searching @@ -33,6 +56,14 @@ J Fortran Joined Separate -J<directory> Put MODULE files in 'directory' +P +Fortran +; Documented in C + +U +Fortran Joined Separate +; Documented in C + Wall Fortran ; Documented in C @@ -81,6 +112,18 @@ Wunderflow Fortran Warning Warn about underflow of numerical constant expressions +cpp +Fortran Joined Separate Negative(nocpp) +Enable preprocessing + +nocpp +Fortran Negative(cpp) +Disable preprocessing + +d +Fortran Joined +-d[DIMNU] Dump details about macro names and definitions during preprocessing + fall-intrinsics Fortran RejectNegative All intrinsics procedures are available regardless of selected standard @@ -289,6 +332,38 @@ funderscoring Fortran Append underscores to externally visible names +fworking-directory +Fortran +; Documented in C + +imultilib +Fortran Joined Separate +; Documented in C + +iprefix +Fortran Joined Separate +; Documented in C + +iquote +Fortran Joined Separate +; Documented in C + +isysroot +Fortran Joined Separate +; Documented in C + +isystem +Fortran Joined Separate +; Documented in C + +nostdinc +Fortran +; Documented in C + +o +Fortran Joined Separate +; Documented in common.opt + static-libgfortran Fortran Statically link the GNU Fortran helper library (libgfortran) @@ -313,4 +388,12 @@ std=legacy Fortran Accept extensions to support legacy code +undef +Fortran +; Documented in C + +v +Fortran +; Documented in C + ; This comment is to ensure we retain the blank line above. diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index a1020bf35d4..e653ac92843 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -31,6 +31,7 @@ along with GCC; see the file COPYING3. If not see #include "tree-inline.h" #include "gfortran.h" #include "target.h" +#include "cpp.h" gfc_option_t gfc_option; @@ -50,8 +51,7 @@ set_default_std_flags (void) /* Get ready for options handling. */ unsigned int -gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED, - const char **argv ATTRIBUTE_UNUSED) +gfc_init_options (unsigned int argc, const char **argv) { gfc_source_file = NULL; gfc_option.module_dir = NULL; @@ -128,6 +128,9 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED, /* -fshort-enums can be default on some targets. */ gfc_option.fshort_enums = targetm.default_short_enums (); + /* Initialize cpp-related options. */ + gfc_cpp_init_options(argc, argv); + return CL_Fortran; } @@ -354,6 +357,15 @@ gfc_post_options (const char **pfilename) if (gfc_option.flag_all_intrinsics) gfc_option.warn_nonstd_intrinsics = 0; + gfc_cpp_post_options (); + +/* FIXME: return gfc_cpp_preprocess_only (); + + The return value of this function indicates whether the + backend needs to be initialized. On -E, we don't need + the backend. However, if we return 'true' here, an + ICE occurs. Initializing the backend doesn't hurt much, + hence, for now we can live with it as is. */ return false; } @@ -452,6 +464,9 @@ gfc_handle_option (size_t scode, const char *arg, int value) if (code == N_OPTS) return 1; + if (gfc_cpp_handle_option (scode, arg, value) == 1) + return 1; + switch (code) { default: @@ -692,7 +707,7 @@ gfc_handle_option (size_t scode, const char *arg, int value) else gfc_fatal_error ("Unrecognized option to -finit-real: %s", arg); - break; + break; case OPT_finit_integer_: gfc_option.flag_init_integer = GFC_INIT_INTEGER_ON; diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index dd072feb30e..b7e63919e8e 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -1917,12 +1917,28 @@ loop: new_state = COMP_SUBROUTINE; gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, gfc_new_block->formal, NULL); + if (current_interface.type != INTERFACE_ABSTRACT && + !gfc_new_block->attr.dummy && + gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE) + { + reject_statement (); + gfc_free_namespace (gfc_current_ns); + goto loop; + } break; case ST_FUNCTION: new_state = COMP_FUNCTION; gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, gfc_new_block->formal, NULL); + if (current_interface.type != INTERFACE_ABSTRACT && + !gfc_new_block->attr.dummy && + gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE) + { + reject_statement (); + gfc_free_namespace (gfc_current_ns); + goto loop; + } break; case ST_PROCEDURE: diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index c3354a97d37..8044990b7dd 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1571,7 +1571,8 @@ resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr) /* Existance of isym should be checked already. */ gcc_assert (isym); - sym->ts = isym->ts; + sym->ts.type = isym->ts.type; + sym->ts.kind = isym->ts.kind; sym->attr.function = 1; sym->attr.proc = PROC_EXTERNAL; goto found; @@ -2646,8 +2647,9 @@ resolve_specific_s0 (gfc_code *c, gfc_symbol *sym) /* Existance of isym should be checked already. */ gcc_assert (isym); - sym->ts = isym->ts; - sym->attr.function = 1; + sym->ts.type = isym->ts.type; + sym->ts.kind = isym->ts.kind; + sym->attr.subroutine = 1; goto found; } diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c index 13e06155283..4c4a8b40670 100644 --- a/gcc/fortran/scanner.c +++ b/gcc/fortran/scanner.c @@ -47,6 +47,7 @@ along with GCC; see the file COPYING3. If not see #include "toplev.h" #include "debug.h" #include "flags.h" +#include "cpp.h" /* Structure for holding module and include file search path. */ typedef struct gfc_directorylist @@ -340,6 +341,7 @@ void gfc_add_include_path (const char *path, bool use_for_modules) { add_path_to_list (&include_dirs, path, use_for_modules); + gfc_cpp_add_include_path (xstrdup(path), true); } @@ -1909,7 +1911,14 @@ gfc_new_file (void) { try result; - result = load_file (gfc_source_file, true); + if (gfc_cpp_enabled ()) + { + result = gfc_cpp_preprocess (gfc_source_file); + if (!gfc_cpp_preprocess_only ()) + result = load_file (gfc_cpp_temporary_file (), true); + } + else + result = load_file (gfc_source_file, true); gfc_current_locus.lb = line_head; gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line; diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 8c1c6b349e7..59b425fbd92 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -4811,26 +4811,75 @@ gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind) 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); + if (e->expr_type == EXPR_CONSTANT) + { + /* Simple case of a scalar. */ + result = gfc_constant_result (BT_CHARACTER, kind, &e->where); + if (result == NULL) return &gfc_bad_expr; - } - return result; + 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; + } + else if (e->expr_type == EXPR_ARRAY) + { + /* For an array constructor, we convert each constructor element. */ + gfc_constructor *head = NULL, *tail = NULL, *c; + + for (c = e->value.constructor; c; c = c->next) + { + if (head == NULL) + head = tail = gfc_get_constructor (); + else + { + tail->next = gfc_get_constructor (); + tail = tail->next; + } + + tail->where = c->where; + tail->expr = gfc_convert_char_constant (c->expr, type, kind); + if (tail->expr == &gfc_bad_expr) + { + tail->expr = NULL; + return &gfc_bad_expr; + } + + if (tail->expr == NULL) + { + gfc_free_constructor (head); + return NULL; + } + } + + result = gfc_get_expr (); + result->ts.type = type; + result->ts.kind = kind; + result->expr_type = EXPR_ARRAY; + result->value.constructor = head; + result->shape = gfc_copy_shape (e->shape, e->rank); + result->where = e->where; + result->rank = e->rank; + result->ts.cl = e->ts.cl; + + return result; + } + else + return NULL; } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 431b6513ce0..e98a19c57fa 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -434,12 +434,14 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (target, external); conf (target, intrinsic); - conf (external, dimension); /* See Fortran 95's R504. */ + + if (!attr->if_source) + conf (external, dimension); /* See Fortran 95's R504. */ conf (external, intrinsic); conf (entry, intrinsic); - if ((attr->if_source && !attr->procedure) || attr->contained) + if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained) { conf (external, subroutine); conf (external, function); @@ -3664,6 +3666,7 @@ copy_formal_args (gfc_symbol *dest, gfc_symbol *src) /* May need to copy more info for the symbol. */ formal_arg->sym->attr = curr_arg->sym->attr; formal_arg->sym->ts = curr_arg->sym->ts; + formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as); /* If this isn't the first arg, set up the next ptr. For the last arg built, the formal_arg->next will never get set to diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index a691ad5ffef..7df192ca88a 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -472,14 +472,14 @@ gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping, gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]); gfc_add_block_to_block (&se->pre, &tmpse.pre); gfc_add_block_to_block (&se->post, &tmpse.post); - lower = tmpse.expr; + lower = fold_convert (gfc_array_index_type, tmpse.expr); /* ...and the upper bound. */ gfc_init_se (&tmpse, NULL); gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]); gfc_add_block_to_block (&se->pre, &tmpse.pre); gfc_add_block_to_block (&se->post, &tmpse.post); - upper = tmpse.expr; + upper = fold_convert (gfc_array_index_type, tmpse.expr); /* Set the upper bound of the loop to UPPER - LOWER. */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower); @@ -969,7 +969,6 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, tree offset, gfc_se * se, gfc_expr * expr) { tree tmp; - tree esize; gfc_conv_expr (se, expr); @@ -977,11 +976,17 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc)); tmp = gfc_build_array_ref (tmp, offset, NULL); - esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc))); - esize = fold_convert (gfc_charlen_type_node, esize); - if (expr->ts.type == BT_CHARACTER) { + int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false); + tree esize; + + esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc))); + esize = fold_convert (gfc_charlen_type_node, esize); + esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize, + build_int_cst (gfc_charlen_type_node, + gfc_character_kinds[i].bit_size / 8)); + gfc_conv_string_parameter (se); if (POINTER_TYPE_P (TREE_TYPE (tmp))) { diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 6deaad65f04..cfd33e464bc 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2319,6 +2319,34 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, return 0; } + else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER + && arg->next->expr->rank == 0) + || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER) + { + /* Convert c_f_pointer if fptr is a scalar + and convert c_f_procpointer. */ + gfc_se cptrse; + gfc_se fptrse; + + gfc_init_se (&cptrse, NULL); + gfc_conv_expr (&cptrse, arg->expr); + gfc_add_block_to_block (&se->pre, &cptrse.pre); + gfc_add_block_to_block (&se->post, &cptrse.post); + + gfc_init_se (&fptrse, NULL); + if (sym->intmod_sym_id == ISOCBINDING_F_POINTER) + fptrse.want_pointer = 1; + + gfc_conv_expr (&fptrse, arg->next->expr); + gfc_add_block_to_block (&se->pre, &fptrse.pre); + gfc_add_block_to_block (&se->post, &fptrse.post); + + tmp = arg->next->expr->symtree->n.sym->backend_decl; + se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), fptrse.expr, + fold_convert (TREE_TYPE (tmp), cptrse.expr)); + + return 0; + } else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED) { gfc_se arg1se; diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 990a12789fe..73e14a3f1fa 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1327,9 +1327,7 @@ gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr) tree var; tree len; tree tmp; - tree type; tree cond; - tree gfc_int8_type_node = gfc_get_int_type (8); tree fndecl; tree *args; unsigned int num_args; @@ -1337,9 +1335,8 @@ gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr) num_args = gfc_intrinsic_argument_list_length (expr) + 2; args = alloca (sizeof (tree) * num_args); - type = build_pointer_type (gfc_character1_type_node); - var = gfc_create_var (type, "pstr"); - len = gfc_create_var (gfc_int8_type_node, "len"); + var = gfc_create_var (pchar_type_node, "pstr"); + len = gfc_create_var (gfc_get_int_type (8), "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); args[0] = build_fold_addr_expr (var); @@ -1368,9 +1365,7 @@ gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr) tree var; tree len; tree tmp; - tree type; tree cond; - tree gfc_int4_type_node = gfc_get_int_type (4); tree fndecl; tree *args; unsigned int num_args; @@ -1378,9 +1373,8 @@ gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr) num_args = gfc_intrinsic_argument_list_length (expr) + 2; args = alloca (sizeof (tree) * num_args); - type = build_pointer_type (gfc_character1_type_node); - var = gfc_create_var (type, "pstr"); - len = gfc_create_var (gfc_int4_type_node, "len"); + var = gfc_create_var (pchar_type_node, "pstr"); + len = gfc_create_var (gfc_get_int_type (4), "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); args[0] = build_fold_addr_expr (var); @@ -1411,19 +1405,16 @@ gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr) tree var; tree len; tree tmp; - tree type; tree cond; tree fndecl; - tree gfc_int4_type_node = gfc_get_int_type (4); tree *args; unsigned int num_args; num_args = gfc_intrinsic_argument_list_length (expr) + 2; args = alloca (sizeof (tree) * num_args); - type = build_pointer_type (gfc_character1_type_node); - var = gfc_create_var (type, "pstr"); - len = gfc_create_var (gfc_int4_type_node, "len"); + var = gfc_create_var (pchar_type_node, "pstr"); + len = gfc_create_var (gfc_get_int_type (4), "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); args[0] = build_fold_addr_expr (var); @@ -1551,7 +1542,7 @@ gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op) /* Create the result variables. */ len = gfc_create_var (gfc_charlen_type_node, "len"); args[0] = build_fold_addr_expr (len); - var = gfc_create_var (build_pointer_type (gfc_character1_type_node), "pstr"); + var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr"); args[1] = gfc_build_addr_expr (ppvoid_type_node, var); args[2] = build_int_cst (NULL_TREE, op); args[3] = build_int_cst (NULL_TREE, nargs / 2); @@ -3237,6 +3228,24 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) } +/* Helper function to compute the size of a character variable, + excluding the terminating null characters. The result has + gfc_array_index_type type. */ + +static tree +size_of_string_in_bytes (int kind, tree string_length) +{ + tree bytesize; + int i = gfc_validate_kind (BT_CHARACTER, kind, false); + + bytesize = build_int_cst (gfc_array_index_type, + gfc_character_kinds[i].bit_size / 8); + + return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize, + fold_convert (gfc_array_index_type, string_length)); +} + + static void gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) { @@ -3249,7 +3258,6 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) tree tmp; tree lower; tree upper; - /*tree stride;*/ int n; arg = expr->value.function.actual->expr; @@ -3268,8 +3276,8 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) /* Obtain the source word length. */ if (arg->ts.type == BT_CHARACTER) - source_bytes = fold_convert (gfc_array_index_type, - argse.string_length); + source_bytes = size_of_string_in_bytes (arg->ts.kind, + argse.string_length); else source_bytes = fold_convert (gfc_array_index_type, size_in_bytes (type)); @@ -3283,7 +3291,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) /* Obtain the argument's word length. */ if (arg->ts.type == BT_CHARACTER) - tmp = fold_convert (gfc_array_index_type, argse.string_length); + tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length); else tmp = fold_convert (gfc_array_index_type, size_in_bytes (type)); @@ -3404,7 +3412,8 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) /* Obtain the source word length. */ if (arg->expr->ts.type == BT_CHARACTER) - tmp = fold_convert (gfc_array_index_type, argse.string_length); + tmp = size_of_string_in_bytes (arg->expr->ts.kind, + argse.string_length); else tmp = fold_convert (gfc_array_index_type, size_in_bytes (source_type)); @@ -3443,7 +3452,8 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) /* Obtain the source word length. */ if (arg->expr->ts.type == BT_CHARACTER) - tmp = fold_convert (gfc_array_index_type, argse.string_length); + tmp = size_of_string_in_bytes (arg->expr->ts.kind, + argse.string_length); else tmp = fold_convert (gfc_array_index_type, size_in_bytes (source_type)); @@ -3495,7 +3505,7 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) if (arg->expr->ts.type == BT_CHARACTER) { - tmp = fold_convert (gfc_array_index_type, argse.string_length); + tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length); mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp); } else @@ -3869,12 +3879,10 @@ gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr) static void gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) { - tree gfc_int4_type_node = gfc_get_int_type (4); tree var; tree len; tree addr; tree tmp; - tree type; tree cond; tree fndecl; tree function; @@ -3884,10 +3892,9 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) num_args = gfc_intrinsic_argument_list_length (expr) + 2; args = alloca (sizeof (tree) * num_args); - type = build_pointer_type (gfc_character1_type_node); - var = gfc_create_var (type, "pstr"); + var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr"); addr = gfc_build_addr_expr (ppvoid_type_node, var); - len = gfc_create_var (gfc_int4_type_node, "len"); + len = gfc_create_var (gfc_get_int_type (4), "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); args[0] = build_fold_addr_expr (len); @@ -3928,7 +3935,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) stmtblock_t block, body; int i; - /* We store in charsize the size of an character. */ + /* We store in charsize the size of a 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); diff --git a/gcc/function.c b/gcc/function.c index f5a67404562..845017f7124 100644 --- a/gcc/function.c +++ b/gcc/function.c @@ -69,10 +69,6 @@ along with GCC; see the file COPYING3. If not see /* So we can assign to cfun in this file. */ #undef cfun -#ifndef LOCAL_ALIGNMENT -#define LOCAL_ALIGNMENT(TYPE, ALIGNMENT) ALIGNMENT -#endif - #ifndef STACK_ALIGNMENT_NEEDED #define STACK_ALIGNMENT_NEEDED 1 #endif @@ -325,6 +321,26 @@ frame_offset_overflow (HOST_WIDE_INT offset, tree func) return FALSE; } +/* Return stack slot alignment in bits for TYPE and MODE. */ + +static unsigned int +get_stack_local_alignment (tree type, enum machine_mode mode) +{ + unsigned int alignment; + + if (mode == BLKmode) + alignment = BIGGEST_ALIGNMENT; + else + alignment = GET_MODE_ALIGNMENT (mode); + + /* Allow the frond-end to (possibly) increase the alignment of this + stack slot. */ + if (! type) + type = lang_hooks.types.type_for_mode (mode, 0); + + return STACK_SLOT_ALIGNMENT (type, mode, alignment); +} + /* Allocate a stack slot of SIZE bytes and return a MEM rtx for it with machine mode MODE. @@ -341,24 +357,12 @@ assign_stack_local (enum machine_mode mode, HOST_WIDE_INT size, int align) { rtx x, addr; int bigend_correction = 0; - unsigned int alignment; + unsigned int alignment, alignment_in_bits; int frame_off, frame_alignment, frame_phase; if (align == 0) { - tree type; - - if (mode == BLKmode) - alignment = BIGGEST_ALIGNMENT; - else - alignment = GET_MODE_ALIGNMENT (mode); - - /* Allow the target to (possibly) increase the alignment of this - stack slot. */ - type = lang_hooks.types.type_for_mode (mode, 0); - if (type) - alignment = LOCAL_ALIGNMENT (type, alignment); - + alignment = get_stack_local_alignment (NULL, mode); alignment /= BITS_PER_UNIT; } else if (align == -1) @@ -378,8 +382,10 @@ assign_stack_local (enum machine_mode mode, HOST_WIDE_INT size, int align) if (alignment * BITS_PER_UNIT > PREFERRED_STACK_BOUNDARY) alignment = PREFERRED_STACK_BOUNDARY / BITS_PER_UNIT; - if (crtl->stack_alignment_needed < alignment * BITS_PER_UNIT) - crtl->stack_alignment_needed = alignment * BITS_PER_UNIT; + alignment_in_bits = alignment * BITS_PER_UNIT; + + if (crtl->stack_alignment_needed < alignment_in_bits) + crtl->stack_alignment_needed = alignment_in_bits; /* Calculate how many bytes the start of local variables is off from stack alignment. */ @@ -432,6 +438,7 @@ assign_stack_local (enum machine_mode mode, HOST_WIDE_INT size, int align) frame_offset += size; x = gen_rtx_MEM (mode, addr); + set_mem_align (x, alignment_in_bits); MEM_NOTRAP_P (x) = 1; stack_slot_list @@ -544,16 +551,7 @@ assign_stack_temp_for_type (enum machine_mode mode, HOST_WIDE_INT size, /* These are now unused. */ gcc_assert (keep <= 1); - if (mode == BLKmode) - align = BIGGEST_ALIGNMENT; - else - align = GET_MODE_ALIGNMENT (mode); - - if (! type) - type = lang_hooks.types.type_for_mode (mode, 0); - - if (type) - align = LOCAL_ALIGNMENT (type, align); + align = get_stack_local_alignment (type, mode); /* Try to find an available, already-allocated temporary of the proper mode which meets the size and alignment requirements. Choose the diff --git a/gcc/function.h b/gcc/function.h index 424cdf7054c..2c469904712 100644 --- a/gcc/function.h +++ b/gcc/function.h @@ -392,6 +392,11 @@ struct rtl_data GTY(()) /* Nonzero if code to initialize arg_pointer_save_area has been emitted. */ bool arg_pointer_save_area_init; + + /* Nonzero means current function must be given a frame pointer. + Set in stmt.c if anything is allocated on the stack there. + Set in reload1.c if anything is allocated on the stack there. */ + bool frame_pointer_needed; }; #define return_label (crtl->x_return_label) @@ -405,6 +410,7 @@ struct rtl_data GTY(()) #define avail_temp_slots (crtl->x_avail_temp_slots) #define temp_slot_level (crtl->x_temp_slot_level) #define nonlocal_goto_handler_labels (crtl->x_nonlocal_goto_handler_labels) +#define frame_pointer_needed (crtl->frame_pointer_needed) extern GTY(()) struct rtl_data x_rtl; diff --git a/gcc/gcse.c b/gcc/gcse.c index 77efc44769b..f6837bf1f60 100644 --- a/gcc/gcse.c +++ b/gcc/gcse.c @@ -1692,12 +1692,25 @@ hash_scan_set (rtx pat, rtx insn, struct hash_table *table) unsigned int regno = REGNO (dest); rtx tmp; - /* See if a REG_NOTE shows this equivalent to a simpler expression. + /* See if a REG_EQUAL note shows this equivalent to a simpler expression. + This allows us to do a single GCSE pass and still eliminate redundant constants, addresses or other expressions that are - constructed with multiple instructions. */ + constructed with multiple instructions. + + However, keep the original SRC if INSN is a simple reg-reg move. In + In this case, there will almost always be a REG_EQUAL note on the + insn that sets SRC. By recording the REG_EQUAL value here as SRC + for INSN, we miss copy propagation opportunities and we perform the + same PRE GCSE operation repeatedly on the same REG_EQUAL value if we + do more than one PRE GCSE pass. + + Note that this does not impede profitale constant propagations. We + "look through" reg-reg sets in lookup_avail_set. */ note = find_reg_equal_equiv_note (insn); if (note != 0 + && REG_NOTE_KIND (note) == REG_EQUAL + && !REG_P (src) && (table->set_p ? gcse_constant_p (XEXP (note, 0)) : want_to_gcse_p (XEXP (note, 0)))) diff --git a/gcc/genoutput.c b/gcc/genoutput.c index ba7fd4c2462..be4fb00bc7c 100644 --- a/gcc/genoutput.c +++ b/gcc/genoutput.c @@ -1122,7 +1122,10 @@ note_constraint (rtx exp, int lineno) unsigned int namelen = strlen (name); struct constraint_data **iter, **slot, *new; - if (strchr (indep_constraints, name[0])) + /* The 'm' constraint is special here since that constraint letter + can be overridden by the back end by defining the + TARGET_MEM_CONSTRAINT macro. */ + if (strchr (indep_constraints, name[0]) && name[0] != 'm') { if (name[1] == '\0') message_with_line (lineno, "constraint letter '%s' cannot be " diff --git a/gcc/genpreds.c b/gcc/genpreds.c index bc20b16f70e..b292784247a 100644 --- a/gcc/genpreds.c +++ b/gcc/genpreds.c @@ -690,8 +690,11 @@ static struct constraint_data **last_constraint_ptr = &first_constraint; for (iter_ = first_constraint; iter_; iter_ = iter_->next_textual) /* These letters, and all names beginning with them, are reserved for - generic constraints. */ -static const char generic_constraint_letters[] = "EFVXgimnoprs"; + generic constraints. + The 'm' constraint is not mentioned here since that constraint + letter can be overridden by the back end by defining the + TARGET_MEM_CONSTRAINT macro. */ +static const char generic_constraint_letters[] = "EFVXginoprs"; /* Machine-independent code expects that constraints with these (initial) letters will allow only (a subset of all) CONST_INTs. */ diff --git a/gcc/c-incpath.c b/gcc/incpath.c index 4d055542820..e5fe8db23ca 100644 --- a/gcc/c-incpath.c +++ b/gcc/incpath.c @@ -28,7 +28,7 @@ #include "cpplib.h" #include "prefix.h" #include "intl.h" -#include "c-incpath.h" +#include "incpath.h" #include "cppdefault.h" /* Windows does not natively support inodes, and neither does MSDOS. diff --git a/gcc/c-incpath.h b/gcc/incpath.h index d19b928061d..d19b928061d 100644 --- a/gcc/c-incpath.h +++ b/gcc/incpath.h diff --git a/gcc/ipa-inline.c b/gcc/ipa-inline.c index a9a62ead930..d7ed8aa1e17 100644 --- a/gcc/ipa-inline.c +++ b/gcc/ipa-inline.c @@ -296,7 +296,7 @@ cgraph_mark_inline (struct cgraph_edge *edge) struct cgraph_node *what = edge->callee; struct cgraph_edge *e, *next; - gcc_assert (!CALL_CANNOT_INLINE_P (edge->call_stmt)); + gcc_assert (!CALL_STMT_CANNOT_INLINE_P (edge->call_stmt)); /* Look for all calls, mark them inline and clone recursively all inlined functions. */ for (e = what->callers; e; e = next) @@ -967,7 +967,7 @@ cgraph_decide_inlining_of_small_functions (void) else { struct cgraph_node *callee; - if (CALL_CANNOT_INLINE_P (edge->call_stmt) + if (CALL_STMT_CANNOT_INLINE_P (edge->call_stmt) || !cgraph_check_inline_limits (edge->caller, edge->callee, &edge->inline_failed, true)) { @@ -1093,7 +1093,7 @@ cgraph_decide_inlining (void) for (e = node->callers; e; e = next) { next = e->next_caller; - if (!e->inline_failed || CALL_CANNOT_INLINE_P (e->call_stmt)) + if (!e->inline_failed || CALL_STMT_CANNOT_INLINE_P (e->call_stmt)) continue; if (cgraph_recursive_inlining_p (e->caller, e->callee, &e->inline_failed)) @@ -1134,7 +1134,7 @@ cgraph_decide_inlining (void) if (node->callers && !node->callers->next_caller && !node->needed && node->local.inlinable && node->callers->inline_failed - && !CALL_CANNOT_INLINE_P (node->callers->call_stmt) + && !CALL_STMT_CANNOT_INLINE_P (node->callers->call_stmt) && !DECL_EXTERNAL (node->decl) && !DECL_COMDAT (node->decl)) { if (dump_file) @@ -1297,7 +1297,7 @@ cgraph_decide_inlining_incrementally (struct cgraph_node *node, if (!e->callee->local.disregard_inline_limits && (mode != INLINE_ALL || !e->callee->local.inlinable)) continue; - if (CALL_CANNOT_INLINE_P (e->call_stmt)) + if (CALL_STMT_CANNOT_INLINE_P (e->call_stmt)) continue; /* When the edge is already inlined, we just need to recurse into it in order to fully flatten the leaves. */ @@ -1399,7 +1399,7 @@ cgraph_decide_inlining_incrementally (struct cgraph_node *node, } if (!cgraph_check_inline_limits (node, e->callee, &e->inline_failed, false) - || CALL_CANNOT_INLINE_P (e->call_stmt)) + || CALL_STMT_CANNOT_INLINE_P (e->call_stmt)) { if (dump_file) { diff --git a/gcc/postreload.c b/gcc/postreload.c index 7e40728e876..15a14f001c6 100644 --- a/gcc/postreload.c +++ b/gcc/postreload.c @@ -542,12 +542,12 @@ reload_cse_simplify_operands (rtx insn, rtx testreg) case '*': case '%': case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': - case 'm': case '<': case '>': case 'V': case 'o': + case '<': case '>': case 'V': case 'o': case 'E': case 'F': case 'G': case 'H': case 's': case 'i': case 'n': case 'I': case 'J': case 'K': case 'L': case 'M': case 'N': case 'O': case 'P': - case 'p': case 'X': + case 'p': case 'X': case TARGET_MEM_CONSTRAINT: /* These don't say anything we care about. */ break; diff --git a/gcc/recog.c b/gcc/recog.c index 9ede30f90fd..ee5837dc1ec 100644 --- a/gcc/recog.c +++ b/gcc/recog.c @@ -60,6 +60,14 @@ along with GCC; see the file COPYING3. If not see #endif #endif +#ifndef HAVE_ATTR_enabled +static inline bool +get_attr_enabled (rtx insn ATTRIBUTE_UNUSED) +{ + return true; +} +#endif + static void validate_replace_rtx_1 (rtx *, rtx, rtx, rtx); static void validate_replace_src_1 (rtx *, void *); static rtx split_insn (rtx); @@ -1543,7 +1551,7 @@ asm_operand_ok (rtx op, const char *constraint) result = 1; break; - case 'm': + case TARGET_MEM_CONSTRAINT: case 'V': /* non-offsettable */ if (memory_operand (op, VOIDmode)) result = 1; @@ -1920,11 +1928,9 @@ extract_insn (rtx insn) int noperands; rtx body = PATTERN (insn); - recog_data.insn = NULL; recog_data.n_operands = 0; recog_data.n_alternatives = 0; recog_data.n_dups = 0; - which_alternative = -1; switch (GET_CODE (body)) { @@ -2004,6 +2010,22 @@ extract_insn (rtx insn) : OP_IN); gcc_assert (recog_data.n_alternatives <= MAX_RECOG_ALTERNATIVES); + + if (INSN_CODE (insn) < 0) + for (i = 0; i < recog_data.n_alternatives; i++) + recog_data.alternative_enabled_p[i] = true; + else + { + recog_data.insn = insn; + for (i = 0; i < recog_data.n_alternatives; i++) + { + which_alternative = i; + recog_data.alternative_enabled_p[i] = get_attr_enabled (insn); + } + } + + recog_data.insn = NULL; + which_alternative = -1; } /* After calling extract_insn, you can use this function to extract some @@ -2033,6 +2055,12 @@ preprocess_constraints (void) op_alt[j].matches = -1; op_alt[j].matched = -1; + if (!recog_data.alternative_enabled_p[j]) + { + p = skip_alternative (p); + continue; + } + if (*p == '\0' || *p == ',') { op_alt[j].anything_ok = 1; @@ -2082,7 +2110,7 @@ preprocess_constraints (void) } continue; - case 'm': + case TARGET_MEM_CONSTRAINT: op_alt[j].memory_ok = 1; break; case '<': @@ -2202,6 +2230,17 @@ constrain_operands (int strict) int lose = 0; funny_match_index = 0; + if (!recog_data.alternative_enabled_p[which_alternative]) + { + int i; + + for (i = 0; i < recog_data.n_operands; i++) + constraints[i] = skip_alternative (constraints[i]); + + which_alternative++; + continue; + } + for (opno = 0; opno < recog_data.n_operands; opno++) { rtx op = recog_data.operand[opno]; @@ -2355,7 +2394,7 @@ constrain_operands (int strict) win = 1; break; - case 'm': + case TARGET_MEM_CONSTRAINT: /* Memory operands must be valid, to the extent required by STRICT. */ if (MEM_P (op)) diff --git a/gcc/recog.h b/gcc/recog.h index cdc438c8892..6a2a2caf1da 100644 --- a/gcc/recog.h +++ b/gcc/recog.h @@ -50,7 +50,8 @@ struct operand_alternative /* Nonzero if '&' was found in the constraint string. */ unsigned int earlyclobber:1; - /* Nonzero if 'm' was found in the constraint string. */ + /* Nonzero if TARGET_MEM_CONSTRAINT was found in the constraint + string. */ unsigned int memory_ok:1; /* Nonzero if 'o' was found in the constraint string. */ unsigned int offmem_ok:1; @@ -142,6 +143,19 @@ recog_memoized (rtx insn) } #endif +/* Skip chars until the next ',' or the end of the string. This is + useful to skip alternatives in a constraint string. */ +static inline const char * +skip_alternative (const char *p) +{ + const char *r = p; + while (*r != '\0' && *r != ',') + r++; + if (*r == ',') + r++; + return r; +} + /* Nonzero means volatile operands are recognized. */ extern int volatile_ok; @@ -201,6 +215,12 @@ struct recog_data /* The number of alternatives in the constraints for the insn. */ char n_alternatives; + /* Specifies whether an insn alternative is enabled using the + `enabled' attribute in the insn pattern definition. For back + ends not using the `enabled' attribute the array fields are + always set to `true' in expand_insn. */ + bool alternative_enabled_p [MAX_RECOG_ALTERNATIVES]; + /* In case we are caching, hold insn data was generated for. */ rtx insn; }; diff --git a/gcc/regclass.c b/gcc/regclass.c index 200f3eefa58..8b9e86b1411 100644 --- a/gcc/regclass.c +++ b/gcc/regclass.c @@ -1143,8 +1143,9 @@ record_operand_costs (rtx insn, struct costs *op_costs, record_address_regs (GET_MODE (recog_data.operand[i]), XEXP (recog_data.operand[i], 0), 0, MEM, SCRATCH, frequency * 2); - else if (constraints[i][0] == 'p' - || EXTRA_ADDRESS_CONSTRAINT (constraints[i][0], constraints[i])) + else if (recog_data.alternative_enabled_p[0] + && (constraints[i][0] == 'p' + || EXTRA_ADDRESS_CONSTRAINT (constraints[i][0], constraints[i]))) record_address_regs (VOIDmode, recog_data.operand[i], 0, ADDRESS, SCRATCH, frequency * 2); } @@ -1701,7 +1702,7 @@ record_reg_classes (int n_alts, int n_ops, rtx *ops, [(int) base_reg_class (VOIDmode, ADDRESS, SCRATCH)]; break; - case 'm': case 'o': case 'V': + case TARGET_MEM_CONSTRAINT: case 'o': case 'V': /* It doesn't seem worth distinguishing between offsettable and non-offsettable addresses here. */ allows_mem[i] = 1; @@ -1932,6 +1933,9 @@ record_reg_classes (int n_alts, int n_ops, rtx *ops, if (alt_fail) continue; + if (!recog_data.alternative_enabled_p[alt]) + continue; + /* Finally, update the costs with the information we've calculated about this alternative. */ diff --git a/gcc/reload.c b/gcc/reload.c index 0492ee8cc64..7472272d9c4 100644 --- a/gcc/reload.c +++ b/gcc/reload.c @@ -2523,7 +2523,7 @@ find_reloads (rtx insn, int replace, int ind_levels, int live_known, int noperands; /* These start out as the constraints for the insn and they are chewed up as we consider alternatives. */ - char *constraints[MAX_RECOG_OPERANDS]; + const char *constraints[MAX_RECOG_OPERANDS]; /* These are the preferred classes for an operand, or NO_REGS if it isn't a register. */ enum reg_class preferred_class[MAX_RECOG_OPERANDS]; @@ -2630,7 +2630,8 @@ find_reloads (rtx insn, int replace, int ind_levels, int live_known, memcpy (operand_mode, recog_data.operand_mode, noperands * sizeof (enum machine_mode)); - memcpy (constraints, recog_data.constraints, noperands * sizeof (char *)); + memcpy (constraints, recog_data.constraints, + noperands * sizeof (const char *)); commutative = -1; @@ -2641,8 +2642,9 @@ find_reloads (rtx insn, int replace, int ind_levels, int live_known, for (i = 0; i < noperands; i++) { - char *p; + const char *p; int c; + char *end; substed_operand[i] = recog_data.operand[i]; p = constraints[i]; @@ -2686,7 +2688,8 @@ find_reloads (rtx insn, int replace, int ind_levels, int live_known, case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': { - c = strtoul (p - 1, &p, 10); + c = strtoul (p - 1, &end, 10); + p = end; operands_match[c][i] = operands_match_p (recog_data.operand[c], @@ -2914,11 +2917,21 @@ find_reloads (rtx insn, int replace, int ind_levels, int live_known, a bad register class to only count 1/3 as much. */ int reject = 0; + if (!recog_data.alternative_enabled_p[this_alternative_number]) + { + int i; + + for (i = 0; i < recog_data.n_operands; i++) + constraints[i] = skip_alternative (constraints[i]); + + continue; + } + this_earlyclobber = 0; for (i = 0; i < noperands; i++) { - char *p = constraints[i]; + const char *p = constraints[i]; char *end; int len; int win = 0; @@ -3182,7 +3195,7 @@ find_reloads (rtx insn, int replace, int ind_levels, int live_known, badop = 0; break; - case 'm': + case TARGET_MEM_CONSTRAINT: if (force_reload) break; if (MEM_P (operand) @@ -3717,7 +3730,7 @@ find_reloads (rtx insn, int replace, int ind_levels, int live_known, address_reloaded[commutative + 1] = t; memcpy (constraints, recog_data.constraints, - noperands * sizeof (char *)); + noperands * sizeof (const char *)); goto try_swapped; } else @@ -4522,7 +4535,7 @@ alternative_allows_const_pool_ref (rtx mem, const char *constraint, int altnum) while (*constraint++ != ','); altnum--; } - /* Scan the requested alternative for 'm' or 'o'. + /* Scan the requested alternative for TARGET_MEM_CONSTRAINT or 'o'. If one of them is present, this alternative accepts the result of passing a constant-pool reference through find_reloads_toplev. @@ -4533,7 +4546,7 @@ alternative_allows_const_pool_ref (rtx mem, const char *constraint, int altnum) for (; (c = *constraint) && c != ',' && c != '#'; constraint += CONSTRAINT_LEN (c, constraint)) { - if (c == 'm' || c == 'o') + if (c == TARGET_MEM_CONSTRAINT || c == 'o') return true; #ifdef EXTRA_CONSTRAINT_STR if (EXTRA_MEMORY_CONSTRAINT (c, constraint) diff --git a/gcc/reload1.c b/gcc/reload1.c index 13b8e6f7ef0..51d3f4c4d19 100644 --- a/gcc/reload1.c +++ b/gcc/reload1.c @@ -1454,11 +1454,11 @@ maybe_fix_stack_asms (void) switch (c) { case '=': case '+': case '*': case '%': case '?': case '!': - case '0': case '1': case '2': case '3': case '4': case 'm': - case '<': case '>': case 'V': case 'o': case '&': case 'E': - case 'F': case 's': case 'i': case 'n': case 'X': case 'I': - case 'J': case 'K': case 'L': case 'M': case 'N': case 'O': - case 'P': + case '0': case '1': case '2': case '3': case '4': case '<': + case '>': case 'V': case 'o': case '&': case 'E': case 'F': + case 's': case 'i': case 'n': case 'X': case 'I': case 'J': + case 'K': case 'L': case 'M': case 'N': case 'O': case 'P': + case TARGET_MEM_CONSTRAINT: break; case 'p': diff --git a/gcc/see.c b/gcc/see.c index dce51691cbe..5084b976559 100644 --- a/gcc/see.c +++ b/gcc/see.c @@ -2554,6 +2554,17 @@ see_def_extension_not_merged (struct see_ref_s *curr_ref_s, rtx def_se) /* The manipulation succeeded. Store the new manipulated reference. */ + /* It is possible for dest_reg to appear multiple times in ref_copy. In this + case, ref_copy now has invalid sharing. Copying solves the problem. + We don't use copy_rtx as an optimization for the common case (no sharing). + We can't just use copy_rtx_if_shared since it does nothing on INSNs. + Another possible solution would be to make validate_replace_rtx_1 + public and use it instead of replace_rtx. */ + reset_used_flags (PATTERN (ref_copy)); + reset_used_flags (REG_NOTES (ref_copy)); + PATTERN (ref_copy) = copy_rtx_if_shared (PATTERN (ref_copy)); + REG_NOTES (ref_copy) = copy_rtx_if_shared (REG_NOTES (ref_copy)); + /* Try to simplify the new manipulated insn. */ validate_simplify_insn (ref_copy); diff --git a/gcc/stmt.c b/gcc/stmt.c index 4dba88196cf..57e8ad4db7e 100644 --- a/gcc/stmt.c +++ b/gcc/stmt.c @@ -363,7 +363,7 @@ parse_output_constraint (const char **constraint_p, int operand_num, } break; - case 'V': case 'm': case 'o': + case 'V': case TARGET_MEM_CONSTRAINT: case 'o': *allows_mem = true; break; @@ -462,7 +462,7 @@ parse_input_constraint (const char **constraint_p, int input_num, } break; - case 'V': case 'm': case 'o': + case 'V': case TARGET_MEM_CONSTRAINT: case 'o': *allows_mem = true; break; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 951fe3d5c8a..c28d1fc3eca 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,156 @@ +2008-05-28 Janus Weil <janus@gcc.gnu.org> + + PR fortran/36325 + PR fortran/35830 + * gfortran.dg/interface_23.f90: New. + * gfortran.dg/gomp/reduction3.f90: Fixed invalid code. + * gfortran.dg/proc_decl_12.f90: New: + * gfortran.dg/external_procedures_1.f90: Fixed error message. + +2008-05-28 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/36319 + * gfortran.dg/widechar_5.f90: New file. + * gfortran.dg/widechar_6.f90: New file. + * gfortran.dg/widechar_7.f90: New file. + * gfortran.dg/widechar_intrinsics_5.f90: Uncomment the lines + testing the SPREAD intrinsic. + * gfortran.dg/widechar_intrinsics_6.f90: New file. + * gfortran.dg/widechar_intrinsics_7.f90: New file. + * gfortran.dg/widechar_intrinsics_8.f90: New file. + * gfortran.dg/widechar_intrinsics_9.f90: New file. + * gfortran.dg/widechar_intrinsics_10.f90: New file. + +2008-05-28 Seongbae Park <seongbae.park@gmail.com> + + * gcc.dg/tree-prof/ic-misattribution-1.c: New test. + * gcc.dg/tree-prof/ic-misattribution-1a.c: New test. + * lib/profopt.exp (profopt-get-options): Support + dg-additional-sources. + (profopt-execute): Handle additional sources. + +2008-05-28 Rafael Espindola <espindola@google.com> + + * gcc.dg/20080528-1.c: New test. + +2008-05-28 Arnaud Charlet <charlet@adacore.com> + + * gnat.dg/old_errors.adb, gnat.dg/deep_old.adb: Adjust. + + * gnat.dg/specs/iface_eq_test.ads, + gnat.dg/specs/iface_eq_test-child.ads: New test. + * gnat.dg/specs/self_class.ads: New test. + * gnat.dg/fixce.adb: New test. + * gnat.dg/frunaligned*.ad[sb]: New test. + +2008-05-27 Andy Hutchinson <hutchinsonandy@aim.com> + + * gcc.dg/tree-ssa/data-dep-1.c: Skip test for avr-*-* too much code. + * gcc.dg/tree-ssa/ldist-3.c: Ditto. + * gcc.dg/tree-ssa/ldist-5.c: Ditto. + * gcc.dg/tree-ssa/ifc-20040816-2 .c: Adjust for int size < 4 bytes. + * gcc.dg/tree-ssa/pr32540-1.c: Ditto. + * gcc.dg/tree-ssa/pr32540-2.c: Ditto. + * gcc.dg/tree-ssa/ssa-lim-5.c: Ditto. + * gcc.dg/tree-ssa/pr23115.c: Adjust test for double size < 8 bytes. + +2008-05-27 H.J. Lu <hongjiu.lu@intel.com> + + PR target/35767 + PR target/35771 + * gcc.target/i386/pr35767-1.c: New. + * gcc.target/i386/pr35767-1d.c: Likewise. + * gcc.target/i386/pr35767-1i.c: Likewise. + * gcc.target/i386/pr35767-2.c: Likewise. + * gcc.target/i386/pr35767-2d.c: Likewise. + * gcc.target/i386/pr35767-2i.c: Likewise. + * gcc.target/i386/pr35767-3.c: Likewise. + * gcc.target/i386/pr35767-4.c: Likewise. + * gcc.target/i386/pr35767-5.c: Likewise. + +2008-05-27 Tobias Burnus <burnus@net-b.de> + + * gfortran.dg/assignment_3.f90: Add missing cleanup-modules. + +2008-05-27 Tobias Burnus <burnus@net-b.de> + + PR fortran/36316 + * gfortran.dg/assignment_3.f90: New. + +2008-05-27 Richard Sandiford <rdsandiford@googlemail.com> + + * lib/fortran-torture.exp (get-fortran-torture-options): + New function, replacing old FORTRAN_TORTURE_OPTIONS code. + * gfortran.fortran-torture/compile/compile.exp: Use + [get-fortran-torture-options] instead of $FORTRAN_TORTURE_OPTIONS. + * gfortran.fortran-torture/execute/execute.exp: Likewise. + +2008-05-27 Michael Matz <matz@suse.de> + + PR c++/27975 + * g++.dg/warn/Wenum-compare.C: New testcase. + * g++.dg/warn/Wenum-compare-no.C: Ditto. + +2008-05-27 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/36339 + * gcc.c-torture/execute/pr36339.c: New testcase. + * gcc.dg/tree-ssa/loadpre8.c: XFAIL. + +2008-05-27 Eric Botcazou <ebotcazou@adacore.com> + + * gnat.dg/pack9.ad[sb]: New test. + +2008-05-27 Arnaud Charlet <charlet@adacore.com> + + * gnat.dg/sync1.ad[sb]: New test. + * gnat.dg/interface5.ad[sb]: New test. + +2008-05-27 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> + + * gcc.c-torture/compile/pr11832.c: XFAIL on (x86 && ilp32 && pic). + * gcc.c-torture/compile/pr33009.c: Likewise. + +2008-05-27 Alexandre Oliva <aoliva@redhat.com> + + PR c++/35909 + * g++.dg/conversion/bitfield9.C: New. + +2008-05-26 Arnaud Charlet <charlet@adacore.com> + + * gnat.dg/specs/array_no_def_init.ads: New test. + +2008-05-26 Kai Tietz <kai.tietz@onevision.com> + + * gcc-c.torture/execute/pr36321.c: New. + +2008-05-26 Richard Guenther <rguenther@suse.de> + + PR middle-end/36300 + * gcc.dg/pr36300-1.c: New testcase. + * gcc.dg/pr36300-2.c: Likewise. + +2008-05-26 Arnaud Charlet <charlet@adacore.com> + + * gnat.dg/set_in_pproc.adb: New test. + * gnat.dg/modular2.adb: New test. + * gnat.dg/pak.ad[sb]: New test. + +2008-05-25 Eric Botcazou <ebotcazou@adacore.com> + + * gnat.dg/trampoline1.adb: New test. + * gnat.dg/trampoline2.adb: Likewise. + +2008-05-25 Tobias Burnus <burnus@net-b.de> + + PR fortran/32600 + * gfortran.dg/c_f_pointer_tests_3.f90: New. + +2008-05-25 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/17526 + * gcc.dg/torture/pr17526.c: New testcase. + 2008-05-24 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> * gcc.dg/tg-tests.h: Fix spelling of FP_INFINITE. diff --git a/gcc/testsuite/g++.dg/conversion/bitfield9.C b/gcc/testsuite/g++.dg/conversion/bitfield9.C new file mode 100644 index 00000000000..998dd4873c8 --- /dev/null +++ b/gcc/testsuite/g++.dg/conversion/bitfield9.C @@ -0,0 +1,17 @@ +// PR c++/35909 +// { dg-do compile } + +struct MidiCommand +{ + unsigned data1 : 8; +}; + +void g(const unsigned char &); +void h(const unsigned int &); + +void f(MidiCommand mc) +{ + g(mc.data1); + h(mc.data1); +} + diff --git a/gcc/testsuite/g++.dg/warn/Wenum-compare-no.C b/gcc/testsuite/g++.dg/warn/Wenum-compare-no.C new file mode 100644 index 00000000000..7dc27d3fe72 --- /dev/null +++ b/gcc/testsuite/g++.dg/warn/Wenum-compare-no.C @@ -0,0 +1,10 @@ +/* Test disabling -Wenum-compare (on by default). See PR27975. */ +/* { dg-do compile } */ +/* { dg-options "-Wno-enum-compare" } */ +enum E1 { a }; +enum E2 { b }; + +int foo (E1 e1, E2 e2) +{ + return e1 == e2; /* { dg-bogus "comparison between" } */ +} diff --git a/gcc/testsuite/g++.dg/warn/Wenum-compare.C b/gcc/testsuite/g++.dg/warn/Wenum-compare.C new file mode 100644 index 00000000000..f60080039fb --- /dev/null +++ b/gcc/testsuite/g++.dg/warn/Wenum-compare.C @@ -0,0 +1,10 @@ +/* Test that we get the -Wenum-compare by default. See PR27975. */ +/* { dg-do compile } */ +/* { dg-options "" } */ +enum E1 { a }; +enum E2 { b }; + +int foo (E1 e1, E2 e2) +{ + return e1 == e2; /* { dg-warning "comparison between" } */ +} diff --git a/gcc/testsuite/gcc.c-torture/compile/pr11832.c b/gcc/testsuite/gcc.c-torture/compile/pr11832.c index 4eba49f0645..88469ff6940 100644 --- a/gcc/testsuite/gcc.c-torture/compile/pr11832.c +++ b/gcc/testsuite/gcc.c-torture/compile/pr11832.c @@ -1,6 +1,8 @@ /* { dg-do compile } */ /* Currently ICEs for MIPS and PowerPC; see PR33642. */ /* { dg-xfail-if "PR33642" { mips*-*-* powerpc*-*-linux* } { "*" } { "" } } */ +/* Currently ICEs for (x86 && ilp32 && pic). */ +/* { dg-xfail-if "PR33642/36240" { { i?86-*-* x86_64-*-* } && { ilp32 && { ! nonpic } } } { "*" } { "" } } */ /* { dg-prune-output ".*internal compiler error.*" } /* { dg-options "-frtl-abstract-sequences" } */ diff --git a/gcc/testsuite/gcc.c-torture/compile/pr33009.c b/gcc/testsuite/gcc.c-torture/compile/pr33009.c index 811fdb5f844..79a4b62a3a6 100644 --- a/gcc/testsuite/gcc.c-torture/compile/pr33009.c +++ b/gcc/testsuite/gcc.c-torture/compile/pr33009.c @@ -1,6 +1,8 @@ /* { dg-do compile } */ /* Currently ICEs for MIPS and PowerPC; see PR33642. */ /* { dg-xfail-if "PR33642" { mips*-*-* powerpc*-*-linux* } { "*" } { "" } } */ +/* Currently ICEs for (x86 && ilp32 && pic). */ +/* { dg-xfail-if "PR33642/36240" { { i?86-*-* x86_64-*-* } && { ilp32 && { ! nonpic } } } { "*" } { "" } } */ /* { dg-prune-output ".*internal compiler error.*" } /* { dg-options "-frtl-abstract-sequences" } */ diff --git a/gcc/testsuite/gcc.c-torture/execute/pr36321.c b/gcc/testsuite/gcc.c-torture/execute/pr36321.c new file mode 100644 index 00000000000..37d64f3d8be --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/execute/pr36321.c @@ -0,0 +1,24 @@ +extern void abort (void); + +extern __SIZE_TYPE__ strlen (const char *); +void foo(char *str) +{ + int len2 = strlen (str); + char *a = (char *) __builtin_alloca (0); + char *b = (char *) __builtin_alloca (len2*3); + + if ((int) (a-b) < (len2*3)) + { +#ifdef _WIN32 + abort (); +#endif + return; + } +} + +int main(int argc, char **argv) +{ + foo (argv[0]); + return 0; +} + diff --git a/gcc/testsuite/gcc.c-torture/execute/pr36339.c b/gcc/testsuite/gcc.c-torture/execute/pr36339.c new file mode 100644 index 00000000000..c4f36ddcace --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/execute/pr36339.c @@ -0,0 +1,32 @@ +extern void abort (void); + +typedef unsigned long my_uintptr_t; + +int check_a(my_uintptr_t tagged_ptr); + +int __attribute__((noinline)) try_a(my_uintptr_t x) +{ + my_uintptr_t heap[2]; + my_uintptr_t *hp = heap; + + hp[0] = x; + hp[1] = 0; + return check_a((my_uintptr_t)(void*)((char*)hp + 1)); +} + +int __attribute__((noinline)) check_a(my_uintptr_t tagged_ptr) +{ + my_uintptr_t *hp = (my_uintptr_t*)(void*)((char*)tagged_ptr - 1); + + if (hp[0] == 42 && hp[1] == 0) + return 0; + return -1; +} + +int main(void) +{ + if (try_a(42) < 0) + abort (); + return 0; +} + diff --git a/gcc/testsuite/gcc.dg/20080528-1.c b/gcc/testsuite/gcc.dg/20080528-1.c new file mode 100644 index 00000000000..9fe978051eb --- /dev/null +++ b/gcc/testsuite/gcc.dg/20080528-1.c @@ -0,0 +1,9 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -fsee" } */ + +unsigned long g(int a, int b) { + return a / b; +} +unsigned long f(long int a) { + return g(a, 1<<13); +} diff --git a/gcc/testsuite/gcc.dg/pr36300-1.c b/gcc/testsuite/gcc.dg/pr36300-1.c new file mode 100644 index 00000000000..466522f8b79 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr36300-1.c @@ -0,0 +1,24 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -fwrapv" } */ + +extern void abort (void); + +#define VALUE ((int)((long long)U1 * (long long)3) + 2) + +int main(void) +{ + int U1; + long long Y, Y2; + int t; + + U1 = -2147483647-1; + + Y = ((long long)(VALUE * VALUE) * 3); + + t = VALUE; + Y2 = ((long long)(t * t) * 3); + + if (Y != Y2) + abort (); + return 0; +} diff --git a/gcc/testsuite/gcc.dg/pr36300-2.c b/gcc/testsuite/gcc.dg/pr36300-2.c new file mode 100644 index 00000000000..7e7cfa2b7eb --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr36300-2.c @@ -0,0 +1,24 @@ +/* { dg-do run } */ +/* { dg-options "-O2" } */ + +extern void abort (void); + +#define VALUE (unsigned int)((int)((long long)U1 * (long long)3) + 2) + +int main(void) +{ + int U1; + long long Y, Y2; + unsigned int t; + + U1 = -2147483647-1; + + Y = ((long long)(int)(VALUE * VALUE) * 3); + + t = VALUE; + Y2 = ((long long)(int)(t * t) * 3); + + if (Y != Y2) + abort (); + return 0; +} diff --git a/gcc/testsuite/gcc.dg/torture/pr17526.c b/gcc/testsuite/gcc.dg/torture/pr17526.c new file mode 100644 index 00000000000..58b479143a8 --- /dev/null +++ b/gcc/testsuite/gcc.dg/torture/pr17526.c @@ -0,0 +1,27 @@ +/* { dg-do run } */ +/* { dg-options "-fno-pcc-struct-return" { target i?86-*-* } } */ + +void abort(void); + +typedef struct { int i; } A; + +A __attribute__((noinline)) +foo(void) +{ + A a = { -1 }; + return a; +} + +void __attribute__((noinline)) +bar(A *p) +{ + *p = foo(); +} + +int main(void) +{ + A a; + bar(&a); + if (a.i != -1) abort(); + return 0; +} diff --git a/gcc/testsuite/gcc.dg/tree-prof/ic-misattribution-1.c b/gcc/testsuite/gcc.dg/tree-prof/ic-misattribution-1.c new file mode 100644 index 00000000000..c36dd8dd052 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-prof/ic-misattribution-1.c @@ -0,0 +1,19 @@ +/* { dg-options "-O2 -fdump-tree-tree_profile" } */ +/* { dg-additional-sources "ic-misattribution-1a.c" } */ + +extern void other_caller (void); + +void +callee (void) +{ + return; +} + +void +caller(void (*func) (void)) +{ + func (); +} + +/* { dg-final-use { scan-tree-dump "hist->count 1 hist->all 1" "tree_profile" } } */ +/* { dg-final-use { cleanup-tree-dump "tree_profile" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-prof/ic-misattribution-1a.c b/gcc/testsuite/gcc.dg/tree-prof/ic-misattribution-1a.c new file mode 100644 index 00000000000..ac54ab13851 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-prof/ic-misattribution-1a.c @@ -0,0 +1,20 @@ +/* { dg-options "-DEMPTY" } */ +/* This file is only needed in combination with ic-misattribution-1.c + but there's no easy way to make this file ignored. */ +extern void callee (void); +extern void caller (void (*func) (void)); + +typedef void (*func_t) (void); +func_t func; + +int +main () +{ +#ifdef EMPTY +#else + func = callee; + caller (callee); + func (); +#endif + return 0; +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/data-dep-1.c b/gcc/testsuite/gcc.dg/tree-ssa/data-dep-1.c index b0225e13ebc..5eb71d9be9e 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/data-dep-1.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/data-dep-1.c @@ -1,4 +1,5 @@ /* { dg-do compile } */ +/* { dg-skip-if "too much code for avr" { "avr-*-*" } { "*" } { "" } } */ /* { dg-options "-O2 -ftree-loop-linear -fdump-tree-ltrans-all" } */ int foo (int n, int m) diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ifc-20040816-2.c b/gcc/testsuite/gcc.dg/tree-ssa/ifc-20040816-2.c index 49cca20857d..f37a4d3361a 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ifc-20040816-2.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ifc-20040816-2.c @@ -11,7 +11,11 @@ void foo(const int * __restrict__ zr_in, { unsigned int pi; int tmp_r, tmp_i, tmp_k; +#if __SIZEOF_INT__ >= 4 for (pi = 0; pi < (512)*(512); pi++) { +#else + for (pi = 0; pi < (32)*(32); pi++) { +#endif int zr = zr_in[pi]; int zi = zi_in[pi]; int zk = zk_in[pi]; diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ldist-3.c b/gcc/testsuite/gcc.dg/tree-ssa/ldist-3.c index 524fb4542b8..a76f36fb196 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ldist-3.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ldist-3.c @@ -1,4 +1,5 @@ /* { dg-do compile } */ +/* { dg-skip-if "too much code for avr" { "avr-*-*" } { "*" } { "" } } */ /* { dg-options "-O2 -ftree-loop-distribution -fdump-tree-ldist-all" } */ int loop1 (int k) diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ldist-5.c b/gcc/testsuite/gcc.dg/tree-ssa/ldist-5.c index af74557024e..39b52607179 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ldist-5.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ldist-5.c @@ -1,4 +1,5 @@ /* { dg-do compile } */ +/* { dg-skip-if "too much code for avr" { "avr-*-*" } { "*" } { "" } } */ /* { dg-options "-O2 -ftree-loop-distribution -fdump-tree-ldist-all" } */ int loop1 (int k) diff --git a/gcc/testsuite/gcc.dg/tree-ssa/loadpre8.c b/gcc/testsuite/gcc.dg/tree-ssa/loadpre8.c index a4d2e50c461..6be2b3ec7fd 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/loadpre8.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/loadpre8.c @@ -93,5 +93,5 @@ rewrite_add_phi_arguments (basic_block bb) get_reaching_def ((get_def_from_ptr (get_phi_result_ptr (phi)))->ssa_name.var); } } -/* { dg-final { scan-tree-dump-times "Eliminated: 1" 1 "pre"} } */ +/* { dg-final { scan-tree-dump-times "Eliminated: 1" 1 "pre" { xfail *-*-* } } } */ /* { dg-final { cleanup-tree-dump "pre" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr23115.c b/gcc/testsuite/gcc.dg/tree-ssa/pr23115.c index 6a52aafb458..61408e47a80 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr23115.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr23115.c @@ -12,9 +12,13 @@ int main() { long j; double R, n, x; - +#if __SIZEOF_DOUBLE__ >= 8 n = 1.e300; x = -1.e300; +#else + n = 1.e30; + x = -1.e30; +#endif for( j=0; j < 2; j++ ) { x = MAX2(x,p[j]); diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr32540-1.c b/gcc/testsuite/gcc.dg/tree-ssa/pr32540-1.c index ce8e0ae824f..f5a444806a1 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr32540-1.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr32540-1.c @@ -19,6 +19,7 @@ void acceptloop_th(int *t) { if (f()) options |= 0x1 << 13; if (f()) options |= 0x1 << 14; if (f()) options |= 0x1 << 15; +#if(__SIZEOF_INT__ >= 4) if (f()) options |= 0x1 << 16; if (f()) options |= 0x1 << 17; if (f()) options |= 0x1 << 18; @@ -30,5 +31,6 @@ void acceptloop_th(int *t) { if (f()) options |= 0x1 << 24; if (f()) options |= 0x1 << 25; if (f()) options |= 0x1 << 26; +#endif if (f()) *t = options; } diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr32540-2.c b/gcc/testsuite/gcc.dg/tree-ssa/pr32540-2.c index 29a5e3c55d0..f7fa38de114 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr32540-2.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr32540-2.c @@ -19,6 +19,7 @@ void acceptloop_th(int *t, int options) { if (f()) options |= 0x1 << 13; if (f()) options |= 0x1 << 14; if (f()) options |= 0x1 << 15; +#if(__SIZEOF_INT__ >= 4) if (f()) options |= 0x1 << 16; if (f()) options |= 0x1 << 17; if (f()) options |= 0x1 << 18; @@ -30,6 +31,8 @@ void acceptloop_th(int *t, int options) { if (f()) options |= 0x1 << 24; if (f()) options |= 0x1 << 25; if (f()) options |= 0x1 << 26; +#endif if (f()) *t = options; } + diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-lim-5.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-lim-5.c index 18ca905bf8e..4a428515dd9 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-lim-5.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ssa-lim-5.c @@ -13,10 +13,14 @@ void link_error(); int foo(struct BUF1 * p) { - int i = 0; +#if(__SIZEOF_INT__ >= 4) for (i = 0; i < 1024*1024; i++) +#else + for (i = 0; i < 128*128; i++) +#endif p->b1 = 1; + if (p->b1 != 1) link_error (); return 0; diff --git a/gcc/testsuite/gcc.target/i386/pr35767-1.c b/gcc/testsuite/gcc.target/i386/pr35767-1.c new file mode 100644 index 00000000000..5ed5b858866 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-1.c @@ -0,0 +1,25 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -msse2" } */ + +#include "sse2-check.h" + +typedef struct { __m128 f __attribute__((packed)); } packed; + +__m128 __attribute__((noinline)) +foo (__m128 a1, __m128 a2, __m128 a3, __m128 a4, + __m128 a5, __m128 a6, __m128 a7, __m128 a8, + int b1, int b2, int b3, int b4, int b5, int b6, int b7, packed y) +{ + return y.f; +} + +void +sse2_test (void) +{ + packed x; + __m128 y = { 0 }; + x.f = y; + y = foo (y, y, y, y, y, y, y, y, 1, 2, 3, 4, 5, 6, -1, x); + if (__builtin_memcmp (&y, &x.f, sizeof (y)) != 0) + abort (); +} diff --git a/gcc/testsuite/gcc.target/i386/pr35767-1d.c b/gcc/testsuite/gcc.target/i386/pr35767-1d.c new file mode 100644 index 00000000000..cdf17fa61b3 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-1d.c @@ -0,0 +1,25 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -msse2" } */ + +#include "sse2-check.h" + +typedef struct { __m128d f __attribute__((packed)); } packed; + +__m128d __attribute__((noinline)) +foo (__m128d a1, __m128d a2, __m128d a3, __m128d a4, + __m128d a5, __m128d a6, __m128d a7, __m128d a8, + int b1, int b2, int b3, int b4, int b5, int b6, int b7, packed y) +{ + return y.f; +} + +void +sse2_test (void) +{ + packed x; + __m128d y = { 0 }; + x.f = y; + y = foo (y, y, y, y, y, y, y, y, 1, 2, 3, 4, 5, 6, -1, x); + if (__builtin_memcmp (&y, &x.f, sizeof (y)) != 0) + abort (); +} diff --git a/gcc/testsuite/gcc.target/i386/pr35767-1i.c b/gcc/testsuite/gcc.target/i386/pr35767-1i.c new file mode 100644 index 00000000000..188e8e737bd --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-1i.c @@ -0,0 +1,25 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -msse2" } */ + +#include "sse2-check.h" + +typedef struct { __m128i f __attribute__((packed)); } packed; + +__m128i __attribute__((noinline)) +foo (__m128i a1, __m128i a2, __m128i a3, __m128i a4, + __m128i a5, __m128i a6, __m128i a7, __m128i a8, + int b1, int b2, int b3, int b4, int b5, int b6, int b7, packed y) +{ + return y.f; +} + +void +sse2_test (void) +{ + packed x; + __m128i y = { 0 }; + x.f = y; + y = foo (y, y, y, y, y, y, y, y, 1, 2, 3, 4, 5, 6, -1, x); + if (__builtin_memcmp (&y, &x.f, sizeof (y)) != 0) + abort (); +} diff --git a/gcc/testsuite/gcc.target/i386/pr35767-2.c b/gcc/testsuite/gcc.target/i386/pr35767-2.c new file mode 100644 index 00000000000..82062ff9ee7 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-2.c @@ -0,0 +1,25 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -msse2" } */ + +#include "sse2-check.h" + +typedef __m128 __attribute__((aligned(1))) unaligned; + +__m128 __attribute__((noinline)) +foo (__m128 a1, __m128 a2, __m128 a3, __m128 a4, + __m128 a5, __m128 a6, __m128 a7, __m128 a8, + int b1, int b2, int b3, int b4, int b5, int b6, int b7, unaligned y) +{ + return y; +} + +void +sse2_test (void) +{ + unaligned x; + __m128 y = { 0 }; + x = y; + y = foo (y, y, y, y, y, y, y, y, 1, 2, 3, 4, 5, 6, -1, x); + if (__builtin_memcmp (&y, &x, sizeof (y)) != 0) + abort (); +} diff --git a/gcc/testsuite/gcc.target/i386/pr35767-2d.c b/gcc/testsuite/gcc.target/i386/pr35767-2d.c new file mode 100644 index 00000000000..ae96cd852d0 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-2d.c @@ -0,0 +1,25 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -msse2" } */ + +#include "sse2-check.h" + +typedef __m128d __attribute__((aligned(1))) unaligned; + +__m128d __attribute__((noinline)) +foo (__m128d a1, __m128d a2, __m128d a3, __m128d a4, + __m128d a5, __m128d a6, __m128d a7, __m128d a8, + int b1, int b2, int b3, int b4, int b5, int b6, int b7, unaligned y) +{ + return y; +} + +void +sse2_test (void) +{ + unaligned x; + __m128d y = { 0 }; + x = y; + y = foo (y, y, y, y, y, y, y, y, 1, 2, 3, 4, 5, 6, -1, x); + if (__builtin_memcmp (&y, &x, sizeof (y)) != 0) + abort (); +} diff --git a/gcc/testsuite/gcc.target/i386/pr35767-2i.c b/gcc/testsuite/gcc.target/i386/pr35767-2i.c new file mode 100644 index 00000000000..d241644b62b --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-2i.c @@ -0,0 +1,25 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -msse2" } */ + +#include "sse2-check.h" + +typedef __m128i __attribute__((aligned(1))) unaligned; + +__m128i __attribute__((noinline)) +foo (__m128i a1, __m128i a2, __m128i a3, __m128i a4, + __m128i a5, __m128i a6, __m128i a7, __m128i a8, + int b1, int b2, int b3, int b4, int b5, int b6, int b7, unaligned y) +{ + return y; +} + +void +sse2_test (void) +{ + unaligned x; + __m128i y = { 0 }; + x = y; + y = foo (y, y, y, y, y, y, y, y, 1, 2, 3, 4, 5, 6, -1, x); + if (__builtin_memcmp (&y, &x, sizeof (y)) != 0) + abort (); +} diff --git a/gcc/testsuite/gcc.target/i386/pr35767-3.c b/gcc/testsuite/gcc.target/i386/pr35767-3.c new file mode 100644 index 00000000000..e7592ff7bcb --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-3.c @@ -0,0 +1,26 @@ +/* { dg-do run } */ +/* { dg-require-effective-target dfp } */ +/* { dg-options "-O -msse2 -std=gnu99" } */ + +#include "sse2-check.h" + +typedef _Decimal128 unaligned __attribute__((aligned(1))); + +_Decimal128 __attribute__((noinline)) +foo (_Decimal128 a1, _Decimal128 a2, _Decimal128 a3, _Decimal128 a4, + _Decimal128 a5, _Decimal128 a6, _Decimal128 a7, _Decimal128 a8, + int b1, int b2, int b3, int b4, int b5, int b6, int b7, unaligned y) +{ + return y; +} + +void +sse2_test (void) +{ + unaligned x; + _Decimal128 y = -1; + x = y; + y = foo (0, 0, 0, 0, 0, 0, 0, 0, 1, 2, 3, 4, 5, 6, -1, x); + if (__builtin_memcmp (&y, &x, sizeof (y))) + abort (); +} diff --git a/gcc/testsuite/gcc.target/i386/pr35767-4.c b/gcc/testsuite/gcc.target/i386/pr35767-4.c new file mode 100644 index 00000000000..e12f64ffe98 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-4.c @@ -0,0 +1,14 @@ +/* Test that we generate aligned load when memory is aligned. */ +/* { dg-do compile } */ +/* { dg-require-effective-target dfp } */ +/* { dg-options "-O -march=x86-64 -mtune=generic -std=gnu99" } */ +/* { dg-final { scan-assembler-not "movdqu" } } */ +/* { dg-final { scan-assembler "movdqa" } } */ + +extern _Decimal128 foo (_Decimal128, _Decimal128, _Decimal128); + +void +bar (void) +{ + foo (0, 0, 0); +} diff --git a/gcc/testsuite/gcc.target/i386/pr35767-5.c b/gcc/testsuite/gcc.target/i386/pr35767-5.c new file mode 100644 index 00000000000..4372d2e5746 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr35767-5.c @@ -0,0 +1,17 @@ +/* Test that we generate aligned load when memory is aligned. */ +/* { dg-do compile } */ +/* { dg-options "-O -msse2 -mtune=generic" } */ +/* { dg-final { scan-assembler-not "movups" } } */ +/* { dg-final { scan-assembler "movaps" } } */ + +typedef float v4sf __attribute__ ((__vector_size__ (16))); + +extern void foo(v4sf, v4sf, v4sf, v4sf, v4sf, v4sf, v4sf, v4sf, v4sf); + +int test(void) +{ + v4sf x = { 0.0, 1.0, 2.0, 3.0 }; + + foo (x, x, x, x, x, x, x, x, x); + return 0; +} diff --git a/gcc/testsuite/gcc.target/spu/muldivti3.c b/gcc/testsuite/gcc.target/spu/muldivti3.c new file mode 100644 index 00000000000..0363e342075 --- /dev/null +++ b/gcc/testsuite/gcc.target/spu/muldivti3.c @@ -0,0 +1,46 @@ +/* { dg-do run } */ +/* { dg-options "-std=c99" } */ +#include <stdlib.h> +typedef unsigned int uqword __attribute__((mode(TI))); +typedef int qword __attribute__((mode(TI))); + +typedef union +{ + uqword uq; + qword q; + unsigned long long ull[2]; +} u; + +int main(void) +{ + uqword e, f; + qword g, h; + + e = 0x1111111111111111ULL; + f = 0xFULL; + g = 0x0000000000111100ULL; + h = 0x0000000000000000ULL; + + u m, n, o, p, q; + + m.ull[0] = f; + m.ull[1] = e; + n.ull[0] = h; + n.ull[1] = g; + + /* __multi3 */ + o.q = m.q * n.q; + + o.q = o.q + n.q + 0x1110FF; + /* __udivti3, __umodti3 */ + p.uq = o.uq / n.uq; + q.uq = o.uq % n.uq; + if (p.uq != (m.uq+1)) abort(); + if (q.uq != 0x1110FF) abort(); + /* __divti3, __modti3 */ + p.q = -o.q / n.q; + q.q = -o.q % n.q; + if ((-p.q * n.q - q.q) != o.q) abort(); + + return 0; +} diff --git a/gcc/testsuite/gfortran.dg/assignment_3.f90 b/gcc/testsuite/gfortran.dg/assignment_3.f90 new file mode 100644 index 00000000000..cdaaa8c5a4f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assignment_3.f90 @@ -0,0 +1,63 @@ +! { dg-do compile } +! PR fortran/36316 +! +! gfortran generated a mismatching tree ("type mismatch in binary expression") +! for array bounds (mixing integer kind=4/kind=8 without fold_convert). +! +MODULE YOMCAIN + +IMPLICIT NONE +SAVE + +TYPE distributed_vector +REAL, pointer :: local(:) +INTEGER(4) :: global_length,local_start +INTEGER(8) :: local_end +END TYPE distributed_vector + +INTERFACE ASSIGNMENT (=) +MODULE PROCEDURE assign_ar_dv +END INTERFACE + +INTERFACE OPERATOR (*) +MODULE PROCEDURE multiply_dv_dv +END INTERFACE + +CONTAINS + +SUBROUTINE assign_ar_dv (handle,pvec) + +! copy array to the distributed_vector + +REAL, INTENT(IN) :: pvec(:) +TYPE (distributed_vector), INTENT(INOUT) :: handle + +handle%local(:) = pvec(:) + +RETURN +END SUBROUTINE assign_ar_dv + +FUNCTION multiply_dv_dv (handle1,handle2) + +! multiply two distributed_vectors + +TYPE (distributed_vector), INTENT(IN) :: handle2 +TYPE (distributed_vector), INTENT(IN) :: handle1 +REAL :: multiply_dv_dv(handle1%local_start:handle1%local_end) + +multiply_dv_dv = handle1%local(:) * handle2%local(:) + +RETURN +END FUNCTION multiply_dv_dv + + +SUBROUTINE CAININAD_SCALE_DISTVEC () +TYPE (distributed_vector) :: PVAZG +TYPE (distributed_vector) :: ZTEMP +TYPE (distributed_vector) :: SCALP_DV + +ZTEMP = PVAZG * SCALP_DV +END SUBROUTINE CAININAD_SCALE_DISTVEC +END MODULE YOMCAIN + +! { dg-final { cleanup-modules "yomcain" } } diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 new file mode 100644 index 00000000000..525af506428 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +! +! PR fortran/32600 c_f_pointer w/o shape +! PR fortran/32580 c_f_procpointer +! +! Verify that c_f_prointer [w/o shape] and c_f_procpointer generate +! the right code - and no library call + +program test + use iso_c_binding + implicit none + type(c_ptr) :: cptr + type(c_funptr) :: cfunptr + integer(4), pointer :: fptr + integer(4), pointer :: fptr_array(:) +! procedure(integer(4)), pointer :: fprocptr ! TODO + + call c_f_pointer(cptr, fptr) + call c_f_pointer(cptr, fptr_array, [ 1 ]) +! call c_f_procpointer(cfunptr, fprocptr) ! TODO +end program test + +! Make sure there is only a single function call: +! { dg-final { scan-tree-dump-times "c_f" 1 "original" } } +! { dg-final { scan-tree-dump-times "c_f_pointer" 1 "original" } } +! { dg-final { scan-tree-dump-times "c_f_pointer_i4" 1 "original" } } +! +! Check scalar c_f_pointer +! { dg-final { scan-tree-dump-times " fptr = .integer.kind=4. .. cptr" 1 "original" } } +! +! Check c_f_procpointer +! TODO { scan-tree-dump-times " fprocptr = .integer.kind=4. .\\*<.*>. .void.. cfunptr;" 1 "original" } } TODO +! +! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/external_procedures_1.f90 b/gcc/testsuite/gfortran.dg/external_procedures_1.f90 index 95d0212353e..6e833be16e2 100644 --- a/gcc/testsuite/gfortran.dg/external_procedures_1.f90 +++ b/gcc/testsuite/gfortran.dg/external_procedures_1.f90 @@ -24,7 +24,7 @@ program main interface function ext1 (y) real ext1, y - external ext1 ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" } + external ext1 ! { dg-error "Duplicate EXTERNAL attribute" } end function ext1 end interface inval = 1.0 @@ -38,4 +38,4 @@ contains inv = y * y * y end function inv end program main -
+ diff --git a/gcc/testsuite/gfortran.dg/gomp/reduction3.f90 b/gcc/testsuite/gfortran.dg/gomp/reduction3.f90 index abd6d04415d..0272a741596 100644 --- a/gcc/testsuite/gfortran.dg/gomp/reduction3.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/reduction3.f90 @@ -33,11 +33,6 @@ subroutine f2 end subroutine f2 subroutine f3 integer :: i - interface - function ior (a, b) - integer :: ior, a, b - end function - end interface intrinsic ior i = 6 !$omp parallel reduction (ior:i) diff --git a/gcc/testsuite/gfortran.dg/interface_23.f90 b/gcc/testsuite/gfortran.dg/interface_23.f90 new file mode 100644 index 00000000000..60b6e796908 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_23.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! This tests the fix for PR36325, which corrected for the fact that a +! specific or generic INTERFACE statement implies the EXTERNAL attibute. +! +! Contributed by Janus Weil <janus@gcc.gnu.org> + +module a + interface + subroutine foo + end subroutine + end interface + external foo ! { dg-error "Duplicate EXTERNAL attribute" } +end module + +module b + interface + function sin (x) + real :: sin, x + end function + end interface + intrinsic sin ! { dg-error "EXTERNAL attribute conflicts with INTRINSIC attribute" } +end module + +! argument checking was not done for external procedures with explicit interface +program c + interface + subroutine bar(x) + real :: x + end subroutine + end interface + call bar() ! { dg-error "Missing actual argument" } +end program + +! { dg-final { cleanup-modules "a b" } } diff --git a/gcc/testsuite/gfortran.dg/proc_decl_12.f90 b/gcc/testsuite/gfortran.dg/proc_decl_12.f90 new file mode 100644 index 00000000000..092c24d3614 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_decl_12.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! This tests the (partial) fix for PR35830, i.e. handling array arguments +! with the PROCEDURE statement. +! +! Contributed by Janus Weil <janus@gcc.gnu.org> + +module m +contains + subroutine one(a) + integer a(1:3) + if (any(a /= [1,2,3])) call abort() + end subroutine one +end module m + +program test + use m + implicit none + call foo(one) +contains + subroutine foo(f) + procedure(one) :: f + call f([1,2,3]) + end subroutine foo +end program test + +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_8.f03 b/gcc/testsuite/gfortran.dg/structure_constructor_8.f03 index 995fd806a96..4b0bce779db 100644 --- a/gcc/testsuite/gfortran.dg/structure_constructor_8.f03 +++ b/gcc/testsuite/gfortran.dg/structure_constructor_8.f03 @@ -58,4 +58,4 @@ PROGRAM test WRITE (*,*) ispriv_t (5) ! { dg-error "has no IMPLICIT type" } END PROGRAM test -! { dg-final { cleanup-modules privmod } } +! { dg-final { cleanup-modules "privmod" } } diff --git a/gcc/testsuite/gfortran.dg/widechar_5.f90 b/gcc/testsuite/gfortran.dg/widechar_5.f90 new file mode 100644 index 00000000000..ed2f32fbd09 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_5.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + +module kinds + implicit none + integer, parameter :: one = 1, four = 4 +end module kinds + +module inner + use kinds + implicit none + character(kind=one,len=*), parameter :: inner1 = "abcdefg \xEF kl" + character(kind=four,len=*), parameter :: & + inner4 = 4_"\u9317x \U001298cef dea\u10De" +end module inner + +module middle + use inner + implicit none + character(kind=one,len=len(inner1)), dimension(2,2), parameter :: middle1 & + = reshape ([ character(kind=one,len=len(inner1)) :: inner1, ""], & + [ 2, 2 ], & + [ character(kind=one,len=len(inner1)) :: "foo", "ba " ]) + character(kind=four,len=len(inner4)), dimension(2,2), parameter :: middle4 & + = reshape ([ character(kind=four,len=len(inner4)) :: inner4, 4_""], & + [ 2, 2 ], & + [ character(kind=four,len=len(inner4)) :: 4_"foo", 4_"ba " ]) +end module middle + +module outer + use middle + implicit none + character(kind=one,len=*), parameter :: my1(2) = middle1(1,:) + character(kind=four,len=*), parameter :: my4(2) = middle4(1,:) +end module outer + +program test_modules + use outer, outer1 => my1, outer4 => my4 + implicit none + + if (len (inner1) /= len(inner4)) call abort + if (len (inner1) /= len_trim(inner1)) call abort + if (len (inner4) /= len_trim(inner4)) call abort + + if (len(middle1) /= len(inner1)) call abort + if (len(outer1) /= len(inner1)) call abort + if (len(middle4) /= len(inner4)) call abort + if (len(outer4) /= len(inner4)) call abort + + if (any (len_trim (middle1) /= reshape([len(middle1), 0, 3, 2], [2,2]))) & + call abort + if (any (len_trim (middle4) /= reshape([len(middle4), 0, 3, 2], [2,2]))) & + call abort + if (any (len_trim (outer1) /= [len(outer1), 3])) call abort + if (any (len_trim (outer4) /= [len(outer4), 3])) call abort + +end program test_modules + +! { dg-final { cleanup-modules "kinds inner middle outer" } } diff --git a/gcc/testsuite/gfortran.dg/widechar_6.f90 b/gcc/testsuite/gfortran.dg/widechar_6.f90 new file mode 100644 index 00000000000..9151adba418 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_6.f90 @@ -0,0 +1,64 @@ +! { dg-do run } + +module mod + + interface cut + module procedure cut1 + module procedure cut4 + end interface cut + +contains + + function cut1 (s) + character(kind=1,len=*), intent(in) :: s + character(kind=1,len=max(0,len(s)-3)) :: cut1 + + cut1 = s(4:) + end function cut1 + + function cut4 (s) + character(kind=4,len=*), intent(in) :: s + character(kind=4,len=max(0,len(s)-3)) :: cut4 + + cut4 = s(4:) + end function cut4 + +end module mod + +program test + use mod + + if (len (cut1("")) /= 0 .or. cut1("") /= "") call abort + if (len (cut1("1")) /= 0 .or. cut1("") /= "") call abort + if (len (cut1("12")) /= 0 .or. cut1("") /= "") call abort + if (len (cut1("123")) /= 0 .or. cut1("") /= "") call abort + if (len (cut1("1234")) /= 1 .or. cut1("4") /= "") call abort + if (len (cut1("12345")) /= 2 .or. cut1("45") /= "") call abort + + if (len (cut4(4_"")) /= 0 .or. cut4(4_"") /= 4_"") call abort + if (len (cut4(4_"1")) /= 0 .or. cut4(4_"") /= 4_"") call abort + if (len (cut4(4_"12")) /= 0 .or. cut4(4_"") /= 4_"") call abort + if (len (cut4(4_"123")) /= 0 .or. cut4(4_"") /= 4_"") call abort + if (len (cut4(4_"1234")) /= 1 .or. cut4(4_"4") /= 4_"") call abort + if (len (cut4(4_"12345")) /= 2 .or. cut4(4_"45") /= 4_"") call abort + + if (kind (cut("")) /= kind("")) call abort + if (kind (cut(4_"")) /= kind(4_"")) call abort + + if (len (cut("")) /= 0 .or. cut("") /= "") call abort + if (len (cut("1")) /= 0 .or. cut("") /= "") call abort + if (len (cut("12")) /= 0 .or. cut("") /= "") call abort + if (len (cut("123")) /= 0 .or. cut("") /= "") call abort + if (len (cut("1234")) /= 1 .or. cut("4") /= "") call abort + if (len (cut("12345")) /= 2 .or. cut("45") /= "") call abort + + if (len (cut(4_"")) /= 0 .or. cut(4_"") /= 4_"") call abort + if (len (cut(4_"1")) /= 0 .or. cut(4_"") /= 4_"") call abort + if (len (cut(4_"12")) /= 0 .or. cut(4_"") /= 4_"") call abort + if (len (cut(4_"123")) /= 0 .or. cut(4_"") /= 4_"") call abort + if (len (cut(4_"1234")) /= 1 .or. cut(4_"4") /= 4_"") call abort + if (len (cut(4_"12345")) /= 2 .or. cut(4_"45") /= 4_"") call abort + +end program test + +! { dg-final { cleanup-modules "mod" } } diff --git a/gcc/testsuite/gfortran.dg/widechar_7.f90 b/gcc/testsuite/gfortran.dg/widechar_7.f90 new file mode 100644 index 00000000000..4368321170b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_7.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } + +program test + + character(kind=1,len=10) :: s1 = 4_"foobargee", t1 = 4_"" + character(kind=4,len=10) :: s4 = "foobargee", t4 = "" + + t1(5:5) = s1(6:6) + t4(5:5) = s4(6:6) + t4(5:5) = s1(6:6) + t1(5:5) = s4(6:6) + + call sub (t1, t4) + +end program test + +! { dg-final { scan-tree-dump-times "memmove" 0 "original" } } +! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_10.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_10.f90 new file mode 100644 index 00000000000..c961d93cfd6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_10.f90 @@ -0,0 +1,89 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + implicit none + character(kind=1,len=3) :: s1(3) + character(kind=4,len=3) :: s4(3) + + s1 = [ "abc", "def", "ghi" ] + s4 = s1 + s4 = [ "abc", "def", "ghi" ] + + if (any (cshift (s1, 0) /= s1)) call abort + if (any (cshift (s4, 0) /= s4)) call abort + if (any (cshift (s1, 3) /= s1)) call abort + if (any (cshift (s4, 3) /= s4)) call abort + if (any (cshift (s1, 6) /= s1)) call abort + if (any (cshift (s4, 6) /= s4)) call abort + if (any (cshift (s1, -3) /= s1)) call abort + if (any (cshift (s4, -3) /= s4)) call abort + if (any (cshift (s1, -6) /= s1)) call abort + if (any (cshift (s4, -6) /= s4)) call abort + + if (any (cshift (s1, 1) /= [ s1(2:3), s1(1) ])) call abort + if (any (cshift (s1, -1) /= [ s1(3), s1(1:2) ])) call abort + if (any (cshift (s1, 4) /= [ s1(2:3), s1(1) ])) call abort + if (any (cshift (s1, -4) /= [ s1(3), s1(1:2) ])) call abort + + if (any (cshift (s4, 1) /= [ s4(2:3), s4(1) ])) call abort + if (any (cshift (s4, -1) /= [ s4(3), s4(1:2) ])) call abort + if (any (cshift (s4, 4) /= [ s4(2:3), s4(1) ])) call abort + if (any (cshift (s4, -4) /= [ s4(3), s4(1:2) ])) call abort + + if (any (cshift (s1, 2) /= [ s1(3), s1(1:2) ])) call abort + if (any (cshift (s1, -2) /= [ s1(2:3), s1(1) ])) call abort + if (any (cshift (s1, 5) /= [ s1(3), s1(1:2) ])) call abort + if (any (cshift (s1, -5) /= [ s1(2:3), s1(1) ])) call abort + + if (any (cshift (s4, 2) /= [ s4(3), s4(1:2) ])) call abort + if (any (cshift (s4, -2) /= [ s4(2:3), s4(1) ])) call abort + if (any (cshift (s4, 5) /= [ s4(3), s4(1:2) ])) call abort + if (any (cshift (s4, -5) /= [ s4(2:3), s4(1) ])) call abort + + + if (any (eoshift (s1, 0) /= s1)) call abort + if (any (eoshift (s4, 0) /= s4)) call abort + if (any (eoshift (s1, 3) /= "")) call abort + if (any (eoshift (s4, 3) /= 4_"")) call abort + if (any (eoshift (s1, 3, " ") /= "")) call abort + if (any (eoshift (s4, 3, 4_" ") /= 4_"")) call abort + if (any (eoshift (s1, 3, " x ") /= " x")) call abort + if (any (eoshift (s4, 3, 4_" x ") /= 4_" x")) call abort + if (any (eoshift (s1, -3) /= "")) call abort + if (any (eoshift (s4, -3) /= 4_"")) call abort + if (any (eoshift (s1, -3, " ") /= "")) call abort + if (any (eoshift (s4, -3, 4_" ") /= 4_"")) call abort + if (any (eoshift (s1, -3, " x ") /= " x")) call abort + if (any (eoshift (s4, -3, 4_" x ") /= 4_" x")) call abort + if (any (eoshift (s1, 4) /= "")) call abort + if (any (eoshift (s4, 4) /= 4_"")) call abort + if (any (eoshift (s1, 4, " ") /= "")) call abort + if (any (eoshift (s4, 4, 4_" ") /= 4_"")) call abort + if (any (eoshift (s1, 4, " x ") /= " x")) call abort + if (any (eoshift (s4, 4, 4_" x ") /= 4_" x")) call abort + if (any (eoshift (s1, -4) /= "")) call abort + if (any (eoshift (s4, -4) /= 4_"")) call abort + if (any (eoshift (s1, -4, " ") /= "")) call abort + if (any (eoshift (s4, -4, 4_" ") /= 4_"")) call abort + if (any (eoshift (s1, -4, " x ") /= " x")) call abort + if (any (eoshift (s4, -4, 4_" x ") /= 4_" x")) call abort + + if (any (eoshift (s1, 1) /= [ s1(2:3), " " ])) call abort + if (any (eoshift (s1, -1) /= [ " ", s1(1:2) ])) call abort + if (any (eoshift (s1, 1, " x ") /= [ s1(2:3), " x " ])) call abort + if (any (eoshift (s1, -1, " x ") /= [ " x ", s1(1:2) ])) call abort + if (any (eoshift (s4, 1) /= [ s4(2:3), 4_" " ])) call abort + if (any (eoshift (s4, -1) /= [ 4_" ", s4(1:2) ])) call abort + if (any (eoshift (s4, 1, 4_" x ") /= [ s4(2:3), 4_" x " ])) call abort + if (any (eoshift (s4, -1, 4_" x ") /= [ 4_" x ", s4(1:2) ])) call abort + + if (any (eoshift (s1, 2) /= [ s1(3), " ", " " ])) call abort + if (any (eoshift (s1, -2) /= [ " ", " ", s1(1) ])) call abort + if (any (eoshift (s1, 2, " x ") /= [ s1(3), " x ", " x " ])) call abort + if (any (eoshift (s1, -2, " x ") /= [ " x ", " x ", s1(1) ])) call abort + if (any (eoshift (s4, 2) /= [ s4(3), 4_" ", 4_" " ])) call abort + if (any (eoshift (s4, -2) /= [ 4_" ", 4_" ", s4(1) ])) call abort + if (any (eoshift (s4, 2, 4_" x ") /= [ s4(3), 4_" x ", 4_" x " ])) call abort + if (any (eoshift (s4, -2, 4_" x ") /= [ 4_" x ", 4_" x ", s4(1) ])) call abort + +end diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_5.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_5.f90 index 5c989cc25b3..e388685adf6 100644 --- a/gcc/testsuite/gfortran.dg/widechar_intrinsics_5.f90 +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_5.f90 @@ -70,15 +70,13 @@ 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 (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 diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_6.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_6.f90 new file mode 100644 index 00000000000..68b46d8f608 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_6.f90 @@ -0,0 +1,109 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + character(kind=1, len=3) :: s1 + character(kind=4, len=3) :: s4 + integer :: i + + s1 = "fo " + s4 = 4_"fo " + i = 3 + + ! Check the REPEAT intrinsic + + if (repeat (1_"foo", 2) /= 1_"foofoo") call abort + if (repeat (1_"fo ", 2) /= 1_"fo fo ") call abort + if (repeat (1_"fo ", 2) /= 1_"fo fo") call abort + if (repeat (1_"fo ", 0) /= 1_"") call abort + if (repeat (s1, 2) /= 1_"fo fo ") call abort + if (repeat (s1, 2) /= 1_"fo fo") call abort + if (repeat (s1, 2) /= s1 // s1) call abort + if (repeat (s1, 3) /= s1 // s1 // s1) call abort + if (repeat (s1, 1) /= s1) call abort + if (repeat (s1, 0) /= "") call abort + + if (repeat (4_"foo", 2) /= 4_"foofoo") call abort + if (repeat (4_"fo ", 2) /= 4_"fo fo ") call abort + if (repeat (4_"fo ", 2) /= 4_"fo fo") call abort + if (repeat (4_"fo ", 0) /= 4_"") call abort + if (repeat (s4, 2) /= 4_"fo fo ") call abort + if (repeat (s4, 2) /= 4_"fo fo") call abort + if (repeat (s4, 3) /= s4 // s4 // s4) call abort + if (repeat (s4, 1) /= s4) call abort + if (repeat (s4, 0) /= 4_"") call abort + + call check_repeat (s1, s4) + call check_repeat ("", 4_"") + call check_repeat ("truc", 4_"truc") + call check_repeat ("truc ", 4_"truc ") + + ! Check NEW_LINE + + if (ichar(new_line ("")) /= 10) call abort + if (len(new_line ("")) /= 1) call abort + if (ichar(new_line (s1)) /= 10) call abort + if (len(new_line (s1)) /= 1) call abort + if (ichar(new_line (["",""])) /= 10) call abort + if (len(new_line (["",""])) /= 1) call abort + if (ichar(new_line ([s1,s1])) /= 10) call abort + if (len(new_line ([s1,s1])) /= 1) call abort + + if (ichar(new_line (4_"")) /= 10) call abort + if (len(new_line (4_"")) /= 1) call abort + if (ichar(new_line (s4)) /= 10) call abort + if (len(new_line (s4)) /= 1) call abort + if (ichar(new_line ([4_"",4_""])) /= 10) call abort + if (len(new_line ([4_"",4_""])) /= 1) call abort + if (ichar(new_line ([s4,s4])) /= 10) call abort + if (len(new_line ([s4,s4])) /= 1) call abort + + ! Check SIZEOF + + if (sizeof ("") /= 0) call abort + if (sizeof (4_"") /= 0) call abort + if (sizeof ("x") /= 1) call abort + if (sizeof ("\xFF") /= 1) call abort + if (sizeof (4_"x") /= 4) call abort + if (sizeof (4_"\UFFFFFFFF") /= 4) call abort + if (sizeof (s1) /= 3) call abort + if (sizeof (s4) /= 12) call abort + + if (sizeof (["a", "x", "z"]) / sizeof ("a") /= 3) call abort + if (sizeof ([4_"a", 4_"x", 4_"z"]) / sizeof (4_"a") /= 3) call abort + + call check_sizeof ("", 4_"", 0) + call check_sizeof ("x", 4_"x", 1) + call check_sizeof ("\xFF", 4_"\UFEBCE19E", 1) + call check_sizeof ("\xFF ", 4_"\UFEBCE19E ", 2) + call check_sizeof (s1, s4, 3) + +contains + + subroutine check_repeat (s1, s4) + character(kind=1, len=*), intent(in) :: s1 + character(kind=4, len=*), intent(in) :: s4 + integer :: i + + do i = 0, 10 + if (len (repeat(s1, i)) /= i * len(s1)) call abort + if (len (repeat(s4, i)) /= i * len(s4)) call abort + + if (len_trim (repeat(s1, i)) & + /= max(0, (i - 1) * len(s1) + len_trim (s1))) call abort + if (len_trim (repeat(s4, i)) & + /= max(0, (i - 1) * len(s4) + len_trim (s4))) call abort + end do + end subroutine check_repeat + + subroutine check_sizeof (s1, s4, i) + character(kind=1, len=*), intent(in) :: s1 + character(kind=4, len=*), intent(in) :: s4 + character(kind=4, len=len(s4)) :: t4 + integer, intent(in) :: i + + if (sizeof (s1) /= i) call abort + if (sizeof (s4) / sizeof (4_" ") /= i) call abort + if (sizeof (t4) / sizeof (4_" ") /= i) call abort + end subroutine check_sizeof + +end diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_7.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_7.f90 new file mode 100644 index 00000000000..7971af3963e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_7.f90 @@ -0,0 +1,125 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + character(kind=1, len=10) :: s1, t1 + character(kind=4, len=10) :: s4, t4 + + call check1("foobargeefoobargee", "arg", & + [ index ("foobargeefoobargee", "arg", .true.), & + index ("foobargeefoobargee", "arg", .false.), & + scan ("foobargeefoobargee", "arg", .true.), & + scan ("foobargeefoobargee", "arg", .false.), & + verify ("foobargeefoobargee", "arg", .true.), & + verify ("foobargeefoobargee", "arg", .false.) ], & + 4_"foobargeefoobargee", 4_"arg", & + [ index (4_"foobargeefoobargee", 4_"arg", .true.), & + index (4_"foobargeefoobargee", 4_"arg", .false.), & + scan (4_"foobargeefoobargee", 4_"arg", .true.), & + scan (4_"foobargeefoobargee", 4_"arg", .false.), & + verify (4_"foobargeefoobargee", 4_"arg", .true.), & + verify (4_"foobargeefoobargee", 4_"arg", .false.) ]) + + call check1("foobargeefoobargee", "", & + [ index ("foobargeefoobargee", "", .true.), & + index ("foobargeefoobargee", "", .false.), & + scan ("foobargeefoobargee", "", .true.), & + scan ("foobargeefoobargee", "", .false.), & + verify ("foobargeefoobargee", "", .true.), & + verify ("foobargeefoobargee", "", .false.) ], & + 4_"foobargeefoobargee", 4_"", & + [ index (4_"foobargeefoobargee", 4_"", .true.), & + index (4_"foobargeefoobargee", 4_"", .false.), & + scan (4_"foobargeefoobargee", 4_"", .true.), & + scan (4_"foobargeefoobargee", 4_"", .false.), & + verify (4_"foobargeefoobargee", 4_"", .true.), & + verify (4_"foobargeefoobargee", 4_"", .false.) ]) + call check1("foobargeefoobargee", "klm", & + [ index ("foobargeefoobargee", "klm", .true.), & + index ("foobargeefoobargee", "klm", .false.), & + scan ("foobargeefoobargee", "klm", .true.), & + scan ("foobargeefoobargee", "klm", .false.), & + verify ("foobargeefoobargee", "klm", .true.), & + verify ("foobargeefoobargee", "klm", .false.) ], & + 4_"foobargeefoobargee", 4_"klm", & + [ index (4_"foobargeefoobargee", 4_"klm", .true.), & + index (4_"foobargeefoobargee", 4_"klm", .false.), & + scan (4_"foobargeefoobargee", 4_"klm", .true.), & + scan (4_"foobargeefoobargee", 4_"klm", .false.), & + verify (4_"foobargeefoobargee", 4_"klm", .true.), & + verify (4_"foobargeefoobargee", 4_"klm", .false.) ]) + call check1("foobargeefoobargee", "gee", & + [ index ("foobargeefoobargee", "gee", .true.), & + index ("foobargeefoobargee", "gee", .false.), & + scan ("foobargeefoobargee", "gee", .true.), & + scan ("foobargeefoobargee", "gee", .false.), & + verify ("foobargeefoobargee", "gee", .true.), & + verify ("foobargeefoobargee", "gee", .false.) ], & + 4_"foobargeefoobargee", 4_"gee", & + [ index (4_"foobargeefoobargee", 4_"gee", .true.), & + index (4_"foobargeefoobargee", 4_"gee", .false.), & + scan (4_"foobargeefoobargee", 4_"gee", .true.), & + scan (4_"foobargeefoobargee", 4_"gee", .false.), & + verify (4_"foobargeefoobargee", 4_"gee", .true.), & + verify (4_"foobargeefoobargee", 4_"gee", .false.) ]) + call check1("foobargeefoobargee", "foo", & + [ index ("foobargeefoobargee", "foo", .true.), & + index ("foobargeefoobargee", "foo", .false.), & + scan ("foobargeefoobargee", "foo", .true.), & + scan ("foobargeefoobargee", "foo", .false.), & + verify ("foobargeefoobargee", "foo", .true.), & + verify ("foobargeefoobargee", "foo", .false.) ], & + 4_"foobargeefoobargee", 4_"foo", & + [ index (4_"foobargeefoobargee", 4_"foo", .true.), & + index (4_"foobargeefoobargee", 4_"foo", .false.), & + scan (4_"foobargeefoobargee", 4_"foo", .true.), & + scan (4_"foobargeefoobargee", 4_"foo", .false.), & + verify (4_"foobargeefoobargee", 4_"foo", .true.), & + verify (4_"foobargeefoobargee", 4_"foo", .false.) ]) + + call check1(" \b fe \b\0 bar cad", " \b\0", & + [ index (" \b fe \b\0 bar cad", " \b\0", .true.), & + index (" \b fe \b\0 bar cad", " \b\0", .false.), & + scan (" \b fe \b\0 bar cad", " \b\0", .true.), & + scan (" \b fe \b\0 bar cad", " \b\0", .false.), & + verify (" \b fe \b\0 bar cad", " \b\0", .true.), & + verify (" \b fe \b\0 bar cad", " \b\0", .false.) ], & + 4_" \uC096 fe \uC096\uB8DE bar cad", 4_" \uC096\uB8DE", & + [ index (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .true.), & + index (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .false.), & + scan (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .true.), & + scan (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .false.), & + verify (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .true.), & + verify (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .false.) ]) + +contains + + subroutine check1 (s1, t1, res1, s4, t4, res4) + character(kind=1, len=*) :: s1, t1 + character(kind=4, len=*) :: s4, t4 + integer :: res1(6), res4(6) + + if (any (res1 /= res4)) call abort + + if (index (s1, t1, .true.) /= res1(1)) call abort + if (index (s1, t1, .false.) /= res1(2)) call abort + if (scan (s1, t1, .true.) /= res1(3)) call abort + if (scan (s1, t1, .false.) /= res1(4)) call abort + if (verify (s1, t1, .true.) /= res1(5)) call abort + if (verify (s1, t1, .false.) /= res1(6)) call abort + + if (index (s4, t4, .true.) /= res4(1)) call abort + if (index (s4, t4, .false.) /= res4(2)) call abort + if (scan (s4, t4, .true.) /= res4(3)) call abort + if (scan (s4, t4, .false.) /= res4(4)) call abort + if (verify (s4, t4, .true.) /= res4(5)) call abort + if (verify (s4, t4, .false.) /= res4(6)) call abort + + end subroutine check1 + +end diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_8.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_8.f90 new file mode 100644 index 00000000000..eeeabbca5af --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_8.f90 @@ -0,0 +1,85 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + logical, parameter :: bigendian = transfer ((/1_1,0_1,0_1,0_1/), 0_4) /= 1 + + character(kind=1,len=3) :: s1, t1, u1 + character(kind=4,len=3) :: s4, t4, u4 + + ! Test MERGE intrinsic + + call check_merge1 ("foo", "gee", .true., .false.) + call check_merge4 (4_"foo", 4_"gee", .true., .false.) + + if (merge ("foo", "gee", .true.) /= "foo") call abort + if (merge ("foo", "gee", .false.) /= "gee") call abort + if (merge (4_"foo", 4_"gee", .true.) /= 4_"foo") call abort + if (merge (4_"foo", 4_"gee", .false.) /= 4_"gee") call abort + + ! Test TRANSFER intrinsic + + if (bigendian) then + if (transfer (4_"x", " ") /= "\0\0\0x") call abort + else + if (transfer (4_"x", " ") /= "x\0\0\0") call abort + endif + if (transfer (4_"\U44444444", " ") /= "\x44\x44\x44\x44") call abort + if (transfer (4_"\U3FE91B5A", 0_4) /= int(z'3FE91B5A', 4)) call abort + + call check_transfer_i (4_"\U3FE91B5A", [int(z'3FE91B5A', 4)]) + call check_transfer_i (4_"\u1B5A", [int(z'1B5A', 4)]) + +contains + + subroutine check_merge1 (s1, t1, t, f) + character(kind=1,len=*) :: s1, t1 + logical :: t, f + + if (merge (s1, t1, .true.) /= s1) call abort + if (merge (s1, t1, .false.) /= t1) call abort + if (len (merge (s1, t1, .true.)) /= len (s1)) call abort + if (len (merge (s1, t1, .false.)) /= len (t1)) call abort + if (len_trim (merge (s1, t1, .true.)) /= len_trim (s1)) call abort + if (len_trim (merge (s1, t1, .false.)) /= len_trim (t1)) call abort + + if (merge (s1, t1, t) /= s1) call abort + if (merge (s1, t1, f) /= t1) call abort + if (len (merge (s1, t1, t)) /= len (s1)) call abort + if (len (merge (s1, t1, f)) /= len (t1)) call abort + if (len_trim (merge (s1, t1, t)) /= len_trim (s1)) call abort + if (len_trim (merge (s1, t1, f)) /= len_trim (t1)) call abort + + end subroutine check_merge1 + + subroutine check_merge4 (s4, t4, t, f) + character(kind=4,len=*) :: s4, t4 + logical :: t, f + + if (merge (s4, t4, .true.) /= s4) call abort + if (merge (s4, t4, .false.) /= t4) call abort + if (len (merge (s4, t4, .true.)) /= len (s4)) call abort + if (len (merge (s4, t4, .false.)) /= len (t4)) call abort + if (len_trim (merge (s4, t4, .true.)) /= len_trim (s4)) call abort + if (len_trim (merge (s4, t4, .false.)) /= len_trim (t4)) call abort + + if (merge (s4, t4, t) /= s4) call abort + if (merge (s4, t4, f) /= t4) call abort + if (len (merge (s4, t4, t)) /= len (s4)) call abort + if (len (merge (s4, t4, f)) /= len (t4)) call abort + if (len_trim (merge (s4, t4, t)) /= len_trim (s4)) call abort + if (len_trim (merge (s4, t4, f)) /= len_trim (t4)) call abort + + end subroutine check_merge4 + + subroutine check_transfer_i (s, i) + character(kind=4,len=*) :: s + integer(kind=4), dimension(len(s)) :: i + + if (transfer (s, 0_4) /= ichar (s(1:1))) call abort + if (transfer (s, 0_4) /= i(1)) call abort + if (any (transfer (s, [0_4]) /= i)) call abort + if (any (transfer (s, 0_4, len(s)) /= i)) call abort + + end subroutine check_transfer_i + +end diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_9.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_9.f90 new file mode 100644 index 00000000000..ca6fa58184e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_9.f90 @@ -0,0 +1,70 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + implicit none + character(kind=1,len=3) :: s1, t1 + character(kind=4,len=3) :: s4, t4 + + s1 = "foo" ; t1 = "bar" + call check_minmax_1 ("foo", "bar", min("foo","bar"), max("foo","bar")) + call check_minmax_1 ("bar", "foo", min("foo","bar"), max("foo","bar")) + call check_minmax_1 (s1, t1, min(s1,t1), max(s1,t1)) + call check_minmax_1 (t1, s1, min(s1,t1), max(s1,t1)) + + s1 = " " ; t1 = "bar" + call check_minmax_1 (" ", "bar", min(" ","bar"), max(" ","bar")) + call check_minmax_1 ("bar", " ", min(" ","bar"), max(" ","bar")) + call check_minmax_1 (s1, t1, min(s1,t1), max(s1,t1)) + call check_minmax_1 (t1, s1, min(s1,t1), max(s1,t1)) + + s1 = " " ; t1 = " " + call check_minmax_1 (" ", " ", min(" "," "), max(" "," ")) + call check_minmax_1 (" ", " ", min(" "," "), max(" "," ")) + call check_minmax_1 (s1, t1, min(s1,t1), max(s1,t1)) + call check_minmax_1 (t1, s1, min(s1,t1), max(s1,t1)) + + s1 = "d\xFF " ; t1 = "d " + call check_minmax_1 ("d\xFF ", "d ", min("d\xFF ","d "), max("d\xFF ","d ")) + call check_minmax_1 ("d ", "d\xFF ", min("d\xFF ","d "), max("d\xFF ","d ")) + call check_minmax_1 (s1, t1, min(s1,t1), max(s1,t1)) + call check_minmax_1 (t1, s1, min(s1,t1), max(s1,t1)) + + s4 = 4_" " ; t4 = 4_"xxx" + call check_minmax_2 (4_" ", 4_"xxx", min(4_" ", 4_"xxx"), & + max(4_" ", 4_"xxx")) + call check_minmax_2 (4_"xxx", 4_" ", min(4_" ", 4_"xxx"), & + max(4_" ", 4_"xxx")) + call check_minmax_2 (s4, t4, min(s4,t4), max(s4,t4)) + call check_minmax_2 (t4, s4, min(s4,t4), max(s4,t4)) + + s4 = 4_" \u1be3m" ; t4 = 4_"xxx" + call check_minmax_2 (4_" \u1be3m", 4_"xxx", min(4_" \u1be3m", 4_"xxx"), & + max(4_" \u1be3m", 4_"xxx")) + call check_minmax_2 (4_"xxx", 4_" \u1be3m", min(4_" \u1be3m", 4_"xxx"), & + max(4_" \u1be3m", 4_"xxx")) + call check_minmax_2 (s4, t4, min(s4,t4), max(s4,t4)) + call check_minmax_2 (t4, s4, min(s4,t4), max(s4,t4)) + +contains + + subroutine check_minmax_1 (s1, s2, smin, smax) + implicit none + character(kind=1,len=*), intent(in) :: s1, s2, smin, smax + character(kind=4,len=len(s1)) :: w1, w2, wmin, wmax + + w1 = s1 ; w2 = s2 ; wmin = smin ; wmax = smax + if (min (w1, w2) /= wmin) call abort + if (max (w1, w2) /= wmax) call abort + if (min (s1, s2) /= smin) call abort + if (max (s1, s2) /= smax) call abort + end subroutine check_minmax_1 + + subroutine check_minmax_2 (s1, s2, smin, smax) + implicit none + character(kind=4,len=*), intent(in) :: s1, s2, smin, smax + + if (min (s1, s2) /= smin) call abort + if (max (s1, s2) /= smax) call abort + end subroutine check_minmax_2 + +end diff --git a/gcc/testsuite/gfortran.fortran-torture/compile/compile.exp b/gcc/testsuite/gfortran.fortran-torture/compile/compile.exp index b18e25c5f6f..6c4890d7b72 100644 --- a/gcc/testsuite/gfortran.fortran-torture/compile/compile.exp +++ b/gcc/testsuite/gfortran.fortran-torture/compile/compile.exp @@ -26,7 +26,7 @@ load_lib fortran-torture.exp load_lib torture-options.exp torture-init -set-torture-options $FORTRAN_TORTURE_OPTIONS +set-torture-options [get-fortran-torture-options] foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.f]] { # If we're only testing specific files and this isn't one of them, skip it. diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/execute.exp b/gcc/testsuite/gfortran.fortran-torture/execute/execute.exp index 157c2404601..2dd408df2d6 100644 --- a/gcc/testsuite/gfortran.fortran-torture/execute/execute.exp +++ b/gcc/testsuite/gfortran.fortran-torture/execute/execute.exp @@ -30,7 +30,7 @@ load_lib fortran-torture.exp load_lib torture-options.exp torture-init -set-torture-options $FORTRAN_TORTURE_OPTIONS +set-torture-options [get-fortran-torture-options] foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.f]] { # If we're only testing specific files and this isn't one of them, skip it. diff --git a/gcc/testsuite/gnat.dg/deep_old.adb b/gcc/testsuite/gnat.dg/deep_old.adb index 6aca027f4ac..d7818ff9686 100644 --- a/gcc/testsuite/gnat.dg/deep_old.adb +++ b/gcc/testsuite/gnat.dg/deep_old.adb @@ -1,3 +1,5 @@ +-- { dg-options "-gnatws" } + procedure Deep_Old (X : Integer) is begin begin diff --git a/gcc/testsuite/gnat.dg/fixce.adb b/gcc/testsuite/gnat.dg/fixce.adb new file mode 100644 index 00000000000..91e02e79383 --- /dev/null +++ b/gcc/testsuite/gnat.dg/fixce.adb @@ -0,0 +1,13 @@ +-- { dg-do run } + +procedure fixce is + type D is delta 128.0 / (2 ** 15) range 0.0 .. 256.0; + type R is range 0 .. 200; + dd : D; + RA : constant array (1 .. 3) of R := (127, 128, 200); +begin + dd := D (RA (2)); + for i in RA'range loop + dd := D (RA (i)); + end loop; +end fixce; diff --git a/gcc/testsuite/gnat.dg/frunaligned.adb b/gcc/testsuite/gnat.dg/frunaligned.adb new file mode 100644 index 00000000000..a57e87227e0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/frunaligned.adb @@ -0,0 +1,8 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } +with FRUnaligned1; use FRUnaligned1; +function FRUnaligned return r is + ss : s; +begin + return ss.y; +end; diff --git a/gcc/testsuite/gnat.dg/frunaligned1.ads b/gcc/testsuite/gnat.dg/frunaligned1.ads new file mode 100644 index 00000000000..4a8db361b48 --- /dev/null +++ b/gcc/testsuite/gnat.dg/frunaligned1.ads @@ -0,0 +1,12 @@ +package FRUnaligned1 is + type r is array (1 .. 72) of Boolean; + pragma Pack (r); + type s is record + x : Boolean; + y : r; + end record; + for s use record + x at 0 range 0 .. 0; + y at 0 range 1 .. 72; + end record; +end FRUnaligned1; diff --git a/gcc/testsuite/gnat.dg/interface5.adb b/gcc/testsuite/gnat.dg/interface5.adb new file mode 100644 index 00000000000..80d240a9fcf --- /dev/null +++ b/gcc/testsuite/gnat.dg/interface5.adb @@ -0,0 +1,7 @@ +-- { dg-do compile } +package body interface5 is + function F (Object : Child) return access Child is + begin + return null; + end F; +end interface5; diff --git a/gcc/testsuite/gnat.dg/interface5.ads b/gcc/testsuite/gnat.dg/interface5.ads new file mode 100644 index 00000000000..e1bd0bac2a8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/interface5.ads @@ -0,0 +1,9 @@ +package interface5 is + type B is tagged null record; + + type I is interface; + function F (Object : I) return access I is abstract; + + type Child is new B and I with null record; + function F (Object : Child) return access Child; +end interface5; diff --git a/gcc/testsuite/gnat.dg/modular2.adb b/gcc/testsuite/gnat.dg/modular2.adb new file mode 100644 index 00000000000..4e01bd60909 --- /dev/null +++ b/gcc/testsuite/gnat.dg/modular2.adb @@ -0,0 +1,8 @@ +-- { dg-do run } + +procedure modular2 is + type x is mod 2 ** 64; + r : x := x'last; +begin + r := r + 1; +end; diff --git a/gcc/testsuite/gnat.dg/old_errors.adb b/gcc/testsuite/gnat.dg/old_errors.adb index 846c6c61f25..a5e4d42177f 100644 --- a/gcc/testsuite/gnat.dg/old_errors.adb +++ b/gcc/testsuite/gnat.dg/old_errors.adb @@ -37,7 +37,7 @@ package body Old_Errors is begin Y := Z'Old; -- { dg-error "cannot refer to local variable" } end; - Y := I'Old; -- OK + Y := I'Old; -- { dg-warning "Old applied to constant has no effect" } Y := O'Old; -- OK Y := IO'Old; -- OK Y := G; -- OK, error has been signalled at G declaration diff --git a/gcc/testsuite/gnat.dg/pack9.adb b/gcc/testsuite/gnat.dg/pack9.adb new file mode 100644 index 00000000000..894ecd6bb06 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack9.adb @@ -0,0 +1,18 @@ +-- { dg-do compile } +-- { dg-options "-O2 -gnatp -cargs --param sra-max-structure-size=24 --param sra-max-structure-count=6 -fdump-tree-final_cleanup" } + +package body Pack9 is + + procedure Copy (X, Y : R2_Ptr) is + T : R2 := Y.all; + begin + if T.I2 /= Y.I2 then + raise Program_Error; + end if; + X.all := T; + end; + +end Pack9; + +-- { dg-final { scan-tree-dump-not "__gnat_rcheck" "final_cleanup" } } +-- { dg-final { cleanup-tree-dump "final_cleanup" } } diff --git a/gcc/testsuite/gnat.dg/pack9.ads b/gcc/testsuite/gnat.dg/pack9.ads new file mode 100644 index 00000000000..00202a97fa9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack9.ads @@ -0,0 +1,18 @@ +package Pack9 is + + type R1 is record + I : Integer; + C : Character; + end record; + + type R2 is record + I1, I2 : Integer; + A : R1; + end record; + pragma Pack(R2); + + type R2_Ptr is access all R2; + + procedure Copy (X, Y : R2_Ptr); + +end Pack9; diff --git a/gcc/testsuite/gnat.dg/pak.adb b/gcc/testsuite/gnat.dg/pak.adb new file mode 100644 index 00000000000..0430482f358 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pak.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } +package body Pak is + pragma Suppress (Discriminant_Check); + -- Suppress discriminant check to prevent the assignment from using + -- the predefined primitive _assign. + + procedure Initialize (X : in out T) is begin null; end Initialize; + procedure Finalize (X : in out T) is begin null; end Finalize; + + procedure Assign (X : out T'Class) is + Y : T; + begin + T (X) := Y; + end Assign; +end Pak; diff --git a/gcc/testsuite/gnat.dg/pak.ads b/gcc/testsuite/gnat.dg/pak.ads new file mode 100644 index 00000000000..e1e2d0d4d63 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pak.ads @@ -0,0 +1,7 @@ +with Ada.Finalization; +package Pak is + type T is new Ada.Finalization.Controlled with null record; + procedure Initialize (X : in out T); + procedure Finalize (X : in out T); + procedure Assign (X : out T'Class); +end Pak; diff --git a/gcc/testsuite/gnat.dg/set_in_pproc.adb b/gcc/testsuite/gnat.dg/set_in_pproc.adb new file mode 100644 index 00000000000..8e9ae1c8b4c --- /dev/null +++ b/gcc/testsuite/gnat.dg/set_in_pproc.adb @@ -0,0 +1,20 @@ +-- { dg-do compile } + +with Ada.Containers.Ordered_Sets; +procedure Set_In_Pproc is + + protected type Ptype is + procedure Pproc; + end; + + protected body Ptype is + procedure Pproc is + package Sets is + new Ada.Containers.Ordered_Sets (Element_Type => Integer); + begin + null; + end; + end; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/specs/array_no_def_init.ads b/gcc/testsuite/gnat.dg/specs/array_no_def_init.ads new file mode 100644 index 00000000000..b7a024d6fd6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/array_no_def_init.ads @@ -0,0 +1,9 @@ +-- { dg-do compile } + +pragma Restrictions (No_Default_Initialization); +package Array_No_Def_Init is + + type Int_Array is array (Natural range <>) of Integer; + IA : Int_Array (1 .. 10); + +end Array_No_Def_Init; diff --git a/gcc/testsuite/gnat.dg/specs/iface_eq_test-child.ads b/gcc/testsuite/gnat.dg/specs/iface_eq_test-child.ads new file mode 100644 index 00000000000..028bb1be053 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/iface_eq_test-child.ads @@ -0,0 +1,9 @@ +-- { dg-do compile } +-- { dg-options "-gnatc" } +generic +package Iface_Eq_Test.Child is + protected type PO is new Iface with + procedure Dummy; + end; + overriding function "=" (L, R : access PO) return Boolean; +end; diff --git a/gcc/testsuite/gnat.dg/specs/iface_eq_test.ads b/gcc/testsuite/gnat.dg/specs/iface_eq_test.ads new file mode 100644 index 00000000000..36f9031ada4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/iface_eq_test.ads @@ -0,0 +1,6 @@ +-- { dg-do compile } +generic +package Iface_Eq_Test is + type Iface is limited interface; + function "=" (L, R : access Iface) return Boolean is abstract; +end; diff --git a/gcc/testsuite/gnat.dg/specs/self_class.ads b/gcc/testsuite/gnat.dg/specs/self_class.ads new file mode 100644 index 00000000000..56c7ab4760c --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/self_class.ads @@ -0,0 +1,9 @@ +-- { dg-do compile } + +package Self_Class is + type P6 is private; +private + type P6 is tagged record + Self : access P6'Class; + end record; +end Self_Class; diff --git a/gcc/testsuite/gnat.dg/sync1.adb b/gcc/testsuite/gnat.dg/sync1.adb new file mode 100644 index 00000000000..08be6395d68 --- /dev/null +++ b/gcc/testsuite/gnat.dg/sync1.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } +package body sync1 is + protected body Chopstick is + + entry Pick_Up when not Busy is + begin + Busy := True; + end Pick_Up; + + procedure Put_Down is + begin + Busy := False; + end Put_Down; + end Chopstick; +end sync1; diff --git a/gcc/testsuite/gnat.dg/sync1.ads b/gcc/testsuite/gnat.dg/sync1.ads new file mode 100644 index 00000000000..81c2f4aabeb --- /dev/null +++ b/gcc/testsuite/gnat.dg/sync1.ads @@ -0,0 +1,12 @@ +package sync1 is + type Chopstick_Type is synchronized interface; + + type Chopstick is new Chopstick_Type with private; +private + protected type Chopstick is new Chopstick_Type with + entry Pick_Up; + procedure Put_Down; + private + Busy : Boolean := False; + end Chopstick; +end sync1; diff --git a/gcc/testsuite/gnat.dg/trampoline1.adb b/gcc/testsuite/gnat.dg/trampoline1.adb new file mode 100644 index 00000000000..065b373f07c --- /dev/null +++ b/gcc/testsuite/gnat.dg/trampoline1.adb @@ -0,0 +1,23 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +with System; use System; + +procedure Trampoline1 is + + A : Integer; + + function F (I : Integer) return Integer is + begin + return A + I; + end F; + + CA : System.Address := F'Code_Address; + +begin + if CA = System.Null_Address then + raise Program_Error; + end if; +end; + +-- { dg-final { scan-assembler-not "GNU-stack.*x" } } diff --git a/gcc/testsuite/gnat.dg/trampoline2.adb b/gcc/testsuite/gnat.dg/trampoline2.adb new file mode 100644 index 00000000000..26b42722ac7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/trampoline2.adb @@ -0,0 +1,27 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +with System; use System; + +procedure Trampoline2 is + + A : Integer; + + type FuncPtr is access function (I : Integer) return Integer; + + function F (I : Integer) return Integer is + begin + return A + I; + end F; + + P : FuncPtr := F'Access; + CA : System.Address := F'Code_Address; + I : Integer; + +begin + if CA = System.Null_Address then + raise Program_Error; + end if; + + I := P(0); +end; diff --git a/gcc/testsuite/lib/fortran-torture.exp b/gcc/testsuite/lib/fortran-torture.exp index 3286ad91e8a..6e49fac834c 100644 --- a/gcc/testsuite/lib/fortran-torture.exp +++ b/gcc/testsuite/lib/fortran-torture.exp @@ -22,12 +22,16 @@ load_lib target-supports.exp +# Return the list of options to use for fortran torture tests. # The default option list can be overridden by # TORTURE_OPTIONS="{ { list1 } ... { listN } }" +proc get-fortran-torture-options { } { + global TORTURE_OPTIONS + + if [info exists TORTURE_OPTIONS] { + return $TORTURE_OPTIONS + } -if [info exists TORTURE_OPTIONS] { - set FORTRAN_TORTURE_OPTIONS $TORTURE_OPTIONS -} else { # determine if host supports vectorization, and the necessary set # of options, based on code from testsuite/vect/vect.exp @@ -61,17 +65,22 @@ if [info exists TORTURE_OPTIONS] { set test_tree_vectorize 0 } - set FORTRAN_TORTURE_OPTIONS [list \ - { -O0 } { -O1 } { -O2 } \ + set options {} + + lappend options \ + { -O0 } \ + { -O1 } \ + { -O2 } \ { -O2 -fomit-frame-pointer -finline-functions } \ { -O2 -fomit-frame-pointer -finline-functions -funroll-loops } \ { -O2 -fbounds-check } \ { -O3 -g } \ - { -Os }] - + { -Os } if { $test_tree_vectorize } { - lappend FORTRAN_TORTURE_OPTIONS $vectorizer_options + lappend options $vectorizer_options } + + return $options } diff --git a/gcc/testsuite/lib/profopt.exp b/gcc/testsuite/lib/profopt.exp index 92e6660b756..967b7906f0e 100644 --- a/gcc/testsuite/lib/profopt.exp +++ b/gcc/testsuite/lib/profopt.exp @@ -184,6 +184,7 @@ proc profopt-get-options { src } { || ![string compare "dg-skip-if" $cmd] \ || ![string compare "dg-final-generate" $cmd] \ || ![string compare "dg-final-use" $cmd] \ + || ![string compare "dg-additional-sources" $cmd] \ || [string match "dg-require-*" $cmd] } { set status [catch "$op" errmsg] if { $status != 0 } { @@ -266,9 +267,11 @@ proc profopt-execute { src } { return } + set extra_options [dg-additional-files-options "" "$src"] + # Compile for profiling. - set options "" + set options "$extra_options" lappend options "additional_flags=$option $extra_flags $profile_option" set optstr "$option $profile_option" set comp_output [${tool}_target_compile "$src" "$execname1" executable $options] @@ -317,7 +320,7 @@ proc profopt-execute { src } { # Compile with feedback-directed optimizations. - set options "" + set options "$extra_options" lappend options "additional_flags=$option $extra_flags $feedback_option" set optstr "$option $feedback_option" set comp_output [${tool}_target_compile "$src" "$execname2" "executable" $options] @@ -364,7 +367,7 @@ proc profopt-execute { src } { # Compile with normal optimizations. - set options "" + set options "$extra_options" lappend options "additional_flags=$option" set optstr "$option" set comp_output [${tool}_target_compile "$src" "$execname3" "executable" $options] diff --git a/gcc/tree-dfa.c b/gcc/tree-dfa.c index 7e4bb7681b7..af167492de6 100644 --- a/gcc/tree-dfa.c +++ b/gcc/tree-dfa.c @@ -142,33 +142,14 @@ var_ann_t create_var_ann (tree t) { var_ann_t ann; - struct static_var_ann_d *sann = NULL; gcc_assert (t); gcc_assert (DECL_P (t)); gcc_assert (!t->base.ann || t->base.ann->common.type == VAR_ANN); - if (!MTAG_P (t) && (TREE_STATIC (t) || DECL_EXTERNAL (t))) - { - sann = GGC_CNEW (struct static_var_ann_d); - ann = &sann->ann; - } - else - ann = GGC_CNEW (struct var_ann_d); - + ann = GGC_CNEW (struct var_ann_d); ann->common.type = VAR_ANN; - - if (!MTAG_P (t) && (TREE_STATIC (t) || DECL_EXTERNAL (t))) - { - void **slot; - sann->uid = DECL_UID (t); - slot = htab_find_slot_with_hash (gimple_var_anns (cfun), - t, DECL_UID (t), INSERT); - gcc_assert (!*slot); - *slot = sann; - } - else - t->base.ann = (tree_ann_t) ann; + t->base.ann = (tree_ann_t) ann; return ann; } @@ -765,8 +746,20 @@ remove_referenced_var (tree var) clear_call_clobbered (var); if ((v_ann = var_ann (var))) - ggc_free (v_ann); - var->base.ann = NULL; + { + /* Preserve var_anns of globals, but clear their alias info. */ + if (MTAG_P (var) + || (!TREE_STATIC (var) && !DECL_EXTERNAL (var))) + { + ggc_free (v_ann); + var->base.ann = NULL; + } + else + { + v_ann->mpt = NULL_TREE; + v_ann->symbol_mem_tag = NULL_TREE; + } + } gcc_assert (DECL_P (var)); in.uid = uid; loc = htab_find_slot_with_hash (gimple_referenced_vars (cfun), &in, uid, diff --git a/gcc/tree-flow-inline.h b/gcc/tree-flow-inline.h index a41ee9ac2eb..95ddfb5b130 100644 --- a/gcc/tree-flow-inline.h +++ b/gcc/tree-flow-inline.h @@ -91,14 +91,6 @@ gimple_nonlocal_all (const struct function *fun) return fun->gimple_df->nonlocal_all; } -/* Hashtable of variables annotations. Used for static variables only; - local variables have direct pointer in the tree node. */ -static inline htab_t -gimple_var_anns (const struct function *fun) -{ - return fun->gimple_df->var_anns; -} - /* Initialize the hashtable iterator HTI to point to hashtable TABLE */ static inline void * @@ -192,22 +184,9 @@ var_ann (const_tree t) { var_ann_t ann; - if (!MTAG_P (t) - && (TREE_STATIC (t) || DECL_EXTERNAL (t))) - { - struct static_var_ann_d *sann - = ((struct static_var_ann_d *) - htab_find_with_hash (gimple_var_anns (cfun), t, DECL_UID (t))); - if (!sann) - return NULL; - ann = &sann->ann; - } - else - { - if (!t->base.ann) - return NULL; - ann = (var_ann_t) t->base.ann; - } + if (!t->base.ann) + return NULL; + ann = (var_ann_t) t->base.ann; gcc_assert (ann->common.type == VAR_ANN); diff --git a/gcc/tree-flow.h b/gcc/tree-flow.h index bd1f87ab396..8bc6cc8a0ca 100644 --- a/gcc/tree-flow.h +++ b/gcc/tree-flow.h @@ -188,10 +188,6 @@ struct gimple_df GTY(()) struct ssa_operands ssa_operands; - /* Hashtable of variables annotations. Used for static variables only; - local variables have direct pointer in the tree node. */ - htab_t GTY((param_is (struct static_var_ann_d))) var_anns; - /* Memory reference statistics collected during alias analysis. This information is used to drive the memory partitioning heuristics in compute_memory_partitions. */ diff --git a/gcc/tree-gimple.c b/gcc/tree-gimple.c index da84777725a..2334e126343 100644 --- a/gcc/tree-gimple.c +++ b/gcc/tree-gimple.c @@ -113,13 +113,8 @@ bool is_gimple_mem_rhs (tree t) { /* If we're dealing with a renamable type, either source or dest must be - a renamed variable. Also force a temporary if the type doesn't need - to be stored in memory, since it's cheap and prevents erroneous - tailcalls (PR 17526). */ - if (is_gimple_reg_type (TREE_TYPE (t)) - || (TYPE_MODE (TREE_TYPE (t)) != BLKmode - && (TREE_CODE (t) != CALL_EXPR - || ! aggregate_value_p (t, t)))) + a renamed variable. */ + if (is_gimple_reg_type (TREE_TYPE (t))) return is_gimple_val (t); else return is_gimple_formal_tmp_rhs (t); diff --git a/gcc/tree-gimple.h b/gcc/tree-gimple.h index 2c4aa2d9379..3864d5d9d3e 100644 --- a/gcc/tree-gimple.h +++ b/gcc/tree-gimple.h @@ -96,6 +96,9 @@ extern bool is_gimple_non_addressable (tree t); extern bool is_gimple_call_addr (tree); /* If T makes a function call, returns the CALL_EXPR operand. */ extern tree get_call_expr_in (tree t); +/* Returns true iff T contains a CALL_EXPR not suitable for inlining. */ +#define CALL_STMT_CANNOT_INLINE_P(T) \ + CALL_CANNOT_INLINE_P (get_call_expr_in (T)) extern void recalculate_side_effects (tree); diff --git a/gcc/tree-nested.c b/gcc/tree-nested.c index e3330032c03..ded3c2bf49b 100644 --- a/gcc/tree-nested.c +++ b/gcc/tree-nested.c @@ -1645,6 +1645,10 @@ convert_tramp_reference (tree *tp, int *walk_subtrees, void *data) if (DECL_NO_STATIC_CHAIN (decl)) break; + /* If we don't want a trampoline, then don't build one. */ + if (TREE_NO_TRAMPOLINE (t)) + break; + /* Lookup the immediate parent of the callee, as that's where we need to insert the trampoline. */ for (i = info; i->context != target_context; i = i->outer) diff --git a/gcc/tree-profile.c b/gcc/tree-profile.c index 7a70cefad19..6121837e496 100644 --- a/gcc/tree-profile.c +++ b/gcc/tree-profile.c @@ -308,7 +308,7 @@ tree_gen_ic_func_profiler (void) edge e; basic_block bb; edge_iterator ei; - tree stmt1; + tree stmt1, stmt2; tree tree_uid, cur_func; if (flag_unit_at_a_time) @@ -321,8 +321,11 @@ tree_gen_ic_func_profiler (void) FOR_EACH_EDGE (e, ei, ENTRY_BLOCK_PTR->succs) { + tree void0; + bb = split_edge (e); bsi = bsi_start (bb); + cur_func = force_gimple_operand_bsi (&bsi, build_addr (current_function_decl, current_function_decl), @@ -335,6 +338,16 @@ tree_gen_ic_func_profiler (void) cur_func, ic_void_ptr_var); bsi_insert_after (&bsi, stmt1, BSI_NEW_STMT); + + gcc_assert (EDGE_COUNT (bb->succs) == 1); + bb = split_edge (EDGE_I (bb->succs, 0)); + bsi = bsi_start (bb); + /* Set __gcov_indirect_call_callee to 0, + so that calls from other modules won't get misattributed + to the last caller of the current callee. */ + void0 = build_int_cst (build_pointer_type (void_type_node), 0); + stmt2 = build_gimple_modify_stmt (ic_void_ptr_var, void0); + bsi_insert_after (&bsi, stmt2, BSI_NEW_STMT); } } diff --git a/gcc/tree-sra.c b/gcc/tree-sra.c index 9e15f928bf3..244219ffe79 100644 --- a/gcc/tree-sra.c +++ b/gcc/tree-sra.c @@ -268,6 +268,7 @@ sra_type_can_be_decomposed_p (tree type) { /* Reject incorrectly represented bit fields. */ if (DECL_BIT_FIELD (t) + && INTEGRAL_TYPE_P (TREE_TYPE (t)) && (tree_low_cst (DECL_SIZE (t), 1) != TYPE_PRECISION (TREE_TYPE (t)))) goto fail; diff --git a/gcc/tree-ssa-alias.c b/gcc/tree-ssa-alias.c index 7ce016b9096..4f661543a55 100644 --- a/gcc/tree-ssa-alias.c +++ b/gcc/tree-ssa-alias.c @@ -521,6 +521,8 @@ set_initial_properties (struct alias_info *ai) referenced_var_iterator rvi; tree var; tree ptr; + bool any_pt_anything = false; + enum escape_type pt_anything_mask = 0; FOR_EACH_REFERENCED_VAR (var, rvi) { @@ -571,6 +573,11 @@ set_initial_properties (struct alias_info *ai) mark_call_clobbered (alias, pi->escape_mask); } } + else if (pi->pt_anything) + { + any_pt_anything = true; + pt_anything_mask |= pi->escape_mask; + } } /* If the name tag is call clobbered, so is the symbol tag @@ -603,6 +610,21 @@ set_initial_properties (struct alias_info *ai) MTAG_GLOBAL (tag) = true; } } + + /* If a pt_anything pointer escaped we need to mark all addressable + variables call clobbered. */ + if (any_pt_anything) + { + bitmap_iterator bi; + unsigned int j; + + EXECUTE_IF_SET_IN_BITMAP (gimple_addressable_vars (cfun), 0, j, bi) + { + tree var = referenced_var (j); + if (!unmodifiable_var_p (var)) + mark_call_clobbered (var, pt_anything_mask); + } + } } /* Compute which variables need to be marked call clobbered because diff --git a/gcc/tree-ssa-propagate.c b/gcc/tree-ssa-propagate.c index 728a709c64c..b0371805568 100644 --- a/gcc/tree-ssa-propagate.c +++ b/gcc/tree-ssa-propagate.c @@ -40,6 +40,7 @@ #include "langhooks.h" #include "varray.h" #include "vec.h" +#include "value-prof.h" /* This file implements a generic value propagation engine based on the same propagation used by the SSA-CCP algorithm [1]. @@ -117,13 +118,13 @@ static ssa_prop_visit_stmt_fn ssa_prop_visit_stmt; static ssa_prop_visit_phi_fn ssa_prop_visit_phi; -/* Use the TREE_DEPRECATED bitflag to mark statements that have been +/* Use the deprecated flag to mark statements that have been added to one of the SSA edges worklists. This flag is used to avoid visiting statements unnecessarily when draining an SSA edge worklist. If while simulating a basic block, we find a statement with STMT_IN_SSA_EDGE_WORKLIST set, we clear it to prevent SSA edge processing from visiting it again. */ -#define STMT_IN_SSA_EDGE_WORKLIST(T) TREE_DEPRECATED (T) +#define STMT_IN_SSA_EDGE_WORKLIST(T) ((T)->base.deprecated_flag) /* A bitmap to keep track of executable blocks in the CFG. */ static sbitmap executable_blocks; @@ -680,9 +681,10 @@ bool set_rhs (tree *stmt_p, tree expr) { tree stmt = *stmt_p, op; - stmt_ann_t ann; + tree new_stmt; tree var; ssa_op_iter iter; + int eh_region; if (!valid_gimple_expression_p (expr)) return false; @@ -733,9 +735,22 @@ set_rhs (tree *stmt_p, tree expr) default: /* Replace the whole statement with EXPR. If EXPR has no side effects, then replace *STMT_P with an empty statement. */ - ann = stmt_ann (stmt); - *stmt_p = TREE_SIDE_EFFECTS (expr) ? expr : build_empty_stmt (); - (*stmt_p)->base.ann = (tree_ann_t) ann; + new_stmt = TREE_SIDE_EFFECTS (expr) ? expr : build_empty_stmt (); + *stmt_p = new_stmt; + + /* Preserve the annotation, the histograms and the EH region information + associated with the original statement. The EH information + needs to be preserved only if the new statement still can throw. */ + new_stmt->base.ann = (tree_ann_t) stmt_ann (stmt); + gimple_move_stmt_histograms (cfun, new_stmt, stmt); + if (tree_could_throw_p (new_stmt)) + { + eh_region = lookup_stmt_eh_region (stmt); + /* We couldn't possibly turn a nothrow into a throw statement. */ + gcc_assert (eh_region >= 0); + remove_stmt_from_eh_region (stmt); + add_stmt_to_eh_region (new_stmt, eh_region); + } if (gimple_in_ssa_p (cfun) && TREE_SIDE_EFFECTS (expr)) diff --git a/gcc/tree-ssa-sccvn.c b/gcc/tree-ssa-sccvn.c index 86777c784f0..c4c13f96ded 100644 --- a/gcc/tree-ssa-sccvn.c +++ b/gcc/tree-ssa-sccvn.c @@ -1139,8 +1139,8 @@ defs_to_varying (tree stmt) return changed; } -static tree -try_to_simplify (tree stmt, tree rhs); +static bool expr_has_constants (tree expr); +static tree try_to_simplify (tree stmt, tree rhs); /* Visit a copy between LHS and RHS, return true if the value number changed. */ @@ -1245,6 +1245,7 @@ visit_reference_op_load (tree lhs, tree op, tree stmt) /* Initialize value-number information properly. */ VN_INFO_GET (result)->valnum = result; VN_INFO (result)->expr = val; + VN_INFO (result)->has_constants = expr_has_constants (val); VN_INFO (result)->needs_insertion = true; /* As all "inserted" statements are singleton SCCs, insert to the valid table. This is strictly needed to diff --git a/gcc/tree-ssa.c b/gcc/tree-ssa.c index 150074f7c23..1c01d71bf6e 100644 --- a/gcc/tree-ssa.c +++ b/gcc/tree-ssa.c @@ -904,24 +904,6 @@ uid_decl_map_hash (const void *item) return ((const_tree)item)->decl_minimal.uid; } -/* Return true if the uid in both int tree maps are equal. */ - -static int -var_ann_eq (const void *va, const void *vb) -{ - const struct static_var_ann_d *a = (const struct static_var_ann_d *) va; - const_tree const b = (const_tree) vb; - return (a->uid == DECL_UID (b)); -} - -/* Hash a UID in a int_tree_map. */ - -static unsigned int -var_ann_hash (const void *item) -{ - return ((const struct static_var_ann_d *)item)->uid; -} - /* Return true if the DECL_UID in both trees are equal. */ static int @@ -951,8 +933,6 @@ init_tree_ssa (struct function *fn) uid_decl_map_eq, NULL); fn->gimple_df->default_defs = htab_create_ggc (20, uid_ssaname_map_hash, uid_ssaname_map_eq, NULL); - fn->gimple_df->var_anns = htab_create_ggc (20, var_ann_hash, - var_ann_eq, NULL); fn->gimple_df->call_clobbered_vars = BITMAP_GGC_ALLOC (); fn->gimple_df->addressable_vars = BITMAP_GGC_ALLOC (); init_ssanames (fn, 0); @@ -998,9 +978,16 @@ delete_tree_ssa (void) set_phi_nodes (bb, NULL); } - /* Remove annotations from every referenced variable. */ + /* Remove annotations from every referenced local variable. */ FOR_EACH_REFERENCED_VAR (var, rvi) { + if (!MTAG_P (var) + && (TREE_STATIC (var) || DECL_EXTERNAL (var))) + { + var_ann (var)->mpt = NULL_TREE; + var_ann (var)->symbol_mem_tag = NULL_TREE; + continue; + } if (var->base.ann) ggc_free (var->base.ann); var->base.ann = NULL; @@ -1018,8 +1005,6 @@ delete_tree_ssa (void) htab_delete (cfun->gimple_df->default_defs); cfun->gimple_df->default_defs = NULL; - htab_delete (cfun->gimple_df->var_anns); - cfun->gimple_df->var_anns = NULL; cfun->gimple_df->call_clobbered_vars = NULL; cfun->gimple_df->addressable_vars = NULL; cfun->gimple_df->modified_noreturn_calls = NULL; diff --git a/gcc/tree-tailcall.c b/gcc/tree-tailcall.c index 7481de59325..09a2eafe119 100644 --- a/gcc/tree-tailcall.c +++ b/gcc/tree-tailcall.c @@ -429,6 +429,20 @@ find_tail_calls (basic_block bb, struct tailcall **ret) return; } + /* If the LHS of our call is not just a simple register, we can't + transform this into a tail or sibling call. This situation happens, + in (e.g.) "*p = foo()" where foo returns a struct. In this case + we won't have a temporary here, but we need to carry out the side + effect anyway, so tailcall is impossible. + + ??? In some situations (when the struct is returned in memory via + invisible argument) we could deal with this, e.g. by passing 'p' + itself as that argument to foo, but it's too early to do this here, + and expand_call() will not handle it anyway. If it ever can, then + we need to revisit this here, to allow that situation. */ + if (ass_var && !is_gimple_reg (ass_var)) + return; + /* We found the call, check whether it is suitable. */ tail_recursion = false; func = get_callee_fndecl (call); diff --git a/gcc/tree.c b/gcc/tree.c index 10642f6fc58..bfede0623fe 100644 --- a/gcc/tree.c +++ b/gcc/tree.c @@ -5682,14 +5682,12 @@ build_array_type (tree elt_type, tree index_type) return t; } -/* Return the TYPE of the elements comprising - the innermost dimension of ARRAY. */ +/* Recursively examines the array elements of TYPE, until a non-array + element type is found. */ tree -get_inner_array_type (const_tree array) +strip_array_types (tree type) { - tree type = TREE_TYPE (array); - while (TREE_CODE (type) == ARRAY_TYPE) type = TREE_TYPE (type); diff --git a/gcc/tree.h b/gcc/tree.h index 362f855961c..4b091d6ac8b 100644 --- a/gcc/tree.h +++ b/gcc/tree.h @@ -423,83 +423,114 @@ struct gimple_stmt GTY(()) }; /* The following table lists the uses of each of the above flags and - for which types of nodes they are defined. Note that expressions - include decls. + for which types of nodes they are defined. addressable_flag: TREE_ADDRESSABLE in - VAR_DECL, FUNCTION_DECL, FIELD_DECL, CONSTRUCTOR, LABEL_DECL, - ..._TYPE, IDENTIFIER_NODE. - In a STMT_EXPR, it means we want the result of the enclosed - expression. - CALL_EXPR_TAILCALL in CALL_EXPR - CASE_LOW_SEEN in CASE_LABEL_EXPR - RETURN_EXPR_OUTCOME in RETURN_EXPR + VAR_DECL, FUNCTION_DECL, FIELD_DECL, LABEL_DECL + all types + CONSTRUCTOR, IDENTIFIER_NODE + STMT_EXPR, it means we want the result of the enclosed expression + + CALL_EXPR_TAILCALL in + CALL_EXPR + + CASE_LOW_SEEN in + CASE_LABEL_EXPR static_flag: TREE_STATIC in - VAR_DECL, FUNCTION_DECL, CONSTRUCTOR, ADDR_EXPR + VAR_DECL, FUNCTION_DECL + CONSTRUCTOR + + TREE_NO_TRAMPOLINE in + ADDR_EXPR + BINFO_VIRTUAL_P in TREE_BINFO + TREE_SYMBOL_REFERENCED in IDENTIFIER_NODE + CLEANUP_EH_ONLY in TARGET_EXPR, WITH_CLEANUP_EXPR + TRY_CATCH_IS_CLEANUP in TRY_CATCH_EXPR + ASM_INPUT_P in ASM_EXPR - EH_FILTER_MUST_NOT_THROW in EH_FILTER_EXPR + + EH_FILTER_MUST_NOT_THROW in + EH_FILTER_EXPR + TYPE_REF_CAN_ALIAS_ALL in POINTER_TYPE, REFERENCE_TYPE + MOVE_NONTEMPORAL in - GIMPLE_MODIFY_STMT + GIMPLE_MODIFY_STMT + CASE_HIGH_SEEN in - CASE_LABEL_EXPR + CASE_LABEL_EXPR + CALL_CANNOT_INLINE_P in - CALL_EXPR + CALL_EXPR public_flag: TREE_OVERFLOW in INTEGER_CST, REAL_CST, COMPLEX_CST, VECTOR_CST + TREE_PUBLIC in - VAR_DECL or FUNCTION_DECL or IDENTIFIER_NODE + VAR_DECL, FUNCTION_DECL + IDENTIFIER_NODE + ASM_VOLATILE_P in ASM_EXPR + CALL_EXPR_VA_ARG_PACK in - CALL_EXPR + CALL_EXPR + TYPE_CACHED_VALUES_P in - ..._TYPE + all types + SAVE_EXPR_RESOLVED_P in - SAVE_EXPR + SAVE_EXPR + OMP_CLAUSE_LASTPRIVATE_FIRSTPRIVATE in - OMP_CLAUSE_LASTPRIVATE + OMP_CLAUSE_LASTPRIVATE + OMP_CLAUSE_PRIVATE_DEBUG in - OMP_CLAUSE_PRIVATE + OMP_CLAUSE_PRIVATE private_flag: TREE_PRIVATE in - ..._DECL + all decls + CALL_EXPR_RETURN_SLOT_OPT in CALL_EXPR + DECL_BY_REFERENCE in PARM_DECL, RESULT_DECL + OMP_RETURN_NOWAIT in - OMP_RETURN + OMP_RETURN + OMP_SECTION_LAST in - OMP_SECTION + OMP_SECTION + OMP_PARALLEL_COMBINED in - OMP_PARALLEL + OMP_PARALLEL protected_flag: TREE_PROTECTED in BLOCK - ..._DECL + all decls + CALL_FROM_THUNK_P in CALL_EXPR @@ -507,75 +538,95 @@ struct gimple_stmt GTY(()) TREE_SIDE_EFFECTS in all expressions - all decls - all constants + all decls + all constants FORCED_LABEL in - LABEL_DECL + LABEL_DECL volatile_flag: TREE_THIS_VOLATILE in all expressions + all decls + TYPE_VOLATILE in - ..._TYPE + all types readonly_flag: TREE_READONLY in all expressions + all decls + TYPE_READONLY in - ..._TYPE + all types constant_flag: TREE_CONSTANT in all expressions - all decls - all constants - TYPE_SIZES_GIMPLIFIED - ..._TYPE + all decls + all constants + + TYPE_SIZES_GIMPLIFIED in + all types unsigned_flag: TYPE_UNSIGNED in all types + DECL_UNSIGNED in all decls + REGISTER_DEFS_IN_THIS_STMT in + all expressions (tree-into-ssa.c) + asm_written_flag: TREE_ASM_WRITTEN in - VAR_DECL, FUNCTION_DECL, RECORD_TYPE, UNION_TYPE, QUAL_UNION_TYPE - BLOCK, SSA_NAME, STRING_CST + VAR_DECL, FUNCTION_DECL + RECORD_TYPE, UNION_TYPE, QUAL_UNION_TYPE + BLOCK, SSA_NAME, STRING_CST + + NECESSARY in + all expressions (tree-ssa-dce.c, tree-ssa-pre.c) used_flag: TREE_USED in - expressions, IDENTIFIER_NODE + all expressions + all decls + IDENTIFIER_NODE nothrow_flag: TREE_NOTHROW in - CALL_EXPR, FUNCTION_DECL + CALL_EXPR + FUNCTION_DECL TYPE_ALIGN_OK in - ..._TYPE + all types TREE_THIS_NOTRAP in (ALIGN/MISALIGNED_)INDIRECT_REF, ARRAY_REF, ARRAY_RANGE_REF deprecated_flag: - TREE_DEPRECATED in - ..._DECL + TREE_DEPRECATED in + all decls + + IDENTIFIER_TRANSPARENT_ALIAS in + IDENTIFIER_NODE - IDENTIFIER_TRANSPARENT_ALIAS in - IDENTIFIER_NODE + STMT_IN_SSA_EDGE_WORKLIST in + all expressions (tree-ssa-propagate.c) visited: - Used in tree traversals to mark visited nodes. + TREE_VISITED in + all trees (used liberally by many passes) saturating_flag: @@ -585,8 +636,15 @@ struct gimple_stmt GTY(()) nowarning_flag: TREE_NO_WARNING in - ... any expr or decl node + all expressions + all decls + + default_def_flag: + + SSA_NAME_IS_DEFAULT_DEF in + SSA_NAME */ + #undef DEFTREESTRUCT #define DEFTREESTRUCT(ENUM, NAME) ENUM, enum tree_node_structure_enum { @@ -1169,12 +1227,12 @@ extern void omp_clause_range_check_failed (const_tree, const char *, int, /* In a VAR_DECL, nonzero means allocate static storage. In a FUNCTION_DECL, nonzero if function has been defined. - In a CONSTRUCTOR, nonzero means allocate static storage. - - ??? This is also used in lots of other nodes in unclear ways which - should be cleaned up some day. */ + In a CONSTRUCTOR, nonzero means allocate static storage. */ #define TREE_STATIC(NODE) ((NODE)->base.static_flag) +/* In an ADDR_EXPR, nonzero means do not use a trampoline. */ +#define TREE_NO_TRAMPOLINE(NODE) (ADDR_EXPR_CHECK (NODE)->base.static_flag) + /* In a TARGET_EXPR or WITH_CLEANUP_EXPR, means that the pertinent cleanup should only be executed if an exception is thrown, not on normal exit of its scope. */ @@ -1191,7 +1249,7 @@ extern void omp_clause_range_check_failed (const_tree, const char *, int, (CASE_LABEL_EXPR_CHECK (NODE)->base.static_flag) /* Used to mark a CALL_EXPR as not suitable for inlining. */ -#define CALL_CANNOT_INLINE_P(NODE) ((NODE)->base.static_flag) +#define CALL_CANNOT_INLINE_P(NODE) (CALL_EXPR_CHECK (NODE)->base.static_flag) /* In an expr node (usually a conversion) this means the node was made implicitly and should not lead to any sort of warning. In a decl node, @@ -1241,7 +1299,7 @@ extern void omp_clause_range_check_failed (const_tree, const char *, int, /* In a SAVE_EXPR, indicates that the original expression has already been substituted with a VAR_DECL that contains the value. */ #define SAVE_EXPR_RESOLVED_P(NODE) \ - (TREE_CHECK (NODE, SAVE_EXPR)->base.public_flag) + (SAVE_EXPR_CHECK (NODE)->base.public_flag) /* Set on a CALL_EXPR if this stdarg call should be passed the argument pack. */ @@ -1259,7 +1317,7 @@ extern void omp_clause_range_check_failed (const_tree, const char *, int, /* In a LABEL_DECL, nonzero means this label had its address taken and therefore can never be deleted and is a jump target for computed gotos. */ -#define FORCED_LABEL(NODE) ((NODE)->base.side_effects_flag) +#define FORCED_LABEL(NODE) (LABEL_DECL_CHECK (NODE)->base.side_effects_flag) /* Nonzero means this expression is volatile in the C sense: its address should be of type `volatile WHATEVER *'. @@ -1333,17 +1391,16 @@ extern void omp_clause_range_check_failed (const_tree, const char *, int, /* In a CALL_EXPR, means that it's safe to use the target of the call expansion as the return slot for a call that returns in memory. */ -#define CALL_EXPR_RETURN_SLOT_OPT(NODE) ((NODE)->base.private_flag) +#define CALL_EXPR_RETURN_SLOT_OPT(NODE) \ + (CALL_EXPR_CHECK (NODE)->base.private_flag) /* In a RESULT_DECL or PARM_DECL, means that it is passed by invisible reference (and the TREE_TYPE is a pointer to the true type). */ -#define DECL_BY_REFERENCE(NODE) \ - (DECL_COMMON_CHECK (NODE)->base.private_flag) +#define DECL_BY_REFERENCE(NODE) (DECL_COMMON_CHECK (NODE)->base.private_flag) /* In a CALL_EXPR, means that the call is the jump from a thunk to the thunked-to function. */ -#define CALL_FROM_THUNK_P(NODE) \ - (CALL_EXPR_CHECK (NODE)->base.protected_flag) +#define CALL_FROM_THUNK_P(NODE) (CALL_EXPR_CHECK (NODE)->base.protected_flag) /* In a type, nonzero means that all objects of the type are guaranteed by the language or front-end to be properly aligned, so we can indicate that a MEM @@ -1664,8 +1721,8 @@ struct tree_constructor GTY(()) #define ASM_CLOBBERS(NODE) TREE_OPERAND (ASM_EXPR_CHECK (NODE), 3) /* Nonzero if we want to create an ASM_INPUT instead of an ASM_OPERAND with no operands. */ -#define ASM_INPUT_P(NODE) (TREE_STATIC (NODE)) -#define ASM_VOLATILE_P(NODE) (TREE_PUBLIC (NODE)) +#define ASM_INPUT_P(NODE) (ASM_EXPR_CHECK (NODE)->base.static_flag) +#define ASM_VOLATILE_P(NODE) (ASM_EXPR_CHECK (NODE)->base.public_flag) /* COND_EXPR accessors. */ #define COND_EXPR_COND(NODE) (TREE_OPERAND (COND_EXPR_CHECK (NODE), 0)) @@ -1692,7 +1749,8 @@ struct tree_constructor GTY(()) /* EH_FILTER_EXPR accessors. */ #define EH_FILTER_TYPES(NODE) TREE_OPERAND (EH_FILTER_EXPR_CHECK (NODE), 0) #define EH_FILTER_FAILURE(NODE) TREE_OPERAND (EH_FILTER_EXPR_CHECK (NODE), 1) -#define EH_FILTER_MUST_NOT_THROW(NODE) TREE_STATIC (EH_FILTER_EXPR_CHECK (NODE)) +#define EH_FILTER_MUST_NOT_THROW(NODE) \ + (EH_FILTER_EXPR_CHECK (NODE)->base.static_flag) /* CHANGE_DYNAMIC_TYPE_EXPR accessors. */ #define CHANGE_DYNAMIC_TYPE_NEW_TYPE(NODE) \ @@ -1770,30 +1828,30 @@ struct tree_constructor GTY(()) /* True on an OMP_SECTION statement that was the last lexical member. This status is meaningful in the implementation of lastprivate. */ #define OMP_SECTION_LAST(NODE) \ - TREE_PRIVATE (OMP_SECTION_CHECK (NODE)) + (OMP_SECTION_CHECK (NODE)->base.private_flag) /* True on an OMP_RETURN statement if the return does not require a thread synchronization via some sort of barrier. The exact barrier that would otherwise be emitted is dependent on the OMP statement with which this return is associated. */ #define OMP_RETURN_NOWAIT(NODE) \ - TREE_PRIVATE (OMP_RETURN_CHECK (NODE)) + (OMP_RETURN_CHECK (NODE)->base.private_flag) /* True on an OMP_PARALLEL statement if it represents an explicit combined parallel work-sharing constructs. */ #define OMP_PARALLEL_COMBINED(NODE) \ - TREE_PRIVATE (OMP_PARALLEL_CHECK (NODE)) + (OMP_PARALLEL_CHECK (NODE)->base.private_flag) /* True on a PRIVATE clause if its decl is kept around for debugging information only and its DECL_VALUE_EXPR is supposed to point to what it has been remapped to. */ #define OMP_CLAUSE_PRIVATE_DEBUG(NODE) \ - TREE_PUBLIC (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_PRIVATE)) + (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_PRIVATE)->base.public_flag) /* True on a LASTPRIVATE clause if a FIRSTPRIVATE clause for the same decl is present in the chain. */ #define OMP_CLAUSE_LASTPRIVATE_FIRSTPRIVATE(NODE) \ - TREE_PUBLIC (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_LASTPRIVATE)) + (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_LASTPRIVATE)->base.public_flag) #define OMP_CLAUSE_IF_EXPR(NODE) \ OMP_CLAUSE_OPERAND (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_IF), 0) @@ -4016,7 +4074,7 @@ extern int tree_int_cst_sign_bit (const_tree); extern bool tree_expr_nonnegative_p (tree); extern bool tree_expr_nonnegative_warnv_p (tree, bool *); extern bool may_negate_without_overflow_p (const_tree); -extern tree get_inner_array_type (const_tree); +extern tree strip_array_types (tree); /* Construct various nodes representing fract or accum data types. */ diff --git a/gcc/value-prof.c b/gcc/value-prof.c index 33ecded88c3..fbefc97a46d 100644 --- a/gcc/value-prof.c +++ b/gcc/value-prof.c @@ -336,6 +336,25 @@ gimple_duplicate_stmt_histograms (struct function *fun, tree stmt, } } + +/* Move all histograms associated with OSTMT to STMT. */ + +void +gimple_move_stmt_histograms (struct function *fun, tree stmt, tree ostmt) +{ + histogram_value val = gimple_histogram_value (fun, ostmt); + if (val) + { + /* The following three statements can't be reordered, + because histogram hashtab relies on stmt field value + for finding the exact slot. */ + set_histogram_value (fun, ostmt, NULL); + for (; val != NULL; val = val->hvalue.next) + val->hvalue.stmt = stmt; + set_histogram_value (fun, stmt, val); + } +} + static bool error_found = false; /* Helper function for verify_histograms. For each histogram reachable via htab @@ -1198,6 +1217,8 @@ tree_ic_transform (tree stmt) print_generic_stmt (dump_file, stmt, TDF_SLIM); fprintf (dump_file, " to "); print_generic_stmt (dump_file, modify, TDF_SLIM); + fprintf (dump_file, "hist->count "HOST_WIDEST_INT_PRINT_DEC + " hist->all "HOST_WIDEST_INT_PRINT_DEC"\n", count, all); } return true; diff --git a/gcc/value-prof.h b/gcc/value-prof.h index a01919bb3f9..2ab9df1cb53 100644 --- a/gcc/value-prof.h +++ b/gcc/value-prof.h @@ -116,6 +116,7 @@ void dump_histograms_for_stmt (struct function *, FILE *, tree); void gimple_remove_histogram_value (struct function *, tree, histogram_value); void gimple_remove_stmt_histograms (struct function *, tree); void gimple_duplicate_stmt_histograms (struct function *, tree, struct function *, tree); +void gimple_move_stmt_histograms (struct function *, tree, tree); void verify_histograms (void); void free_histograms (void); void stringop_block_profile (tree, unsigned int *, HOST_WIDE_INT *); diff --git a/gcc/varasm.c b/gcc/varasm.c index d9468c4997d..2202ce11098 100644 --- a/gcc/varasm.c +++ b/gcc/varasm.c @@ -4099,25 +4099,29 @@ initializer_constant_valid_p (tree value, tree endtype) case ADDR_EXPR: case FDESC_EXPR: - value = staticp (TREE_OPERAND (value, 0)); - if (value) - { - /* "&(*a).f" is like unto pointer arithmetic. If "a" turns out to - be a constant, this is old-skool offsetof-like nonsense. */ - if (TREE_CODE (value) == INDIRECT_REF - && TREE_CONSTANT (TREE_OPERAND (value, 0))) - return null_pointer_node; - /* Taking the address of a nested function involves a trampoline. */ - if (TREE_CODE (value) == FUNCTION_DECL - && decl_function_context (value) - && !DECL_NO_STATIC_CHAIN (value)) - return NULL_TREE; - /* "&{...}" requires a temporary to hold the constructed - object. */ - if (TREE_CODE (value) == CONSTRUCTOR) - return NULL_TREE; - } - return value; + { + tree op0 = staticp (TREE_OPERAND (value, 0)); + if (op0) + { + /* "&(*a).f" is like unto pointer arithmetic. If "a" turns out + to be a constant, this is old-skool offsetof-like nonsense. */ + if (TREE_CODE (op0) == INDIRECT_REF + && TREE_CONSTANT (TREE_OPERAND (op0, 0))) + return null_pointer_node; + /* Taking the address of a nested function involves a trampoline, + unless we don't need or want one. */ + if (TREE_CODE (op0) == FUNCTION_DECL + && decl_function_context (op0) + && !DECL_NO_STATIC_CHAIN (op0) + && !TREE_NO_TRAMPOLINE (value)) + return NULL_TREE; + /* "&{...}" requires a temporary to hold the constructed + object. */ + if (TREE_CODE (op0) == CONSTRUCTOR) + return NULL_TREE; + } + return op0; + } case VIEW_CONVERT_EXPR: case NON_LVALUE_EXPR: diff --git a/libgcc/ChangeLog b/libgcc/ChangeLog index 2dec005b4d8..9c14fdd7b31 100644 --- a/libgcc/ChangeLog +++ b/libgcc/ChangeLog @@ -1,3 +1,7 @@ +2008-05-25 Arthur Loiret <arthur.loiret@u-psud.fr> + + * config.host (sh2[lbe]*-*-linux*): Allow target. + 2008-04-30 Nathan Froyd <froydnj@codesourcery.com> * config/rs6000/t-ppccomm: Add build rules for new files. diff --git a/libgcc/config.host b/libgcc/config.host index d695b44182d..93fb8a0cde5 100644 --- a/libgcc/config.host +++ b/libgcc/config.host @@ -556,7 +556,7 @@ score-*-elf) ;; sh-*-elf* | sh[12346l]*-*-elf* | sh*-*-kaos* | \ sh-*-symbianelf* | sh[12346l]*-*-symbianelf* | \ - sh-*-linux* | sh[346lbe]*-*-linux* | \ + sh-*-linux* | sh[2346lbe]*-*-linux* | \ sh-*-netbsdelf* | shl*-*-netbsdelf* | sh5-*-netbsd* | sh5l*-*-netbsd* | \ sh64-*-netbsd* | sh64l*-*-netbsd*) case ${host} in diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 81820965ca6..9a25ecd5cee 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,44 @@ +2008-05-28 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/36319 + * intrinsics/string_intrinsics_inc.c (string_index): Return + correct value for zero-length substring. + * intrinsics/cshift0.c: Add _char4 variant. + * intrinsics/eoshift0.c (eoshift0): Allow filler to be a pattern + wider than a single byte. Add _char4 variant and use above + functionality. + * intrinsics/eoshift2.c (eoshift2): Likewise. + * m4/eoshift1.m4: Likewise. + * m4/eoshift3.m4: Likewise. + * m4/cshift1.m4: Add _char4 variants. + * gfortran.map (GFORTRAN_1.1): Add _gfortran_cshift0_1_char4, + _gfortran_cshift0_2_char4, _gfortran_cshift0_4_char4, + _gfortran_cshift0_8_char4, _gfortran_cshift1_16_char4, + _gfortran_cshift1_4_char4, _gfortran_cshift1_8_char4, + _gfortran_eoshift0_1_char4, _gfortran_eoshift0_2_char4, + _gfortran_eoshift0_4_char4, _gfortran_eoshift0_8_char4, + _gfortran_eoshift1_16_char4, _gfortran_eoshift1_4_char4, + _gfortran_eoshift1_8_char4, _gfortran_eoshift2_1_char4, + _gfortran_eoshift2_2_char4, _gfortran_eoshift2_4_char4, + _gfortran_eoshift2_8_char4, _gfortran_eoshift3_16_char4, + _gfortran_eoshift3_4_char4 and _gfortran_eoshift3_8_char4. + * generated/eoshift3_4.c: Regenerate. + * generated/eoshift1_8.c: Regenerate. + * generated/eoshift1_16.c: Regenerate. + * generated/cshift1_4.c: Regenerate. + * generated/eoshift1_4.c: Regenerate. + * generated/eoshift3_8.c: Regenerate. + * generated/eoshift3_16.c: Regenerate. + * generated/cshift1_8.c: Regenerate. + * generated/cshift1_16.c: Regenerate. + +2008-05-25 Tobias Burnus <burnus@net-b.de> + + PR fortran/32600 + * intrinsics/iso_c_binding.c (c_f_procpointer): Remove. + * intrinsics/iso_c_binding.h (c_f_procpointer): Remove. + * gfortran.map (c_f_procpointer): Remove. + 2008-05-22 Thomas Koenig <tkoenig@gcc.gnu.org> PR libgfortran/36302 diff --git a/libgfortran/generated/cshift1_16.c b/libgfortran/generated/cshift1_16.c index a29bf79ce72..2943c3ed86d 100644 --- a/libgfortran/generated/cshift1_16.c +++ b/libgfortran/generated/cshift1_16.c @@ -212,6 +212,7 @@ cshift1_16 (gfc_array_char * const restrict ret, cshift1 (ret, array, h, pwhich, GFC_DESCRIPTOR_SIZE (array)); } + void cshift1_16_char (gfc_array_char * const restrict ret, GFC_INTEGER_4, const gfc_array_char * const restrict array, @@ -231,4 +232,24 @@ cshift1_16_char (gfc_array_char * const restrict ret, cshift1 (ret, array, h, pwhich, array_length); } + +void cshift1_16_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4, + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const GFC_INTEGER_16 * const restrict pwhich, + GFC_INTEGER_4); +export_proto(cshift1_16_char4); + +void +cshift1_16_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const GFC_INTEGER_16 * const restrict pwhich, + GFC_INTEGER_4 array_length) +{ + cshift1 (ret, array, h, pwhich, array_length * sizeof (gfc_char4_t)); +} + #endif diff --git a/libgfortran/generated/cshift1_4.c b/libgfortran/generated/cshift1_4.c index 0525873b563..3f4f9e0bf25 100644 --- a/libgfortran/generated/cshift1_4.c +++ b/libgfortran/generated/cshift1_4.c @@ -212,6 +212,7 @@ cshift1_4 (gfc_array_char * const restrict ret, cshift1 (ret, array, h, pwhich, GFC_DESCRIPTOR_SIZE (array)); } + void cshift1_4_char (gfc_array_char * const restrict ret, GFC_INTEGER_4, const gfc_array_char * const restrict array, @@ -231,4 +232,24 @@ cshift1_4_char (gfc_array_char * const restrict ret, cshift1 (ret, array, h, pwhich, array_length); } + +void cshift1_4_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4, + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const GFC_INTEGER_4 * const restrict pwhich, + GFC_INTEGER_4); +export_proto(cshift1_4_char4); + +void +cshift1_4_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const GFC_INTEGER_4 * const restrict pwhich, + GFC_INTEGER_4 array_length) +{ + cshift1 (ret, array, h, pwhich, array_length * sizeof (gfc_char4_t)); +} + #endif diff --git a/libgfortran/generated/cshift1_8.c b/libgfortran/generated/cshift1_8.c index 624b662cea7..4d246e54d95 100644 --- a/libgfortran/generated/cshift1_8.c +++ b/libgfortran/generated/cshift1_8.c @@ -212,6 +212,7 @@ cshift1_8 (gfc_array_char * const restrict ret, cshift1 (ret, array, h, pwhich, GFC_DESCRIPTOR_SIZE (array)); } + void cshift1_8_char (gfc_array_char * const restrict ret, GFC_INTEGER_4, const gfc_array_char * const restrict array, @@ -231,4 +232,24 @@ cshift1_8_char (gfc_array_char * const restrict ret, cshift1 (ret, array, h, pwhich, array_length); } + +void cshift1_8_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4, + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const GFC_INTEGER_8 * const restrict pwhich, + GFC_INTEGER_4); +export_proto(cshift1_8_char4); + +void +cshift1_8_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const GFC_INTEGER_8 * const restrict pwhich, + GFC_INTEGER_4 array_length) +{ + cshift1 (ret, array, h, pwhich, array_length * sizeof (gfc_char4_t)); +} + #endif diff --git a/libgfortran/generated/eoshift1_16.c b/libgfortran/generated/eoshift1_16.c index e16db209e3d..63b75bdbd6b 100644 --- a/libgfortran/generated/eoshift1_16.c +++ b/libgfortran/generated/eoshift1_16.c @@ -42,7 +42,7 @@ eoshift1 (gfc_array_char * const restrict ret, const gfc_array_i16 * const restrict h, const char * const restrict pbound, const GFC_INTEGER_16 * const restrict pwhich, - index_type size, char filler) + index_type size, const char * filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -183,7 +183,14 @@ eoshift1 (gfc_array_char * const restrict ret, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -234,9 +241,11 @@ eoshift1_16 (gfc_array_char * const restrict ret, const char * const restrict pbound, const GFC_INTEGER_16 * const restrict pwhich) { - eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); + eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), + "\0", 1); } + void eoshift1_16_char (gfc_array_char * const restrict, GFC_INTEGER_4, const gfc_array_char * const restrict, @@ -256,7 +265,32 @@ eoshift1_16_char (gfc_array_char * const restrict ret, GFC_INTEGER_4 array_length, GFC_INTEGER_4 bound_length __attribute__((unused))) { - eoshift1 (ret, array, h, pbound, pwhich, array_length, ' '); + eoshift1 (ret, array, h, pbound, pwhich, array_length, " ", 1); +} + + +void eoshift1_16_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i16 * const restrict, + const char * const restrict, + const GFC_INTEGER_16 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift1_16_char4); + +void +eoshift1_16_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_16 * const restrict pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift1 (ret, array, h, pbound, pwhich, array_length * sizeof (gfc_char4_t), + (const char *) &space, sizeof (gfc_char4_t)); } #endif diff --git a/libgfortran/generated/eoshift1_4.c b/libgfortran/generated/eoshift1_4.c index 11cc71fc917..58ce7e9f5dd 100644 --- a/libgfortran/generated/eoshift1_4.c +++ b/libgfortran/generated/eoshift1_4.c @@ -42,7 +42,7 @@ eoshift1 (gfc_array_char * const restrict ret, const gfc_array_i4 * const restrict h, const char * const restrict pbound, const GFC_INTEGER_4 * const restrict pwhich, - index_type size, char filler) + index_type size, const char * filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -183,7 +183,14 @@ eoshift1 (gfc_array_char * const restrict ret, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -234,9 +241,11 @@ eoshift1_4 (gfc_array_char * const restrict ret, const char * const restrict pbound, const GFC_INTEGER_4 * const restrict pwhich) { - eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); + eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), + "\0", 1); } + void eoshift1_4_char (gfc_array_char * const restrict, GFC_INTEGER_4, const gfc_array_char * const restrict, @@ -256,7 +265,32 @@ eoshift1_4_char (gfc_array_char * const restrict ret, GFC_INTEGER_4 array_length, GFC_INTEGER_4 bound_length __attribute__((unused))) { - eoshift1 (ret, array, h, pbound, pwhich, array_length, ' '); + eoshift1 (ret, array, h, pbound, pwhich, array_length, " ", 1); +} + + +void eoshift1_4_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i4 * const restrict, + const char * const restrict, + const GFC_INTEGER_4 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift1_4_char4); + +void +eoshift1_4_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_4 * const restrict pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift1 (ret, array, h, pbound, pwhich, array_length * sizeof (gfc_char4_t), + (const char *) &space, sizeof (gfc_char4_t)); } #endif diff --git a/libgfortran/generated/eoshift1_8.c b/libgfortran/generated/eoshift1_8.c index 4b7d0e04f31..0e9c2f1442a 100644 --- a/libgfortran/generated/eoshift1_8.c +++ b/libgfortran/generated/eoshift1_8.c @@ -42,7 +42,7 @@ eoshift1 (gfc_array_char * const restrict ret, const gfc_array_i8 * const restrict h, const char * const restrict pbound, const GFC_INTEGER_8 * const restrict pwhich, - index_type size, char filler) + index_type size, const char * filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -183,7 +183,14 @@ eoshift1 (gfc_array_char * const restrict ret, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -234,9 +241,11 @@ eoshift1_8 (gfc_array_char * const restrict ret, const char * const restrict pbound, const GFC_INTEGER_8 * const restrict pwhich) { - eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); + eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), + "\0", 1); } + void eoshift1_8_char (gfc_array_char * const restrict, GFC_INTEGER_4, const gfc_array_char * const restrict, @@ -256,7 +265,32 @@ eoshift1_8_char (gfc_array_char * const restrict ret, GFC_INTEGER_4 array_length, GFC_INTEGER_4 bound_length __attribute__((unused))) { - eoshift1 (ret, array, h, pbound, pwhich, array_length, ' '); + eoshift1 (ret, array, h, pbound, pwhich, array_length, " ", 1); +} + + +void eoshift1_8_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i8 * const restrict, + const char * const restrict, + const GFC_INTEGER_8 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift1_8_char4); + +void +eoshift1_8_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_8 * const restrict pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift1 (ret, array, h, pbound, pwhich, array_length * sizeof (gfc_char4_t), + (const char *) &space, sizeof (gfc_char4_t)); } #endif diff --git a/libgfortran/generated/eoshift3_16.c b/libgfortran/generated/eoshift3_16.c index 1dda668d47b..214f3783d4f 100644 --- a/libgfortran/generated/eoshift3_16.c +++ b/libgfortran/generated/eoshift3_16.c @@ -42,7 +42,7 @@ eoshift3 (gfc_array_char * const restrict ret, const gfc_array_i16 * const restrict h, const gfc_array_char * const restrict bound, const GFC_INTEGER_16 * const restrict pwhich, - index_type size, char filler) + index_type size, const char * filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -198,7 +198,14 @@ eoshift3 (gfc_array_char * const restrict ret, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -253,9 +260,11 @@ eoshift3_16 (gfc_array_char * const restrict ret, const gfc_array_char * const restrict bound, const GFC_INTEGER_16 * const restrict pwhich) { - eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); + eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), + "\0", 1); } + extern void eoshift3_16_char (gfc_array_char * const restrict, GFC_INTEGER_4, const gfc_array_char * const restrict, @@ -275,7 +284,32 @@ eoshift3_16_char (gfc_array_char * const restrict ret, GFC_INTEGER_4 array_length, GFC_INTEGER_4 bound_length __attribute__((unused))) { - eoshift3 (ret, array, h, bound, pwhich, array_length, ' '); + eoshift3 (ret, array, h, bound, pwhich, array_length, " ", 1); +} + + +extern void eoshift3_16_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i16 * const restrict, + const gfc_array_char * const restrict, + const GFC_INTEGER_16 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift3_16_char4); + +void +eoshift3_16_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_16 * const restrict pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift3 (ret, array, h, bound, pwhich, array_length * sizeof (gfc_char4_t), + (const char *) &space, sizeof (gfc_char4_t)); } #endif diff --git a/libgfortran/generated/eoshift3_4.c b/libgfortran/generated/eoshift3_4.c index aa46f7c5a10..e96ef2504b0 100644 --- a/libgfortran/generated/eoshift3_4.c +++ b/libgfortran/generated/eoshift3_4.c @@ -42,7 +42,7 @@ eoshift3 (gfc_array_char * const restrict ret, const gfc_array_i4 * const restrict h, const gfc_array_char * const restrict bound, const GFC_INTEGER_4 * const restrict pwhich, - index_type size, char filler) + index_type size, const char * filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -198,7 +198,14 @@ eoshift3 (gfc_array_char * const restrict ret, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -253,9 +260,11 @@ eoshift3_4 (gfc_array_char * const restrict ret, const gfc_array_char * const restrict bound, const GFC_INTEGER_4 * const restrict pwhich) { - eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); + eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), + "\0", 1); } + extern void eoshift3_4_char (gfc_array_char * const restrict, GFC_INTEGER_4, const gfc_array_char * const restrict, @@ -275,7 +284,32 @@ eoshift3_4_char (gfc_array_char * const restrict ret, GFC_INTEGER_4 array_length, GFC_INTEGER_4 bound_length __attribute__((unused))) { - eoshift3 (ret, array, h, bound, pwhich, array_length, ' '); + eoshift3 (ret, array, h, bound, pwhich, array_length, " ", 1); +} + + +extern void eoshift3_4_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i4 * const restrict, + const gfc_array_char * const restrict, + const GFC_INTEGER_4 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift3_4_char4); + +void +eoshift3_4_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_4 * const restrict pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift3 (ret, array, h, bound, pwhich, array_length * sizeof (gfc_char4_t), + (const char *) &space, sizeof (gfc_char4_t)); } #endif diff --git a/libgfortran/generated/eoshift3_8.c b/libgfortran/generated/eoshift3_8.c index 04e81b8eb39..dc39b94eb97 100644 --- a/libgfortran/generated/eoshift3_8.c +++ b/libgfortran/generated/eoshift3_8.c @@ -42,7 +42,7 @@ eoshift3 (gfc_array_char * const restrict ret, const gfc_array_i8 * const restrict h, const gfc_array_char * const restrict bound, const GFC_INTEGER_8 * const restrict pwhich, - index_type size, char filler) + index_type size, const char * filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -198,7 +198,14 @@ eoshift3 (gfc_array_char * const restrict ret, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -253,9 +260,11 @@ eoshift3_8 (gfc_array_char * const restrict ret, const gfc_array_char * const restrict bound, const GFC_INTEGER_8 * const restrict pwhich) { - eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); + eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), + "\0", 1); } + extern void eoshift3_8_char (gfc_array_char * const restrict, GFC_INTEGER_4, const gfc_array_char * const restrict, @@ -275,7 +284,32 @@ eoshift3_8_char (gfc_array_char * const restrict ret, GFC_INTEGER_4 array_length, GFC_INTEGER_4 bound_length __attribute__((unused))) { - eoshift3 (ret, array, h, bound, pwhich, array_length, ' '); + eoshift3 (ret, array, h, bound, pwhich, array_length, " ", 1); +} + + +extern void eoshift3_8_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i8 * const restrict, + const gfc_array_char * const restrict, + const GFC_INTEGER_8 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift3_8_char4); + +void +eoshift3_8_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_8 * const restrict pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift3 (ret, array, h, bound, pwhich, array_length * sizeof (gfc_char4_t), + (const char *) &space, sizeof (gfc_char4_t)); } #endif diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index b61ce87990e..60ef8532275 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -1026,7 +1026,6 @@ GFORTRAN_1.0 { __iso_c_binding_c_f_pointer_l4; __iso_c_binding_c_f_pointer_l8; __iso_c_binding_c_f_pointer_u0; - __iso_c_binding_c_f_procpointer; local: *; }; @@ -1041,10 +1040,31 @@ GFORTRAN_1.1 { _gfortran_convert_char4_to_char1; _gfortran_cshift0_16; _gfortran_cshift0_16_char; + _gfortran_cshift0_1_char4; + _gfortran_cshift0_2_char4; + _gfortran_cshift0_4_char4; + _gfortran_cshift0_8_char4; + _gfortran_cshift1_16_char4; + _gfortran_cshift1_4_char4; + _gfortran_cshift1_8_char4; _gfortran_eoshift0_16; _gfortran_eoshift0_16_char; + _gfortran_eoshift0_1_char4; + _gfortran_eoshift0_2_char4; + _gfortran_eoshift0_4_char4; + _gfortran_eoshift0_8_char4; + _gfortran_eoshift1_16_char4; + _gfortran_eoshift1_4_char4; + _gfortran_eoshift1_8_char4; _gfortran_eoshift2_16; _gfortran_eoshift2_16_char; + _gfortran_eoshift2_1_char4; + _gfortran_eoshift2_2_char4; + _gfortran_eoshift2_4_char4; + _gfortran_eoshift2_8_char4; + _gfortran_eoshift3_16_char4; + _gfortran_eoshift3_4_char4; + _gfortran_eoshift3_8_char4; _gfortran_erfc_scaled_r10; _gfortran_erfc_scaled_r16; _gfortran_erfc_scaled_r4; @@ -1052,17 +1072,17 @@ GFORTRAN_1.1 { _gfortran_pack_char4; _gfortran_pack_s_char4; _gfortran_reshape_char4; - _gfortran_select_string_char4; _gfortran_selected_char_kind; + _gfortran_select_string_char4; _gfortran_spread_char4; _gfortran_spread_char4_scalar; - _gfortran_st_wait; _gfortran_string_index_char4; _gfortran_string_len_trim_char4; _gfortran_string_minmax_char4; _gfortran_string_scan_char4; _gfortran_string_trim_char4; _gfortran_string_verify_char4; + _gfortran_st_wait; _gfortran_transpose_char4; _gfortran_unpack0_char4; _gfortran_unpack1_char4; diff --git a/libgfortran/intrinsics/cshift0.c b/libgfortran/intrinsics/cshift0.c index 71574658dda..76ce97e0f10 100644 --- a/libgfortran/intrinsics/cshift0.c +++ b/libgfortran/intrinsics/cshift0.c @@ -334,6 +334,24 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array, GFC_INTEGER_4 array_length) \ { \ cshift0 (ret, array, *pshift, pdim ? *pdim : 1, array_length); \ + } \ + \ + extern void cshift0_##N##_char4 (gfc_array_char *, GFC_INTEGER_4, \ + const gfc_array_char *, \ + const GFC_INTEGER_##N *, \ + const GFC_INTEGER_##N *, GFC_INTEGER_4); \ + export_proto(cshift0_##N##_char4); \ + \ + void \ + cshift0_##N##_char4 (gfc_array_char *ret, \ + GFC_INTEGER_4 ret_length __attribute__((unused)), \ + const gfc_array_char *array, \ + const GFC_INTEGER_##N *pshift, \ + const GFC_INTEGER_##N *pdim, \ + GFC_INTEGER_4 array_length) \ + { \ + cshift0 (ret, array, *pshift, pdim ? *pdim : 1, \ + array_length * sizeof (gfc_char4_t)); \ } DEFINE_CSHIFT (1); diff --git a/libgfortran/intrinsics/eoshift0.c b/libgfortran/intrinsics/eoshift0.c index c75199c4a2f..ac7a0ba85b6 100644 --- a/libgfortran/intrinsics/eoshift0.c +++ b/libgfortran/intrinsics/eoshift0.c @@ -39,7 +39,7 @@ Boston, MA 02110-1301, USA. */ static void eoshift0 (gfc_array_char * ret, const gfc_array_char * array, int shift, const char * pbound, int which, index_type size, - char filler) + const char *filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -175,7 +175,14 @@ eoshift0 (gfc_array_char * ret, const gfc_array_char * array, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size ; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -223,7 +230,7 @@ eoshift0 (gfc_array_char * ret, const gfc_array_char * array, const GFC_INTEGER_##N *pdim) \ { \ eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ - GFC_DESCRIPTOR_SIZE (array), 0); \ + GFC_DESCRIPTOR_SIZE (array), "\0", 1); \ } \ \ extern void eoshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4, \ @@ -244,7 +251,30 @@ eoshift0 (gfc_array_char * ret, const gfc_array_char * array, GFC_INTEGER_4 bound_length __attribute__((unused))) \ { \ eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ - array_length, ' '); \ + array_length, " ", 1); \ + } \ + \ + extern void eoshift0_##N##_char4 (gfc_array_char *, GFC_INTEGER_4, \ + const gfc_array_char *, \ + const GFC_INTEGER_##N *, const char *, \ + const GFC_INTEGER_##N *, GFC_INTEGER_4, \ + GFC_INTEGER_4); \ + export_proto(eoshift0_##N##_char4); \ + \ + void \ + eoshift0_##N##_char4 (gfc_array_char *ret, \ + GFC_INTEGER_4 ret_length __attribute__((unused)), \ + const gfc_array_char *array, \ + const GFC_INTEGER_##N *pshift, \ + const char *pbound, \ + const GFC_INTEGER_##N *pdim, \ + GFC_INTEGER_4 array_length, \ + GFC_INTEGER_4 bound_length __attribute__((unused))) \ + { \ + static const gfc_char4_t space = (unsigned char) ' '; \ + eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ + array_length * sizeof (gfc_char4_t), (const char *) &space, \ + sizeof (gfc_char4_t)); \ } DEFINE_EOSHIFT (1); diff --git a/libgfortran/intrinsics/eoshift2.c b/libgfortran/intrinsics/eoshift2.c index f74cb01fec8..239d9714a99 100644 --- a/libgfortran/intrinsics/eoshift2.c +++ b/libgfortran/intrinsics/eoshift2.c @@ -39,7 +39,7 @@ Boston, MA 02110-1301, USA. */ static void eoshift2 (gfc_array_char *ret, const gfc_array_char *array, int shift, const gfc_array_char *bound, int which, - index_type size, char filler) + index_type size, const char *filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -192,7 +192,14 @@ eoshift2 (gfc_array_char *ret, const gfc_array_char *array, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size ; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -243,7 +250,7 @@ eoshift2 (gfc_array_char *ret, const gfc_array_char *array, const GFC_INTEGER_##N *pdim) \ { \ eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ - GFC_DESCRIPTOR_SIZE (array), 0); \ + GFC_DESCRIPTOR_SIZE (array), "\0", 1); \ } \ \ extern void eoshift2_##N##_char (gfc_array_char *, GFC_INTEGER_4, \ @@ -265,7 +272,31 @@ eoshift2 (gfc_array_char *ret, const gfc_array_char *array, GFC_INTEGER_4 bound_length __attribute__((unused))) \ { \ eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ - array_length, ' '); \ + array_length, " ", 1); \ + } \ + \ + extern void eoshift2_##N##_char4 (gfc_array_char *, GFC_INTEGER_4, \ + const gfc_array_char *, \ + const GFC_INTEGER_##N *, \ + const gfc_array_char *, \ + const GFC_INTEGER_##N *, \ + GFC_INTEGER_4, GFC_INTEGER_4); \ + export_proto(eoshift2_##N##_char4); \ + \ + void \ + eoshift2_##N##_char4 (gfc_array_char *ret, \ + GFC_INTEGER_4 ret_length __attribute__((unused)), \ + const gfc_array_char *array, \ + const GFC_INTEGER_##N *pshift, \ + const gfc_array_char *pbound, \ + const GFC_INTEGER_##N *pdim, \ + GFC_INTEGER_4 array_length, \ + GFC_INTEGER_4 bound_length __attribute__((unused))) \ + { \ + static const gfc_char4_t space = (unsigned char) ' '; \ + eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ + array_length * sizeof (gfc_char4_t), (const char *) &space, \ + sizeof (gfc_char4_t)); \ } DEFINE_EOSHIFT (1); diff --git a/libgfortran/intrinsics/iso_c_binding.c b/libgfortran/intrinsics/iso_c_binding.c index 2a1e994d4d9..171b1524751 100644 --- a/libgfortran/intrinsics/iso_c_binding.c +++ b/libgfortran/intrinsics/iso_c_binding.c @@ -180,16 +180,3 @@ ISO_C_BINDING_PREFIX (c_f_pointer_d0) (void *c_ptr_in, | (GFC_DTYPE_DERIVED << GFC_DTYPE_TYPE_SHIFT); } } - - -/* This function will change, once there is an actual f90 type for the - procedure pointer. */ - -void -ISO_C_BINDING_PREFIX (c_f_procpointer) (void *c_ptr_in, - gfc_array_void *f_ptr_out) -{ - GFC_DESCRIPTOR_DATA(f_ptr_out) = c_ptr_in; -} - - diff --git a/libgfortran/intrinsics/iso_c_binding.h b/libgfortran/intrinsics/iso_c_binding.h index 4679c2aba02..cb1a7a066b7 100644 --- a/libgfortran/intrinsics/iso_c_binding.h +++ b/libgfortran/intrinsics/iso_c_binding.h @@ -52,10 +52,6 @@ c_funptr_t; void ISO_C_BINDING_PREFIX(c_f_pointer)(void *, gfc_array_void *, const array_t *, int, int); -/* The second param here may change, once procedure pointers are - implemented. */ -void ISO_C_BINDING_PREFIX(c_f_procpointer) (void *, gfc_array_void *); - void ISO_C_BINDING_PREFIX(c_f_pointer_u0) (void *, gfc_array_void *, const array_t *); void ISO_C_BINDING_PREFIX(c_f_pointer_d0) (void *, gfc_array_void *, diff --git a/libgfortran/intrinsics/string_intrinsics_inc.c b/libgfortran/intrinsics/string_intrinsics_inc.c index 87e137e8e6c..0008db5b2fc 100644 --- a/libgfortran/intrinsics/string_intrinsics_inc.c +++ b/libgfortran/intrinsics/string_intrinsics_inc.c @@ -214,7 +214,7 @@ string_index (gfc_charlen_type slen, const CHARTYPE *str, gfc_charlen_type start, last, delta, i; if (sslen == 0) - return 1; + return back ? (slen + 1) : 1; if (sslen > slen) return 0; diff --git a/libgfortran/m4/cshift1.m4 b/libgfortran/m4/cshift1.m4 index 735621d4f7b..28fae596bd4 100644 --- a/libgfortran/m4/cshift1.m4 +++ b/libgfortran/m4/cshift1.m4 @@ -213,6 +213,7 @@ cshift1_'atype_kind` (gfc_array_char * const restrict ret, cshift1 (ret, array, h, pwhich, GFC_DESCRIPTOR_SIZE (array)); } + void cshift1_'atype_kind`_char (gfc_array_char * const restrict ret, GFC_INTEGER_4, const gfc_array_char * const restrict array, @@ -232,4 +233,24 @@ cshift1_'atype_kind`_char (gfc_array_char * const restrict ret, cshift1 (ret, array, h, pwhich, array_length); } + +void cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4, + const gfc_array_char * const restrict array, + const 'atype` * const restrict h, + const 'atype_name` * const restrict pwhich, + GFC_INTEGER_4); +export_proto(cshift1_'atype_kind`_char4); + +void +cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const 'atype` * const restrict h, + const 'atype_name` * const restrict pwhich, + GFC_INTEGER_4 array_length) +{ + cshift1 (ret, array, h, pwhich, array_length * sizeof (gfc_char4_t)); +} + #endif' diff --git a/libgfortran/m4/eoshift1.m4 b/libgfortran/m4/eoshift1.m4 index efa38b201af..8ce24eff0f5 100644 --- a/libgfortran/m4/eoshift1.m4 +++ b/libgfortran/m4/eoshift1.m4 @@ -43,7 +43,7 @@ eoshift1 (gfc_array_char * const restrict ret, const 'atype` * const restrict h, const char * const restrict pbound, const 'atype_name` * const restrict pwhich, - index_type size, char filler) + index_type size, const char * filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -184,7 +184,14 @@ eoshift1 (gfc_array_char * const restrict ret, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -235,9 +242,11 @@ eoshift1_'atype_kind` (gfc_array_char * const restrict ret, const char * const restrict pbound, const 'atype_name` * const restrict pwhich) { - eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); + eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), + "\0", 1); } + void eoshift1_'atype_kind`_char (gfc_array_char * const restrict, GFC_INTEGER_4, const gfc_array_char * const restrict, @@ -257,7 +266,32 @@ eoshift1_'atype_kind`_char (gfc_array_char * const restrict ret, GFC_INTEGER_4 array_length, GFC_INTEGER_4 bound_length __attribute__((unused))) { - eoshift1 (ret, array, h, pbound, pwhich, array_length, ''` ''`); + eoshift1 (ret, array, h, pbound, pwhich, array_length, " ", 1); +} + + +void eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const 'atype` * const restrict, + const char * const restrict, + const 'atype_name` * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift1_'atype_kind`_char4); + +void +eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const 'atype` * const restrict h, + const char * const restrict pbound, + const 'atype_name` * const restrict pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ''` ''`; + eoshift1 (ret, array, h, pbound, pwhich, array_length * sizeof (gfc_char4_t), + (const char *) &space, sizeof (gfc_char4_t)); } #endif' diff --git a/libgfortran/m4/eoshift3.m4 b/libgfortran/m4/eoshift3.m4 index 050f5277822..081ff927277 100644 --- a/libgfortran/m4/eoshift3.m4 +++ b/libgfortran/m4/eoshift3.m4 @@ -43,7 +43,7 @@ eoshift3 (gfc_array_char * const restrict ret, const 'atype` * const restrict h, const gfc_array_char * const restrict bound, const 'atype_name` * const restrict pwhich, - index_type size, char filler) + index_type size, const char * filler, index_type filler_len) { /* r.* indicates the return array. */ index_type rstride[GFC_MAX_DIMENSIONS]; @@ -199,7 +199,14 @@ eoshift3 (gfc_array_char * const restrict ret, else while (n--) { - memset (dest, filler, size); + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + dest += roffset; } @@ -254,9 +261,11 @@ eoshift3_'atype_kind` (gfc_array_char * const restrict ret, const gfc_array_char * const restrict bound, const 'atype_name` * const restrict pwhich) { - eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0); + eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), + "\0", 1); } + extern void eoshift3_'atype_kind`_char (gfc_array_char * const restrict, GFC_INTEGER_4, const gfc_array_char * const restrict, @@ -276,7 +285,32 @@ eoshift3_'atype_kind`_char (gfc_array_char * const restrict ret, GFC_INTEGER_4 array_length, GFC_INTEGER_4 bound_length __attribute__((unused))) { - eoshift3 (ret, array, h, bound, pwhich, array_length, ''` ''`); + eoshift3 (ret, array, h, bound, pwhich, array_length, " ", 1); +} + + +extern void eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const 'atype` * const restrict, + const gfc_array_char * const restrict, + const 'atype_name` * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift3_'atype_kind`_char4); + +void +eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const 'atype` * const restrict h, + const gfc_array_char * const restrict bound, + const 'atype_name` * const restrict pwhich, + GFC_INTEGER_4 array_length, + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ''` ''`; + eoshift3 (ret, array, h, bound, pwhich, array_length * sizeof (gfc_char4_t), + (const char *) &space, sizeof (gfc_char4_t)); } #endif' diff --git a/libjava/ChangeLog b/libjava/ChangeLog index 37f12e2c892..65abe270155 100644 --- a/libjava/ChangeLog +++ b/libjava/ChangeLog @@ -1,3 +1,9 @@ +2008-05-28 Andrew Haley <aph@redhat.com> + + * java/lang/Class.java (getSimpleName): Use getEnclosingClass(). + * testsuite/libjava.lang/PR35020.java: New cases. + * testsuite/libjava.lang/PR35020.out: New cases. + 2008-05-22 Andrew Haley <aph@redhat.com> PR libgcj/35020 diff --git a/libjava/classpath/lib/java/lang/Class.class b/libjava/classpath/lib/java/lang/Class.class Binary files differindex ce854558e54..2e4126b71d9 100644 --- a/libjava/classpath/lib/java/lang/Class.class +++ b/libjava/classpath/lib/java/lang/Class.class diff --git a/libjava/java/lang/Class.java b/libjava/java/lang/Class.java index 868e370b819..a4e8ee5929e 100644 --- a/libjava/java/lang/Class.java +++ b/libjava/java/lang/Class.java @@ -1078,26 +1078,24 @@ public final class Class<T> if (isAnonymousClass()) return ""; if (isArray()) - { - return getComponentType().getSimpleName() + "[]"; - } + return getComponentType().getSimpleName() + "[]"; + String fullName = getName(); - int pos = fullName.lastIndexOf("$"); - if (pos == -1) - pos = 0; - else - { - ++pos; - while (Character.isDigit(fullName.charAt(pos))) - ++pos; - fullName = fullName.substring(pos); - } + Class enclosingClass = getEnclosingClass(); + if (enclosingClass == null) + // It's a top level class. + return fullName.substring(fullName.lastIndexOf(".") + 1); - int packagePos = fullName.lastIndexOf("."); - if (packagePos == -1) - return fullName; - else - return fullName.substring(packagePos + 1); + fullName = fullName.substring(enclosingClass.getName().length()); + + // We've carved off the enclosing class name; now we must have '$' + // followed optionally by digits, followed by the class name. + int pos = 1; + while (Character.isDigit(fullName.charAt(pos))) + ++pos; + fullName = fullName.substring(pos); + + return fullName; } /** diff --git a/libjava/testsuite/libjava.lang/PR35020.jar b/libjava/testsuite/libjava.lang/PR35020.jar Binary files differindex bedaed7ecdb..09c4ef4818d 100644 --- a/libjava/testsuite/libjava.lang/PR35020.jar +++ b/libjava/testsuite/libjava.lang/PR35020.jar diff --git a/libjava/testsuite/libjava.lang/PR35020.java b/libjava/testsuite/libjava.lang/PR35020.java index 1850da79683..ff5f6bf06f2 100644 --- a/libjava/testsuite/libjava.lang/PR35020.java +++ b/libjava/testsuite/libjava.lang/PR35020.java @@ -1,21 +1,30 @@ +class outer$inner +{ +}; + public class PR35020 { - class inner - { - } - public static void main(String[] args) - { - System.out.println(inner.class.getSimpleName()); - System.out.println(PR35020.class.getSimpleName()); - System.out.println(Class.class.getSimpleName()); - System.out.println((new int[7]).getClass().getSimpleName()); - System.out.println((new Object[1][1][1][1][1][1][1][1]).getClass().getSimpleName()); - System.out.println((new java.security.PrivilegedAction() - { - public Object run() { - return null; - } - }).getClass().getSimpleName()); - } + class PR35020$Inner + { + }; + class inner + { + } + public static void main(String[] args) + { + System.out.println(inner.class.getSimpleName()); + System.out.println(PR35020.class.getSimpleName()); + System.out.println(Class.class.getSimpleName()); + System.out.println((new int[7]).getClass().getSimpleName()); + System.out.println((new Object[1][1][1][1][1][1][1][1]).getClass().getSimpleName()); + System.out.println((new java.security.PrivilegedAction() + { + public Object run() { + return null; + } + }).getClass().getSimpleName()); + System.out.println(PR35020$Inner.class.getSimpleName()); + System.out.println(outer$inner.class.getSimpleName()); + System.out.println(outer$inner.inner.class.getSimpleName()); + } } - diff --git a/libjava/testsuite/libjava.lang/PR35020.out b/libjava/testsuite/libjava.lang/PR35020.out index 73eb0c917fc..9bf85e209d5 100644 --- a/libjava/testsuite/libjava.lang/PR35020.out +++ b/libjava/testsuite/libjava.lang/PR35020.out @@ -4,3 +4,6 @@ Class int[] Object[][][][][][][][] +PR35020$Inner +outer$inner +inner diff --git a/libobjc/ChangeLog b/libobjc/ChangeLog index 046b652248b..df30eaae50c 100644 --- a/libobjc/ChangeLog +++ b/libobjc/ChangeLog @@ -1,3 +1,8 @@ +2008-05-25 Alan Modra <amodra@bigpond.net.au> + + * encoding.c (strip_array_types): Rename from get_inner_array_type. + (rs6000_special_round_type_align): Update. + 2008-05-09 Julian Brown <julian@codesourcery.com> * Makefile.in (LTLDFLAGS): New. diff --git a/libobjc/encoding.c b/libobjc/encoding.c index e65634103aa..93395ddaffc 100644 --- a/libobjc/encoding.c +++ b/libobjc/encoding.c @@ -78,7 +78,7 @@ Boston, MA 02110-1301, USA. */ #define DFmode _C_DBL -#define get_inner_array_type(TYPE) ({const char *_field = (TYPE); \ +#define strip_array_types(TYPE) ({const char *_field = (TYPE); \ while (*_field == _C_ARY_B)\ {\ while (isdigit ((unsigned char)*++_field))\ @@ -115,9 +115,7 @@ static int __attribute__ ((__unused__)) not_target_flags = 0; #define rs6000_special_round_type_align(STRUCT, COMPUTED, SPECIFIED) \ ({ const char *_fields = TYPE_FIELDS (STRUCT); \ ((_fields != 0 \ - && TYPE_MODE (TREE_CODE (TREE_TYPE (_fields)) == ARRAY_TYPE \ - ? get_inner_array_type (_fields) \ - : TREE_TYPE (_fields)) == DFmode) \ + && TYPE_MODE (strip_array_types (TREE_TYPE (_fields))) == DFmode) \ ? MAX (MAX (COMPUTED, SPECIFIED), 64) \ : MAX (COMPUTED, SPECIFIED));}) /* FIXME: The word 'fixme' is insufficient to explain the wrong-ness diff --git a/libstdc++-v3/ChangeLog b/libstdc++-v3/ChangeLog index 657bde17864..1c023cfe827 100644 --- a/libstdc++-v3/ChangeLog +++ b/libstdc++-v3/ChangeLog @@ -1,3 +1,62 @@ +2008-05-26 Paolo Carlini <paolo.carlini@oracle.com> + + * include/c_global/cmath (pow(float, int), pow(double, int), + pow(long double, int)): Do not define in C++0x mode, per DR 550. + * include/tr1_impl/cmath (pow): Do not bring in unconditionally + from namespace std. + * include/tr1/cmath (pow(double, double), pow(float, float), + pow(long double, long double), pow(_Tp, _Up)): Define. + * include/tr1/complex (pow): Do not bring in from namespace std. + (pow(const std::complex<_Tp>&, int), pow(const std::complex<_Tp>&, + const _Tp&), pow(const _Tp&, const std::complex<_Tp>&), + pow(const std::complex<_Tp>&, const std::complex<_Tp>&)): Define. + * include/tr1_impl/complex (pow(const std::complex<_Tp>&, + const _Up&), pow(const _Tp&, const std::complex<_Up>&), + pow(const std::complex<_Tp>&, const std::complex<_Up>&)): Always + define. + * doc/xml/manual/intro.xml: Add an entry for DR 550. + * testsuite/26_numerics/headers/cmath/dr550.cc: New. + * testsuite/tr1/8_c_compatibility/cmath/overloads.cc: Adjust. + +2008-05-25 Paolo Carlini <paolo.carlini@oracle.com> + + * include/std/tuple: Ifndef __GXX_EXPERIMENTAL_CXX0X__ just error out. + * include/std/date_time: Likewise. + * include/std/system_error: Likewise. + * include/std/type_traits: Likewise; fix typo in macro name. + * include/std/regex: Likewise. + * include/std/random: Likewise. + * include/std/unordered_map: Likewise. + * include/std/condition_variable: Likewise. + * include/std/unordered_set: Likewise. + * include/std/mutex: Likewise. + * include/std/array: Likewise. + + * include/c_std/cmath: Fix obsolete comment. + * include/c_global/cmath: Likewise. + +2008-05-25 Paolo Carlini <paolo.carlini@oracle.com> + + * include/std/complex (complex<>::real(_Tp), complex<>::imag(_Tp), + complex<float>::real(float), complex<float>::imag(float), + complex<double>::real(double), complex<double>::imag(double), + complex<long double>::real(long double), + complex<long double>::imag(long double)): Add per DR 387. + (complex<>::real(), complex<>::imag(), complex<float>::real(), + complex<float>::imag(), complex<double>::real(), + complex<double>::imag(), complex<long double>::real(), + complex<long double>::imag(long double)): Adjust in C++0x mode. + (real(complex<>&), imag(complex<>&), real(const complex<>&), + imag(const complex<>&)): Likewise. + * testsuite/26_numerics/complex/dr387.cc: New. + * doc/xml/manual/intro.xml: Add an entry for DR 387. + +2008-05-25 Paolo Carlini <paolo.carlini@oracle.com> + + * include/std/complex: Trivial stylistic changes, define inline + members inline, consistently with the rest of the library. + (pow(const _Tp&, const complex<>&)): Minor tweak. + 2008-05-24 Paolo Carlini <paolo.carlini@oracle.com> * src/atomic.cc (atomic_flag_test_and_set_explicit, diff --git a/libstdc++-v3/doc/xml/manual/intro.xml b/libstdc++-v3/doc/xml/manual/intro.xml index 0287c9e5562..1f6708dac9a 100644 --- a/libstdc++-v3/doc/xml/manual/intro.xml +++ b/libstdc++-v3/doc/xml/manual/intro.xml @@ -475,19 +475,21 @@ <varlistentry><term><ulink url="../ext/lwg-defects.html#303">303</ulink>: <emphasis>Bitset input operator underspecified</emphasis> </term> - <listitem><para>Basically, compare the input character to <code>is.widen(0)</code> - and <code>is.widen(1)</code>. + <listitem><para>Basically, compare the input character to + <code>is.widen(0)</code> and <code>is.widen(1)</code>. </para></listitem></varlistentry> <varlistentry><term><ulink url="../ext/lwg-defects.html#305">305</ulink>: - <emphasis>Default behavior of codecvt<wchar_t, char, mbstate_t>::length()</emphasis> + <emphasis>Default behavior of codecvt<wchar_t, char, + mbstate_t>::length()</emphasis> </term> - <listitem><para>Do not specify what <code>codecvt<wchar_t, char, mbstate_t>::do_length</code> - must return. + <listitem><para>Do not specify what <code>codecvt<wchar_t, char, + mbstate_t>::do_length</code> must return. </para></listitem></varlistentry> <varlistentry><term><ulink url="../ext/lwg-defects.html#328">328</ulink>: - <emphasis>Bad sprintf format modifier in money_put<>::do_put()</emphasis> + <emphasis>Bad sprintf format modifier in + money_put<>::do_put()</emphasis> </term> <listitem><para>Change the format string to "%.0Lf". </para></listitem></varlistentry> @@ -498,8 +500,18 @@ <listitem><para>Add const overloads of <code>is_open</code>. </para></listitem></varlistentry> + <varlistentry><term><ulink url="../ext/lwg-active.html#387">387</ulink>: + <emphasis>std::complex over-encapsulated</emphasis> + </term> + <listitem><para>Add the <code>real(T)</code> and <code>imag(T)</code> + members; in C++0x mode, also adjust the existing + <code>real()</code> and <code>imag()</code> members and + free functions. + </para></listitem></varlistentry> + <varlistentry><term><ulink url="../ext/lwg-defects.html#389">389</ulink>: - <emphasis>Const overload of valarray::operator[] returns by value</emphasis> + <emphasis>Const overload of valarray::operator[] returns + by value</emphasis> </term> <listitem><para>Change it to return a <code>const T&</code>. </para></listitem></varlistentry> @@ -599,6 +611,12 @@ <listitem><para>Follow the straightforward proposed resolution. </para></listitem></varlistentry> + <varlistentry><term><ulink url="../ext/lwg-active.html#550">550</ulink>: + <emphasis>What should the return type of pow(float,int) be?</emphasis> + </term> + <listitem><para>In C++0x mode, remove the pow(float,int), etc., signatures. + </para></listitem></varlistentry> + <varlistentry><term><ulink url="../ext/lwg-defects.html#586">586</ulink>: <emphasis>string inserter not a formatted function</emphasis> </term> diff --git a/libstdc++-v3/include/c_global/cmath b/libstdc++-v3/include/c_global/cmath index fad38e2f95d..dd26db1a718 100644 --- a/libstdc++-v3/include/c_global/cmath +++ b/libstdc++-v3/include/c_global/cmath @@ -367,7 +367,9 @@ _GLIBCXX_BEGIN_NAMESPACE(std) pow(long double __x, long double __y) { return __builtin_powl(__x, __y); } - // DR 550. +#ifndef __GXX_EXPERIMENTAL_CXX0X__ + // _GLIBCXX_RESOLVE_LIB_DEFECTS + // DR 550. What should the return type of pow(float,int) be? inline double pow(double __x, int __i) { return __builtin_powi(__x, __i); } @@ -379,6 +381,7 @@ _GLIBCXX_BEGIN_NAMESPACE(std) inline long double pow(long double __x, int __n) { return __builtin_powil(__x, __n); } +#endif template<typename _Tp, typename _Up> inline @@ -476,11 +479,8 @@ _GLIBCXX_END_NAMESPACE #if _GLIBCXX_USE_C99_MATH #if !_GLIBCXX_USE_C99_FP_MACROS_DYNAMIC -// These are possible macros imported from C99-land. For strict -// conformance, remove possible C99-injected names from the global -// namespace, and sequester them in the __gnu_cxx extension namespace. -// Only undefine the C99 FP macros, if actually captured for namespace movement +// These are possible macros imported from C99-land. #undef fpclassify #undef isfinite #undef isinf diff --git a/libstdc++-v3/include/c_std/cmath b/libstdc++-v3/include/c_std/cmath index cc26880bb81..948a0bece29 100644 --- a/libstdc++-v3/include/c_std/cmath +++ b/libstdc++-v3/include/c_std/cmath @@ -458,11 +458,8 @@ _GLIBCXX_END_NAMESPACE #if _GLIBCXX_USE_C99_MATH #if !_GLIBCXX_USE_C99_FP_MACROS_DYNAMIC -// These are possible macros imported from C99-land. For strict -// conformance, remove possible C99-injected names from the global -// namespace, and sequester them in the __gnu_cxx extension namespace. -// Only undefine the C99 FP macros, if actually captured for namespace movement +// These are possible macros imported from C99-land. #undef fpclassify #undef isfinite #undef isinf diff --git a/libstdc++-v3/include/std/array b/libstdc++-v3/include/std/array index c84ddb6573f..fc3552aa8f9 100644 --- a/libstdc++-v3/include/std/array +++ b/libstdc++-v3/include/std/array @@ -1,6 +1,6 @@ // <array> -*- C++ -*- -// 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 @@ -38,7 +38,7 @@ #ifndef __GXX_EXPERIMENTAL_CXX0X__ # include <c++0x_warning.h> -#endif +#else #if defined(_GLIBCXX_INCLUDE_AS_TR1) # error C++0x header cannot be included from TR1 header @@ -60,4 +60,6 @@ # undef _GLIBCXX_INCLUDE_AS_CXX0X #endif +#endif // __GXX_EXPERIMENTAL_CXX0X__ + #endif // _GLIBCXX_ARRAY diff --git a/libstdc++-v3/include/std/complex b/libstdc++-v3/include/std/complex index e3feef0918f..0fa381cbeac 100644 --- a/libstdc++-v3/include/std/complex +++ b/libstdc++-v3/include/std/complex @@ -121,29 +121,71 @@ _GLIBCXX_BEGIN_NAMESPACE(std) /// Default constructor. First parameter is x, second parameter is y. /// Unspecified parameters default to 0. - complex(const _Tp& = _Tp(), const _Tp & = _Tp()); + complex(const _Tp& __r = _Tp(), const _Tp& __i = _Tp()) + : _M_real(__r), _M_imag(__i) { } // Lets the compiler synthesize the copy constructor // complex (const complex<_Tp>&); /// Copy constructor. template<typename _Up> - complex(const complex<_Up>&); + complex(const complex<_Up>& __z) + : _M_real(__z.real()), _M_imag(__z.imag()) { } +#ifdef __GXX_EXPERIMENTAL_CXX0X__ + // _GLIBCXX_RESOLVE_LIB_DEFECTS + // DR 387. std::complex over-encapsulated. + _Tp real() const + { return _M_real; } + + _Tp imag() const + { return _M_imag; } +#else /// Return real part of complex number. - _Tp& real(); + _Tp& real() + { return _M_real; } + /// Return real part of complex number. - const _Tp& real() const; + const _Tp& real() const + { return _M_real; } + /// Return imaginary part of complex number. - _Tp& imag(); + _Tp& imag() + { return _M_imag; } + /// Return imaginary part of complex number. - const _Tp& imag() const; + const _Tp& imag() const + { return _M_imag; } +#endif + + // _GLIBCXX_RESOLVE_LIB_DEFECTS + // DR 387. std::complex over-encapsulated. + void real(_Tp __val) + { _M_real = __val; } + + void imag(_Tp __val) + { _M_imag = __val; } /// Assign this complex number to scalar @a t. complex<_Tp>& operator=(const _Tp&); + /// Add @a t to this complex number. - complex<_Tp>& operator+=(const _Tp&); + // 26.2.5/1 + complex<_Tp>& + operator+=(const _Tp& __t) + { + _M_real += __t; + return *this; + } + /// Subtract @a t from this complex number. - complex<_Tp>& operator-=(const _Tp&); + // 26.2.5/3 + complex<_Tp>& + operator-=(const _Tp& __t) + { + _M_real -= __t; + return *this; + } + /// Multiply this complex number by @a t. complex<_Tp>& operator*=(const _Tp&); /// Divide this complex number by @a t. @@ -168,7 +210,8 @@ _GLIBCXX_BEGIN_NAMESPACE(std) template<typename _Up> complex<_Tp>& operator/=(const complex<_Up>&); - const complex& __rep() const; + const complex& __rep() const + { return *this; } private: _Tp _M_real; @@ -176,33 +219,6 @@ _GLIBCXX_BEGIN_NAMESPACE(std) }; template<typename _Tp> - inline _Tp& - complex<_Tp>::real() { return _M_real; } - - template<typename _Tp> - inline const _Tp& - complex<_Tp>::real() const { return _M_real; } - - template<typename _Tp> - inline _Tp& - complex<_Tp>::imag() { return _M_imag; } - - template<typename _Tp> - inline const _Tp& - complex<_Tp>::imag() const { return _M_imag; } - - template<typename _Tp> - inline - complex<_Tp>::complex(const _Tp& __r, const _Tp& __i) - : _M_real(__r), _M_imag(__i) { } - - template<typename _Tp> - template<typename _Up> - inline - complex<_Tp>::complex(const complex<_Up>& __z) - : _M_real(__z.real()), _M_imag(__z.imag()) { } - - template<typename _Tp> complex<_Tp>& complex<_Tp>::operator=(const _Tp& __t) { @@ -211,24 +227,6 @@ _GLIBCXX_BEGIN_NAMESPACE(std) return *this; } - // 26.2.5/1 - template<typename _Tp> - inline complex<_Tp>& - complex<_Tp>::operator+=(const _Tp& __t) - { - _M_real += __t; - return *this; - } - - // 26.2.5/3 - template<typename _Tp> - inline complex<_Tp>& - complex<_Tp>::operator-=(const _Tp& __t) - { - _M_real -= __t; - return *this; - } - // 26.2.5/5 template<typename _Tp> complex<_Tp>& @@ -307,10 +305,6 @@ _GLIBCXX_BEGIN_NAMESPACE(std) _M_real = __r / __n; return *this; } - - template<typename _Tp> - inline const complex<_Tp>& - complex<_Tp>::__rep() const { return *this; } // Operators: //@{ @@ -528,6 +522,17 @@ _GLIBCXX_BEGIN_NAMESPACE(std) } // Values +#ifdef __GXX_EXPERIMENTAL_CXX0X__ + template<typename _Tp> + inline _Tp + real(const complex<_Tp>& __z) + { return __z.real(); } + + template<typename _Tp> + inline _Tp + imag(const complex<_Tp>& __z) + { return __z.imag(); } +#else template<typename _Tp> inline _Tp& real(complex<_Tp>& __z) @@ -547,6 +552,7 @@ _GLIBCXX_BEGIN_NAMESPACE(std) inline const _Tp& imag(const complex<_Tp>& __z) { return __z.imag(); } +#endif // 26.2.7/3 abs(__z): Returns the magnitude of __z. template<typename _Tp> @@ -995,7 +1001,7 @@ _GLIBCXX_BEGIN_NAMESPACE(std) { return __x > _Tp() ? std::polar(pow(__x, __y.real()), __y.imag() * log(__x)) - : std::pow(complex<_Tp>(__x, _Tp()), __y); + : std::pow(complex<_Tp>(__x), __y); } // 26.2.3 complex specializations @@ -1008,35 +1014,133 @@ _GLIBCXX_BEGIN_NAMESPACE(std) complex(_ComplexT __z) : _M_value(__z) { } - complex(float = 0.0f, float = 0.0f); + complex(float __r = 0.0f, float __i = 0.0f) + { + __real__ _M_value = __r; + __imag__ _M_value = __i; + } explicit complex(const complex<double>&); - explicit complex(const complex<long double>&); + explicit complex(const complex<long double>&); + +#ifdef __GXX_EXPERIMENTAL_CXX0X__ + // _GLIBCXX_RESOLVE_LIB_DEFECTS + // DR 387. std::complex over-encapsulated. + float real() const + { return __real__ _M_value; } - float& real(); - const float& real() const; - float& imag(); - const float& imag() const; + float imag() const + { return __imag__ _M_value; } +#else + float& real() + { return __real__ _M_value; } - complex<float>& operator=(float); - complex<float>& operator+=(float); - complex<float>& operator-=(float); - complex<float>& operator*=(float); - complex<float>& operator/=(float); + const float& real() const + { return __real__ _M_value; } + + float& imag() + { return __imag__ _M_value; } + + const float& imag() const + { return __imag__ _M_value; } +#endif + + // _GLIBCXX_RESOLVE_LIB_DEFECTS + // DR 387. std::complex over-encapsulated. + void real(float __val) + { __real__ _M_value = __val; } + + void imag(float __val) + { __imag__ _M_value = __val; } + + complex<float>& + operator=(float __f) + { + __real__ _M_value = __f; + __imag__ _M_value = 0.0f; + return *this; + } + + complex<float>& + operator+=(float __f) + { + __real__ _M_value += __f; + return *this; + } + + complex<float>& + operator-=(float __f) + { + __real__ _M_value -= __f; + return *this; + } + + complex<float>& + operator*=(float __f) + { + _M_value *= __f; + return *this; + } + + complex<float>& + operator/=(float __f) + { + _M_value /= __f; + return *this; + } // Let the compiler synthesize the copy and assignment // operator. It always does a pretty good job. - // complex& operator= (const complex&); + // complex& operator=(const complex&); + template<typename _Tp> - complex<float>&operator=(const complex<_Tp>&); + complex<float>& + operator=(const complex<_Tp>& __z) + { + __real__ _M_value = __z.real(); + __imag__ _M_value = __z.imag(); + return *this; + } + template<typename _Tp> - complex<float>& operator+=(const complex<_Tp>&); + complex<float>& + operator+=(const complex<_Tp>& __z) + { + __real__ _M_value += __z.real(); + __imag__ _M_value += __z.imag(); + return *this; + } + template<class _Tp> - complex<float>& operator-=(const complex<_Tp>&); + complex<float>& + operator-=(const complex<_Tp>& __z) + { + __real__ _M_value -= __z.real(); + __imag__ _M_value -= __z.imag(); + return *this; + } + template<class _Tp> - complex<float>& operator*=(const complex<_Tp>&); + complex<float>& + operator*=(const complex<_Tp>& __z) + { + _ComplexT __t; + __real__ __t = __z.real(); + __imag__ __t = __z.imag(); + _M_value *= __t; + return *this; + } + template<class _Tp> - complex<float>&operator/=(const complex<_Tp>&); + complex<float>& + operator/=(const complex<_Tp>& __z) + { + _ComplexT __t; + __real__ __t = __z.real(); + __imag__ __t = __z.imag(); + _M_value /= __t; + return *this; + } const _ComplexT& __rep() const { return _M_value; } @@ -1044,114 +1148,6 @@ _GLIBCXX_BEGIN_NAMESPACE(std) _ComplexT _M_value; }; - inline float& - complex<float>::real() - { return __real__ _M_value; } - - inline const float& - complex<float>::real() const - { return __real__ _M_value; } - - inline float& - complex<float>::imag() - { return __imag__ _M_value; } - - inline const float& - complex<float>::imag() const - { return __imag__ _M_value; } - - inline - complex<float>::complex(float __r, float __i) - { - __real__ _M_value = __r; - __imag__ _M_value = __i; - } - - inline complex<float>& - complex<float>::operator=(float __f) - { - __real__ _M_value = __f; - __imag__ _M_value = 0.0f; - return *this; - } - - inline complex<float>& - complex<float>::operator+=(float __f) - { - __real__ _M_value += __f; - return *this; - } - - inline complex<float>& - complex<float>::operator-=(float __f) - { - __real__ _M_value -= __f; - return *this; - } - - inline complex<float>& - complex<float>::operator*=(float __f) - { - _M_value *= __f; - return *this; - } - - inline complex<float>& - complex<float>::operator/=(float __f) - { - _M_value /= __f; - return *this; - } - - template<typename _Tp> - inline complex<float>& - complex<float>::operator=(const complex<_Tp>& __z) - { - __real__ _M_value = __z.real(); - __imag__ _M_value = __z.imag(); - return *this; - } - - template<typename _Tp> - inline complex<float>& - complex<float>::operator+=(const complex<_Tp>& __z) - { - __real__ _M_value += __z.real(); - __imag__ _M_value += __z.imag(); - return *this; - } - - template<typename _Tp> - inline complex<float>& - complex<float>::operator-=(const complex<_Tp>& __z) - { - __real__ _M_value -= __z.real(); - __imag__ _M_value -= __z.imag(); - return *this; - } - - template<typename _Tp> - inline complex<float>& - complex<float>::operator*=(const complex<_Tp>& __z) - { - _ComplexT __t; - __real__ __t = __z.real(); - __imag__ __t = __z.imag(); - _M_value *= __t; - return *this; - } - - template<typename _Tp> - inline complex<float>& - complex<float>::operator/=(const complex<_Tp>& __z) - { - _ComplexT __t; - __real__ __t = __z.real(); - __imag__ __t = __z.imag(); - _M_value /= __t; - return *this; - } - // 26.2.3 complex specializations // complex<double> specialization template<> @@ -1162,34 +1158,134 @@ _GLIBCXX_BEGIN_NAMESPACE(std) complex(_ComplexT __z) : _M_value(__z) { } - complex(double = 0.0, double = 0.0); + complex(double __r = 0.0, double __i = 0.0) + { + __real__ _M_value = __r; + __imag__ _M_value = __i; + } + + complex(const complex<float>& __z) + : _M_value(__z.__rep()) { } + + explicit complex(const complex<long double>&); + +#ifdef __GXX_EXPERIMENTAL_CXX0X__ + // _GLIBCXX_RESOLVE_LIB_DEFECTS + // DR 387. std::complex over-encapsulated. + double real() const + { return __real__ _M_value; } + + double imag() const + { return __imag__ _M_value; } +#else + double& real() + { return __real__ _M_value; } + + const double& real() const + { return __real__ _M_value; } - complex(const complex<float>&); - explicit complex(const complex<long double>&); + double& imag() + { return __imag__ _M_value; } - double& real(); - const double& real() const; - double& imag(); - const double& imag() const; + const double& imag() const + { return __imag__ _M_value; } +#endif - complex<double>& operator=(double); - complex<double>& operator+=(double); - complex<double>& operator-=(double); - complex<double>& operator*=(double); - complex<double>& operator/=(double); + // _GLIBCXX_RESOLVE_LIB_DEFECTS + // DR 387. std::complex over-encapsulated. + void real(double __val) + { __real__ _M_value = __val; } + + void imag(double __val) + { __imag__ _M_value = __val; } + + complex<double>& + operator=(double __d) + { + __real__ _M_value = __d; + __imag__ _M_value = 0.0; + return *this; + } + + complex<double>& + operator+=(double __d) + { + __real__ _M_value += __d; + return *this; + } + + complex<double>& + operator-=(double __d) + { + __real__ _M_value -= __d; + return *this; + } + + complex<double>& + operator*=(double __d) + { + _M_value *= __d; + return *this; + } + + complex<double>& + operator/=(double __d) + { + _M_value /= __d; + return *this; + } // The compiler will synthesize this, efficiently. - // complex& operator= (const complex&); + // complex& operator=(const complex&); + template<typename _Tp> - complex<double>& operator=(const complex<_Tp>&); + complex<double>& + operator=(const complex<_Tp>& __z) + { + __real__ _M_value = __z.real(); + __imag__ _M_value = __z.imag(); + return *this; + } + template<typename _Tp> - complex<double>& operator+=(const complex<_Tp>&); + complex<double>& + operator+=(const complex<_Tp>& __z) + { + __real__ _M_value += __z.real(); + __imag__ _M_value += __z.imag(); + return *this; + } + template<typename _Tp> - complex<double>& operator-=(const complex<_Tp>&); + complex<double>& + operator-=(const complex<_Tp>& __z) + { + __real__ _M_value -= __z.real(); + __imag__ _M_value -= __z.imag(); + return *this; + } + template<typename _Tp> - complex<double>& operator*=(const complex<_Tp>&); + complex<double>& + operator*=(const complex<_Tp>& __z) + { + _ComplexT __t; + __real__ __t = __z.real(); + __imag__ __t = __z.imag(); + _M_value *= __t; + return *this; + } + template<typename _Tp> - complex<double>& operator/=(const complex<_Tp>&); + complex<double>& + operator/=(const complex<_Tp>& __z) + { + _ComplexT __t; + __real__ __t = __z.real(); + __imag__ __t = __z.imag(); + _M_value /= __t; + return *this; + } const _ComplexT& __rep() const { return _M_value; } @@ -1197,114 +1293,6 @@ _GLIBCXX_BEGIN_NAMESPACE(std) _ComplexT _M_value; }; - inline double& - complex<double>::real() - { return __real__ _M_value; } - - inline const double& - complex<double>::real() const - { return __real__ _M_value; } - - inline double& - complex<double>::imag() - { return __imag__ _M_value; } - - inline const double& - complex<double>::imag() const - { return __imag__ _M_value; } - - inline - complex<double>::complex(double __r, double __i) - { - __real__ _M_value = __r; - __imag__ _M_value = __i; - } - - inline complex<double>& - complex<double>::operator=(double __d) - { - __real__ _M_value = __d; - __imag__ _M_value = 0.0; - return *this; - } - - inline complex<double>& - complex<double>::operator+=(double __d) - { - __real__ _M_value += __d; - return *this; - } - - inline complex<double>& - complex<double>::operator-=(double __d) - { - __real__ _M_value -= __d; - return *this; - } - - inline complex<double>& - complex<double>::operator*=(double __d) - { - _M_value *= __d; - return *this; - } - - inline complex<double>& - complex<double>::operator/=(double __d) - { - _M_value /= __d; - return *this; - } - - template<typename _Tp> - inline complex<double>& - complex<double>::operator=(const complex<_Tp>& __z) - { - __real__ _M_value = __z.real(); - __imag__ _M_value = __z.imag(); - return *this; - } - - template<typename _Tp> - inline complex<double>& - complex<double>::operator+=(const complex<_Tp>& __z) - { - __real__ _M_value += __z.real(); - __imag__ _M_value += __z.imag(); - return *this; - } - - template<typename _Tp> - inline complex<double>& - complex<double>::operator-=(const complex<_Tp>& __z) - { - __real__ _M_value -= __z.real(); - __imag__ _M_value -= __z.imag(); - return *this; - } - - template<typename _Tp> - inline complex<double>& - complex<double>::operator*=(const complex<_Tp>& __z) - { - _ComplexT __t; - __real__ __t = __z.real(); - __imag__ __t = __z.imag(); - _M_value *= __t; - return *this; - } - - template<typename _Tp> - inline complex<double>& - complex<double>::operator/=(const complex<_Tp>& __z) - { - _ComplexT __t; - __real__ __t = __z.real(); - __imag__ __t = __z.imag(); - _M_value /= __t; - return *this; - } - // 26.2.3 complex specializations // complex<long double> specialization template<> @@ -1315,34 +1303,135 @@ _GLIBCXX_BEGIN_NAMESPACE(std) complex(_ComplexT __z) : _M_value(__z) { } - complex(long double = 0.0L, long double = 0.0L); + complex(long double __r = 0.0L, long double __i = 0.0L) + { + __real__ _M_value = __r; + __imag__ _M_value = __i; + } + + complex(const complex<float>& __z) + : _M_value(__z.__rep()) { } + + complex(const complex<double>& __z) + : _M_value(__z.__rep()) { } + +#ifdef __GXX_EXPERIMENTAL_CXX0X__ + // _GLIBCXX_RESOLVE_LIB_DEFECTS + // DR 387. std::complex over-encapsulated. + long double real() const + { return __real__ _M_value; } + + long double imag() const + { return __imag__ _M_value; } +#else + long double& real() + { return __real__ _M_value; } + + const long double& real() const + { return __real__ _M_value; } - complex(const complex<float>&); - complex(const complex<double>&); + long double& imag() + { return __imag__ _M_value; } - long double& real(); - const long double& real() const; - long double& imag(); - const long double& imag() const; + const long double& imag() const + { return __imag__ _M_value; } +#endif - complex<long double>& operator= (long double); - complex<long double>& operator+= (long double); - complex<long double>& operator-= (long double); - complex<long double>& operator*= (long double); - complex<long double>& operator/= (long double); + // _GLIBCXX_RESOLVE_LIB_DEFECTS + // DR 387. std::complex over-encapsulated. + void real(long double __val) + { __real__ _M_value = __val; } + + void imag(long double __val) + { __imag__ _M_value = __val; } + + complex<long double>& + operator=(long double __r) + { + __real__ _M_value = __r; + __imag__ _M_value = 0.0L; + return *this; + } + + complex<long double>& + operator+=(long double __r) + { + __real__ _M_value += __r; + return *this; + } + + complex<long double>& + operator-=(long double __r) + { + __real__ _M_value -= __r; + return *this; + } + + complex<long double>& + operator*=(long double __r) + { + _M_value *= __r; + return *this; + } + + complex<long double>& + operator/=(long double __r) + { + _M_value /= __r; + return *this; + } // The compiler knows how to do this efficiently - // complex& operator= (const complex&); + // complex& operator=(const complex&); + template<typename _Tp> - complex<long double>& operator=(const complex<_Tp>&); + complex<long double>& + operator=(const complex<_Tp>& __z) + { + __real__ _M_value = __z.real(); + __imag__ _M_value = __z.imag(); + return *this; + } + template<typename _Tp> - complex<long double>& operator+=(const complex<_Tp>&); + complex<long double>& + operator+=(const complex<_Tp>& __z) + { + __real__ _M_value += __z.real(); + __imag__ _M_value += __z.imag(); + return *this; + } + template<typename _Tp> - complex<long double>& operator-=(const complex<_Tp>&); + complex<long double>& + operator-=(const complex<_Tp>& __z) + { + __real__ _M_value -= __z.real(); + __imag__ _M_value -= __z.imag(); + return *this; + } + template<typename _Tp> - complex<long double>& operator*=(const complex<_Tp>&); + complex<long double>& + operator*=(const complex<_Tp>& __z) + { + _ComplexT __t; + __real__ __t = __z.real(); + __imag__ __t = __z.imag(); + _M_value *= __t; + return *this; + } + template<typename _Tp> - complex<long double>& operator/=(const complex<_Tp>&); + complex<long double>& + operator/=(const complex<_Tp>& __z) + { + _ComplexT __t; + __real__ __t = __z.real(); + __imag__ __t = __z.imag(); + _M_value /= __t; + return *this; + } const _ComplexT& __rep() const { return _M_value; } @@ -1350,114 +1439,6 @@ _GLIBCXX_BEGIN_NAMESPACE(std) _ComplexT _M_value; }; - inline - complex<long double>::complex(long double __r, long double __i) - { - __real__ _M_value = __r; - __imag__ _M_value = __i; - } - - inline long double& - complex<long double>::real() - { return __real__ _M_value; } - - inline const long double& - complex<long double>::real() const - { return __real__ _M_value; } - - inline long double& - complex<long double>::imag() - { return __imag__ _M_value; } - - inline const long double& - complex<long double>::imag() const - { return __imag__ _M_value; } - - inline complex<long double>& - complex<long double>::operator=(long double __r) - { - __real__ _M_value = __r; - __imag__ _M_value = 0.0L; - return *this; - } - - inline complex<long double>& - complex<long double>::operator+=(long double __r) - { - __real__ _M_value += __r; - return *this; - } - - inline complex<long double>& - complex<long double>::operator-=(long double __r) - { - __real__ _M_value -= __r; - return *this; - } - - inline complex<long double>& - complex<long double>::operator*=(long double __r) - { - _M_value *= __r; - return *this; - } - - inline complex<long double>& - complex<long double>::operator/=(long double __r) - { - _M_value /= __r; - return *this; - } - - template<typename _Tp> - inline complex<long double>& - complex<long double>::operator=(const complex<_Tp>& __z) - { - __real__ _M_value = __z.real(); - __imag__ _M_value = __z.imag(); - return *this; - } - - template<typename _Tp> - inline complex<long double>& - complex<long double>::operator+=(const complex<_Tp>& __z) - { - __real__ _M_value += __z.real(); - __imag__ _M_value += __z.imag(); - return *this; - } - - template<typename _Tp> - inline complex<long double>& - complex<long double>::operator-=(const complex<_Tp>& __z) - { - __real__ _M_value -= __z.real(); - __imag__ _M_value -= __z.imag(); - return *this; - } - - template<typename _Tp> - inline complex<long double>& - complex<long double>::operator*=(const complex<_Tp>& __z) - { - _ComplexT __t; - __real__ __t = __z.real(); - __imag__ __t = __z.imag(); - _M_value *= __t; - return *this; - } - - template<typename _Tp> - inline complex<long double>& - complex<long double>::operator/=(const complex<_Tp>& __z) - { - _ComplexT __t; - __real__ __t = __z.real(); - __imag__ __t = __z.imag(); - _M_value /= __t; - return *this; - } - // These bits have to be at the end of this file, so that the // specializations have all been defined. // ??? No, they have to be there because of compiler limitation at @@ -1471,21 +1452,9 @@ _GLIBCXX_BEGIN_NAMESPACE(std) : _M_value(__z.__rep()) { } inline - complex<double>::complex(const complex<float>& __z) - : _M_value(__z.__rep()) { } - - inline complex<double>::complex(const complex<long double>& __z) : _M_value(__z.__rep()) { } - inline - complex<long double>::complex(const complex<float>& __z) - : _M_value(__z.__rep()) { } - - inline - complex<long double>::complex(const complex<double>& __z) - : _M_value(__z.__rep()) { } - // Inhibit implicit instantiations for required instantiations, // which are defined via explicit instantiations elsewhere. // NB: This syntax is a GNU extension. diff --git a/libstdc++-v3/include/std/condition_variable b/libstdc++-v3/include/std/condition_variable index c8d8f7845e4..1dfb7789499 100644 --- a/libstdc++-v3/include/std/condition_variable +++ b/libstdc++-v3/include/std/condition_variable @@ -38,7 +38,7 @@ #ifndef __GXX_EXPERIMENTAL_CXX0X__ # include <c++0x_warning.h> -#endif +#else #include <mutex> // unique_lock @@ -159,4 +159,6 @@ namespace std } -#endif +#endif // __GXX_EXPERIMENTAL_CXX0X__ + +#endif // _GLIBCXX_CONDITION_VARIABLE diff --git a/libstdc++-v3/include/std/date_time b/libstdc++-v3/include/std/date_time index 0aca6b3b4ac..2ad95169715 100644 --- a/libstdc++-v3/include/std/date_time +++ b/libstdc++-v3/include/std/date_time @@ -38,7 +38,7 @@ #ifndef __GXX_EXPERIMENTAL_CXX0X__ # include <c++0x_warning.h> -#endif +#else #include <ctime> @@ -206,8 +206,8 @@ namespace std operator!=(const _LhsDuration& __lhs, const _RhsDuration& __rhs); template<class _LhsDuration, class _RhsDuration> - bool - operator<(const _LhsDuration& __lhs, const _RhsDuration& __rhs); + bool + operator<(const _LhsDuration& __lhs, const _RhsDuration& __rhs); template<class _LhsDuration, class _RhsDuration> bool operator<=(const _LhsDuration& __lhs, const _RhsDuration& __rhs); @@ -240,4 +240,6 @@ namespace std operator/(_Duration __lhs, long __rhs); } -#endif /* _GLIBCXX_DATE_TIME */ +#endif // __GXX_EXPERIMENTAL_CXX0X__ + +#endif // _GLIBCXX_DATE_TIME diff --git a/libstdc++-v3/include/std/mutex b/libstdc++-v3/include/std/mutex index 6a75e782416..5d4e52105f8 100644 --- a/libstdc++-v3/include/std/mutex +++ b/libstdc++-v3/include/std/mutex @@ -39,7 +39,7 @@ #ifndef __GXX_EXPERIMENTAL_CXX0X__ # include <c++0x_warning.h> -#endif +#else #include <exception> #include <cstddef> @@ -363,5 +363,6 @@ namespace std } } +#endif // __GXX_EXPERIMENTAL_CXX0X__ -#endif +#endif // _GLIBCXX_MUTEX diff --git a/libstdc++-v3/include/std/random b/libstdc++-v3/include/std/random index 2fccb606985..395604b246a 100644 --- a/libstdc++-v3/include/std/random +++ b/libstdc++-v3/include/std/random @@ -1,6 +1,6 @@ // <random> -*- C++ -*- -// 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 @@ -38,7 +38,7 @@ #ifndef __GXX_EXPERIMENTAL_CXX0X__ # include <c++0x_warning.h> -#endif +#else #if defined(_GLIBCXX_INCLUDE_AS_TR1) # error C++0x header cannot be included from TR1 header @@ -70,4 +70,6 @@ # undef _GLIBCXX_INCLUDE_AS_CXX0X #endif +#endif // __GXX_EXPERIMENTAL_CXX0X__ + #endif // _GLIBCXX_RANDOM diff --git a/libstdc++-v3/include/std/regex b/libstdc++-v3/include/std/regex index 9014fbabb2e..00d6f696a55 100644 --- a/libstdc++-v3/include/std/regex +++ b/libstdc++-v3/include/std/regex @@ -1,6 +1,6 @@ // <regex> -*- C++ -*- -// 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 @@ -38,7 +38,7 @@ #ifndef __GXX_EXPERIMENTAL_CXX0X__ # include <c++0x_warning.h> -#endif +#else #if defined(_GLIBCXX_INCLUDE_AS_TR1) # error C++0x header cannot be included from TR1 header @@ -67,4 +67,6 @@ # undef _GLIBCXX_INCLUDE_AS_CXX0X #endif +#endif // __GXX_EXPERIMENTAL_CXX0X__ + #endif // _GLIBCXX_REGEX diff --git a/libstdc++-v3/include/std/system_error b/libstdc++-v3/include/std/system_error index ac3b1f75b61..343eb6e83f7 100644 --- a/libstdc++-v3/include/std/system_error +++ b/libstdc++-v3/include/std/system_error @@ -38,7 +38,7 @@ #ifndef __GXX_EXPERIMENTAL_CXX0X__ # include <c++0x_warning.h> -#endif +#else #include <bits/c++config.h> #include <bits/error_constants.h> @@ -185,7 +185,7 @@ _GLIBCXX_BEGIN_NAMESPACE(std) template<typename charT, typename traits> basic_ostream<charT,traits>& - operator<<(basic_ostream<charT,traits>& os, const error_code& __code); + operator<<(basic_ostream<charT, traits>& os, const error_code& __code); /// error_condition @@ -198,14 +198,18 @@ _GLIBCXX_BEGIN_NAMESPACE(std) : _M_value(__v), _M_cat(__cat) { } template<typename _ErrorEnum> - error_condition(typename enable_if<is_error_condition_enum<_ErrorEnum>::value, _ErrorEnum>::type __v) : _M_value(__v), _M_cat(system_category) { } + error_condition(typename enable_if< + is_error_condition_enum<_ErrorEnum>::value, + _ErrorEnum>::type __v) + : _M_value(__v), _M_cat(system_category) { } void assign(int val, const error_category& cat); template<typename _ErrorEnum> error_condition& - operator=(typename enable_if<is_error_condition_enum<_ErrorEnum>::value, _ErrorEnum>::type __v) + operator=(typename enable_if<is_error_condition_enum<_ErrorEnum>::value, + _ErrorEnum>::type __v) { _M_value = __v; } void @@ -317,5 +321,7 @@ _GLIBCXX_BEGIN_NAMESPACE(std) _GLIBCXX_END_NAMESPACE -#endif +#endif // __GXX_EXPERIMENTAL_CXX0X__ + +#endif // _GLIBCXX_SYSTEM_ERROR diff --git a/libstdc++-v3/include/std/tuple b/libstdc++-v3/include/std/tuple index 83a81ee497a..a295e4ef937 100644 --- a/libstdc++-v3/include/std/tuple +++ b/libstdc++-v3/include/std/tuple @@ -38,7 +38,7 @@ #ifndef __GXX_EXPERIMENTAL_CXX0X__ # include <c++0x_warning.h> -#endif +#else #include <utility> @@ -645,4 +645,6 @@ namespace std }; // anonymous namespace } +#endif // __GXX_EXPERIMENTAL_CXX0X__ + #endif // _GLIBCXX_TUPLE diff --git a/libstdc++-v3/include/std/type_traits b/libstdc++-v3/include/std/type_traits index 66650f540d9..5fdc95ecad9 100644 --- a/libstdc++-v3/include/std/type_traits +++ b/libstdc++-v3/include/std/type_traits @@ -36,9 +36,9 @@ #pragma GCC system_header -#ifndef __GXX_EXPERIMENTAL__ +#ifndef __GXX_EXPERIMENTAL_CXX0X__ # include <c++0x_warning.h> -#endif +#else #if defined(_GLIBCXX_INCLUDE_AS_TR1) # error C++0x header cannot be included from TR1 header @@ -553,5 +553,7 @@ namespace std struct make_signed<bool>; } +#endif // __GXX_EXPERIMENTAL_CXX0X__ + #endif // _GLIBCXX_TYPE_TRAITS diff --git a/libstdc++-v3/include/std/unordered_map b/libstdc++-v3/include/std/unordered_map index 73be402e474..e338ef7805c 100644 --- a/libstdc++-v3/include/std/unordered_map +++ b/libstdc++-v3/include/std/unordered_map @@ -38,7 +38,7 @@ #ifndef __GXX_EXPERIMENTAL_CXX0X__ # include <c++0x_warning.h> -#endif +#else #if defined(_GLIBCXX_INCLUDE_AS_TR1) # error C++0x header cannot be included from TR1 header @@ -77,4 +77,6 @@ # include <debug/unordered_map> #endif +#endif // __GXX_EXPERIMENTAL_CXX0X__ + #endif // _GLIBCXX_UNORDERED_MAP diff --git a/libstdc++-v3/include/std/unordered_set b/libstdc++-v3/include/std/unordered_set index 1e599840fff..13b412b1eb5 100644 --- a/libstdc++-v3/include/std/unordered_set +++ b/libstdc++-v3/include/std/unordered_set @@ -1,6 +1,6 @@ // <unordered_set> -*- C++ -*- -// 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 @@ -38,7 +38,7 @@ #ifndef __GXX_EXPERIMENTAL_CXX0X__ # include <c++0x_warning.h> -#endif +#else #if defined(_GLIBCXX_INCLUDE_AS_TR1) # error C++0x header cannot be included from TR1 header @@ -77,4 +77,6 @@ # include <debug/unordered_set> #endif +#endif // __GXX_EXPERIMENTAL_CXX0X__ + #endif // _GLIBCXX_UNORDERED_SET diff --git a/libstdc++-v3/include/tr1/cmath b/libstdc++-v3/include/tr1/cmath index 63e6a2e5fda..a9c5aecf018 100644 --- a/libstdc++-v3/include/tr1/cmath +++ b/libstdc++-v3/include/tr1/cmath @@ -56,6 +56,34 @@ # undef _GLIBCXX_INCLUDE_AS_TR1 #endif +namespace std +{ +namespace tr1 +{ + // DR 550. What should the return type of pow(float,int) be? + // NB: C++0x and TR1 != C++03. + inline double + pow(double __x, double __y) + { return std::pow(__x, __y); } + + inline float + pow(float __x, float __y) + { return std::pow(__x, __y); } + + inline long double + pow(long double __x, long double __y) + { return std::pow(__x, __y); } + + template<typename _Tp, typename _Up> + inline typename __gnu_cxx::__promote_2<_Tp, _Up>::__type + pow(_Tp __x, _Up __y) + { + typedef typename __gnu_cxx::__promote_2<_Tp, _Up>::__type __type; + return std::pow(__type(__x), __type(__y)); + } +} +} + #include <bits/stl_algobase.h> #include <limits> #include <tr1/type_traits> diff --git a/libstdc++-v3/include/tr1/complex b/libstdc++-v3/include/tr1/complex index 8d14681e955..b571a5982ed 100644 --- a/libstdc++-v3/include/tr1/complex +++ b/libstdc++-v3/include/tr1/complex @@ -75,9 +75,27 @@ namespace tr1 } using std::real; - using std::pow; + + template<typename _Tp> + inline std::complex<_Tp> + pow(const std::complex<_Tp>& __x, int __n) + { return std::pow(__x, __n); } + + template<typename _Tp> + inline std::complex<_Tp> + pow(const std::complex<_Tp>& __x, const _Tp& __y) + { return std::pow(__x, __y); } + + template<typename _Tp> + inline std::complex<_Tp> + pow(const _Tp& __x, const std::complex<_Tp>& __y) + { return std::pow(__x, __y); } + + template<typename _Tp> + inline std::complex<_Tp> + pow(const std::complex<_Tp>& __x, const std::complex<_Tp>& __y) + { return std::pow(__x, __y); } } } #endif // _GLIBCXX_TR1_COMPLEX - diff --git a/libstdc++-v3/include/tr1_impl/cmath b/libstdc++-v3/include/tr1_impl/cmath index afb05e2aa71..d969a8feada 100644 --- a/libstdc++-v3/include/tr1_impl/cmath +++ b/libstdc++-v3/include/tr1_impl/cmath @@ -763,7 +763,9 @@ _GLIBCXX_BEGIN_NAMESPACE_TR1 return nexttoward(__type(__x), __y); } - using std::pow; + // DR 550. What should the return type of pow(float,int) be? + // NB: C++0x and TR1 != C++03. + // using std::pow; inline float remainder(float __x, float __y) diff --git a/libstdc++-v3/include/tr1_impl/complex b/libstdc++-v3/include/tr1_impl/complex index 8b4f97401f6..46560deaa4b 100644 --- a/libstdc++-v3/include/tr1_impl/complex +++ b/libstdc++-v3/include/tr1_impl/complex @@ -301,12 +301,11 @@ _GLIBCXX_BEGIN_NAMESPACE_TR1 fabs(const std::complex<_Tp>& __z) { return std::abs(__z); } - + /// Additional overloads [8.1.9]. #if (defined(_GLIBCXX_INCLUDE_AS_CXX0X) \ || (defined(_GLIBCXX_INCLUDE_AS_TR1) \ && !defined(__GXX_EXPERIMENTAL_CXX0X__))) - /// Additional overloads [8.1.9]. template<typename _Tp> inline typename __gnu_cxx::__promote<_Tp>::__type arg(_Tp __x) @@ -338,6 +337,8 @@ _GLIBCXX_BEGIN_NAMESPACE_TR1 real(_Tp __x) { return __x; } +#endif + template<typename _Tp, typename _Up> inline std::complex<typename __gnu_cxx::__promote_2<_Tp, _Up>::__type> pow(const std::complex<_Tp>& __x, const _Up& __y) @@ -363,7 +364,5 @@ _GLIBCXX_BEGIN_NAMESPACE_TR1 std::complex<__type>(__y)); } -#endif - _GLIBCXX_END_NAMESPACE_TR1 } diff --git a/libstdc++-v3/testsuite/26_numerics/complex/dr387.cc b/libstdc++-v3/testsuite/26_numerics/complex/dr387.cc new file mode 100644 index 00000000000..4431842242c --- /dev/null +++ b/libstdc++-v3/testsuite/26_numerics/complex/dr387.cc @@ -0,0 +1,52 @@ +// 2008-05-22 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 <complex> +#include <testsuite_hooks.h> + +// DR 387. std::complex over-encapsulated. +template<typename T> + void + do_test() + { + bool test __attribute__((unused)) = true; + + const T r = 1.0; + const T i = -1.0; + const T v = 0.0; + + std::complex<T> z1(r, i); + z1.real(v); + VERIFY( z1.real() == v ); + VERIFY( z1.imag() == i ); + + std::complex<T> z2(r, i); + z2.imag(v); + VERIFY( z2.real() == r ); + VERIFY( z2.imag() == v ); + } + +int main() +{ + do_test<float>(); + do_test<double>(); + do_test<long double>(); + return 0; +} diff --git a/libstdc++-v3/testsuite/26_numerics/headers/cmath/dr550.cc b/libstdc++-v3/testsuite/26_numerics/headers/cmath/dr550.cc new file mode 100644 index 00000000000..b3a9ce0255d --- /dev/null +++ b/libstdc++-v3/testsuite/26_numerics/headers/cmath/dr550.cc @@ -0,0 +1,47 @@ +// { dg-options "-std=gnu++0x" } +// 2008-05-26 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 <cmath> +#include <testsuite_hooks.h> +#include <testsuite_tr1.h> + +// DR 550. What should the return type of pow(float,int) be? +void test01() +{ + bool test __attribute__((unused)) = true; + using __gnu_test::check_ret_type; + + const int i1 = 1; + const float f1 = 1.0f; + const double d1 = 1.0; + const long double ld1 = 1.0l; + + check_ret_type<double>(std::pow(f1, i1)); + VERIFY( std::pow(f1, i1) == std::pow(double(f1), double(i1)) ); + check_ret_type<double>(std::pow(d1, i1)); + check_ret_type<long double>(std::pow(ld1, i1)); +} + +int main() +{ + test01(); + return 0; +} diff --git a/libstdc++-v3/testsuite/tr1/8_c_compatibility/cmath/overloads.cc b/libstdc++-v3/testsuite/tr1/8_c_compatibility/cmath/overloads.cc index e925340081e..fea560fc293 100644 --- a/libstdc++-v3/testsuite/tr1/8_c_compatibility/cmath/overloads.cc +++ b/libstdc++-v3/testsuite/tr1/8_c_compatibility/cmath/overloads.cc @@ -206,9 +206,7 @@ void test01() check_ret_type<long double>(std::tr1::pow(ld0, d0)); check_ret_type<double>(std::tr1::pow(i0, i0)); check_ret_type<double>(std::tr1::pow(d0, i0)); - // DR 550. - // check_ret_type<double>(std::tr1::pow(f0, i0)); - check_ret_type<float>(std::tr1::pow(f0, i0)); + check_ret_type<double>(std::tr1::pow(f0, i0)); check_ret_type<double>(std::tr1::remainder(d0, d0)); check_ret_type<double>(std::tr1::remainder(d0, f0)); |