[deliverable/binutils-gdb.git] / gdb / f-typeprint.c

/* 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));
\f

/* 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;
    }
}
Commit	Line	Data
c906108c SS	1	/* Support for printing Fortran types for GDB, the GNU debugger.
	2	Copyright 1986, 1988, 1989, 1991, 1993, 1994 Free Software Foundation, Inc.
	3	Contributed by Motorola. Adapted from the C version by Farooq Butt
	4	(fmbutt@engage.sps.mot.com).
	5
c5aa993b	6	This file is part of GDB.
c906108c	7
c5aa993b JM	8	This program is free software; you can redistribute it and/or modify
	9	it under the terms of the GNU General Public License as published by
	10	the Free Software Foundation; either version 2 of the License, or
	11	(at your option) any later version.
c906108c	12
c5aa993b JM	13	This program is distributed in the hope that it will be useful,
	14	but WITHOUT ANY WARRANTY; without even the implied warranty of
	15	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	16	GNU General Public License for more details.
c906108c	17
c5aa993b JM	18	You should have received a copy of the GNU General Public License
	19	along with this program; if not, write to the Free Software
	20	Foundation, Inc., 59 Temple Place - Suite 330,
	21	Boston, MA 02111-1307, USA. */
c906108c SS	22
	23	#include "defs.h"
	24	#include "obstack.h"
	25	#include "bfd.h"
	26	#include "symtab.h"
	27	#include "gdbtypes.h"
	28	#include "expression.h"
	29	#include "value.h"
	30	#include "gdbcore.h"
	31	#include "target.h"
	32	#include "command.h"
	33	#include "gdbcmd.h"
	34	#include "language.h"
	35	#include "demangle.h"
	36	#include "f-lang.h"
	37	#include "typeprint.h"
c5aa993b	38	#include "frame.h" /* ??? */
c906108c SS	39
	40	#include "gdb_string.h"
	41	#include <errno.h>
	42
c5aa993b	43	#if 0 /* Currently unused */
c906108c SS	44	static void f_type_print_args PARAMS ((struct type , GDB_FILE ));
	45	#endif
	46
	47	static void print_equivalent_f77_float_type PARAMS ((struct type *,
	48	GDB_FILE *));
	49
	50	static void f_type_print_varspec_suffix PARAMS ((struct type , GDB_FILE ,
	51	int, int, int));
	52
	53	void f_type_print_varspec_prefix PARAMS ((struct type , GDB_FILE ,
	54	int, int));
	55
	56	void f_type_print_base PARAMS ((struct type , GDB_FILE , int, int));
c906108c	57	\f
c5aa993b	58
c906108c SS	59	/* LEVEL is the depth to indent lines by. */
	60
	61	void
	62	f_print_type (type, varstring, stream, show, level)
	63	struct type *type;
	64	char *varstring;
	65	GDB_FILE *stream;
	66	int show;
	67	int level;
	68	{
	69	register enum type_code code;
	70	int demangled_args;
	71
	72	f_type_print_base (type, stream, show, level);
	73	code = TYPE_CODE (type);
	74	if ((varstring != NULL && *varstring != '\0')
	75	\|\|
c5aa993b JM	76	/* Need a space if going to print stars or brackets;
c5aa993b JM	77	but not if we will print just a type name. */
c906108c SS	78	((show > 0 \|\| TYPE_NAME (type) == 0)
	79	&&
	80	(code == TYPE_CODE_PTR \|\| code == TYPE_CODE_FUNC
	81	\|\| code == TYPE_CODE_METHOD
	82	\|\| code == TYPE_CODE_ARRAY
	83	\|\| code == TYPE_CODE_MEMBER
	84	\|\| code == TYPE_CODE_REF)))
	85	fputs_filtered (" ", stream);
	86	f_type_print_varspec_prefix (type, stream, show, 0);
	87
	88	fputs_filtered (varstring, stream);
	89
	90	/* For demangled function names, we have the arglist as part of the name,
	91	so don't print an additional pair of ()'s */
	92
c5aa993b	93	demangled_args = varstring[strlen (varstring) - 1] == ')';
c906108c SS	94	f_type_print_varspec_suffix (type, stream, show, 0, demangled_args);
	95	}
	96
	97	/* Print any asterisks or open-parentheses needed before the
	98	variable name (to describe its type).
	99
	100	On outermost call, pass 0 for PASSED_A_PTR.
	101	On outermost call, SHOW > 0 means should ignore
	102	any typename for TYPE and show its details.
	103	SHOW is always zero on recursive calls. */
	104
	105	void
	106	f_type_print_varspec_prefix (type, stream, show, passed_a_ptr)
	107	struct type *type;
	108	GDB_FILE *stream;
	109	int show;
	110	int passed_a_ptr;
	111	{
	112	if (type == 0)
	113	return;
	114
	115	if (TYPE_NAME (type) && show <= 0)
	116	return;
	117
	118	QUIT;
	119
	120	switch (TYPE_CODE (type))
	121	{
	122	case TYPE_CODE_PTR:
	123	f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 1);
	124	break;
	125
	126	case TYPE_CODE_FUNC:
	127	f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
	128	if (passed_a_ptr)
	129	fprintf_filtered (stream, "(");
	130	break;
	131
	132	case TYPE_CODE_ARRAY:
	133	f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
	134	break;
	135
	136	case TYPE_CODE_UNDEF:
	137	case TYPE_CODE_STRUCT:
	138	case TYPE_CODE_UNION:
	139	case TYPE_CODE_ENUM:
	140	case TYPE_CODE_INT:
	141	case TYPE_CODE_FLT:
	142	case TYPE_CODE_VOID:
	143	case TYPE_CODE_ERROR:
	144	case TYPE_CODE_CHAR:
	145	case TYPE_CODE_BOOL:
	146	case TYPE_CODE_SET:
	147	case TYPE_CODE_RANGE:
	148	case TYPE_CODE_STRING:
	149	case TYPE_CODE_BITSTRING:
	150	case TYPE_CODE_METHOD:
	151	case TYPE_CODE_MEMBER:
	152	case TYPE_CODE_REF:
	153	case TYPE_CODE_COMPLEX:
	154	case TYPE_CODE_TYPEDEF:
	155	/* These types need no prefix. They are listed here so that
c5aa993b	156	gcc -Wall will reveal any types that haven't been handled. */
c906108c SS	157	break;
	158	}
	159	}
	160
c5aa993b	161	#if 0 /* Currently unused */
c906108c SS	162
	163	static void
	164	f_type_print_args (type, stream)
	165	struct type *type;
	166	GDB_FILE *stream;
	167	{
	168	int i;
	169	struct type **args;
	170
	171	fprintf_filtered (stream, "(");
	172	args = TYPE_ARG_TYPES (type);
	173	if (args != NULL)
	174	{
	175	if (args[1] == NULL)
	176	{
	177	fprintf_filtered (stream, "...");
	178	}
	179	else
	180	{
	181	for (i = 1; args[i] != NULL && args[i]->code != TYPE_CODE_VOID; i++)
	182	{
	183	f_print_type (args[i], "", stream, -1, 0);
c5aa993b	184	if (args[i + 1] == NULL)
c906108c	185	fprintf_filtered (stream, "...");
c5aa993b	186	else if (args[i + 1]->code != TYPE_CODE_VOID)
c906108c SS	187	{
	188	fprintf_filtered (stream, ",");
	189	wrap_here (" ");
	190	}
	191	}
	192	}
	193	}
	194	fprintf_filtered (stream, ")");
	195	}
	196
c5aa993b	197	#endif /* 0 */
c906108c SS	198
	199	/* Print any array sizes, function arguments or close parentheses
	200	needed after the variable name (to describe its type).
	201	Args work like c_type_print_varspec_prefix. */
	202
	203	static void
	204	f_type_print_varspec_suffix (type, stream, show, passed_a_ptr, demangled_args)
	205	struct type *type;
	206	GDB_FILE *stream;
	207	int show;
	208	int passed_a_ptr;
	209	int demangled_args;
	210	{
	211	int upper_bound, lower_bound;
	212	int lower_bound_was_default = 0;
	213	static int arrayprint_recurse_level = 0;
	214	int retcode;
	215
	216	if (type == 0)
	217	return;
	218
	219	if (TYPE_NAME (type) && show <= 0)
	220	return;
	221
	222	QUIT;
	223
	224	switch (TYPE_CODE (type))
	225	{
	226	case TYPE_CODE_ARRAY:
	227	arrayprint_recurse_level++;
	228
	229	if (arrayprint_recurse_level == 1)
c5aa993b	230	fprintf_filtered (stream, "(");
c906108c SS	231
	232	if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY)
	233	f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
	234
c5aa993b	235	retcode = f77_get_dynamic_lowerbound (type, &lower_bound);
c906108c SS	236
	237	lower_bound_was_default = 0;
	238
	239	if (retcode == BOUND_FETCH_ERROR)
c5aa993b JM	240	fprintf_filtered (stream, "???");
	241	else if (lower_bound == 1) /* The default */
	242	lower_bound_was_default = 1;
c906108c	243	else
c5aa993b	244	fprintf_filtered (stream, "%d", lower_bound);
c906108c SS	245
	246	if (lower_bound_was_default)
	247	lower_bound_was_default = 0;
	248	else
c5aa993b	249	fprintf_filtered (stream, ":");
c906108c SS	250
c906108c SS	251	/* Make sure that, if we have an assumed size array, we
c5aa993b	252	print out a warning and print the upperbound as '' /
c906108c	253
c5aa993b	254	if (TYPE_ARRAY_UPPER_BOUND_TYPE (type) == BOUND_CANNOT_BE_DETERMINED)
c906108c	255	fprintf_filtered (stream, "*");
c5aa993b JM	256	else
	257	{
	258	retcode = f77_get_dynamic_upperbound (type, &upper_bound);
c906108c	259
c5aa993b JM	260	if (retcode == BOUND_FETCH_ERROR)
	261	fprintf_filtered (stream, "???");
	262	else
	263	fprintf_filtered (stream, "%d", upper_bound);
	264	}
c906108c SS	265
	266	if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_ARRAY)
	267	f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
	268	if (arrayprint_recurse_level == 1)
	269	fprintf_filtered (stream, ")");
	270	else
c5aa993b	271	fprintf_filtered (stream, ",");
c906108c SS	272	arrayprint_recurse_level--;
	273	break;
	274
	275	case TYPE_CODE_PTR:
	276	case TYPE_CODE_REF:
	277	f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0);
c5aa993b	278	fprintf_filtered (stream, ")");
c906108c SS	279	break;
	280
	281	case TYPE_CODE_FUNC:
	282	f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
c5aa993b	283	passed_a_ptr, 0);
c906108c SS	284	if (passed_a_ptr)
	285	fprintf_filtered (stream, ")");
	286
	287	fprintf_filtered (stream, "()");
	288	break;
	289
	290	case TYPE_CODE_UNDEF:
	291	case TYPE_CODE_STRUCT:
	292	case TYPE_CODE_UNION:
	293	case TYPE_CODE_ENUM:
	294	case TYPE_CODE_INT:
	295	case TYPE_CODE_FLT:
	296	case TYPE_CODE_VOID:
	297	case TYPE_CODE_ERROR:
	298	case TYPE_CODE_CHAR:
	299	case TYPE_CODE_BOOL:
	300	case TYPE_CODE_SET:
	301	case TYPE_CODE_RANGE:
	302	case TYPE_CODE_STRING:
	303	case TYPE_CODE_BITSTRING:
	304	case TYPE_CODE_METHOD:
	305	case TYPE_CODE_MEMBER:
	306	case TYPE_CODE_COMPLEX:
	307	case TYPE_CODE_TYPEDEF:
	308	/* These types do not need a suffix. They are listed so that
c5aa993b	309	gcc -Wall will report types that may not have been considered. */
c906108c SS	310	break;
	311	}
	312	}
	313
	314	static void
	315	print_equivalent_f77_float_type (type, stream)
	316	struct type *type;
	317	GDB_FILE *stream;
	318	{
	319	/* Override type name "float" and make it the
	320	appropriate real. XLC stupidly outputs -12 as a type
	321	for real when it really should be outputting -18 */
	322
	323	fprintf_filtered (stream, "real*%d", TYPE_LENGTH (type));
	324	}
	325
	326	/* Print the name of the type (or the ultimate pointer target,
	327	function value or array element), or the description of a
	328	structure or union.
	329
	330	SHOW nonzero means don't print this type as just its name;
	331	show its real definition even if it has a name.
	332	SHOW zero means print just typename or struct tag if there is one
	333	SHOW negative means abbreviate structure elements.
	334	SHOW is decremented for printing of structure elements.
	335
	336	LEVEL is the depth to indent by.
	337	We increase it for some recursive calls. */
	338
	339	void
	340	f_type_print_base (type, stream, show, level)
	341	struct type *type;
	342	GDB_FILE *stream;
	343	int show;
	344	int level;
	345	{
	346	int retcode;
	347	int upper_bound;
	348
	349	QUIT;
	350
	351	wrap_here (" ");
	352	if (type == NULL)
	353	{
	354	fputs_filtered ("<type unknown>", stream);
	355	return;
	356	}
	357
	358	/* When SHOW is zero or less, and there is a valid type name, then always
	359	just print the type name directly from the type. */
	360
	361	if ((show <= 0) && (TYPE_NAME (type) != NULL))
	362	{
	363	if (TYPE_CODE (type) == TYPE_CODE_FLT)
	364	print_equivalent_f77_float_type (type, stream);
	365	else
	366	fputs_filtered (TYPE_NAME (type), stream);
	367	return;
	368	}
	369
	370	if (TYPE_CODE (type) != TYPE_CODE_TYPEDEF)
	371	CHECK_TYPEDEF (type);
	372
	373	switch (TYPE_CODE (type))
374	{
375	case TYPE_CODE_TYPEDEF:
376	f_type_print_base (TYPE_TARGET_TYPE (type), stream, 0, level);
377	break;
378
379	case TYPE_CODE_ARRAY:
380	case TYPE_CODE_FUNC:
381	f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
382	break;
383
c5aa993b	384	case TYPE_CODE_PTR:
c906108c SS	385	fprintf_filtered (stream, "PTR TO -> ( ");
	386	f_type_print_base (TYPE_TARGET_TYPE (type), stream, 0, level);
	387	break;
	388
	389	case TYPE_CODE_VOID:
	390	fprintf_filtered (stream, "VOID");
	391	break;
	392
	393	case TYPE_CODE_UNDEF:
	394	fprintf_filtered (stream, "struct <unknown>");
	395	break;
	396
	397	case TYPE_CODE_ERROR:
	398	fprintf_filtered (stream, "<unknown type>");
	399	break;
	400
	401	case TYPE_CODE_RANGE:
	402	/* This should not occur */
	403	fprintf_filtered (stream, "<range type>");
	404	break;
	405
	406	case TYPE_CODE_CHAR:
	407	/* Override name "char" and make it "character" */
	408	fprintf_filtered (stream, "character");
	409	break;
	410
	411	case TYPE_CODE_INT:
	412	/* There may be some character types that attempt to come
	413	through as TYPE_CODE_INT since dbxstclass.h is so
	414	C-oriented, we must change these to "character" from "char". */
	415
	416	if (STREQ (TYPE_NAME (type), "char"))
	417	fprintf_filtered (stream, "character");
	418	else
	419	goto default_case;
	420	break;
	421
	422	case TYPE_CODE_COMPLEX:
	423	fprintf_filtered (stream, "complex*%d", TYPE_LENGTH (type));
	424	break;
	425
	426	case TYPE_CODE_FLT:
	427	print_equivalent_f77_float_type (type, stream);
	428	break;
	429
	430	case TYPE_CODE_STRING:
	431	/* Strings may have dynamic upperbounds (lengths) like arrays. */
	432
	433	if (TYPE_ARRAY_UPPER_BOUND_TYPE (type) == BOUND_CANNOT_BE_DETERMINED)
	434	fprintf_filtered (stream, "character()");
	435	else
	436	{
	437	retcode = f77_get_dynamic_upperbound (type, &upper_bound);
	438
	439	if (retcode == BOUND_FETCH_ERROR)
	440	fprintf_filtered (stream, "character*???");
	441	else
	442	fprintf_filtered (stream, "character*%d", upper_bound);
	443	}
	444	break;
	445
	446	default_case:
	447	default:
	448	/* Handle types not explicitly handled by the other cases,
c5aa993b JM	449	such as fundamental types. For these, just print whatever
	450	the type name is, as recorded in the type itself. If there
	451	is no type name, then complain. */
c906108c SS	452	if (TYPE_NAME (type) != NULL)
	453	fputs_filtered (TYPE_NAME (type), stream);
	454	else
	455	error ("Invalid type code (%d) in symbol table.", TYPE_CODE (type));
	456	break;
	457	}
	458	}