Re: Patch for pascal-dynamic arrays

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

On Wed, 14 Apr 2010 12:34:52 +0200, Joost van der Sluis wrote:
> On Mon, 2010-04-12 at 21:51 +0200, Jan Kratochvil wrote:
> > Going to try some alternative adjustment of this part.
> 
> Another approach could be to do a full check_typedef before the
> code-block above. But then the OBJECT_ADDRESS (as used by check_typedef
> to evaluate all dynamic properties) has to be set to the right
> (=value_data_address) value. Iirc I've already tried that in an earlier
> patch I've send.

Attached patch should match it I hope.  It is on top of gdb-7.1-18.fc13.

No regressions on {x86_64,x86_64-m32,i686}-fedora13-linux-gnu.  The
gdb.pascal/arrays.exp full-PASS has been tested only for
x86_64-fedora14-linux-gnu.  gdb.pascal/arrays.exp requires fpc-2.4.0-1.fc14
with your FPC upstream patch r15038 as requested in Fedora Bug 589495.

Do you agree with this patch or would you like some changes?  I would push it
only for F-14 (=Rawhide) as fpc-2.4.0+ is only there anyway.


Thanks,
Jan


gdb/
2010-05-07  Jan Kratochvil  <jan.kratochvil@redhat.com>
	    Joost van der Sluis  <joost@cnoc.nl>

	* p-valprint.c: Include dwarf2loc.h.
	(pascal_val_print): New variables back_to, saved_type and
	saved_address.  Initialize them.  Call object_address_get_data instead
	of CHECK_TYPEDEF, return on its failure.  Reread valaddr content if
	ADDRESS has changed.  Pass SAVED_TYPE and SAVED_ADDRESS to
	val_print_array_elements.  Cleanup to BACK_TO on any return code path.
	Never print TYPE_CODE_INT array for language_pascal as a string.
	* valprint.c: Include dwarf2loc.h.
	(val_print_array_elements): New variables back_to, saved_type and
	saved_address.  Initialize them.  Call object_address_get_data, return
	on its failure.  Reread valaddr content if ADDRESS has changed.
	Cleanup to BACK_TO on any return code path.  Protect ELTTYPE against
	check_typedef.  Initialize ELTLEN by the byte stride now.  Remove the
	TYPE_LENGTH bounds initialization possibility.

	* valops.c (object_address_get_data): Return now struct type *.  Adjust
	the function comment and function code.
	* value.h (object_address_get_data): Likewise.

gdb/testsuite/
2010-04-12  Joost van der Sluis  <joost@cnoc.nl>

	* gdb.pascal/arrays.exp, gdb.pascal/arrays.pas: New.
	* lib/pascal.exp: Added variables fpcversion_major, fpcversion_minor and
	fpcversion_release with the version of the used compiler.

--- ./gdb/p-valprint.c	2010-01-14 09:03:36.000000000 +0100
+++ ./gdb/p-valprint.c	2010-05-07 00:17:16.000000000 +0200
@@ -38,6 +38,7 @@
 #include "p-lang.h"
 #include "cp-abi.h"
 #include "cp-support.h"
+#include "dwarf2loc.h"
 
 
 
@@ -66,8 +67,27 @@ pascal_val_print (struct type *type, con
   struct type *char_type;
   LONGEST val;
   CORE_ADDR addr;
+  struct cleanup *back_to;
+  struct type *saved_type = type;
+  CORE_ADDR saved_address = address;
+  
+  back_to = make_cleanup (null_cleanup, 0);
+  type = object_address_get_data (type, &address);
+  if (type == NULL)
+    {
+      fputs_filtered (object_address_data_not_valid (saved_type), stream);
+      gdb_flush (stream);
+      do_cleanups (back_to);
+      return 0;
+    }
+  if (address != saved_address)
+    {
+      size_t length = TYPE_LENGTH (type);
 
-  CHECK_TYPEDEF (type);
+      valaddr = xmalloc (length);
+      make_cleanup (xfree, (gdb_byte *) valaddr);
+      read_memory (address, (gdb_byte *) valaddr, length);
+    }
   switch (TYPE_CODE (type))
     {
     case TYPE_CODE_ARRAY:
@@ -82,9 +102,10 @@ pascal_val_print (struct type *type, con
 	    }
 	  /* For an array of chars, print with string syntax.  */
 	  if ((eltlen == 1 || eltlen == 2 || eltlen == 4)
-	      && ((TYPE_CODE (elttype) == TYPE_CODE_INT)
-	       || ((current_language->la_language == language_pascal)
-		   && (TYPE_CODE (elttype) == TYPE_CODE_CHAR)))
+	      && ((current_language->la_language != language_pascal
+	           && TYPE_CODE (elttype) == TYPE_CODE_INT)
+		  || (current_language->la_language == language_pascal
+		      && TYPE_CODE (elttype) == TYPE_CODE_CHAR))
 	      && (options->format == 0 || options->format == 's'))
 	    {
 	      /* If requested, look for the first null char and only print
@@ -122,8 +143,9 @@ pascal_val_print (struct type *type, con
 		{
 		  i = 0;
 		}
-	      val_print_array_elements (type, valaddr + embedded_offset, address, stream,
-					recurse, options, i);
+	      val_print_array_elements (saved_type, valaddr + embedded_offset,
+					saved_address, stream, recurse, options,
+					i);
 	      fprintf_filtered (stream, "}");
 	    }
 	  break;
@@ -161,6 +183,7 @@ pascal_val_print (struct type *type, con
 	      /* Try to print what function it points to.  */
 	      print_address_demangle (gdbarch, addr, stream, demangle);
 	      /* Return value is irrelevant except for string pointers.  */
+	      do_cleanups (back_to);
 	      return (0);
 	    }
 
@@ -248,6 +271,7 @@ pascal_val_print (struct type *type, con
 	  /* Return number of characters printed, including the terminating
 	     '\0' if we reached the end.  val_print_string takes care including
 	     the terminating '\0' if necessary.  */
+	  do_cleanups (back_to);
 	  return i;
 	}
       break;
@@ -535,6 +559,7 @@ pascal_val_print (struct type *type, con
       error (_("Invalid pascal type code %d in symbol table."), TYPE_CODE (type));
     }
   gdb_flush (stream);
+  do_cleanups (back_to);
   return (0);
 }
 
--- ./gdb/testsuite/gdb.pascal/arrays.exp	1970-01-01 01:00:00.000000000 +0100
+++ ./gdb/testsuite/gdb.pascal/arrays.exp	2010-05-07 00:17:13.000000000 +0200
@@ -0,0 +1,104 @@
+# Copyright 2008, 2009 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 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 $tracelevel then {
+    strace $tracelevel
+}
+
+load_lib "pascal.exp"
+
+set testfile "arrays"
+set srcfile ${testfile}.pas
+set binfile ${objdir}/${subdir}/${testfile}$EXEEXT
+
+# These tests only work with fpc, using the -gw3 compile-option
+pascal_init
+if { $pascal_compiler_is_fpc != 1 } {
+  return -1
+}
+
+# Detect if the fpc version is below 2.3.0
+set fpc_generates_dwarf_for_dynamic_arrays 1
+if { ($fpcversion_major < 2) || ( ($fpcversion_major == 2) && ($fpcversion_minor < 3))}  {
+  set fpc_generates_dwarf_for_dynamic_arrays 0
+}
+
+
+if {[gdb_compile_pascal "-gw3 ${srcdir}/${subdir}/${srcfile}" "${binfile}" executable [list debug ]] != "" } {
+  return -1
+}
+
+gdb_exit
+gdb_start
+gdb_reinitialize_dir $srcdir/$subdir
+gdb_load ${binfile}
+set bp_location1 [gdb_get_line_number "set breakpoint 1 here"]
+set bp_location2 [gdb_get_line_number "set breakpoint 2 here"]
+
+
+if { [gdb_breakpoint ${srcfile}:${bp_location1}] } {
+    pass "setting breakpoint 1"
+}
+if { [gdb_breakpoint ${srcfile}:${bp_location2}] } {
+    pass "setting breakpoint 2"
+}
+
+# Verify that "start" lands inside the right procedure.
+if { [gdb_start_cmd] < 0 } {
+    untested start
+    return -1
+}
+
+gdb_test "" ".* at .*${srcfile}.*" "start"
+
+gdb_test "cont" "Breakpoint .*:${bp_location1}.*" "Going to first breakpoint"
+
+gdb_test "print StatArrInt" ".* = \\{50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61\\}" "Print static array of integer type"
+gdb_test "print StatArrInt_" ".* = \\{50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61\\}" "Print static array of integer"
+
+gdb_test "cont" "Breakpoint .*:${bp_location2}.*" "Going to second breakpoint"
+
+gdb_test "print StatArrChar" ".* = 'abcdefghijkl'" "Print static array of char"
+gdb_test "print Stat2dArrInt" ".* = \\{\\{0, 1, 2, 3, 4\\}, \\{1, 2, 3, 4, 5\\}, \\{2, 3, 4, 5, 6\\}, \\{3, 4, 5, 6, 7\\}, \\{4, 5, 6, 7, 8\\}, \\{5, 6, 7, 8, 9\\}, \\{6, 7, 8, 9, 10\\}, \\{7, 8, 9, 10, 11\\}, \\{8, 9, 10, 11, 12\\}, \\{9, 10, 11, 12, 13\\}, \\{10, 11, 12, 13, 14\\}, \\{11, 12, 13, 14, 15\\}\\}" "Print static 2-dimensional array of integer"
+
+if { $fpc_generates_dwarf_for_dynamic_arrays == 0} {
+  setup_xfail "*-*-*"
+}
+gdb_test "print DynArrInt" ".* = \\{50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62\\}" "Print dynamic array of integer type"
+if { $fpc_generates_dwarf_for_dynamic_arrays == 0} {
+  setup_xfail "*-*-*"
+}
+gdb_test "print DynArrInt_" ".* = \\{50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62\\}" "Print dynamic array of integer"
+
+if { $fpc_generates_dwarf_for_dynamic_arrays == 0} {
+  setup_xfail "*-*-*"
+}
+gdb_test "print s" ".* = 'test'#0'string'" "Print string containing null-char"
+
+if { $fpc_generates_dwarf_for_dynamic_arrays == 0} {
+  setup_xfail "*-*-*"
+}
+gdb_test "print DynArrStr" ".* = \\{'dstr0', 'dstr1', 'dstr2', 'dstr3', 'dstr4', 'dstr5', 'dstr6', 'dstr7', 'dstr8', 'dstr9', 'dstr10', 'dstr11', 'dstr12'\\}" "Print dynamic array of string"
+
+if { $fpc_generates_dwarf_for_dynamic_arrays == 0} {
+  setup_xfail "*-*-*"
+}
+gdb_test "print StatArrStr" ".* = \\{'str0', 'str1', 'str2', 'str3', 'str4', 'str5', 'str6', 'str7', 'str8', 'str9', 'str10', 'str11', 'str12'\\}" "Print static array of string"
+
+if { $fpc_generates_dwarf_for_dynamic_arrays == 0} {
+  setup_xfail "*-*-*"
+}
+gdb_test "print DynArrChar" ".* = 'abcdefghijklm'" "Print dynamic array of char"
+
--- ./gdb/testsuite/gdb.pascal/arrays.pas	1970-01-01 01:00:00.000000000 +0100
+++ ./gdb/testsuite/gdb.pascal/arrays.pas	2010-05-07 00:17:13.000000000 +0200
@@ -0,0 +1,82 @@
+{
+ Copyright 2008, 2009 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 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/>.
+}
+
+program arrays;
+
+{$mode objfpc}{$h+}
+
+uses sysutils;
+
+type TStatArrInt= array[0..11] of integer;
+     TDynArrInt= array of integer;
+     TStatArrStr= array[0..12] of string;
+     TDynArrStr= array of string;
+     TDynArrChar = array of char;
+     TStatArrChar = array [0..11] of char;
+
+     TStat2dArrInt = array[0..11,0..4] of integer;
+
+var StatArrInt: TStatArrInt;
+    StatArrInt_: Array[0..11] of integer;
+    DynArrInt:  TDynArrInt;
+    DynArrInt_: Array of integer;
+    StatArrStr: TStatArrStr;
+    DynArrStr: TDynArrStr;
+    StatArrChar: TStatArrChar;
+    DynArrChar: TDynArrChar;
+
+    Stat2dArrInt: TStat2dArrInt;
+
+    s: string;
+	
+    i,j : integer;
+
+begin
+  for i := 0 to 11 do
+    begin
+    StatArrInt[i]:= i+50;
+    StatArrInt_[i]:= i+50;
+    StatArrChar[i]:= chr(ord('a')+i);
+    for j := 0 to 4 do
+      Stat2dArrInt[i,j]:=i+j;
+    end;
+  writeln(StatArrInt_[0]);
+  writeln(StatArrInt[0]); { set breakpoint 1 here }
+  writeln(StatArrChar[0]);
+  writeln(Stat2dArrInt[0,0]);
+
+  setlength(DynArrInt,13);
+  setlength(DynArrInt_,13);
+  setlength(DynArrStr,13);
+  setlength(DynArrChar,13);
+  for i := 0 to 12 do
+    begin
+    DynArrInt[i]:= i+50;
+    DynArrInt_[i]:= i+50;
+    DynArrChar[i]:= chr(ord('a')+i);
+    StatArrStr[i]:='str'+inttostr(i);
+    DynArrStr[i]:='dstr'+inttostr(i);
+    end;
+  writeln(DynArrInt_[1]);
+  writeln(DynArrInt[1]); 
+  writeln(DynArrStr[1]); 
+  writeln(StatArrStr[1]);
+  writeln(DynArrChar[1]);
+
+  s := 'test'#0'string';
+  writeln(s); { set breakpoint 2 here }
+end.
--- ./gdb/testsuite/lib/pascal.exp	2010-01-01 08:32:07.000000000 +0100
+++ ./gdb/testsuite/lib/pascal.exp	2010-05-07 00:17:13.000000000 +0200
@@ -37,6 +37,9 @@ proc pascal_init {} {
     global pascal_compiler_is_fpc
     global gpc_compiler
     global fpc_compiler
+    global fpcversion_major
+    global fpcversion_minor
+    global fpcversion_release
     global env
  
     if { $pascal_init_done == 1 } {
@@ -64,6 +67,20 @@ proc pascal_init {} {
 	    set pascal_compiler_is_fpc 1
 	    verbose -log "Free Pascal compiler found"
 	}
+
+	# Detect the fpc-version
+	if { $pascal_compiler_is_fpc == 1 } {
+	    set fpcversion_major 1
+	    set fpcversion_minor 0
+	    set fpcversion_release 0
+	    set fpcversion [ remote_exec host $fpc_compiler "-iV" ] 
+	    if [regexp {.*([0-9]+)\.([0-9]+)\.([0-9]+).?} $fpcversion] {
+              regsub {.*([0-9]+)\.([0-9]+)\.([0-9]+).?\n?.?} $fpcversion {\1} fpcversion_major
+              regsub {.*([0-9]+)\.([0-9]+)\.([0-9]+).?\n?.?} $fpcversion {\2} fpcversion_minor
+              regsub {.*([0-9]+)\.([0-9]+)\.([0-9]+).?\n?.?} $fpcversion {\3} fpcversion_release
+	    }
+            verbose -log "Freepascal version: $fpcversion_major.$fpcversion_minor.$fpcversion_release"
+	}
     }
     set pascal_init_done 1
 }   
--- ./gdb/valops.c	2010-05-07 00:16:49.000000000 +0200
+++ ./gdb/valops.c	2010-05-07 00:17:16.000000000 +0200
@@ -868,14 +868,15 @@ object_address_data_not_valid (struct ty
   return NULL;
 }
 
-/* Return non-zero if the variable is valid.  If it is valid the function
-   may store the data address (DW_AT_DATA_LOCATION) of TYPE at *ADDRESS_RETURN.
-   You must set *ADDRESS_RETURN from value_raw_address (VAL) before calling this
-   function.  If no DW_AT_DATA_LOCATION is present for TYPE the address at
-   *ADDRESS_RETURN is left unchanged.  ADDRESS_RETURN must not be NULL, use
+/* Return non-NULL check_typedef result on TYPE if the variable is valid.  If
+   it is valid the function may store the data address (DW_AT_DATA_LOCATION) of
+   TYPE at *ADDRESS_RETURN.  You must set *ADDRESS_RETURN from
+   value_raw_address (VAL) before calling this function.  If no
+   DW_AT_DATA_LOCATION is present for TYPE the address at *ADDRESS_RETURN is
+   left unchanged.  ADDRESS_RETURN must not be NULL, use
    object_address_data_not_valid () for just the data validity check.  */
 
-int
+struct type *
 object_address_get_data (struct type *type, CORE_ADDR *address_return)
 {
   gdb_assert (address_return != NULL);
@@ -890,7 +891,7 @@ object_address_get_data (struct type *ty
     {
       /* 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;
+      return NULL;
     }
 
   if (TYPE_DATA_LOCATION_IS_ADDR (type))
@@ -899,7 +900,7 @@ object_address_get_data (struct type *ty
     *address_return
       = dwarf_locexpr_baton_eval (TYPE_DATA_LOCATION_DWARF_BLOCK (type));
 
-  return 1;
+  return type;
 }
 
 /* Helper function for value_at, value_at_lazy, and value_at_lazy_stack.  */
--- ./gdb/valprint.c	2010-05-07 00:16:49.000000000 +0200
+++ ./gdb/valprint.c	2010-05-07 00:23:48.000000000 +0200
@@ -35,6 +35,7 @@
 #include "exceptions.h"
 #include "dfp.h"
 #include "python/python.h"
+#include "dwarf2loc.h"
 
 #include <errno.h>
 
@@ -1109,6 +1110,7 @@ val_print_array_elements (struct type *t
 {
   unsigned int things_printed = 0;
   unsigned len;
+  struct type *saved_type = type;
   struct type *elttype, *index_type;
   unsigned eltlen;
   /* Position of the array element we are examining to see
@@ -1117,9 +1119,33 @@ val_print_array_elements (struct type *t
   /* Number of repetitions we have detected so far.  */
   unsigned int reps;
   long low_bound_index = 0;
+  struct cleanup *back_to;
+  CORE_ADDR saved_address = address;
+  
+  back_to = make_cleanup (null_cleanup, 0);
+  type = object_address_get_data (type, &address);
+  if (!type)
+    {
+      fputs_filtered (object_address_data_not_valid (type), stream);
+      do_cleanups (back_to);
+      return;
+    }
+  if (address != saved_address)
+    {
+      size_t length = TYPE_LENGTH (type);
 
-  elttype = TYPE_TARGET_TYPE (type);
-  eltlen = TYPE_LENGTH (check_typedef (elttype));
+      valaddr = xmalloc (length);
+      make_cleanup (xfree, (gdb_byte *) valaddr);
+      read_memory (address, (gdb_byte *) valaddr, length);
+    }
+
+  /* Skip typedefs but do not resolve TYPE_DYNAMIC.  */
+  elttype = saved_type;
+  while (TYPE_CODE (elttype) == TYPE_CODE_TYPEDEF)
+    elttype = TYPE_TARGET_TYPE (elttype);
+  elttype = TYPE_TARGET_TYPE (elttype);
+
+  eltlen = TYPE_ARRAY_BYTE_STRIDE_VALUE (type);
   index_type = TYPE_INDEX_TYPE (type);
 
   /* Compute the number of elements in the array.  On most arrays,
@@ -1127,9 +1153,6 @@ val_print_array_elements (struct type *t
      is simply the size of the array divided by the size of the elements.
      But for arrays of elements whose size is zero, we need to look at
      the bounds.  */
-  if (eltlen != 0)
-    len = TYPE_LENGTH (type) / eltlen;
-  else
     {
       long low, hi;
       if (get_array_bounds (type, &low, &hi))
@@ -1203,6 +1226,8 @@ val_print_array_elements (struct type *t
     {
       fprintf_filtered (stream, "...");
     }
+
+  do_cleanups (back_to);
 }
 
 /* Read LEN bytes of target memory at address MEMADDR, placing the
--- ./gdb/value.h	2010-05-07 00:16:49.000000000 +0200
+++ ./gdb/value.h	2010-05-07 00:17:16.000000000 +0200
@@ -349,8 +349,8 @@ extern struct value *value_from_decfloat
 					  const gdb_byte *decbytes);
 
 extern const char *object_address_data_not_valid (struct type *type);
-extern int object_address_get_data (struct type *type,
-				    CORE_ADDR *address_return);
+extern struct type *object_address_get_data (struct type *type,
+					     CORE_ADDR *address_return);
 
 extern struct value *value_at (struct type *type, CORE_ADDR addr);
 extern struct value *value_at_lazy (struct type *type, CORE_ADDR addr);