[3/6] Fortran dynamic arrays #2: DW_FORM_block* execution

[Jan Kratochvil <jan dot kratochvil at redhat dot com>]

Hi,

currently the DWARF support never executed the DW_FORM_block* data.
It also implements the DWARF support for DW_OP_push_object_address.


Regards,
Jan

2007-11-23  Jan Kratochvil  <jan.kratochvil@redhat.com>

	* Makefile.in: Update dependencies.
	(dwarf2block_h, dwarf2block.o): New.
	(COMMON_OBS): Add `dwarf2block.o'.
	* dwarf2expr.h (struct dwarf_expr_context): New (uncommented) field
	GET_OBJECT_ADDRESS.
	* dwarf2expr.c (execute_stack_op): New support for
	`DW_OP_push_object_address'.
	* dwarf2read.c: Include "dwarf2block.h".
	(struct dwarf_block): Move into ...
	* dwarf2block.h: ... here.  New file.
	* dwarf2block.c: New file.
	* printcmd.c (print_command_1): New comment about OBJECT_ADDRESS_SET.
	* dwarf2loc.c: Include "dwarf2block.h".
	(dwarf2_evaluate_loc_desc): Call OBJECT_ADDRESS_SET.
	* typeprint.c: Include "dwarf2block.h".
	(whatis_exp): Call OBJECT_ADDRESS_SET.

Index: sources/gdb/Makefile.in
===================================================================
--- sources.orig/gdb/Makefile.in	2007-11-23 22:16:47.000000000 +0100
+++ sources/gdb/Makefile.in	2007-11-23 22:23:35.000000000 +0100
@@ -749,6 +749,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
@@ -1039,7 +1040,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 \
@@ -2035,6 +2036,8 @@ dummy-frame.o: dummy-frame.c $(defs_h) $
 	$(frame_h) $(inferior_h) $(gdb_assert_h) $(frame_unwind_h) \
 	$(command_h) $(gdbcmd_h) $(gdb_string_h)
 dfp.o: dfp.c $(defs_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) \
@@ -2045,13 +2048,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)
 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) \
@@ -2880,7 +2884,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)
Index: sources/gdb/dwarf2block.c
===================================================================
--- /dev/null	1970-01-01 00:00:00.000000000 +0000
+++ sources/gdb/dwarf2block.c	2007-11-23 22:20:54.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 <http://www.gnu.org/licenses/>.  */
+
+#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;
+}
Index: sources/gdb/dwarf2block.h
===================================================================
--- /dev/null	1970-01-01 00:00:00.000000000 +0000
+++ sources/gdb/dwarf2block.h	2007-11-23 22:22:43.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 <http://www.gnu.org/licenses/>.  */
+
+#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) */
Index: sources/gdb/dwarf2expr.h
===================================================================
--- sources.orig/gdb/dwarf2expr.h	2007-11-23 22:20:01.000000000 +0100
+++ sources/gdb/dwarf2expr.h	2007-11-23 22:20:54.000000000 +0100
@@ -60,10 +60,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
Index: sources/gdb/dwarf2expr.c
===================================================================
--- sources.orig/gdb/dwarf2expr.c	2007-11-23 22:16:47.000000000 +0100
+++ sources/gdb/dwarf2expr.c	2007-11-23 22:20:54.000000000 +0100
@@ -747,6 +747,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);
 	}
Index: sources/gdb/dwarf2read.c
===================================================================
--- sources.orig/gdb/dwarf2read.c	2007-11-23 22:20:54.000000000 +0100
+++ sources/gdb/dwarf2read.c	2007-11-23 22:23:17.000000000 +0100
@@ -45,6 +45,7 @@
 #include "hashtab.h"
 #include "command.h"
 #include "gdbcmd.h"
+#include "dwarf2block.h"
 
 #include <fcntl.h>
 #include "gdb_string.h"
@@ -573,13 +574,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
Index: sources/gdb/printcmd.c
===================================================================
--- sources.orig/gdb/printcmd.c	2007-11-23 22:16:47.000000000 +0100
+++ sources/gdb/printcmd.c	2007-11-23 22:20:54.000000000 +0100
@@ -873,6 +873,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))
     {
Index: sources/gdb/dwarf2loc.c
===================================================================
--- sources.orig/gdb/dwarf2loc.c	2007-11-23 22:16:47.000000000 +0100
+++ sources/gdb/dwarf2loc.c	2007-11-23 22:20:54.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);
Index: sources/gdb/typeprint.c
===================================================================
--- sources.orig/gdb/typeprint.c	2007-11-23 22:16:47.000000000 +0100
+++ sources/gdb/typeprint.c	2007-11-23 22:20:54.000000000 +0100
@@ -33,6 +33,7 @@
 #include "cp-abi.h"
 #include "typeprint.h"
 #include "gdb_string.h"
+#include "dwarf2block.h"
 #include <errno.h>
 
 /* 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)
     {