Re: [RFC]: Patch to support Fortran derived type - Revised

[Wu Zhou <woodzltc@cn.ibm.com>]

On Mon, 20 Feb 2006, Daniel Jacobowitz wrote:

> On Sat, Dec 10, 2005 at 03:24:29PM +0800, Wu Zhou wrote:
> > > > +name	:	NAME
> > > > +		{  $$ = $1.stoken; }
> > > > +	;
> > > > +
> > > 
> > > Why not just use name_not_typename instead of adding "name"?
> > > 
> > > Also, the comments in name_not_typename don't apply here; you could
> > > also handle exp : exp % NAME_OR_INT as a name.  But, I don't think that
> > > adds much value.  The whole NAME_OR_INT thing seems like overkill.
> > 
> > AFAICT, adding "name" might be a more direct and easier way to handle 
> > that. I am not sure yet how to handle name_not_typename or NAME_OR_INT, 
> > but it seems that some more work is needed in either the parsing or 
> > evaluation phase.  What is more, using "name" is the same way as that in
> > c and c++ expression parser, which looks to be more consistent. 
> > 
> > Does these make sense?
> 
> I suppose.
> 
> > 2005-12-10  Wu Zhou  <woodzltc@cn.ibm.com>
> > 
> > 	* gdb.fortran/derived-type.f90: New file.
> > 	* .fortran/derived-type.exp: New testcase.
> 
> Typo there.
> 
> > +++ gdb.fortran/derived-type.f90	16 Nov 2005 06:50:22 -0000
> > @@ -0,0 +1,22 @@
> > +program main
> 
> Please add a copyright notice to all new tests.
> 
> Otherwise the code and testcase look fine; Eli had some additional
> comments on the texinfo bits.

Hi Daniel,

Thanks for the review.  I had fix the above typo and add the copyright 
notice to gdb.fortran/derived-type.f90 and committed them into the CVS.

For the document patch, I will resend a modified version for review.

Here is what I checked in:

2006-02-24  Wu Zhou  <woodzltc@cn.ibm.com>

	* f-exp.y: Symbol '%' is not used as the modulus operator in
	Fortran.  Delete this from Fortran expression.
	It is now used by Fortran 90 and later to access the member
	of derived type.  Add this into Fortran expression.
	* f-valprint.c (f_val_print): Add code to handle TYPE_CODE_STRUCT.
	Print each elements in the derived type.
	* f-typeprint.c (print_equivalent_f77_float_type): Add a parameter
	level into the function definition to do indented printing.  And
	call fprintfi_filtered instead to do indented printing.
	(f_type_print_base): Replace fprintf_filtered with the indented
	version (fprintfi_filtered).
	(f_type_print_base): Call indented print_equivalent_f77_float_type.
	(f_type_print_base): Add code to handle TYPE_CODE_STRUCT.  Print
	the definition of the derived type.

Index: f-exp.y
===================================================================
RCS file: /cvs/src/src/gdb/f-exp.y,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- src/gdb/f-exp.y	2005/12/17 22:33:59	1.19
+++ src/gdb/f-exp.y	2006/02/24 07:26:10	1.20
@@ -1,6 +1,6 @@
 /* YACC parser for Fortran expressions, for GDB.
    Copyright (C) 1986, 1989, 1990, 1991, 1993, 1994, 1995, 1996, 2000, 
2001,
-   2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+   2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
 
    Contributed by Motorola.  Adapted from the C parser by Farooq Butt
    (fmbutt@engage.sps.mot.com).
@@ -178,6 +178,7 @@
 %token <lval> BOOLEAN_LITERAL
 %token <ssym> NAME 
 %token <tsym> TYPENAME
+%type <sval> name
 %type <ssym> name_not_typename
 
 /* A NAME_OR_INT is a symbol which is not known in the symbol table,
@@ -217,8 +218,9 @@
 %left LSH RSH
 %left '@'
 %left '+' '-'
-%left '*' '/' '%'
+%left '*' '/'
 %right STARSTAR
+%right '%'
 %right UNARY 
 %right '('
 
@@ -332,6 +334,12 @@
 			  write_exp_elt_opcode (UNOP_CAST); }
 	;
 
+exp     :       exp '%' name
+                        { write_exp_elt_opcode (STRUCTOP_STRUCT);
+                          write_exp_string ($3);
+                          write_exp_elt_opcode (STRUCTOP_STRUCT); }
+        ;
+
 /* Binary operators in order of decreasing precedence.  */
 
 exp	:	exp '@' exp
@@ -350,10 +358,6 @@
 			{ write_exp_elt_opcode (BINOP_DIV); }
 	;
 
-exp	:	exp '%' exp
-			{ write_exp_elt_opcode (BINOP_REM); }
-	;
-
 exp	:	exp '+' exp
 			{ write_exp_elt_opcode (BINOP_ADD); }
 	;
@@ -635,6 +639,10 @@
 		}
 	;
 
+name	:	NAME
+		{  $$ = $1.stoken; }
+	;
+
 name_not_typename :	NAME
 /* These would be useful if name_not_typename was useful, but it is just
    a fake for "variable", so these cause reduce/reduce conflicts because
Index: f-valprint.c
===================================================================
RCS file: /cvs/src/src/gdb/f-valprint.c,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- src/gdb/f-valprint.c	2006/01/18 21:24:19	1.32
+++ src/gdb/f-valprint.c	2006/02/24 07:26:10	1.33
@@ -366,6 +366,7 @@
   struct type *elttype;
   LONGEST val;
   CORE_ADDR addr;
+  int index;
 
   CHECK_TYPEDEF (type);
   switch (TYPE_CODE (type))
@@ -583,6 +584,22 @@
       fprintf_filtered (stream, "<incomplete type>");
       break;
 
+    case TYPE_CODE_STRUCT:
+      /* Starting from the Fortran 90 standard, Fortran supports derived
+         types.  */
+      fprintf_filtered (stream, "{ ");
+      for (index = 0; index < TYPE_NFIELDS (type); index++)
+        {
+          int offset = TYPE_FIELD_BITPOS (type, index) / 8;
+          f_val_print (TYPE_FIELD_TYPE (type, index), valaddr + offset,
+                       embedded_offset, address, stream,
+                       format, deref_ref, recurse, pretty);
+          if (index != TYPE_NFIELDS (type) - 1)
+            fputs_filtered (", ", stream);
+        }
+      fprintf_filtered (stream, "}");
+      break;     
+
     default:
       error (_("Invalid F77 type code %d in symbol table."), TYPE_CODE 
(type));
     }
Index: f-typeprint.c
===================================================================
RCS file: /cvs/src/src/gdb/f-typeprint.c,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- src/gdb/f-typeprint.c	2005/12/17 22:33:59	1.14
+++ src/gdb/f-typeprint.c	2006/02/24 07:26:10	1.15
@@ -1,7 +1,7 @@
 /* Support for printing Fortran types for GDB, the GNU debugger.
 
    Copyright (C) 1986, 1988, 1989, 1991, 1993, 1994, 1995, 1996, 1998,
-   2000, 2001, 2002, 2003 Free Software Foundation, Inc.
+   2000, 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
 
    Contributed by Motorola.  Adapted from the C version by Farooq Butt
    (fmbutt@engage.sps.mot.com).
@@ -41,7 +41,7 @@
 static void f_type_print_args (struct type *, struct ui_file *);
 #endif
 
-static void print_equivalent_f77_float_type (struct type *,
+static void print_equivalent_f77_float_type (int level, struct type *,
 					     struct ui_file *);
 
 static void f_type_print_varspec_suffix (struct type *, struct ui_file *,
@@ -260,13 +260,14 @@
 }
 
 static void
-print_equivalent_f77_float_type (struct type *type, struct ui_file *stream)
+print_equivalent_f77_float_type (int level, struct type *type,
+				 struct ui_file *stream)
 {
   /* Override type name "float" and make it the
      appropriate real. XLC stupidly outputs -12 as a type
      for real when it really should be outputting -18 */
 
-  fprintf_filtered (stream, "real*%d", TYPE_LENGTH (type));
+  fprintfi_filtered (level, stream, "real*%d", TYPE_LENGTH (type));
 }
 
 /* Print the name of the type (or the ultimate pointer target,
@@ -289,6 +290,8 @@
   int retcode;
   int upper_bound;
 
+  int index;
+
   QUIT;
 
   wrap_here ("    ");
@@ -304,7 +307,7 @@
   if ((show <= 0) && (TYPE_NAME (type) != NULL))
     {
       if (TYPE_CODE (type) == TYPE_CODE_FLT)
-	print_equivalent_f77_float_type (type, stream);
+	print_equivalent_f77_float_type (level, type, stream);
       else
 	fputs_filtered (TYPE_NAME (type), stream);
       return;
@@ -335,25 +338,25 @@
       break;
 
     case TYPE_CODE_VOID:
-      fprintf_filtered (stream, "VOID");
+      fprintfi_filtered (level, stream, "VOID");
       break;
 
     case TYPE_CODE_UNDEF:
-      fprintf_filtered (stream, "struct <unknown>");
+      fprintfi_filtered (level, stream, "struct <unknown>");
       break;
 
     case TYPE_CODE_ERROR:
-      fprintf_filtered (stream, "<unknown type>");
+      fprintfi_filtered (level, stream, "<unknown type>");
       break;
 
     case TYPE_CODE_RANGE:
       /* This should not occur */
-      fprintf_filtered (stream, "<range type>");
+      fprintfi_filtered (level, stream, "<range type>");
       break;
 
     case TYPE_CODE_CHAR:
       /* Override name "char" and make it "character" */
-      fprintf_filtered (stream, "character");
+      fprintfi_filtered (level, stream, "character");
       break;
 
     case TYPE_CODE_INT:
@@ -362,24 +365,24 @@
          C-oriented, we must change these to "character" from "char".  */
 
       if (strcmp (TYPE_NAME (type), "char") == 0)
-	fprintf_filtered (stream, "character");
+	fprintfi_filtered (level, stream, "character");
       else
 	goto default_case;
       break;
 
     case TYPE_CODE_COMPLEX:
-      fprintf_filtered (stream, "complex*%d", TYPE_LENGTH (type));
+      fprintfi_filtered (level, stream, "complex*%d", TYPE_LENGTH (type));
       break;
 
     case TYPE_CODE_FLT:
-      print_equivalent_f77_float_type (type, stream);
+      print_equivalent_f77_float_type (level, type, stream);
       break;
 
     case TYPE_CODE_STRING:
       /* Strings may have dynamic upperbounds (lengths) like arrays. */
 
       if (TYPE_ARRAY_UPPER_BOUND_TYPE (type) == BOUND_CANNOT_BE_DETERMINED)
-	fprintf_filtered (stream, "character*(*)");
+	fprintfi_filtered (level, stream, "character*(*)");
       else
 	{
 	  retcode = f77_get_dynamic_upperbound (type, &upper_bound);
@@ -391,6 +394,21 @@
 	}
       break;
 
+    case TYPE_CODE_STRUCT:
+      fprintfi_filtered (level, stream, "Type ");
+      fputs_filtered (TYPE_TAG_NAME (type), stream);
+      fputs_filtered ("\n", stream);
+      for (index = 0; index < TYPE_NFIELDS (type); index++)
+	{
+	  f_print_type (TYPE_FIELD_TYPE (type, index), "", stream, show, level + 4);
+	  fputs_filtered (" :: ", stream);
+	  fputs_filtered (TYPE_FIELD_NAME (type, index), stream);
+	  fputs_filtered ("\n", stream);
+	} 
+      fprintfi_filtered (level, stream, "End Type ");
+      fputs_filtered (TYPE_TAG_NAME (type), stream);
+      break;
+
     default_case:
     default:
       /* Handle types not explicitly handled by the other cases,
@@ -398,7 +416,7 @@
          the type name is, as recorded in the type itself.  If there
          is no type name, then complain. */
       if (TYPE_NAME (type) != NULL)
-	fputs_filtered (TYPE_NAME (type), stream);
+	fprintfi_filtered (level, stream, "%s ", TYPE_NAME (type));
       else
 	error (_("Invalid type code (%d) in symbol table."), TYPE_CODE 
(type));
       break;




Regards
- Wu Zhou