Initial revision

1 files changed, 458 insertions, 0 deletions

diff --git a/gdb/f-typeprint.c b/gdb/f-typeprint.c
new file mode 100644
index 00000000000..09bb3ebd095
--- /dev/null
+++ b/gdb/f-typeprint.c
@@ -0,0 +1,458 @@
+/* Support for printing Fortran types for GDB, the GNU debugger.
+   Copyright 1986, 1988, 1989, 1991, 1993, 1994 Free Software Foundation, Inc.
+   Contributed by Motorola.  Adapted from the C version by Farooq Butt
+   (fmbutt@engage.sps.mot.com).
+
+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 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.  */
+
+#include "defs.h"
+#include "obstack.h"
+#include "bfd.h"
+#include "symtab.h"
+#include "gdbtypes.h"
+#include "expression.h"
+#include "value.h"
+#include "gdbcore.h"
+#include "target.h"
+#include "command.h"
+#include "gdbcmd.h"
+#include "language.h"
+#include "demangle.h"
+#include "f-lang.h"
+#include "typeprint.h"
+#include "frame.h"  /* ??? */
+
+#include "gdb_string.h"
+#include <errno.h>
+
+#if 0	/* Currently unused */
+static void f_type_print_args PARAMS ((struct type *, GDB_FILE *));
+#endif
+
+static void print_equivalent_f77_float_type PARAMS ((struct type *,
+						     GDB_FILE *));
+
+static void f_type_print_varspec_suffix PARAMS ((struct type *, GDB_FILE *,
+						 int, int, int));
+
+void f_type_print_varspec_prefix PARAMS ((struct type *, GDB_FILE *,
+					  int, int));
+
+void f_type_print_base PARAMS ((struct type *, GDB_FILE *, int, int));
+
+
+/* LEVEL is the depth to indent lines by.  */
+
+void
+f_print_type (type, varstring, stream, show, level)
+     struct type *type;
+     char *varstring;
+     GDB_FILE *stream;
+     int show;
+     int level;
+{
+  register enum type_code code;
+  int demangled_args;
+
+  f_type_print_base (type, stream, show, level);
+  code = TYPE_CODE (type);
+  if ((varstring != NULL && *varstring != '\0')
+      ||
+      /* Need a space if going to print stars or brackets;
+	 but not if we will print just a type name.  */
+      ((show > 0 || TYPE_NAME (type) == 0)
+       &&
+       (code == TYPE_CODE_PTR || code == TYPE_CODE_FUNC
+	|| code == TYPE_CODE_METHOD
+	|| code == TYPE_CODE_ARRAY
+	|| code == TYPE_CODE_MEMBER
+	|| code == TYPE_CODE_REF)))
+    fputs_filtered (" ", stream);
+  f_type_print_varspec_prefix (type, stream, show, 0);
+
+  fputs_filtered (varstring, stream);
+
+  /* For demangled function names, we have the arglist as part of the name,
+     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);
+}
+
+/* Print any asterisks or open-parentheses needed before the
+   variable name (to describe its type).
+
+   On outermost call, pass 0 for PASSED_A_PTR.
+   On outermost call, SHOW > 0 means should ignore
+   any typename for TYPE and show its details.
+   SHOW is always zero on recursive calls.  */
+
+void
+f_type_print_varspec_prefix (type, stream, show, passed_a_ptr)
+     struct type *type;
+     GDB_FILE *stream;
+     int show;
+     int passed_a_ptr;
+{
+  if (type == 0)
+    return;
+
+  if (TYPE_NAME (type) && show <= 0)
+    return;
+
+  QUIT;
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_PTR:
+      f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 1);
+      break;
+
+    case TYPE_CODE_FUNC:
+      f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
+      if (passed_a_ptr)
+	fprintf_filtered (stream, "(");
+      break;
+
+    case TYPE_CODE_ARRAY:
+      f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
+      break;
+
+    case TYPE_CODE_UNDEF:
+    case TYPE_CODE_STRUCT:
+    case TYPE_CODE_UNION:
+    case TYPE_CODE_ENUM:
+    case TYPE_CODE_INT:
+    case TYPE_CODE_FLT:
+    case TYPE_CODE_VOID:
+    case TYPE_CODE_ERROR:
+    case TYPE_CODE_CHAR:
+    case TYPE_CODE_BOOL:
+    case TYPE_CODE_SET:
+    case TYPE_CODE_RANGE:
+    case TYPE_CODE_STRING:
+    case TYPE_CODE_BITSTRING:
+    case TYPE_CODE_METHOD:
+    case TYPE_CODE_MEMBER:
+    case TYPE_CODE_REF:
+    case TYPE_CODE_COMPLEX:
+    case TYPE_CODE_TYPEDEF:
+      /* These types need no prefix.  They are listed here so that
+	 gcc -Wall will reveal any types that haven't been handled.  */
+      break;
+    }
+}
+
+#if 0	/* Currently unused */
+
+static void
+f_type_print_args (type, stream)
+     struct type *type;
+     GDB_FILE *stream;
+{
+  int i;
+  struct type **args;
+
+  fprintf_filtered (stream, "(");
+  args = TYPE_ARG_TYPES (type);
+  if (args != NULL)
+    {
+      if (args[1] == NULL)
+	{
+	  fprintf_filtered (stream, "...");
+	}
+      else
+	{
+	  for (i = 1; args[i] != NULL && args[i]->code != TYPE_CODE_VOID; i++)
+	    {
+	      f_print_type (args[i], "", stream, -1, 0);
+	      if (args[i+1] == NULL)
+		fprintf_filtered (stream, "...");
+	      else if (args[i+1]->code != TYPE_CODE_VOID)
+		{
+		  fprintf_filtered (stream, ",");
+		  wrap_here ("    ");
+		}
+	    }
+	}
+    }
+  fprintf_filtered (stream, ")");
+}
+
+#endif	/* 0 */
+
+/* Print any array sizes, function arguments or close parentheses
+   needed after the variable name (to describe its type).
+   Args work like c_type_print_varspec_prefix.  */
+
+static void
+f_type_print_varspec_suffix (type, stream, show, passed_a_ptr, demangled_args)
+     struct type *type;
+     GDB_FILE *stream;
+     int show;
+     int passed_a_ptr;
+     int demangled_args;
+{
+  int upper_bound, lower_bound;
+  int lower_bound_was_default = 0;
+  static int arrayprint_recurse_level = 0;
+  int retcode;
+
+  if (type == 0)
+    return;
+
+  if (TYPE_NAME (type) && show <= 0)
+    return;
+
+  QUIT;
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_ARRAY:
+      arrayprint_recurse_level++;
+
+      if (arrayprint_recurse_level == 1)
+	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);
+
+      retcode = f77_get_dynamic_lowerbound (type,&lower_bound);
+
+      lower_bound_was_default = 0;
+
+      if (retcode == BOUND_FETCH_ERROR)
+	fprintf_filtered (stream,"???");
+      else
+	if (lower_bound == 1) /* The default */
+	  lower_bound_was_default = 1;
+	else
+	  fprintf_filtered (stream,"%d",lower_bound);
+
+      if (lower_bound_was_default)
+	lower_bound_was_default = 0;
+      else
+	fprintf_filtered(stream,":");
+
+      /* Make sure that, if we have an assumed size array, we
+	 print out a warning and print the upperbound as '*' */
+
+      if (TYPE_ARRAY_UPPER_BOUND_TYPE(type) == BOUND_CANNOT_BE_DETERMINED)
+	fprintf_filtered (stream, "*");
+       else
+	 {
+	   retcode = f77_get_dynamic_upperbound(type,&upper_bound);
+
+	   if (retcode == BOUND_FETCH_ERROR)
+	     fprintf_filtered(stream,"???");
+	   else
+	     fprintf_filtered(stream,"%d",upper_bound);
+	 }
+
+      if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_ARRAY)
+	f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
+      if (arrayprint_recurse_level == 1)
+	fprintf_filtered (stream, ")");
+      else
+	fprintf_filtered(stream,",");
+      arrayprint_recurse_level--;
+      break;
+
+    case TYPE_CODE_PTR:
+    case TYPE_CODE_REF:
+      f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0);
+      fprintf_filtered(stream,")");
+      break;
+
+    case TYPE_CODE_FUNC:
+      f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
+				 passed_a_ptr, 0);
+      if (passed_a_ptr)
+	fprintf_filtered (stream, ")");
+
+      fprintf_filtered (stream, "()");
+      break;
+
+    case TYPE_CODE_UNDEF:
+    case TYPE_CODE_STRUCT:
+    case TYPE_CODE_UNION:
+    case TYPE_CODE_ENUM:
+    case TYPE_CODE_INT:
+    case TYPE_CODE_FLT:
+    case TYPE_CODE_VOID:
+    case TYPE_CODE_ERROR:
+    case TYPE_CODE_CHAR:
+    case TYPE_CODE_BOOL:
+    case TYPE_CODE_SET:
+    case TYPE_CODE_RANGE:
+    case TYPE_CODE_STRING:
+    case TYPE_CODE_BITSTRING:
+    case TYPE_CODE_METHOD:
+    case TYPE_CODE_MEMBER:
+    case TYPE_CODE_COMPLEX:
+    case TYPE_CODE_TYPEDEF:
+      /* These types do not need a suffix.  They are listed so that
+	 gcc -Wall will report types that may not have been considered.  */
+      break;
+    }
+}
+
+static void
+print_equivalent_f77_float_type (type, stream)
+     struct type *type;
+     GDB_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));
+}
+
+/* Print the name of the type (or the ultimate pointer target,
+   function value or array element), or the description of a
+   structure or union.
+
+   SHOW nonzero means don't print this type as just its name;
+   show its real definition even if it has a name.
+   SHOW zero means print just typename or struct tag if there is one
+   SHOW negative means abbreviate structure elements.
+   SHOW is decremented for printing of structure elements.
+
+   LEVEL is the depth to indent by.
+   We increase it for some recursive calls.  */
+
+void
+f_type_print_base (type, stream, show, level)
+     struct type *type;
+     GDB_FILE *stream;
+     int show;
+     int level;
+{
+  int retcode;
+  int upper_bound;
+
+  QUIT;
+
+  wrap_here ("    ");
+  if (type == NULL)
+    {
+      fputs_filtered ("<type unknown>", stream);
+      return;
+    }
+
+  /* When SHOW is zero or less, and there is a valid type name, then always
+     just print the type name directly from the type. */
+
+  if ((show <= 0) && (TYPE_NAME (type) != NULL))
+    {
+      if (TYPE_CODE (type) == TYPE_CODE_FLT)
+	print_equivalent_f77_float_type (type, stream);
+      else
+	fputs_filtered (TYPE_NAME (type), stream);
+      return;
+    }
+
+  if (TYPE_CODE (type) != TYPE_CODE_TYPEDEF)
+    CHECK_TYPEDEF (type);
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_TYPEDEF:
+      f_type_print_base (TYPE_TARGET_TYPE (type), stream, 0, level);
+      break;
+
+    case TYPE_CODE_ARRAY:
+    case TYPE_CODE_FUNC:
+      f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
+      break;
+
+   case TYPE_CODE_PTR:
+      fprintf_filtered (stream, "PTR TO -> ( ");
+      f_type_print_base (TYPE_TARGET_TYPE (type), stream, 0, level);
+      break;
+
+    case TYPE_CODE_VOID:
+      fprintf_filtered (stream, "VOID");
+      break;
+
+    case TYPE_CODE_UNDEF:
+      fprintf_filtered (stream, "struct <unknown>");
+      break;
+
+    case TYPE_CODE_ERROR:
+      fprintf_filtered (stream, "<unknown type>");
+      break;
+
+    case TYPE_CODE_RANGE:
+      /* This should not occur */
+      fprintf_filtered (stream, "<range type>");
+      break;
+
+    case TYPE_CODE_CHAR:
+      /* Override name "char" and make it "character" */
+      fprintf_filtered (stream, "character");
+      break;
+
+    case TYPE_CODE_INT:
+      /* There may be some character types that attempt to come
+         through as TYPE_CODE_INT since dbxstclass.h is so
+         C-oriented, we must change these to "character" from "char".  */
+
+      if (STREQ (TYPE_NAME (type), "char"))
+	fprintf_filtered (stream, "character");
+      else
+	goto default_case;
+      break;
+
+    case TYPE_CODE_COMPLEX:
+      fprintf_filtered (stream, "complex*%d", TYPE_LENGTH (type));
+      break;
+
+    case TYPE_CODE_FLT:
+      print_equivalent_f77_float_type (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*(*)");
+      else
+	{
+	  retcode = f77_get_dynamic_upperbound (type, &upper_bound);
+
+	  if (retcode == BOUND_FETCH_ERROR)
+	    fprintf_filtered (stream, "character*???");
+	  else
+	    fprintf_filtered (stream, "character*%d", upper_bound);
+	}
+      break;
+
+    default_case:
+    default:
+      /* Handle types not explicitly handled by the other cases,
+	 such as fundamental types.  For these, just print whatever
+	 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);
+      else
+	error ("Invalid type code (%d) in symbol table.", TYPE_CODE (type));
+      break;
+    }
+}