The last version posted upstream: 0: http://sources.redhat.com/ml/gdb-patches/2007-11/msg00438.html 1: http://sources.redhat.com/ml/gdb-patches/2007-11/msg00439.html 2: http://sources.redhat.com/ml/gdb-patches/2007-11/msg00440.html 3: http://sources.redhat.com/ml/gdb-patches/2007-11/msg00441.html 4: http://sources.redhat.com/ml/gdb-patches/2007-11/msg00442.html 5: http://sources.redhat.com/ml/gdb-patches/2007-11/msg00443.html 6: http://sources.redhat.com/ml/gdb-patches/2007-11/msg00444.html 2008-02-24 Jan Kratochvil Port to GDB-6.8pre. diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/Makefile.in gdb-6.8cvs20080219/gdb/Makefile.in --- gdb-6.8cvs20080219-fortranless/gdb/Makefile.in 2008-02-22 08:19:37.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/Makefile.in 2008-02-22 16:59:22.000000000 +0100 @@ -758,6 +758,7 @@ disasm_h = disasm.h doublest_h = doublest.h $(floatformat_h) dummy_frame_h = dummy-frame.h dfp_h = dfp.h +dwarf2block_h = dwarf2block.h dwarf2expr_h = dwarf2expr.h dwarf2_frame_h = dwarf2-frame.h dwarf2loc_h = dwarf2loc.h @@ -1051,7 +1052,7 @@ COMMON_OBS = $(DEPFILES) $(CONFIG_OBS) $ exec.o bcache.o objfiles.o observer.o minsyms.o maint.o demangle.o \ dbxread.o coffread.o coff-pe-read.o \ dwarf2read.o mipsread.o stabsread.o corefile.o \ - dwarf2expr.o dwarf2loc.o dwarf2-frame.o \ + dwarf2block.o dwarf2expr.o dwarf2loc.o dwarf2-frame.o \ ada-lang.o c-lang.o f-lang.o objc-lang.o \ ui-out.o cli-out.o \ varobj.o vec.o wrapper.o \ @@ -2086,6 +2087,8 @@ dummy-frame.o: dummy-frame.c $(defs_h) $ $(command_h) $(gdbcmd_h) $(gdb_string_h) dfp.o: dfp.c $(defs_h) $(expression_h) $(gdbtypes_h) $(value_h) $(dfp_h) \ $(decimal128_h) $(decimal64_h) $(decimal32_h) +dwarf2block.o: dwarf2block.c $(dwarf2block_h) $(defs_h) $(gdbcore_h) \ + $(dwarf2expr_h) $(exceptions_h) dwarf2expr.o: dwarf2expr.c $(defs_h) $(symtab_h) $(gdbtypes_h) $(value_h) \ $(gdbcore_h) $(elf_dwarf2_h) $(dwarf2expr_h) dwarf2-frame.o: dwarf2-frame.c $(defs_h) $(dwarf2expr_h) $(elf_dwarf2_h) \ @@ -2096,13 +2099,14 @@ dwarf2-frame.o: dwarf2-frame.c $(defs_h) dwarf2loc.o: dwarf2loc.c $(defs_h) $(ui_out_h) $(value_h) $(frame_h) \ $(gdbcore_h) $(target_h) $(inferior_h) $(ax_h) $(ax_gdb_h) \ $(regcache_h) $(objfiles_h) $(exceptions_h) $(elf_dwarf2_h) \ - $(dwarf2expr_h) $(dwarf2loc_h) $(gdb_string_h) $(gdb_assert_h) + $(dwarf2expr_h) $(dwarf2loc_h) $(gdb_string_h) $(gdb_assert_h) \ + $(dwarf2block_h) dwarf2read.o: dwarf2read.c $(defs_h) $(bfd_h) $(symtab_h) $(gdbtypes_h) \ $(objfiles_h) $(elf_dwarf2_h) $(buildsym_h) $(demangle_h) \ $(expression_h) $(filenames_h) $(macrotab_h) $(language_h) \ $(complaints_h) $(bcache_h) $(dwarf2expr_h) $(dwarf2loc_h) \ $(cp_support_h) $(hashtab_h) $(command_h) $(gdbcmd_h) \ - $(gdb_string_h) $(gdb_assert_h) + $(gdb_string_h) $(gdb_assert_h) $(dwarf2block_h) $(f_lang_h) elfread.o: elfread.c $(defs_h) $(bfd_h) $(gdb_string_h) $(elf_bfd_h) \ $(elf_mips_h) $(symtab_h) $(symfile_h) $(objfiles_h) $(buildsym_h) \ $(stabsread_h) $(gdb_stabs_h) $(complaints_h) $(demangle_h) \ @@ -2138,10 +2142,10 @@ f-exp.o: f-exp.c $(defs_h) $(gdb_string_ findvar.o: findvar.c $(defs_h) $(symtab_h) $(gdbtypes_h) $(frame_h) \ $(value_h) $(gdbcore_h) $(inferior_h) $(target_h) $(gdb_string_h) \ $(gdb_assert_h) $(floatformat_h) $(symfile_h) $(regcache_h) \ - $(user_regs_h) $(block_h) + $(user_regs_h) $(block_h) $(dwarf2block_h) f-lang.o: f-lang.c $(defs_h) $(gdb_string_h) $(symtab_h) $(gdbtypes_h) \ $(expression_h) $(parser_defs_h) $(language_h) $(f_lang_h) \ - $(valprint_h) $(value_h) + $(valprint_h) $(value_h) $(dwarf2block_h) fork-child.o: fork-child.c $(defs_h) $(gdb_string_h) $(frame_h) \ $(inferior_h) $(target_h) $(gdb_wait_h) $(gdb_vfork_h) $(gdbcore_h) \ $(terminal_h) $(gdbthread_h) $(command_h) $(solib_h) @@ -2166,7 +2170,7 @@ frv-tdep.o: frv-tdep.c $(defs_h) $(gdb_s $(frv_tdep_h) f-typeprint.o: f-typeprint.c $(defs_h) $(gdb_obstack_h) $(bfd_h) $(symtab_h) \ $(gdbtypes_h) $(expression_h) $(value_h) $(gdbcore_h) $(target_h) \ - $(f_lang_h) $(gdb_string_h) + $(f_lang_h) $(gdb_string_h) $(dwarf2block_h) f-valprint.o: f-valprint.c $(defs_h) $(gdb_string_h) $(symtab_h) \ $(gdbtypes_h) $(expression_h) $(value_h) $(valprint_h) $(language_h) \ $(f_lang_h) $(frame_h) $(gdbcore_h) $(command_h) $(block_h) @@ -2181,7 +2185,8 @@ gdb-events.o: gdb-events.c $(defs_h) $(g gdbtypes.o: gdbtypes.c $(defs_h) $(gdb_string_h) $(bfd_h) $(symtab_h) \ $(symfile_h) $(objfiles_h) $(gdbtypes_h) $(expression_h) \ $(language_h) $(target_h) $(value_h) $(demangle_h) $(complaints_h) \ - $(gdbcmd_h) $(wrapper_h) $(cp_abi_h) $(gdb_assert_h) $(hashtab_h) + $(gdbcmd_h) $(wrapper_h) $(cp_abi_h) $(gdb_assert_h) $(hashtab_h) \ + $(dwarf2block_h) glibc-tdep.o: glibc-tdep.c $(defs_h) $(frame_h) $(symtab_h) $(symfile_h) \ $(objfiles_h) $(glibc_tdep_h) gnu-nat.o: gnu-nat.c $(gdb_string_h) $(defs_h) $(inferior_h) $(symtab_h) \ @@ -2939,7 +2944,7 @@ tramp-frame.o: tramp-frame.c $(defs_h) $ typeprint.o: typeprint.c $(defs_h) $(gdb_obstack_h) $(bfd_h) $(symtab_h) \ $(gdbtypes_h) $(expression_h) $(value_h) $(gdbcore_h) $(command_h) \ $(gdbcmd_h) $(target_h) $(language_h) $(cp_abi_h) $(typeprint_h) \ - $(gdb_string_h) + $(gdb_string_h) $(dwarf2block_h) ui-file.o: ui-file.c $(defs_h) $(ui_file_h) $(gdb_string_h) ui-out.o: ui-out.c $(defs_h) $(gdb_string_h) $(expression_h) $(language_h) \ $(ui_out_h) $(gdb_assert_h) diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/ada-lang.c gdb-6.8cvs20080219/gdb/ada-lang.c --- gdb-6.8cvs20080219-fortranless/gdb/ada-lang.c 2008-02-14 23:03:56.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/ada-lang.c 2008-02-22 16:47:53.000000000 +0100 @@ -11012,6 +11012,7 @@ const struct language_defn ada_language_ ada_language_arch_info, ada_print_array_index, default_pass_by_reference, + default_value_address_get, /* Retrieve the real data value */ LANG_MAGIC }; diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/c-lang.c gdb-6.8cvs20080219/gdb/c-lang.c --- gdb-6.8cvs20080219-fortranless/gdb/c-lang.c 2008-02-14 23:03:56.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/c-lang.c 2008-02-22 17:01:17.000000000 +0100 @@ -427,6 +427,7 @@ const struct language_defn c_language_de c_language_arch_info, default_print_array_index, default_pass_by_reference, + default_value_address_get, /* Retrieve the real data value */ LANG_MAGIC }; @@ -540,6 +541,7 @@ const struct language_defn cplus_languag cplus_language_arch_info, default_print_array_index, cp_pass_by_reference, + default_value_address_get, /* Retrieve the real data value */ LANG_MAGIC }; @@ -575,6 +577,7 @@ const struct language_defn asm_language_ c_language_arch_info, /* FIXME: la_language_arch_info. */ default_print_array_index, default_pass_by_reference, + default_value_address_get, /* Retrieve the real data value */ LANG_MAGIC }; @@ -615,6 +618,7 @@ const struct language_defn minimal_langu c_language_arch_info, default_print_array_index, default_pass_by_reference, + default_value_address_get, /* Retrieve the real data value */ LANG_MAGIC }; diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/dwarf2block.c gdb-6.8cvs20080219/gdb/dwarf2block.c --- gdb-6.8cvs20080219-fortranless/gdb/dwarf2block.c 1970-01-01 01:00:00.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/dwarf2block.c 2008-02-22 16:49:35.000000000 +0100 @@ -0,0 +1,153 @@ +/* DWARF DW_FORM_block* expression evaluation. + + Copyright (C) 2007 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program 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 program. If not, see . */ + +#include "defs.h" +#include "dwarf2block.h" +#include "gdbcore.h" +#include "dwarf2expr.h" +#include "exceptions.h" + +/* This is the baton used when performing dwarf2 DW_BLOCK evaluation. */ +struct dwarf_block_baton +{ + CORE_ADDR address; +}; + +/* Read memory at ADDR (length LEN) into BUF. */ + +static void +dwarf_block_read_mem (void *baton, gdb_byte *buf, CORE_ADDR addr, size_t len) +{ + read_memory (addr, buf, len); +} + +static CORE_ADDR +dwarf_block_object_address (void *baton) +{ + struct dwarf_block_baton *debaton = baton; + + /* The message is suppressed in DWARF_BLOCK_EXEC. */ + if (debaton->address == 0) + error (_("Cannot resolve DW_OP_push_object_address for a missing object")); + + return debaton->address; +} + +static CORE_ADDR +dwarf_block_read_reg (void *baton, int regnum) +{ + error (_("Unsupported operation for DW_FORM_block*: %s"), "read_reg"); + return 0; +} + +static void +dwarf_block_get_frame_base (void *baton, gdb_byte **start, size_t *length) +{ + error (_("Unsupported operation for DW_FORM_block*: %s"), "get_frame_base"); +} + +static CORE_ADDR +dwarf_block_get_tls_address (void *baton, CORE_ADDR offset) +{ + error (_("Unsupported operation for DW_FORM_block*: %s"), "get_tls_address"); + return 0; +} + +static CORE_ADDR dwarf_block_exec_core (struct dwarf_block *dwarf_block, + CORE_ADDR address) +{ + struct dwarf_expr_context *ctx; + struct dwarf_block_baton baton; + struct cleanup *back_to; + CORE_ADDR retval; + + back_to = make_cleanup (null_cleanup, 0); + + baton.address = address; + + ctx = new_dwarf_expr_context (); + back_to = make_cleanup ((make_cleanup_ftype *) free_dwarf_expr_context, ctx); + ctx->baton = &baton; + ctx->read_mem = dwarf_block_read_mem; + ctx->get_object_address = dwarf_block_object_address; + ctx->read_reg = dwarf_block_read_reg; + ctx->get_frame_base = dwarf_block_get_frame_base; + ctx->get_tls_address = dwarf_block_get_tls_address; + + dwarf_expr_eval (ctx, dwarf_block->data, dwarf_block->size); + + if (ctx->num_pieces > 0) + error (_("DW_OP_piece is an unsupported result for DW_FORM_block*")); + if (ctx->in_reg) + error (_("DW_OP_reg* is an unsupported result for DW_FORM_block*")); + + retval = dwarf_expr_fetch (ctx, 0); + + do_cleanups (back_to); + + return retval; +} + +static CORE_ADDR object_address; + +static void +object_address_cleanup (void *prev_save_voidp) +{ + CORE_ADDR *prev_save = prev_save_voidp; + + object_address = *prev_save; + xfree (prev_save); +} + +void +object_address_set (CORE_ADDR address) +{ + CORE_ADDR *prev_save; + + prev_save = xmalloc (sizeof *prev_save); + *prev_save = object_address; + make_cleanup (object_address_cleanup, prev_save); + + object_address = address; +} + +CORE_ADDR +object_address_get (void) +{ + return object_address; +} + +CORE_ADDR dwarf_block_exec (struct dwarf_block *dwarf_block) +{ + volatile struct gdb_exception e; + volatile CORE_ADDR retval = 0; + + TRY_CATCH (e, RETURN_MASK_ERROR) + { + retval = dwarf_block_exec_core (dwarf_block, object_address); + } + /* CATCH_ERRORS would print the possible error message of + DWARF_BLOCK_OBJECT_ADDRESS. Sometimes it is valid as CHECK_TYPEDEF is + a very common call even if we still do not know any variable instance of + that type. We cannot fill in the right TYPE_LENGTH at that time. */ + if (e.reason < 0) + return 0; + + return retval; +} diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/dwarf2block.h gdb-6.8cvs20080219/gdb/dwarf2block.h --- gdb-6.8cvs20080219-fortranless/gdb/dwarf2block.h 1970-01-01 01:00:00.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/dwarf2block.h 2008-02-22 16:49:35.000000000 +0100 @@ -0,0 +1,36 @@ +/* DWARF DW_FORM_block* expression evaluation. + + Copyright (C) 2007 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program 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 program. If not, see . */ + +#if !defined (DWARF2BLOCK_H) +#define DWARF2BLOCK_H 1 + +/* Blocks are a bunch of untyped bytes. */ +struct dwarf_block + { + unsigned int size; + gdb_byte *data; + }; + +extern CORE_ADDR dwarf_block_exec (struct dwarf_block *dwarf_block); + +extern void object_address_set (CORE_ADDR address); + +extern CORE_ADDR object_address_get (void); + +#endif /* !defined(DWARF2BLOCK_H) */ diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/dwarf2expr.c gdb-6.8cvs20080219/gdb/dwarf2expr.c --- gdb-6.8cvs20080219-fortranless/gdb/dwarf2expr.c 2008-02-22 08:19:37.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/dwarf2expr.c 2008-02-22 16:49:35.000000000 +0100 @@ -750,6 +750,13 @@ execute_stack_op (struct dwarf_expr_cont ctx->initialized = 0; goto no_push; + case DW_OP_push_object_address: + if (ctx->get_object_address == NULL) + error (_("DWARF-2 expression error: DW_OP_push_object_address must " + "have a value to push.")); + result = (ctx->get_object_address) (ctx->baton); + break; + default: error (_("Unhandled dwarf expression opcode 0x%x"), op); } diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/dwarf2expr.h gdb-6.8cvs20080219/gdb/dwarf2expr.h --- gdb-6.8cvs20080219-fortranless/gdb/dwarf2expr.h 2008-01-02 00:03:54.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/dwarf2expr.h 2008-02-22 16:49:35.000000000 +0100 @@ -61,10 +61,10 @@ struct dwarf_expr_context The result must be live until the current expression evaluation is complete. */ unsigned char *(*get_subr) (void *baton, off_t offset, size_t *length); +#endif /* Return the `object address' for DW_OP_push_object_address. */ CORE_ADDR (*get_object_address) (void *baton); -#endif /* The current depth of dwarf expression recursion, via DW_OP_call*, DW_OP_fbreg, DW_OP_push_object_address, etc., and the maximum diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/dwarf2loc.c gdb-6.8cvs20080219/gdb/dwarf2loc.c --- gdb-6.8cvs20080219-fortranless/gdb/dwarf2loc.c 2008-01-02 00:03:54.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/dwarf2loc.c 2008-02-22 16:49:35.000000000 +0100 @@ -35,6 +35,7 @@ #include "elf/dwarf2.h" #include "dwarf2expr.h" #include "dwarf2loc.h" +#include "dwarf2block.h" #include "gdb_string.h" #include "gdb_assert.h" @@ -252,6 +253,9 @@ dwarf2_evaluate_loc_desc (struct symbol { CORE_ADDR address = dwarf_expr_fetch (ctx, 0); + /* ADDR is set here for ALLOCATE_VALUE's CHECK_TYPEDEF for + DW_OP_push_object_address. */ + object_address_set (address); retval = allocate_value (SYMBOL_TYPE (var)); VALUE_LVAL (retval) = lval_memory; set_value_lazy (retval, 1); diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/dwarf2read.c gdb-6.8cvs20080219/gdb/dwarf2read.c --- gdb-6.8cvs20080219-fortranless/gdb/dwarf2read.c 2008-02-22 08:19:37.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/dwarf2read.c 2008-02-22 16:59:22.000000000 +0100 @@ -46,6 +46,8 @@ #include "top.h" #include "command.h" #include "gdbcmd.h" +#include "dwarf2block.h" +#include "f-lang.h" #include #include "gdb_string.h" @@ -563,13 +565,6 @@ struct function_range #define DW_SND(attr) ((attr)->u.snd) #define DW_ADDR(attr) ((attr)->u.addr) -/* Blocks are a bunch of untyped bytes. */ -struct dwarf_block - { - unsigned int size; - gdb_byte *data; - }; - #ifndef ATTR_ALLOC_CHUNK #define ATTR_ALLOC_CHUNK 4 #endif @@ -1004,7 +999,14 @@ static void store_in_ref_table (unsigned static unsigned int dwarf2_get_ref_die_offset (struct attribute *, struct dwarf2_cu *); -static int dwarf2_get_attr_constant_value (struct attribute *, int); +enum dwarf2_get_attr_constant_value + { + dwarf2_attr_unknown, + dwarf2_attr_const, + dwarf2_attr_block + }; +static enum dwarf2_get_attr_constant_value dwarf2_get_attr_constant_value + (struct attribute *attr, int *val_return); static struct die_info *follow_die_ref (struct die_info *, struct attribute *, @@ -4383,6 +4385,56 @@ process_enumeration_scope (struct die_in new_symbol (die, die->type, cu); } +static void +fortran_array_update (struct fortran_array_type **fortran_array_pointer, + struct die_info *die, struct dwarf2_cu *cu, + int read_data_location, struct type *memory_owner) +{ + struct fortran_array_type *p; + struct fortran_array_type fortran_array_local; + /* Used only for checking if FORTRAN_ARRAY is non-zero. */ + static struct fortran_array_type fortran_array_zero; + struct attribute *attr; + + /* Prepare FORTRAN_ARRAY_POINTER. It needs to be present in all the subarray + types and in all the range types at least for + TYPE_VERIFY_VALID_ARRAY_OBJECT. */ + + if (*fortran_array_pointer != NULL) + p = *fortran_array_pointer; + else + { + memset (&fortran_array_local, 0, sizeof fortran_array_local); + p = &fortran_array_local; + } + + if (read_data_location) + { + attr = dwarf2_attr (die, DW_AT_data_location, cu); + if (attr) + p->data_location = DW_BLOCK (attr); + } + + attr = dwarf2_attr (die, DW_AT_allocated, cu); + if (attr) + p->allocated = DW_BLOCK (attr); + + attr = dwarf2_attr (die, DW_AT_associated, cu); + if (attr) + p->associated = DW_BLOCK (attr); + + if (p != &fortran_array_local) + {} + else if (memcmp (p, &fortran_array_zero, sizeof *p) == 0) + *fortran_array_pointer = NULL; + else + { + *fortran_array_pointer = TYPE_ALLOC (memory_owner, + sizeof **fortran_array_pointer); + **fortran_array_pointer = fortran_array_local; + } +} + /* Extract all information from a DW_TAG_array_type DIE and put it in the DIE's type field. For now, this only handles one dimensional arrays. */ @@ -4399,6 +4451,7 @@ read_array_type (struct die_info *die, s int ndim = 0; struct cleanup *back_to; char *name; + struct fortran_array_type *fortran_array; /* Return if we've already decoded this type. */ if (die->type) @@ -4408,6 +4461,13 @@ read_array_type (struct die_info *die, s element_type = die_type (die, cu); + /* Prepare FORTRAN_ARRAY_POINTER. It needs to be present in all the subarray + types and in all the range types at least for + TYPE_VERIFY_VALID_ARRAY_OBJECT. */ + + fortran_array = NULL; + fortran_array_update (&fortran_array, die, cu, 1, element_type); + /* Irix 6.2 native cc creates array types without children for arrays with unspecified length. */ if (die->child == NULL) @@ -4416,6 +4476,9 @@ read_array_type (struct die_info *die, s range_type = create_range_type (NULL, index_type, 0, -1); set_die_type (die, create_array_type (NULL, element_type, range_type), cu); + + TYPE_FORTRAN_ARRAY (range_type) = fortran_array; + TYPE_FORTRAN_ARRAY (die->type) = fortran_array; return; } @@ -4452,14 +4515,31 @@ read_array_type (struct die_info *die, s if (read_array_order (die, cu) == DW_ORD_col_major) { - int i = 0; - while (i < ndim) - type = create_array_type (NULL, type, range_types[i++]); + int i; + for (i = 0; i < ndim; i++) + { + type = create_array_type (NULL, type, range_types[i]); + TYPE_FORTRAN_ARRAY (range_types[i]) = fortran_array; + TYPE_FORTRAN_ARRAY (type) = fortran_array; + TYPE_ARRAY_UPPER_BOUND_TYPE (type) = + TYPE_ARRAY_UPPER_BOUND_TYPE (range_types[i]); + TYPE_ARRAY_LOWER_BOUND_TYPE (type) = + TYPE_ARRAY_LOWER_BOUND_TYPE (range_types[i]); + } } else { - while (ndim-- > 0) - type = create_array_type (NULL, type, range_types[ndim]); + int i; + for (i = ndim - 1; i >= 0; i--) + { + type = create_array_type (NULL, type, range_types[i]); + TYPE_FORTRAN_ARRAY (range_types[i]) = fortran_array; + TYPE_FORTRAN_ARRAY (type) = fortran_array; + TYPE_ARRAY_UPPER_BOUND_TYPE (type) = + TYPE_ARRAY_UPPER_BOUND_TYPE (range_types[i]); + TYPE_ARRAY_LOWER_BOUND_TYPE (type) = + TYPE_ARRAY_LOWER_BOUND_TYPE (range_types[i]); + } } /* Understand Dwarf2 support for vector types (like they occur on @@ -4679,13 +4759,25 @@ read_tag_pointer_type (struct die_info * struct attribute *attr_byte_size; struct attribute *attr_address_class; int byte_size, addr_class; + struct type *target_type; if (die->type) { return; } - type = lookup_pointer_type (die_type (die, cu)); + target_type = die_type (die, cu); + + /* Intel Fortran Compiler 10.1.008 puts DW_AT_associated into + DW_TAG_pointer_type pointing to its target DW_TAG_array_type. + GDB supports DW_AT_associated and DW_AT_allocated only for the + DW_TAG_array_type tags. */ + if (TYPE_CODE (target_type) == TYPE_CODE_ARRAY + && TYPE_FORTRAN_ARRAY (target_type) != NULL) + fortran_array_update (&TYPE_FORTRAN_ARRAY (target_type), die, cu, 0, + target_type); + + type = lookup_pointer_type (target_type); attr_byte_size = dwarf2_attr (die, DW_AT_byte_size, cu); if (attr_byte_size) @@ -5048,9 +5140,9 @@ read_subrange_type (struct die_info *die { struct type *base_type; struct type *range_type; - struct attribute *attr; - int low = 0; - int high = -1; + struct attribute *attr, *byte_stride_attr; + int low, high, byte_stride_int; + enum dwarf2_get_attr_constant_value high_type, byte_stride_type; char *name; /* If we have already decoded this die, then nothing more to do. */ @@ -5067,42 +5159,99 @@ read_subrange_type (struct die_info *die 0, NULL, cu->objfile); } - if (cu->language == language_fortran) - { - /* FORTRAN implies a lower bound of 1, if not given. */ - low = 1; - } + /* DW_AT_bit_stride is unsupported as if it would be non-constant we would + have to wrap it by the division by 8 or provide another value type etc. */ + byte_stride_attr = dwarf2_attr (die, DW_AT_byte_stride, cu); + byte_stride_type = dwarf2_get_attr_constant_value (byte_stride_attr, + &byte_stride_int); + + range_type = create_range_type_nfields + (NULL, base_type, byte_stride_type == dwarf2_attr_unknown ? 2 : 3); - /* FIXME: For variable sized arrays either of these could be - a variable rather than a constant value. We'll allow it, - but we don't know how to handle it. */ attr = dwarf2_attr (die, DW_AT_lower_bound, cu); - if (attr) - low = dwarf2_get_attr_constant_value (attr, 0); + switch (dwarf2_get_attr_constant_value (attr, &low)) + { + case dwarf2_attr_unknown: + if (cu->language == language_fortran) + { + /* FORTRAN implies a lower bound of 1, if not given. */ + low = 1; + } + else + { + /* According to DWARF3 we should assume the value 0 only for + LANGUAGE_C and LANGUAGE_CPLUS. */ + low = 0; + } + /* PASSTHRU */ + case dwarf2_attr_const: + TYPE_LOW_BOUND_RAW (range_type) = low; + if (low >= 0) + TYPE_FLAGS (range_type) |= TYPE_FLAG_UNSIGNED; + break; + case dwarf2_attr_block: + TYPE_BOUND_IS_DWARF_BLOCK_VAR (range_type, 0) + |= TYPE_BOUND_IS_DWARF_BLOCK_MASK; + TYPE_FIELD_DWARF_BLOCK (range_type, 0) = DW_BLOCK (attr); + /* For auto-detection of possibly missing DW_AT_upper_bound. */ + low = 0; + break; + } attr = dwarf2_attr (die, DW_AT_upper_bound, cu); - if (attr) - { - if (attr->form == DW_FORM_block1) - { - /* GCC encodes arrays with unspecified or dynamic length - with a DW_FORM_block1 attribute. - FIXME: GDB does not yet know how to handle dynamic - arrays properly, treat them as arrays with unspecified - length for now. - - FIXME: jimb/2003-09-22: GDB does not really know - how to handle arrays of unspecified length - either; we just represent them as zero-length - arrays. Choose an appropriate upper bound given - the lower bound we've computed above. */ - high = low - 1; - } - else - high = dwarf2_get_attr_constant_value (attr, 1); + high_type = dwarf2_get_attr_constant_value (attr, &high); + if (high_type == dwarf2_attr_unknown) + { + int count; + + attr = dwarf2_attr (die, DW_AT_count, cu); + high_type = dwarf2_get_attr_constant_value (attr, &count); + switch (high_type) + { + case dwarf2_attr_unknown: + break; + case dwarf2_attr_const: + /* We do not handle LOW being set as DW_BLOCK here. */ + high = low + count - 1; + /* PASSTHRU */ + case dwarf2_attr_block: + TYPE_HIGH_BOUND_IS_COUNT_VAR (range_type) + |= TYPE_HIGH_BOUND_IS_COUNT_MASK; + break; + } + } + switch (high_type) + { + case dwarf2_attr_unknown: + /* It needs to get propagated to he array type owning us. */ + TYPE_ARRAY_UPPER_BOUND_TYPE (range_type) = BOUND_CANNOT_BE_DETERMINED; + high = low - 1; + /* PASSTHRU */ + case dwarf2_attr_const: + TYPE_HIGH_BOUND_RAW (range_type) = high; + break; + case dwarf2_attr_block: + TYPE_BOUND_IS_DWARF_BLOCK_VAR (range_type, 1) + |= TYPE_BOUND_IS_DWARF_BLOCK_MASK; + TYPE_FIELD_DWARF_BLOCK (range_type, 1) = DW_BLOCK (attr); + break; } - range_type = create_range_type (NULL, base_type, low, high); + switch (byte_stride_type) + { + case dwarf2_attr_unknown: + break; + case dwarf2_attr_const: + if (byte_stride_int == 0) + warning (_("Found DW_AT_byte_stride with unsupported value 0")); + TYPE_HIGH_BOUND_RAW (range_type) = byte_stride_int; + break; + case dwarf2_attr_block: + TYPE_BOUND_IS_DWARF_BLOCK_VAR (range_type, 2) + |= TYPE_BOUND_IS_DWARF_BLOCK_MASK; + TYPE_FIELD_DWARF_BLOCK (range_type, 2) = DW_BLOCK (byte_stride_attr); + break; + } name = dwarf2_name (die, cu); if (name) @@ -9058,26 +9207,35 @@ dwarf2_get_ref_die_offset (struct attrib return result; } -/* Return the constant value held by the given attribute. Return -1 - if the value held by the attribute is not constant. */ +/* *VAL_RETURN is filled only for DWARF2_ATTR_CONST. */ -static int -dwarf2_get_attr_constant_value (struct attribute *attr, int default_value) +static enum dwarf2_get_attr_constant_value +dwarf2_get_attr_constant_value (struct attribute *attr, int *val_return) { + if (attr == NULL) + return dwarf2_attr_unknown; if (attr->form == DW_FORM_sdata) - return DW_SND (attr); - else if (attr->form == DW_FORM_udata - || attr->form == DW_FORM_data1 - || attr->form == DW_FORM_data2 - || attr->form == DW_FORM_data4 - || attr->form == DW_FORM_data8) - return DW_UNSND (attr); - else { - complaint (&symfile_complaints, _("Attribute value is not a constant (%s)"), - dwarf_form_name (attr->form)); - return default_value; + *val_return = DW_SND (attr); + return dwarf2_attr_const; + } + if (attr->form == DW_FORM_udata + || attr->form == DW_FORM_data1 + || attr->form == DW_FORM_data2 + || attr->form == DW_FORM_data4 + || attr->form == DW_FORM_data8) + { + *val_return = DW_UNSND (attr); + return dwarf2_attr_const; } + if (attr->form == DW_FORM_block + || attr->form == DW_FORM_block1 + || attr->form == DW_FORM_block2 + || attr->form == DW_FORM_block4) + return dwarf2_attr_block; + complaint (&symfile_complaints, _("Attribute value is not a constant (%s)"), + dwarf_form_name (attr->form)); + return dwarf2_attr_unknown; } static struct die_info * diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/eval.c gdb-6.8cvs20080219/gdb/eval.c --- gdb-6.8cvs20080219-fortranless/gdb/eval.c 2008-02-14 23:03:57.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/eval.c 2008-02-22 16:59:22.000000000 +0100 @@ -1643,9 +1643,12 @@ evaluate_subexp_standard (struct type *e { int subscript_array[MAX_FORTRAN_DIMS]; int array_size_array[MAX_FORTRAN_DIMS]; + int byte_stride_array[MAX_FORTRAN_DIMS]; int ndimensions = 1, i; struct type *tmp_type; int offset_item; /* The array offset where the item lives */ + CORE_ADDR offset_byte; /* byte_stride based offset */ + unsigned element_size; if (nargs > MAX_FORTRAN_DIMS) error (_("Too many subscripts for F77 (%d Max)"), MAX_FORTRAN_DIMS); @@ -1682,6 +1685,9 @@ evaluate_subexp_standard (struct type *e if (retcode == BOUND_FETCH_ERROR) error (_("Cannot obtain dynamic lower bound")); + byte_stride_array[nargs - i - 1] = + TYPE_ARRAY_BYTE_STRIDE_VALUE (tmp_type); + array_size_array[nargs - i - 1] = upper - lower + 1; /* Zero-normalize subscripts so that offsetting will work. */ @@ -1702,11 +1708,22 @@ evaluate_subexp_standard (struct type *e /* Now let us calculate the offset for this item */ - offset_item = subscript_array[ndimensions - 1]; + offset_item = 0; + offset_byte = 0; + + for (i = ndimensions - 1; i >= 0; --i) + { + offset_item *= array_size_array[i]; + if (byte_stride_array[i] == 0) + offset_item += subscript_array[i]; + else + offset_byte += subscript_array[i] * byte_stride_array[i]; + } - for (i = ndimensions - 1; i > 0; --i) - offset_item = - array_size_array[i - 1] * offset_item + subscript_array[i - 1]; + element_size = TYPE_LENGTH (TYPE_TARGET_TYPE (tmp_type)); + if (offset_byte % element_size != 0) + warning (_("Fortran array stride not divisible by the element size")); + offset_item += offset_byte / element_size; /* Construct a value node with the value of the offset */ diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/f-lang.c gdb-6.8cvs20080219/gdb/f-lang.c --- gdb-6.8cvs20080219-fortranless/gdb/f-lang.c 2008-02-14 23:03:57.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/f-lang.c 2008-02-22 16:59:22.000000000 +0100 @@ -31,6 +31,7 @@ #include "f-lang.h" #include "valprint.h" #include "value.h" +#include "dwarf2block.h" /* Following is dubious stuff that had been in the xcoff reader. */ @@ -222,6 +223,29 @@ f_printstr (struct ui_file *stream, cons if (force_ellipses || i < length) fputs_filtered ("...", stream); } + +static int +f_value_address_get (struct type *type, CORE_ADDR *address_return) +{ + if (f_type_object_valid_query (type) != NULL) + { + /* Do not try to evaluate DW_AT_data_location as it may even crash + (it would just return the value zero in the gfortran case). */ + return 0; + } + + /* Accelerated codepath. */ + if (address_return == NULL) + return 1; + + if (TYPE_CODE (type) == TYPE_CODE_ARRAY && TYPE_FORTRAN_ARRAY (type) != NULL) + { + if (TYPE_FORTRAN_ARRAY_DATA_LOCATION (type) != NULL) + *address_return = dwarf_block_exec (TYPE_FORTRAN_ARRAY_DATA_LOCATION (type)); + } + + return 1; +} /* Table of operators and their precedences for printing expressions. */ @@ -337,6 +361,7 @@ const struct language_defn f_language_de f_language_arch_info, default_print_array_index, default_pass_by_reference, + f_value_address_get, /* Retrieve the real data value */ LANG_MAGIC }; diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/f-lang.h gdb-6.8cvs20080219/gdb/f-lang.h --- gdb-6.8cvs20080219-fortranless/gdb/f-lang.h 2008-01-02 00:03:54.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/f-lang.h 2008-02-22 16:59:22.000000000 +0100 @@ -28,6 +28,11 @@ extern void f_error (char *); /* Defined extern void f_print_type (struct type *, char *, struct ui_file *, int, int); +extern const char *f_type_object_valid_query (struct type *type); +extern const char *f_type_object_valid_to_stream (struct type *type, + struct ui_file *stream); +extern void f_type_object_valid_error (struct type *type); + extern int f_val_print (struct type *, const gdb_byte *, int, CORE_ADDR, struct ui_file *, int, int, int, enum val_prettyprint); @@ -47,6 +52,32 @@ enum f90_range_type NONE_BOUND_DEFAULT /* "(low:high)" */ }; +/* GNU Fortran specific - for TYPE_FORTRAN_ARRAY. + All the DWARF_BLOCK fields are passed for execution to DWARF_BLOCK_EXEC. */ + +struct fortran_array_type +{ + /* For DW_AT_data_location. This entry is more appropriate for generic + MAIN_TYPE but we save the MAIN_TYPE size as it is in practice not present + for the other types. */ + struct dwarf_block *data_location; + + /* For DW_AT_allocated. */ + struct dwarf_block *allocated; + + /* For DW_AT_associated. */ + struct dwarf_block *associated; +}; + +/* Be sure to check `TYPE_CODE (thistype) == TYPE_CODE_ARRAY + && TYPE_FORTRAN_ARRAY (thistype) != NULL'. */ +#define TYPE_FORTRAN_ARRAY_DATA_LOCATION(thistype) \ + TYPE_FORTRAN_ARRAY (thistype)->data_location +#define TYPE_FORTRAN_ARRAY_ALLOCATED(thistype) \ + TYPE_FORTRAN_ARRAY (thistype)->allocated +#define TYPE_FORTRAN_ARRAY_ASSOCIATED(thistype) \ + TYPE_FORTRAN_ARRAY (thistype)->associated + struct common_entry { struct symbol *symbol; /* The symbol node corresponding diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/f-typeprint.c gdb-6.8cvs20080219/gdb/f-typeprint.c --- gdb-6.8cvs20080219-fortranless/gdb/f-typeprint.c 2008-01-02 00:03:54.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/f-typeprint.c 2008-02-22 16:59:22.000000000 +0100 @@ -31,6 +31,7 @@ #include "gdbcore.h" #include "target.h" #include "f-lang.h" +#include "dwarf2block.h" #include "gdb_string.h" #include @@ -39,7 +40,7 @@ static void f_type_print_args (struct type *, struct ui_file *); #endif -static void f_type_print_varspec_suffix (struct type *, struct ui_file *, +static void f_type_print_varspec_suffix (struct type *, struct ui_file *, int, int, int, int); void f_type_print_varspec_prefix (struct type *, struct ui_file *, @@ -48,6 +49,50 @@ void f_type_print_varspec_prefix (struct void f_type_print_base (struct type *, struct ui_file *, int, int); +const char * +f_type_object_valid_query (struct type *type) +{ + if (TYPE_CODE (type) == TYPE_CODE_ARRAY && TYPE_FORTRAN_ARRAY (type) != NULL) + { + /* DW_AT_associated has a preference over DW_AT_allocated. */ + if (TYPE_FORTRAN_ARRAY_ASSOCIATED (type) != NULL + && !dwarf_block_exec (TYPE_FORTRAN_ARRAY_ASSOCIATED (type))) + return N_("the array is not associated"); + + if (TYPE_FORTRAN_ARRAY_ALLOCATED (type) != NULL + && !dwarf_block_exec (TYPE_FORTRAN_ARRAY_ALLOCATED (type))) + return N_("the array is not allocated"); + } + return NULL; +} + +const char * +f_type_object_valid_to_stream (struct type *type, struct ui_file *stream) +{ + const char *msg; + + msg = f_type_object_valid_query (type); + if (msg != NULL) + { + /* Assuming the content printed to STREAM should not be localized. */ + fprintf_filtered (stream, "<%s>", msg); + } + + return msg; +} + +void +f_type_object_valid_error (struct type *type) +{ + const char *msg; + + msg = f_type_object_valid_query (type); + if (msg != NULL) + { + error (_("Unable to access the object because %s."), _(msg)); + } +} + /* LEVEL is the depth to indent lines by. */ void @@ -57,6 +102,9 @@ f_print_type (struct type *type, char *v enum type_code code; int demangled_args; + if (f_type_object_valid_to_stream (type, stream) != NULL) + return; + f_type_print_base (type, stream, show, level); code = TYPE_CODE (type); if ((varstring != NULL && *varstring != '\0') @@ -78,7 +126,7 @@ f_print_type (struct type *type, char *v so don't print an additional pair of ()'s */ demangled_args = varstring[strlen (varstring) - 1] == ')'; - f_type_print_varspec_suffix (type, stream, show, 0, demangled_args); + f_type_print_varspec_suffix (type, stream, show, 0, demangled_args, 0); } /* Print any asterisks or open-parentheses needed before the @@ -147,12 +195,14 @@ f_type_print_varspec_prefix (struct type static void f_type_print_varspec_suffix (struct type *type, struct ui_file *stream, - int show, int passed_a_ptr, int demangled_args) + int show, int passed_a_ptr, int demangled_args, + int arrayprint_recurse_level) { int upper_bound, lower_bound; int lower_bound_was_default = 0; - static int arrayprint_recurse_level = 0; int retcode; + /* No static variables (such as ARRAYPRINT_RECURSE_LEVEL) permitted as ERROR + may occur during the evaluation of DWARF_BLOCK values. */ if (type == 0) return; @@ -171,7 +221,8 @@ f_type_print_varspec_suffix (struct type fprintf_filtered (stream, "("); if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY) - f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0); + f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0, + arrayprint_recurse_level); retcode = f77_get_dynamic_lowerbound (type, &lower_bound); @@ -205,7 +256,8 @@ f_type_print_varspec_suffix (struct type } if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_ARRAY) - f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0); + f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0, + arrayprint_recurse_level); if (arrayprint_recurse_level == 1) fprintf_filtered (stream, ")"); else @@ -215,13 +267,14 @@ f_type_print_varspec_suffix (struct type case TYPE_CODE_PTR: case TYPE_CODE_REF: - f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0); + f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0, + arrayprint_recurse_level); fprintf_filtered (stream, ")"); break; case TYPE_CODE_FUNC: f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, - passed_a_ptr, 0); + passed_a_ptr, 0, arrayprint_recurse_level); if (passed_a_ptr) fprintf_filtered (stream, ")"); diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/f-valprint.c gdb-6.8cvs20080219/gdb/f-valprint.c --- gdb-6.8cvs20080219-fortranless/gdb/f-valprint.c 2008-02-14 23:03:57.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/f-valprint.c 2008-02-22 16:59:22.000000000 +0100 @@ -54,11 +54,11 @@ int f77_array_offset_tbl[MAX_FORTRAN_DIM /* The following macro gives us the size of the nth dimension, Where n is 1 based. */ -#define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1]) +#define F77_DIM_COUNT(n) (f77_array_offset_tbl[n][1]) -/* The following gives us the offset for row n where n is 1-based. */ +/* The following gives us the element size for row n where n is 1-based. */ -#define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0]) +#define F77_DIM_BYTE_STRIDE(n) (f77_array_offset_tbl[n][0]) int f77_get_dynamic_lowerbound (struct type *type, int *lower_bound) @@ -67,6 +67,8 @@ f77_get_dynamic_lowerbound (struct type CORE_ADDR current_frame_addr; CORE_ADDR ptr_to_lower_bound; + f_type_object_valid_error (type); + switch (TYPE_ARRAY_LOWER_BOUND_TYPE (type)) { case BOUND_BY_VALUE_ON_STACK: @@ -128,6 +130,8 @@ f77_get_dynamic_upperbound (struct type CORE_ADDR current_frame_addr = 0; CORE_ADDR ptr_to_upper_bound; + f_type_object_valid_error (type); + switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type)) { case BOUND_BY_VALUE_ON_STACK: @@ -250,24 +254,29 @@ f77_create_arrayprint_offset_tbl (struct if (retcode == BOUND_FETCH_ERROR) error (_("Cannot obtain dynamic lower bound")); - F77_DIM_SIZE (ndimen) = upper - lower + 1; + F77_DIM_COUNT (ndimen) = upper - lower + 1; + + F77_DIM_BYTE_STRIDE (ndimen) = + TYPE_ARRAY_BYTE_STRIDE_VALUE (tmp_type); tmp_type = TYPE_TARGET_TYPE (tmp_type); ndimen++; } - /* Now we multiply eltlen by all the offsets, so that later we + /* Now we multiply eltlen by all the BYTE_STRIDEs, so that later we can print out array elements correctly. Up till now we - know an offset to apply to get the item but we also + know an eltlen to apply to get the item but we also have to know how much to add to get to the next item */ ndimen--; eltlen = TYPE_LENGTH (tmp_type); - F77_DIM_OFFSET (ndimen) = eltlen; + if (F77_DIM_BYTE_STRIDE (ndimen) == 0) + F77_DIM_BYTE_STRIDE (ndimen) = eltlen; while (--ndimen > 0) { - eltlen *= F77_DIM_SIZE (ndimen + 1); - F77_DIM_OFFSET (ndimen) = eltlen; + eltlen *= F77_DIM_COUNT (ndimen + 1); + if (F77_DIM_BYTE_STRIDE (ndimen) == 0) + F77_DIM_BYTE_STRIDE (ndimen) = eltlen; } } @@ -287,33 +296,33 @@ f77_print_array_1 (int nss, int ndimensi if (nss != ndimensions) { - for (i = 0; (i < F77_DIM_SIZE (nss) && (*elts) < print_max); i++) + for (i = 0; (i < F77_DIM_COUNT (nss) && (*elts) < print_max); i++) { fprintf_filtered (stream, "( "); f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type), - valaddr + i * F77_DIM_OFFSET (nss), - address + i * F77_DIM_OFFSET (nss), + valaddr + i * F77_DIM_BYTE_STRIDE (nss), + address + i * F77_DIM_BYTE_STRIDE (nss), stream, format, deref_ref, recurse, pretty, elts); fprintf_filtered (stream, ") "); } - if (*elts >= print_max && i < F77_DIM_SIZE (nss)) + if (*elts >= print_max && i < F77_DIM_COUNT (nss)) fprintf_filtered (stream, "..."); } else { - for (i = 0; i < F77_DIM_SIZE (nss) && (*elts) < print_max; + for (i = 0; i < F77_DIM_COUNT (nss) && (*elts) < print_max; i++, (*elts)++) { val_print (TYPE_TARGET_TYPE (type), - valaddr + i * F77_DIM_OFFSET (ndimensions), + valaddr + i * F77_DIM_BYTE_STRIDE (ndimensions), 0, - address + i * F77_DIM_OFFSET (ndimensions), + address + i * F77_DIM_BYTE_STRIDE (ndimensions), stream, format, deref_ref, recurse, pretty); - if (i != (F77_DIM_SIZE (nss) - 1)) + if (i != (F77_DIM_COUNT (nss) - 1)) fprintf_filtered (stream, ", "); - if ((*elts == print_max - 1) && (i != (F77_DIM_SIZE (nss) - 1))) + if ((*elts == print_max - 1) && (i != (F77_DIM_COUNT (nss) - 1))) fprintf_filtered (stream, "..."); } } @@ -372,6 +381,9 @@ f_val_print (struct type *type, const gd CORE_ADDR addr; int index; + if (f_type_object_valid_to_stream (type, stream) != NULL) + return 0; + CHECK_TYPEDEF (type); switch (TYPE_CODE (type)) { diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/findvar.c gdb-6.8cvs20080219/gdb/findvar.c --- gdb-6.8cvs20080219-fortranless/gdb/findvar.c 2008-01-02 00:03:54.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/findvar.c 2008-02-22 16:50:29.000000000 +0100 @@ -34,6 +34,7 @@ #include "regcache.h" #include "user-regs.h" #include "block.h" +#include "dwarf2block.h" /* Basic byte-swapping routines. GDB has needed these for a long time... All extract a target-format integer at ADDR which is LEN bytes long. */ @@ -370,24 +371,8 @@ symbol_read_needs_frame (struct symbol * struct value * read_var_value (struct symbol *var, struct frame_info *frame) { - struct value *v; struct type *type = SYMBOL_TYPE (var); CORE_ADDR addr; - int len; - - if (SYMBOL_CLASS (var) == LOC_COMPUTED - || SYMBOL_CLASS (var) == LOC_COMPUTED_ARG - || SYMBOL_CLASS (var) == LOC_REGISTER - || SYMBOL_CLASS (var) == LOC_REGPARM) - /* These cases do not use V. */ - v = NULL; - else - { - v = allocate_value (type); - VALUE_LVAL (v) = lval_memory; /* The most likely possibility. */ - } - - len = TYPE_LENGTH (type); /* FIXME drow/2003-09-06: this call to the selected frame should be pushed upwards to the callers. */ @@ -397,31 +382,39 @@ read_var_value (struct symbol *var, stru switch (SYMBOL_CLASS (var)) { case LOC_CONST: - /* Put the constant back in target format. */ - store_signed_integer (value_contents_raw (v), len, - (LONGEST) SYMBOL_VALUE (var)); - VALUE_LVAL (v) = not_lval; - return v; + { + /* Put the constant back in target format. */ + struct value *v = allocate_value (type); + VALUE_LVAL (v) = not_lval; + store_signed_integer (value_contents_raw (v), TYPE_LENGTH (type), + (LONGEST) SYMBOL_VALUE (var)); + return v; + } case LOC_LABEL: - /* Put the constant back in target format. */ - if (overlay_debugging) - { - CORE_ADDR addr - = symbol_overlayed_address (SYMBOL_VALUE_ADDRESS (var), - SYMBOL_BFD_SECTION (var)); - store_typed_address (value_contents_raw (v), type, addr); - } - else - store_typed_address (value_contents_raw (v), type, - SYMBOL_VALUE_ADDRESS (var)); - VALUE_LVAL (v) = not_lval; - return v; + { + /* Put the constant back in target format. */ + struct value *v = allocate_value (type); + VALUE_LVAL (v) = not_lval; + if (overlay_debugging) + { + CORE_ADDR addr + = symbol_overlayed_address (SYMBOL_VALUE_ADDRESS (var), + SYMBOL_BFD_SECTION (var)); + store_typed_address (value_contents_raw (v), type, addr); + } + else + store_typed_address (value_contents_raw (v), type, + SYMBOL_VALUE_ADDRESS (var)); + return v; + } case LOC_CONST_BYTES: { - memcpy (value_contents_raw (v), SYMBOL_VALUE_BYTES (var), len); + struct value *v = allocate_value (type); VALUE_LVAL (v) = not_lval; + memcpy (value_contents_raw (v), SYMBOL_VALUE_BYTES (var), + TYPE_LENGTH (type)); return v; } @@ -503,12 +496,23 @@ addresses have not been bound by the dyn break; case LOC_BLOCK: - if (overlay_debugging) - VALUE_ADDRESS (v) = symbol_overlayed_address - (BLOCK_START (SYMBOL_BLOCK_VALUE (var)), SYMBOL_BFD_SECTION (var)); - else - VALUE_ADDRESS (v) = BLOCK_START (SYMBOL_BLOCK_VALUE (var)); - return v; + { + CORE_ADDR addr; + struct value *v; + + if (overlay_debugging) + addr = symbol_overlayed_address + (BLOCK_START (SYMBOL_BLOCK_VALUE (var)), SYMBOL_BFD_SECTION (var)); + else + addr = BLOCK_START (SYMBOL_BLOCK_VALUE (var)); + /* ADDR is set here for ALLOCATE_VALUE's CHECK_TYPEDEF for + DW_OP_push_object_address. */ + object_address_set (addr); + v = allocate_value (type); + VALUE_ADDRESS (v) = addr; + VALUE_LVAL (v) = lval_memory; + return v; + } case LOC_REGISTER: case LOC_REGPARM: @@ -532,7 +536,6 @@ addresses have not been bound by the dyn error (_("Value of register variable not available.")); addr = value_as_address (regval); - VALUE_LVAL (v) = lval_memory; } else { @@ -572,18 +575,33 @@ addresses have not been bound by the dyn break; case LOC_OPTIMIZED_OUT: - VALUE_LVAL (v) = not_lval; - set_value_optimized_out (v, 1); - return v; + { + struct value *v = allocate_value (type); + + VALUE_LVAL (v) = not_lval; + set_value_optimized_out (v, 1); + return v; + } default: error (_("Cannot look up value of a botched symbol.")); break; } - VALUE_ADDRESS (v) = addr; - set_value_lazy (v, 1); - return v; + { + struct value *v; + + /* ADDR is set here for ALLOCATE_VALUE's CHECK_TYPEDEF for + DW_OP_push_object_address. */ + object_address_set (addr); + v = allocate_value (type); + VALUE_ADDRESS (v) = addr; + VALUE_LVAL (v) = lval_memory; + + set_value_lazy (v, 1); + + return v; + } } /* Install default attributes for register values. */ diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/gdbtypes.c gdb-6.8cvs20080219/gdb/gdbtypes.c --- gdb-6.8cvs20080219-fortranless/gdb/gdbtypes.c 2008-02-22 08:19:37.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/gdbtypes.c 2008-02-22 16:58:30.000000000 +0100 @@ -38,6 +38,7 @@ #include "cp-abi.h" #include "gdb_assert.h" #include "hashtab.h" +#include "dwarf2block.h" /* These variables point to the objects representing the predefined C data types. */ @@ -682,16 +683,21 @@ allocate_stub_method (struct type *type) RESULT_TYPE, or creating a new type, inheriting the objfile from INDEX_TYPE. - Indices will be of type INDEX_TYPE, and will range from LOW_BOUND - to HIGH_BOUND, inclusive. + Indices will be of type INDEX_TYPE. NFIELDS should be 2 for standard + arrays, 3 for a custom TYPE_BYTE_STRIDE. Use CREATE_RANGE_TYPE for common + constant LOW_BOUND/HIGH_BOUND ranges. + + You must set TYPE_FLAG_UNSIGNED yourself as being done in CREATE_RANGE_TYPE. FIXME: Maybe we should check the TYPE_CODE of RESULT_TYPE to make sure it is TYPE_CODE_UNDEF before we bash it into a range type? */ struct type * -create_range_type (struct type *result_type, struct type *index_type, - int low_bound, int high_bound) +create_range_type_nfields (struct type *result_type, struct type *index_type, + int nfields) { + int fieldno; + if (result_type == NULL) { result_type = alloc_type (TYPE_OBJFILE (index_type)); @@ -702,17 +708,33 @@ create_range_type (struct type *result_t TYPE_FLAGS (result_type) |= TYPE_FLAG_TARGET_STUB; else TYPE_LENGTH (result_type) = TYPE_LENGTH (check_typedef (index_type)); - TYPE_NFIELDS (result_type) = 2; + TYPE_NFIELDS (result_type) = nfields; TYPE_FIELDS (result_type) = (struct field *) - TYPE_ALLOC (result_type, 2 * sizeof (struct field)); - memset (TYPE_FIELDS (result_type), 0, 2 * sizeof (struct field)); - TYPE_FIELD_BITPOS (result_type, 0) = low_bound; - TYPE_FIELD_BITPOS (result_type, 1) = high_bound; + TYPE_ALLOC (result_type, + TYPE_NFIELDS (result_type) * sizeof (struct field)); + memset (TYPE_FIELDS (result_type), 0, + TYPE_NFIELDS (result_type) * sizeof (struct field)); + + return (result_type); +} + +/* Simplified CREATE_RANGE_TYPE_NFIELDS for constant ranges from LOW_BOUND to + HIGH_BOUND, inclusive. TYPE_BYTE_STRIDE is always set to zero (default + native target type length). */ + +struct type * +create_range_type (struct type *result_type, struct type *index_type, + int low_bound, int high_bound) +{ + result_type = create_range_type_nfields (result_type, index_type, 2); + + TYPE_LOW_BOUND_RAW (result_type) = low_bound; + TYPE_HIGH_BOUND_RAW (result_type) = high_bound; if (low_bound >= 0) TYPE_FLAGS (result_type) |= TYPE_FLAG_UNSIGNED; - return (result_type); + return result_type; } /* Set *LOWP and *HIGHP to the lower and upper bounds of discrete type @@ -800,25 +822,23 @@ create_array_type (struct type *result_t struct type *element_type, struct type *range_type) { - LONGEST low_bound, high_bound; - if (result_type == NULL) { result_type = alloc_type (TYPE_OBJFILE (range_type)); } TYPE_CODE (result_type) = TYPE_CODE_ARRAY; TYPE_TARGET_TYPE (result_type) = element_type; - if (get_discrete_bounds (range_type, &low_bound, &high_bound) < 0) - low_bound = high_bound = 0; CHECK_TYPEDEF (element_type); - /* Be careful when setting the array length. Ada arrays can be - empty arrays with the high_bound being smaller than the low_bound. - In such cases, the array length should be zero. */ - if (high_bound < low_bound) + /* Dynamically sized arrays cannot be computed now as we may have forward + DWARF references here. */ + if ((TYPE_BOUND_IS_DWARF_BLOCK_VAR (range_type, 0) + & TYPE_BOUND_IS_DWARF_BLOCK_MASK) != 0 + && (TYPE_BOUND_IS_DWARF_BLOCK_VAR (range_type, 1) + & TYPE_BOUND_IS_DWARF_BLOCK_MASK) != 0) TYPE_LENGTH (result_type) = 0; else - TYPE_LENGTH (result_type) = - TYPE_LENGTH (element_type) * (high_bound - low_bound + 1); + TYPE_LENGTH (result_type) = TYPE_LENGTH (element_type) + * TYPE_COUNT_BOUND (range_type); TYPE_NFIELDS (result_type) = 1; TYPE_FIELDS (result_type) = (struct field *) TYPE_ALLOC (result_type, sizeof (struct field)); @@ -1377,6 +1397,116 @@ stub_noname_complaint (void) complaint (&symfile_complaints, _("stub type has NULL name")); } +CORE_ADDR range_type_any_field_internal (struct type *range_type, int fieldno) +{ + if ((TYPE_BOUND_IS_DWARF_BLOCK_VAR (range_type, fieldno) + & TYPE_BOUND_IS_DWARF_BLOCK_MASK) != 0) + return dwarf_block_exec (TYPE_FIELD_DWARF_BLOCK (range_type, fieldno)); + else + return TYPE_FIELD_BITPOS (range_type, (fieldno)); +} + +int +range_type_high_bound_internal (struct type *range_type) +{ + int raw_value = range_type_any_field_internal (range_type, 1); + + if ((TYPE_HIGH_BOUND_IS_COUNT_VAR (range_type) + & TYPE_HIGH_BOUND_IS_COUNT_MASK) == 0) + { + /* DW_AT_upper_bound value. */ + return raw_value; + } + else + { + /* DW_AT_count value. */ + return TYPE_LOW_BOUND (range_type) + raw_value - 1; + } +} + +int +range_type_count_bound_internal (struct type *range_type) +{ + int raw_value = range_type_any_field_internal (range_type, 1); + if ((TYPE_HIGH_BOUND_IS_COUNT_VAR (range_type) + & TYPE_HIGH_BOUND_IS_COUNT_MASK) != 0) + { + /* DW_AT_count value. */ + return raw_value; + } + else + { + /* DW_AT_upper_bound value. */ + /* Be careful when getting the array length. Ada arrays can be + empty arrays with the high_bound being smaller than the low_bound. + In such cases, the array length should be zero. */ + if (raw_value < TYPE_LOW_BOUND (range_type)) + return 0; + return 1 + raw_value - TYPE_LOW_BOUND (range_type); + } +} + +CORE_ADDR range_type_byte_stride_internal (struct type *range_type) +{ + if (TYPE_NFIELDS (range_type) >= 3) + return range_type_any_field_internal (range_type, 2); + else + { + /* The caller will need to call something like + `TYPE_LENGTH (check_typedef (element_type)) + * TYPE_COUNT_BOUND (range_type) '. */ + return 0; + } +} + +/* Calculate the memory length of array TYPE. + + TARGET_TYPE should be set to `check_typedef (TYPE_TARGET_TYPE (type))' as + a performance hint. Feel free to pass NULL. Set FULL_SPAN to return the + size incl. the possibly incomplete last element - it may differ from the + cleared FULL_SPAN return value for larger TYPE_BYTE_STRIDE values. */ + +static CORE_ADDR +type_length_get (struct type *type, struct type *target_type, int full_span) +{ + struct type *range_type; + int count; + CORE_ADDR byte_stride = 0; /* `= 0' for a false GCC warning. */ + CORE_ADDR element_size; + + if (TYPE_CODE (type) != TYPE_CODE_ARRAY) + return TYPE_LENGTH (type); + + /* Avoid executing TYPE_COUNT_BOUND for invalid (unallocated/unassociated) + Fortran arrays. The allocated data will never be used so they can be + zero-length. */ + if (!LA_VALUE_ADDRESS_GET (type, NULL)) + return 0; + + range_type = TYPE_INDEX_TYPE (type); + count = TYPE_COUNT_BOUND (range_type); + if (count < 0) + warning (_("Object count %d < 0"), count); + if (count <= 0) + return 0; + if (full_span || count > 1) + { + byte_stride = TYPE_BYTE_STRIDE (range_type); + if (byte_stride == 0) + { + if (target_type == NULL) + target_type = check_typedef (TYPE_TARGET_TYPE (type)); + byte_stride = type_length_get (target_type, NULL, 1); + } + } + if (full_span) + return count * byte_stride; + if (target_type == NULL) + target_type = check_typedef (TYPE_TARGET_TYPE (type)); + element_size = type_length_get (target_type, NULL, 1); + return (count - 1) * byte_stride + element_size; +} + /* Added by Bryan Boreham, Kewill, Sun Sep 17 18:07:17 1989. If this is a stubbed struct (i.e. declared as struct foo *), see if @@ -1520,19 +1650,8 @@ check_typedef (struct type *type) == TYPE_CODE_RANGE)) { /* Now recompute the length of the array type, based on its - number of elements and the target type's length. - Watch out for Ada null Ada arrays where the high bound - is smaller than the low bound. */ - const int low_bound = TYPE_FIELD_BITPOS (range_type, 0); - const int high_bound = TYPE_FIELD_BITPOS (range_type, 1); - int nb_elements; - - if (high_bound < low_bound) - nb_elements = 0; - else - nb_elements = high_bound - low_bound + 1; - - TYPE_LENGTH (type) = nb_elements * TYPE_LENGTH (target_type); + number of elements and the target type's length. */ + TYPE_LENGTH (type) = type_length_get (type, target_type, 0); TYPE_FLAGS (type) &= ~TYPE_FLAG_TARGET_STUB; } else if (TYPE_CODE (type) == TYPE_CODE_RANGE) diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/gdbtypes.h gdb-6.8cvs20080219/gdb/gdbtypes.h --- gdb-6.8cvs20080219-fortranless/gdb/gdbtypes.h 2008-02-22 08:19:37.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/gdbtypes.h 2008-02-22 16:59:22.000000000 +0100 @@ -417,6 +417,9 @@ struct main_type CORE_ADDR physaddr; char *physname; + + /* For dynamically-sized arrays. Passed to DWARF_BLOCK_EXEC. */ + struct dwarf_block *dwarf_block; } loc; @@ -427,7 +430,11 @@ struct main_type /* This flag is zero for non-static fields, 1 for fields whose location is specified by the label loc.physname, and 2 for fields whose location - is specified by loc.physaddr. */ + is specified by loc.physaddr. + For range bounds bit 0 cleared is for loc.bitpos and bit 0 set is for + loc.dwarf_block (TYPE_BOUND_IS_DWARF_BLOCK_MASK). + For range bounds bit 1 cleared is for DW_AT_upper_bound and bit 1 set is + for DW_AT_count (TYPE_HIGH_BOUND_IS_COUNT_MASK). */ unsigned int static_kind : 2; @@ -481,6 +488,10 @@ struct main_type targets and the second is for little endian targets. */ const struct floatformat **floatformat; + + /* FORTRAN_ARRAY is for TYPE_CODE_ARRAY. */ + + struct fortran_array_type *fortran_array; } type_specific; }; @@ -766,9 +777,9 @@ extern void allocate_cplus_struct_type ( #define TYPE_POINTER_TYPE(thistype) (thistype)->pointer_type #define TYPE_REFERENCE_TYPE(thistype) (thistype)->reference_type #define TYPE_CHAIN(thistype) (thistype)->chain -/* Note that if thistype is a TYPEDEF type, you have to call check_typedef. - But check_typedef does set the TYPE_LENGTH of the TYPEDEF type, - so you only have to call check_typedef once. Since allocate_value +/* Note that if thistype is a TYPEDEF or ARRAY type, you have to call + check_typedef. But check_typedef does set the TYPE_LENGTH of the TYPEDEF + type, so you only have to call check_typedef once. Since allocate_value calls check_typedef, TYPE_LENGTH (VALUE_TYPE (X)) is safe. */ #define TYPE_LENGTH(thistype) (thistype)->length #define TYPE_OBJFILE(thistype) TYPE_MAIN_TYPE(thistype)->objfile @@ -782,8 +793,25 @@ extern void allocate_cplus_struct_type ( #define TYPE_INSTANTIATIONS(thistype) TYPE_CPLUS_SPECIFIC(thistype)->instantiations #define TYPE_INDEX_TYPE(type) TYPE_FIELD_TYPE (type, 0) -#define TYPE_LOW_BOUND(range_type) TYPE_FIELD_BITPOS (range_type, 0) -#define TYPE_HIGH_BOUND(range_type) TYPE_FIELD_BITPOS (range_type, 1) +#define TYPE_LOW_BOUND_RAW(range_type) TYPE_FIELD_BITPOS (range_type, 0) +#define TYPE_HIGH_BOUND_RAW(range_type) TYPE_FIELD_BITPOS (range_type, 1) +/* `TYPE_NFIELDS (range_type) >= 3' check is required before accessing it: */ +#define TYPE_BYTE_STRIDE_RAW(range_type) TYPE_FIELD_BITPOS (range_type, 2) +#define TYPE_LOW_BOUND(range_type) \ + ((int) range_type_any_field_internal ((range_type), 0)) +#define TYPE_HIGH_BOUND(range_type) \ + range_type_high_bound_internal ((range_type)) +#define TYPE_COUNT_BOUND(range_type) \ + range_type_count_bound_internal ((range_type)) +#define TYPE_BYTE_STRIDE(type) \ + range_type_byte_stride_internal ((type)) + +#define TYPE_BOUND_IS_DWARF_BLOCK_MASK 1 +#define TYPE_BOUND_IS_DWARF_BLOCK_VAR(range_type, fieldno) \ + TYPE_FIELD_STATIC_KIND (range_type, fieldno) +#define TYPE_HIGH_BOUND_IS_COUNT_MASK 2 +#define TYPE_HIGH_BOUND_IS_COUNT_VAR(range_type) \ + TYPE_FIELD_STATIC_KIND (range_type, 1) /* Moto-specific stuff for FORTRAN arrays */ @@ -792,11 +820,12 @@ extern void allocate_cplus_struct_type ( #define TYPE_ARRAY_LOWER_BOUND_TYPE(thistype) \ TYPE_MAIN_TYPE(thistype)->lower_bound_type -#define TYPE_ARRAY_UPPER_BOUND_VALUE(arraytype) \ - (TYPE_FIELD_BITPOS((TYPE_FIELD_TYPE((arraytype),0)),1)) - #define TYPE_ARRAY_LOWER_BOUND_VALUE(arraytype) \ - (TYPE_FIELD_BITPOS((TYPE_FIELD_TYPE((arraytype),0)),0)) + (TYPE_LOW_BOUND(TYPE_INDEX_TYPE(arraytype))) +#define TYPE_ARRAY_UPPER_BOUND_VALUE(arraytype) \ + (TYPE_HIGH_BOUND(TYPE_INDEX_TYPE(arraytype))) +#define TYPE_ARRAY_BYTE_STRIDE_VALUE(arraytype) \ + (TYPE_BYTE_STRIDE(TYPE_INDEX_TYPE(arraytype))) /* C++ */ @@ -812,6 +841,7 @@ extern void allocate_cplus_struct_type ( #define TYPE_TYPE_SPECIFIC(thistype) TYPE_MAIN_TYPE(thistype)->type_specific #define TYPE_CPLUS_SPECIFIC(thistype) TYPE_MAIN_TYPE(thistype)->type_specific.cplus_stuff #define TYPE_FLOATFORMAT(thistype) TYPE_MAIN_TYPE(thistype)->type_specific.floatformat +#define TYPE_FORTRAN_ARRAY(thistype) TYPE_MAIN_TYPE(thistype)->type_specific.fortran_array #define TYPE_BASECLASS(thistype,index) TYPE_MAIN_TYPE(thistype)->fields[index].type #define TYPE_N_BASECLASSES(thistype) TYPE_CPLUS_SPECIFIC(thistype)->n_baseclasses #define TYPE_BASECLASS_NAME(thistype,index) TYPE_MAIN_TYPE(thistype)->fields[index].name @@ -826,6 +856,7 @@ extern void allocate_cplus_struct_type ( #define FIELD_TYPE(thisfld) ((thisfld).type) #define FIELD_NAME(thisfld) ((thisfld).name) #define FIELD_BITPOS(thisfld) ((thisfld).loc.bitpos) +#define FIELD_DWARF_BLOCK(thisfld) ((thisfld).loc.dwarf_block) #define FIELD_ARTIFICIAL(thisfld) ((thisfld).artificial) #define FIELD_BITSIZE(thisfld) ((thisfld).bitsize) #define FIELD_STATIC_KIND(thisfld) ((thisfld).static_kind) @@ -839,6 +870,7 @@ extern void allocate_cplus_struct_type ( #define TYPE_FIELD_TYPE(thistype, n) FIELD_TYPE(TYPE_FIELD(thistype, n)) #define TYPE_FIELD_NAME(thistype, n) FIELD_NAME(TYPE_FIELD(thistype, n)) #define TYPE_FIELD_BITPOS(thistype, n) FIELD_BITPOS(TYPE_FIELD(thistype,n)) +#define TYPE_FIELD_DWARF_BLOCK(thistype, n) FIELD_DWARF_BLOCK(TYPE_FIELD(thistype,n)) #define TYPE_FIELD_ARTIFICIAL(thistype, n) FIELD_ARTIFICIAL(TYPE_FIELD(thistype,n)) #define TYPE_FIELD_BITSIZE(thistype, n) FIELD_BITSIZE(TYPE_FIELD(thistype,n)) #define TYPE_FIELD_PACKED(thistype, n) (FIELD_BITSIZE(TYPE_FIELD(thistype,n))!=0) @@ -1251,12 +1283,25 @@ extern struct type *make_function_type ( extern struct type *lookup_function_type (struct type *); +extern struct type *create_range_type_nfields (struct type *result_type, + struct type *index_type, + int nfields); + extern struct type *create_range_type (struct type *, struct type *, int, int); extern struct type *create_array_type (struct type *, struct type *, struct type *); +extern CORE_ADDR range_type_any_field_internal (struct type *range_type, + int fieldno); + +extern int range_type_high_bound_internal (struct type *range_type); + +extern int range_type_count_bound_internal (struct type *range_type); + +extern CORE_ADDR range_type_byte_stride_internal (struct type *range_type); + extern struct type *create_string_type (struct type *, struct type *); extern struct type *create_set_type (struct type *, struct type *); diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/jv-lang.c gdb-6.8cvs20080219/gdb/jv-lang.c --- gdb-6.8cvs20080219-fortranless/gdb/jv-lang.c 2008-02-14 23:03:57.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/jv-lang.c 2008-02-22 16:47:53.000000000 +0100 @@ -1083,6 +1083,7 @@ const struct language_defn java_language c_language_arch_info, default_print_array_index, default_pass_by_reference, + default_value_address_get, /* Retrieve the real data value */ LANG_MAGIC }; diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/language.c gdb-6.8cvs20080219/gdb/language.c --- gdb-6.8cvs20080219-fortranless/gdb/language.c 2008-02-14 23:03:57.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/language.c 2008-02-22 16:47:53.000000000 +0100 @@ -1087,6 +1087,15 @@ default_print_array_index (struct value fprintf_filtered (stream, "] = "); } +/* No *ADDRESS_RETURN change is needed as we do not support DW_AT_data_location + * for general types. */ + +int +default_value_address_get (struct type *type, CORE_ADDR *address_return) +{ + return 1; +} + /* Define the language that is no language. */ static int @@ -1205,6 +1214,7 @@ const struct language_defn unknown_langu unknown_language_arch_info, /* la_language_arch_info. */ default_print_array_index, default_pass_by_reference, + default_value_address_get, /* Retrieve the real data value */ LANG_MAGIC }; @@ -1241,6 +1251,7 @@ const struct language_defn auto_language unknown_language_arch_info, /* la_language_arch_info. */ default_print_array_index, default_pass_by_reference, + default_value_address_get, /* Retrieve the real data value */ LANG_MAGIC }; @@ -1276,6 +1287,7 @@ const struct language_defn local_languag unknown_language_arch_info, /* la_language_arch_info. */ default_print_array_index, default_pass_by_reference, + default_value_address_get, /* Retrieve the real data value */ LANG_MAGIC }; diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/language.h gdb-6.8cvs20080219/gdb/language.h --- gdb-6.8cvs20080219-fortranless/gdb/language.h 2008-02-14 23:03:57.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/language.h 2008-02-22 16:47:53.000000000 +0100 @@ -268,6 +268,13 @@ struct language_defn reference at the language level. */ int (*la_pass_by_reference) (struct type *type); + /* Return the data address (DW_AT_data_location) of TYPE into + *ADDRESS_RETURN. Return non-zero if the variable/data is valid. + You should set *ADDRESS_RETURN as VALUE_ADDRESS (VAL) as if no + DW_AT_data_location is present for TYPE *ADDRESS_RETURN is left + unchanged. ADDRESS_RETURN may be NULL. */ + int (*la_value_address_get) (struct type *type, CORE_ADDR *address_return); + /* Add fields above this point, so the magic number is always last. */ /* Magic number for compat checking */ @@ -363,6 +370,9 @@ extern enum language set_language (enum #define LA_PRINT_ARRAY_INDEX(index_value, stream, format, pretty) \ (current_language->la_print_array_index(index_value, stream, format, pretty)) +#define LA_VALUE_ADDRESS_GET(type, address_return) \ + (current_language->la_value_address_get(type, address_return)) + /* Test a character to decide whether it can be printed in literal form or needs to be printed in another representation. For example, in C the literal form of the character with octal value 141 is 'a' @@ -470,4 +480,7 @@ int language_pass_by_reference (struct t independent of this. */ int default_pass_by_reference (struct type *type); +extern int default_value_address_get (struct type *type, + CORE_ADDR *address_return); + #endif /* defined (LANGUAGE_H) */ diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/m2-lang.c gdb-6.8cvs20080219/gdb/m2-lang.c --- gdb-6.8cvs20080219-fortranless/gdb/m2-lang.c 2008-02-14 23:03:58.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/m2-lang.c 2008-02-22 16:47:53.000000000 +0100 @@ -388,6 +388,7 @@ const struct language_defn m2_language_d m2_language_arch_info, default_print_array_index, default_pass_by_reference, + default_value_address_get, /* Retrieve the real data value */ LANG_MAGIC }; diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/objc-lang.c gdb-6.8cvs20080219/gdb/objc-lang.c --- gdb-6.8cvs20080219-fortranless/gdb/objc-lang.c 2008-02-14 23:03:59.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/objc-lang.c 2008-02-22 16:47:53.000000000 +0100 @@ -522,6 +522,7 @@ const struct language_defn objc_language c_language_arch_info, default_print_array_index, default_pass_by_reference, + default_value_address_get, /* Retrieve the real data value */ LANG_MAGIC }; diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/p-lang.c gdb-6.8cvs20080219/gdb/p-lang.c --- gdb-6.8cvs20080219-fortranless/gdb/p-lang.c 2008-02-14 23:03:59.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/p-lang.c 2008-02-22 16:47:53.000000000 +0100 @@ -427,6 +427,7 @@ const struct language_defn pascal_langua pascal_language_arch_info, default_print_array_index, default_pass_by_reference, + default_value_address_get, /* Retrieve the real data value */ LANG_MAGIC }; diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/printcmd.c gdb-6.8cvs20080219/gdb/printcmd.c --- gdb-6.8cvs20080219-fortranless/gdb/printcmd.c 2008-02-22 08:19:37.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/printcmd.c 2008-02-22 16:49:35.000000000 +0100 @@ -888,6 +888,11 @@ print_command_1 (char *exp, int inspect, else val = access_value_history (0); + /* Do not try to OBJECT_ADDRESS_SET here anything. We are interested in the + source variable base addresses as found by READ_VAR_VALUE. The value here + can be already a calculated expression address inappropriate for + DW_OP_push_object_address. */ + if (voidprint || (val && value_type (val) && TYPE_CODE (value_type (val)) != TYPE_CODE_VOID)) { diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/scm-lang.c gdb-6.8cvs20080219/gdb/scm-lang.c --- gdb-6.8cvs20080219-fortranless/gdb/scm-lang.c 2008-02-14 23:04:00.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/scm-lang.c 2008-02-22 16:47:53.000000000 +0100 @@ -266,6 +266,7 @@ const struct language_defn scm_language_ c_language_arch_info, default_print_array_index, default_pass_by_reference, + default_value_address_get, /* Retrieve the real data value */ LANG_MAGIC }; diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/testsuite/gdb.fortran/dynamic.exp gdb-6.8cvs20080219/gdb/testsuite/gdb.fortran/dynamic.exp --- gdb-6.8cvs20080219-fortranless/gdb/testsuite/gdb.fortran/dynamic.exp 1970-01-01 01:00:00.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/testsuite/gdb.fortran/dynamic.exp 2008-02-22 16:59:42.000000000 +0100 @@ -0,0 +1,145 @@ +# Copyright 2007 Free Software Foundation, Inc. + +# This program 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 program 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 program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# This file was written by Jan Kratochvil . + +# This file is part of the gdb testsuite. It contains tests for dynamically +# allocated Fortran arrays. +# It depends on the GCC dynamic Fortran arrays DWARF support: +# http://gcc.gnu.org/bugzilla/show_bug.cgi?id=22244 + +if $tracelevel then { + strace $tracelevel +} + +set testfile "dynamic" +set srcfile ${testfile}.f90 +set binfile ${objdir}/${subdir}/${testfile} + +if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${binfile}" executable {debug f77 quiet}] != "" } { + untested "Couldn't compile ${srcfile}" + return -1 +} + +gdb_exit +gdb_start +gdb_reinitialize_dir $srcdir/$subdir +gdb_load ${binfile} + +if ![runto MAIN__] then { + perror "couldn't run to breakpoint MAIN__" + continue +} + +gdb_breakpoint [gdb_get_line_number "varx-init"] +gdb_continue_to_breakpoint "varx-init" +gdb_test "p varx" "\\$\[0-9\]* = " +gdb_test "ptype varx" "type = " +gdb_test "p varx(1,5,17)" "Unable to access the object because the array is not allocated\\." +gdb_test "p varx(1,5,17)=1" "Unable to access the object because the array is not allocated\\." +gdb_test "ptype varx(1,5,17)" "Unable to access the object because the array is not allocated\\." + +gdb_breakpoint [gdb_get_line_number "varx-allocated"] +gdb_continue_to_breakpoint "varx-allocated" +# $1 = (( ( 0, 0, 0, 0, 0, 0) ( 0, 0, 0, 0, 0, 0) --- , 0) ) ( ( 0, 0, ...) ...) ...) +gdb_test "ptype varx" "type = real\\*4 \\(6,5:15,17:28\\)" +# Intel Fortran Compiler 10.1.008 uses -1 there, GCC uses 1. +gdb_test "p l" "\\$\[0-9\]* = (\\.TRUE\\.|4294967295)" + +gdb_breakpoint [gdb_get_line_number "varx-filled"] +gdb_continue_to_breakpoint "varx-filled" +gdb_test "p varx(2, 5, 17)" "\\$\[0-9\]* = 6" +gdb_test "p varx(1, 5, 17)" "\\$\[0-9\]* = 7" +gdb_test "p varx(2, 6, 18)" "\\$\[0-9\]* = 8" +gdb_test "p varx(6, 15, 28)" "\\$\[0-9\]* = 9" +# The latter one is for the Intel Fortran Compiler 10.1.008 pointer type. +gdb_test "p varv" "\\$\[0-9\]* = (|.*Unable to access the object because the array is not associated.)" +gdb_test "ptype varv" "type = (|.*Unable to access the object because the array is not associated.)" + +gdb_breakpoint [gdb_get_line_number "varv-associated"] +gdb_continue_to_breakpoint "varv-associated" +gdb_test "p varx(3, 7, 19)" "\\$\[0-9\]* = 6" +gdb_test "p varv(3, 7, 19)" "\\$\[0-9\]* = 6" +# Intel Fortran Compiler 10.1.008 uses -1 there, GCC uses 1. +gdb_test "p l" "\\$\[0-9\]* = (\\.TRUE\\.|4294967295)" +gdb_test "ptype varx" "type = real\\*4 \\(6,5:15,17:28\\)" +# Intel Fortran Compiler 10.1.008 uses the pointer type. +gdb_test "ptype varv" "type = (PTR TO -> \\( )?real\\*4 \\(6,5:15,17:28\\)\\)?" + +gdb_breakpoint [gdb_get_line_number "varv-filled"] +gdb_continue_to_breakpoint "varv-filled" +gdb_test "p varx(3, 7, 19)" "\\$\[0-9\]* = 10" +gdb_test "p varv(3, 7, 19)" "\\$\[0-9\]* = 10" + +gdb_breakpoint [gdb_get_line_number "varv-deassociated"] +gdb_continue_to_breakpoint "varv-deassociated" +# The latter one is for the Intel Fortran Compiler 10.1.008 pointer type. +gdb_test "p varv" "\\$\[0-9\]* = (|.*Unable to access the object because the array is not associated.)" +gdb_test "ptype varv" "type = (|.*Unable to access the object because the array is not associated.)" +gdb_test "p l" "\\$\[0-9\]* = \\.FALSE\\." +gdb_test "p varv(1,5,17)" "Unable to access the object because the array is not associated\\." +gdb_test "ptype varv(1,5,17)" "Unable to access the object because the array is not associated\\." + +gdb_breakpoint [gdb_get_line_number "varx-deallocated"] +gdb_continue_to_breakpoint "varx-deallocated" +gdb_test "p varx" "\\$\[0-9\]* = " +gdb_test "ptype varx" "type = " +gdb_test "p l" "\\$\[0-9\]* = \\.FALSE\\." +gdb_test "p varx(1,5,17)" "Unable to access the object because the array is not allocated\\." +gdb_test "ptype varx(1,5,17)" "Unable to access the object because the array is not allocated\\." + +gdb_breakpoint [gdb_get_line_number "vary-passed"] +gdb_continue_to_breakpoint "vary-passed" +# $1 = (( ( 1, 1, 1, 1, 1, 1) ( 1, 1, 1, 1, 1, 1) --- , 1) ) ( ( 1, 1, ...) ...) ...) +gdb_test "p vary" "\\$\[0-9\]* = \\(\[()1, .\]*\\)" + +gdb_breakpoint [gdb_get_line_number "vary-filled"] +gdb_continue_to_breakpoint "vary-filled" +gdb_test "ptype vary" "type = real\\*4 \\(10,10\\)" +gdb_test "p vary(1, 1)" "\\$\[0-9\]* = 8" +gdb_test "p vary(2, 2)" "\\$\[0-9\]* = 9" +gdb_test "p vary(1, 3)" "\\$\[0-9\]* = 10" +# $1 = (( ( 3, 3, 3, 3, 3, 3) ( 3, 3, 3, 3, 3, 3) --- , 3) ) ( ( 3, 3, ...) ...) ...) +gdb_test "p varw" "\\$\[0-9\]* = \\(\[()3, .\]*\\)" + +gdb_breakpoint [gdb_get_line_number "varw-almostfilled"] +gdb_continue_to_breakpoint "varw-almostfilled" +gdb_test "ptype varw" "type = real\\*4 \\(5,4,3\\)" +gdb_test "p varw(3,1,1)=1" "\\$\[0-9\]* = 1" +# $1 = (( ( 6, 5, 1, 5, 5, 5) ( 5, 5, 5, 5, 5, 5) --- , 5) ) ( ( 5, 5, ...) ...) ...) +gdb_test "p varw" "\\$\[0-9\]* = \\( *\\( *\\( *6, *5, *1,\[()5, .\]*\\)" +# "up" works with GCC but other Fortran compilers may copy the values into the +# outer function only on the exit of the inner function. +gdb_test "finish" ".*call bar \\(y, x\\)" +gdb_test "p z(2,4,5)" "\\$\[0-9\]* = 3" +gdb_test "p z(2,4,6)" "\\$\[0-9\]* = 6" +gdb_test "p z(2,4,7)" "\\$\[0-9\]* = 5" +gdb_test "p z(4,4,6)" "\\$\[0-9\]* = 1" + +gdb_breakpoint [gdb_get_line_number "varz-almostfilled"] +gdb_continue_to_breakpoint "varz-almostfilled" +# GCC uses the pointer type here, Intel Fortran Compiler 10.1.008 does not. +gdb_test "ptype varz" "type = (PTR TO -> \\( )?real\\*4 \\(\\*\\)\\)?" +# Intel Fortran Compiler 10.1.008 has a bug here - (2:11,7:7) +# as it produces DW_AT_lower_bound == DW_AT_upper_bound == 7. +gdb_test "ptype vart" "type = (PTR TO -> \\( )?real\\*4 \\(2:11,7:\\*\\)\\)?" +gdb_test "p varz(3)" "\\$\[0-9\]* = 4" +# maps to foo::vary(1,1) +gdb_test "p vart(2,7)" "\\$\[0-9\]* = 8" +# maps to foo::vary(2,2) +gdb_test "p vart(3,8)" "\\$\[0-9\]* = 9" +# maps to foo::vary(1,3) +gdb_test "p vart(2,9)" "\\$\[0-9\]* = 10" diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/testsuite/gdb.fortran/dynamic.f90 gdb-6.8cvs20080219/gdb/testsuite/gdb.fortran/dynamic.f90 --- gdb-6.8cvs20080219-fortranless/gdb/testsuite/gdb.fortran/dynamic.f90 1970-01-01 01:00:00.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/testsuite/gdb.fortran/dynamic.f90 2008-02-22 16:59:42.000000000 +0100 @@ -0,0 +1,97 @@ +! Copyright 2007 Free Software Foundation, Inc. +! +! This program 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 program 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 program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +! +! Ihis file is the Fortran source file for dynamic.exp. +! Original file written by Jakub Jelinek . +! Modified for the GDB testcase by Jan Kratochvil . + +subroutine baz + real, target, allocatable :: varx (:, :, :) + real, pointer :: varv (:, :, :) + real, target :: varu (1, 2, 3) + logical :: l + allocate (varx (1:6, 5:15, 17:28)) ! varx-init + l = allocated (varx) + varx(:, :, :) = 6 ! varx-allocated + varx(1, 5, 17) = 7 + varx(2, 6, 18) = 8 + varx(6, 15, 28) = 9 + varv => varx ! varx-filled + l = associated (varv) + varv(3, 7, 19) = 10 ! varv-associated + varv => null () ! varv-filled + l = associated (varv) + deallocate (varx) ! varv-deassociated + l = allocated (varx) + varu(:, :, :) = 10 ! varx-deallocated + allocate (varv (1:6, 5:15, 17:28)) + l = associated (varv) + varv(:, :, :) = 6 + varv(1, 5, 17) = 7 + varv(2, 6, 18) = 8 + varv(6, 15, 28) = 9 + deallocate (varv) + l = associated (varv) + varv => varu + varv(1, 1, 1) = 6 + varv(1, 2, 3) = 7 + l = associated (varv) +end subroutine baz +subroutine foo (vary, varw) + real :: vary (:, :) + real :: varw (:, :, :) + vary(:, :) = 4 ! vary-passed + vary(1, 1) = 8 + vary(2, 2) = 9 + vary(1, 3) = 10 + varw(:, :, :) = 5 ! vary-filled + varw(1, 1, 1) = 6 + varw(2, 2, 2) = 7 ! varw-almostfilled +end subroutine foo +subroutine bar (varz, vart) + real :: varz (*) + real :: vart (2:11, 7:*) + varz(1:3) = 4 + varz(2) = 5 ! varz-almostfilled +end subroutine bar +program test + interface + subroutine foo (vary, varw) + real :: vary (:, :) + real :: varw (:, :, :) + end subroutine + end interface + interface + subroutine bar (varz, vart) + real :: varz (*) + real :: vart (2:11, 7:*) + end subroutine + end interface + real :: x (10, 10), y (5), z(8, 8, 8) + x(:,:) = 1 + y(:) = 2 + z(:,:,:) = 3 + call baz + call foo (x, z(2:6, 4:7, 6:8)) + call bar (y, x) + if (x (1, 1) .ne. 8 .or. x (2, 2) .ne. 9 .or. x (1, 2) .ne. 4) call abort + if (x (1, 3) .ne. 10) call abort + if (z (2, 4, 6) .ne. 6 .or. z (3, 5, 7) .ne. 7 .or. z (2, 4, 7) .ne. 5) call abort + if (any (y .ne. (/4, 5, 4, 2, 2/))) call abort + call foo (transpose (x), z) + if (x (1, 1) .ne. 8 .or. x (2, 2) .ne. 9 .or. x (1, 2) .ne. 4) call abort + if (x (3, 1) .ne. 10) call abort +end diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/typeprint.c gdb-6.8cvs20080219/gdb/typeprint.c --- gdb-6.8cvs20080219-fortranless/gdb/typeprint.c 2008-02-14 23:04:00.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/typeprint.c 2008-02-22 16:49:35.000000000 +0100 @@ -33,6 +33,7 @@ #include "cp-abi.h" #include "typeprint.h" #include "gdb_string.h" +#include "dwarf2block.h" #include /* For real-type printing in whatis_exp() */ @@ -130,6 +131,7 @@ whatis_exp (char *exp, int show) val = access_value_history (0); type = value_type (val); + object_address_set (VALUE_ADDRESS (val)); if (objectprint) { diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/valops.c gdb-6.8cvs20080219/gdb/valops.c --- gdb-6.8cvs20080219-fortranless/gdb/valops.c 2008-02-22 08:19:37.000000000 +0100 +++ gdb-6.8cvs20080219/gdb/valops.c 2008-02-22 16:47:53.000000000 +0100 @@ -571,12 +571,21 @@ value_at_lazy (struct type *type, CORE_A int value_fetch_lazy (struct value *val) { - CORE_ADDR addr = VALUE_ADDRESS (val) + value_offset (val); - int length = TYPE_LENGTH (value_enclosing_type (val)); + CORE_ADDR addr; + int length; - struct type *type = value_type (val); - if (length) - read_memory (addr, value_contents_all_raw (val), length); + addr = VALUE_ADDRESS (val); + if (LA_VALUE_ADDRESS_GET (value_type (val), &addr)) + { + struct type *type = value_enclosing_type (val); + int length = TYPE_LENGTH (check_typedef (type)); + + if (length) + { + addr += value_offset (val); + read_memory (addr, value_contents_all_raw (val), length); + } + } set_value_lazy (val, 0); return 0; @@ -880,12 +889,17 @@ struct value * value_coerce_array (struct value *arg1) { struct type *type = check_typedef (value_type (arg1)); + CORE_ADDR address; if (VALUE_LVAL (arg1) != lval_memory) error (_("Attempt to take address of value not located in memory.")); + address = VALUE_ADDRESS (arg1); + if (!LA_VALUE_ADDRESS_GET (type, &address)) + error (_("Attempt to take address of non-valid value.")); + return value_from_pointer (lookup_pointer_type (TYPE_TARGET_TYPE (type)), - (VALUE_ADDRESS (arg1) + value_offset (arg1))); + address + value_offset (arg1)); } /* Given a value which is a function, return a value which is a pointer