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

/* 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, 2006 Free Software Foundation, Inc.

   Contributed by Motorola.  Adapted from the C version by Farooq Butt
   ([email protected]).

   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., 51 Franklin Street, Fifth Floor,
   Boston, MA 02110-1301, USA.  */

#include "defs.h"
#include "gdb_obstack.h"
#include "bfd.h"
#include "symtab.h"
#include "gdbtypes.h"
#include "expression.h"
#include "value.h"
#include "gdbcore.h"
#include "target.h"
#include "f-lang.h"

#include "gdb_string.h"
#include <errno.h>

#if 0				/* Currently unused */
static void f_type_print_args (struct type *, struct ui_file *);
#endif

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 *,
					 int, int, int);

void f_type_print_varspec_prefix (struct type *, struct ui_file *,
				  int, int);

void f_type_print_base (struct type *, struct ui_file *, int, int);
\f

/* LEVEL is the depth to indent lines by.  */

void
f_print_type (struct type *type, char *varstring, struct ui_file *stream,
	      int show, int level)
{
  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_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 (struct type *type, struct ui_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_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;
    }
}

/* 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 (struct type *type, struct ui_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_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 (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 */

  fprintfi_filtered (level, 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 (struct type *type, struct ui_file *stream, int show,
		   int level)
{
  int retcode;
  int upper_bound;

  int index;

  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 (level, 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_REF:
      fprintf_filtered (stream, "REF TO -> ( ");
      f_type_print_base (TYPE_TARGET_TYPE (type), stream, 0, level);
      break;

    case TYPE_CODE_VOID:
      fprintfi_filtered (level, stream, "VOID");
      break;

    case TYPE_CODE_UNDEF:
      fprintfi_filtered (level, stream, "struct <unknown>");
      break;

    case TYPE_CODE_ERROR:
      fprintfi_filtered (level, stream, "<unknown type>");
      break;

    case TYPE_CODE_RANGE:
      /* This should not occur */
      fprintfi_filtered (level, stream, "<range type>");
      break;

    case TYPE_CODE_CHAR:
      /* Override name "char" and make it "character" */
      fprintfi_filtered (level, 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 (strcmp (TYPE_NAME (type), "char") == 0)
	fprintfi_filtered (level, stream, "character");
      else
	goto default_case;
      break;

    case TYPE_CODE_COMPLEX:
      fprintfi_filtered (level, stream, "complex*%d", TYPE_LENGTH (type));
      break;

    case TYPE_CODE_FLT:
      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)
	fprintfi_filtered (level, 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;

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