[deliverable/binutils-gdb.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
   (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., 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_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 (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_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;
    }
}

/* 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_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 (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	(fmbutt@engage.sps.mot.com).
	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
	76	\|\| code == TYPE_CODE_MEMBER
	77	\|\| code == TYPE_CODE_REF)))
	78	fputs_filtered (" ", stream);
	79	f_type_print_varspec_prefix (type, stream, show, 0);
	80
	81	fputs_filtered (varstring, stream);
	82
	83	/* For demangled function names, we have the arglist as part of the name,
	84	so don't print an additional pair of ()'s */
	85
c5aa993b	86	demangled_args = varstring[strlen (varstring) - 1] == ')';
c906108c SS	87	f_type_print_varspec_suffix (type, stream, show, 0, demangled_args);
	88	}
	89
	90	/* Print any asterisks or open-parentheses needed before the
	91	variable name (to describe its type).
	92
	93	On outermost call, pass 0 for PASSED_A_PTR.
	94	On outermost call, SHOW > 0 means should ignore
	95	any typename for TYPE and show its details.
	96	SHOW is always zero on recursive calls. */
	97
	98	void
fba45db2 KB	99	f_type_print_varspec_prefix (struct type type, struct ui_file stream,
fba45db2 KB	100	int show, int passed_a_ptr)
c906108c SS	101	{
	102	if (type == 0)
	103	return;
	104
	105	if (TYPE_NAME (type) && show <= 0)
	106	return;
	107
	108	QUIT;
	109
	110	switch (TYPE_CODE (type))
	111	{
	112	case TYPE_CODE_PTR:
	113	f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 1);
	114	break;
	115
	116	case TYPE_CODE_FUNC:
	117	f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
	118	if (passed_a_ptr)
	119	fprintf_filtered (stream, "(");
	120	break;
	121
	122	case TYPE_CODE_ARRAY:
	123	f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
	124	break;
	125
	126	case TYPE_CODE_UNDEF:
	127	case TYPE_CODE_STRUCT:
	128	case TYPE_CODE_UNION:
	129	case TYPE_CODE_ENUM:
	130	case TYPE_CODE_INT:
	131	case TYPE_CODE_FLT:
	132	case TYPE_CODE_VOID:
	133	case TYPE_CODE_ERROR:
	134	case TYPE_CODE_CHAR:
	135	case TYPE_CODE_BOOL:
	136	case TYPE_CODE_SET:
	137	case TYPE_CODE_RANGE:
	138	case TYPE_CODE_STRING:
	139	case TYPE_CODE_BITSTRING:
	140	case TYPE_CODE_METHOD:
	141	case TYPE_CODE_MEMBER:
	142	case TYPE_CODE_REF:
	143	case TYPE_CODE_COMPLEX:
	144	case TYPE_CODE_TYPEDEF:
	145	/* These types need no prefix. They are listed here so that
c5aa993b	146	gcc -Wall will reveal any types that haven't been handled. */
c906108c SS	147	break;
	148	}
	149	}
	150
c906108c SS	151	/* Print any array sizes, function arguments or close parentheses
	152	needed after the variable name (to describe its type).
	153	Args work like c_type_print_varspec_prefix. */
	154
	155	static void
fba45db2 KB	156	f_type_print_varspec_suffix (struct type type, struct ui_file stream,
fba45db2 KB	157	int show, int passed_a_ptr, int demangled_args)
c906108c SS	158	{
	159	int upper_bound, lower_bound;
	160	int lower_bound_was_default = 0;
	161	static int arrayprint_recurse_level = 0;
	162	int retcode;
	163
	164	if (type == 0)
	165	return;
	166
	167	if (TYPE_NAME (type) && show <= 0)
	168	return;
	169
	170	QUIT;
	171
	172	switch (TYPE_CODE (type))
	173	{
	174	case TYPE_CODE_ARRAY:
	175	arrayprint_recurse_level++;
	176
	177	if (arrayprint_recurse_level == 1)
c5aa993b	178	fprintf_filtered (stream, "(");
c906108c SS	179
	180	if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY)
	181	f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
	182
c5aa993b	183	retcode = f77_get_dynamic_lowerbound (type, &lower_bound);
c906108c SS	184
	185	lower_bound_was_default = 0;
	186
	187	if (retcode == BOUND_FETCH_ERROR)
c5aa993b JM	188	fprintf_filtered (stream, "???");
	189	else if (lower_bound == 1) /* The default */
	190	lower_bound_was_default = 1;
c906108c	191	else
c5aa993b	192	fprintf_filtered (stream, "%d", lower_bound);
c906108c SS	193
	194	if (lower_bound_was_default)
	195	lower_bound_was_default = 0;
	196	else
c5aa993b	197	fprintf_filtered (stream, ":");
c906108c SS	198
c906108c SS	199	/* Make sure that, if we have an assumed size array, we
c5aa993b	200	print out a warning and print the upperbound as '' /
c906108c	201
c5aa993b	202	if (TYPE_ARRAY_UPPER_BOUND_TYPE (type) == BOUND_CANNOT_BE_DETERMINED)
c906108c	203	fprintf_filtered (stream, "*");
c5aa993b JM	204	else
	205	{
	206	retcode = f77_get_dynamic_upperbound (type, &upper_bound);
c906108c	207
c5aa993b JM	208	if (retcode == BOUND_FETCH_ERROR)
	209	fprintf_filtered (stream, "???");
	210	else
	211	fprintf_filtered (stream, "%d", upper_bound);
	212	}
c906108c SS	213
	214	if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_ARRAY)
	215	f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
	216	if (arrayprint_recurse_level == 1)
	217	fprintf_filtered (stream, ")");
	218	else
c5aa993b	219	fprintf_filtered (stream, ",");
c906108c SS	220	arrayprint_recurse_level--;
	221	break;
	222
	223	case TYPE_CODE_PTR:
	224	case TYPE_CODE_REF:
	225	f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0);
c5aa993b	226	fprintf_filtered (stream, ")");
c906108c SS	227	break;
	228
	229	case TYPE_CODE_FUNC:
	230	f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
c5aa993b	231	passed_a_ptr, 0);
c906108c SS	232	if (passed_a_ptr)
	233	fprintf_filtered (stream, ")");
	234
	235	fprintf_filtered (stream, "()");
	236	break;
	237
	238	case TYPE_CODE_UNDEF:
	239	case TYPE_CODE_STRUCT:
	240	case TYPE_CODE_UNION:
	241	case TYPE_CODE_ENUM:
	242	case TYPE_CODE_INT:
	243	case TYPE_CODE_FLT:
	244	case TYPE_CODE_VOID:
	245	case TYPE_CODE_ERROR:
	246	case TYPE_CODE_CHAR:
	247	case TYPE_CODE_BOOL:
	248	case TYPE_CODE_SET:
	249	case TYPE_CODE_RANGE:
	250	case TYPE_CODE_STRING:
	251	case TYPE_CODE_BITSTRING:
	252	case TYPE_CODE_METHOD:
	253	case TYPE_CODE_MEMBER:
	254	case TYPE_CODE_COMPLEX:
	255	case TYPE_CODE_TYPEDEF:
	256	/* These types do not need a suffix. They are listed so that
c5aa993b	257	gcc -Wall will report types that may not have been considered. */
c906108c SS	258	break;
	259	}
	260	}
	261
	262	static void
2a5e440c WZ	263	print_equivalent_f77_float_type (int level, struct type *type,
2a5e440c WZ	264	struct ui_file *stream)
c906108c SS	265	{
	266	/* Override type name "float" and make it the
	267	appropriate real. XLC stupidly outputs -12 as a type
	268	for real when it really should be outputting -18 */
	269
2a5e440c	270	fprintfi_filtered (level, stream, "real*%d", TYPE_LENGTH (type));
c906108c SS	271	}
	272
	273	/* Print the name of the type (or the ultimate pointer target,
	274	function value or array element), or the description of a
	275	structure or union.
	276
	277	SHOW nonzero means don't print this type as just its name;
	278	show its real definition even if it has a name.
	279	SHOW zero means print just typename or struct tag if there is one
	280	SHOW negative means abbreviate structure elements.
	281	SHOW is decremented for printing of structure elements.
	282
	283	LEVEL is the depth to indent by.
	284	We increase it for some recursive calls. */
	285
	286	void
fba45db2 KB	287	f_type_print_base (struct type type, struct ui_file stream, int show,
fba45db2 KB	288	int level)
c906108c SS	289	{
	290	int retcode;
	291	int upper_bound;
	292
2a5e440c WZ	293	int index;
2a5e440c WZ	294
c906108c SS	295	QUIT;
	296
	297	wrap_here (" ");
	298	if (type == NULL)
	299	{
	300	fputs_filtered ("<type unknown>", stream);
	301	return;
	302	}
	303
	304	/* When SHOW is zero or less, and there is a valid type name, then always
	305	just print the type name directly from the type. */
	306
	307	if ((show <= 0) && (TYPE_NAME (type) != NULL))
	308	{
	309	if (TYPE_CODE (type) == TYPE_CODE_FLT)
2a5e440c	310	print_equivalent_f77_float_type (level, type, stream);
c906108c SS	311	else
	312	fputs_filtered (TYPE_NAME (type), stream);
	313	return;
	314	}
	315
	316	if (TYPE_CODE (type) != TYPE_CODE_TYPEDEF)
	317	CHECK_TYPEDEF (type);
	318
	319	switch (TYPE_CODE (type))
	320	{
	321	case TYPE_CODE_TYPEDEF:
	322	f_type_print_base (TYPE_TARGET_TYPE (type), stream, 0, level);
	323	break;
	324
	325	case TYPE_CODE_ARRAY:
	326	case TYPE_CODE_FUNC:
	327	f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
	328	break;
	329
c5aa993b	330	case TYPE_CODE_PTR:
c906108c SS	331	fprintf_filtered (stream, "PTR TO -> ( ");
c906108c SS	332	f_type_print_base (TYPE_TARGET_TYPE (type), stream, 0, level);
7e86466e RH	333	break;
	334
	335	case TYPE_CODE_REF:
	336	fprintf_filtered (stream, "REF TO -> ( ");
	337	f_type_print_base (TYPE_TARGET_TYPE (type), stream, 0, level);
c906108c SS	338	break;
	339
	340	case TYPE_CODE_VOID:
2a5e440c	341	fprintfi_filtered (level, stream, "VOID");
c906108c SS	342	break;
	343
	344	case TYPE_CODE_UNDEF:
2a5e440c	345	fprintfi_filtered (level, stream, "struct <unknown>");
c906108c SS	346	break;
	347
	348	case TYPE_CODE_ERROR:
2a5e440c	349	fprintfi_filtered (level, stream, "<unknown type>");
c906108c SS	350	break;
	351
	352	case TYPE_CODE_RANGE:
	353	/* This should not occur */
2a5e440c	354	fprintfi_filtered (level, stream, "<range type>");
c906108c SS	355	break;
	356
	357	case TYPE_CODE_CHAR:
	358	/* Override name "char" and make it "character" */
2a5e440c	359	fprintfi_filtered (level, stream, "character");
c906108c SS	360	break;
	361
	362	case TYPE_CODE_INT:
	363	/* There may be some character types that attempt to come
	364	through as TYPE_CODE_INT since dbxstclass.h is so
	365	C-oriented, we must change these to "character" from "char". */
	366
bde58177	367	if (strcmp (TYPE_NAME (type), "char") == 0)
2a5e440c	368	fprintfi_filtered (level, stream, "character");
c906108c SS	369	else
	370	goto default_case;
	371	break;
	372
	373	case TYPE_CODE_COMPLEX:
2a5e440c	374	fprintfi_filtered (level, stream, "complex*%d", TYPE_LENGTH (type));
c906108c SS	375	break;
	376
	377	case TYPE_CODE_FLT:
2a5e440c	378	print_equivalent_f77_float_type (level, type, stream);
c906108c SS	379	break;
	380
	381	case TYPE_CODE_STRING:
	382	/* Strings may have dynamic upperbounds (lengths) like arrays. */
	383
	384	if (TYPE_ARRAY_UPPER_BOUND_TYPE (type) == BOUND_CANNOT_BE_DETERMINED)
2a5e440c	385	fprintfi_filtered (level, stream, "character()");
c906108c SS	386	else
	387	{
	388	retcode = f77_get_dynamic_upperbound (type, &upper_bound);
	389
	390	if (retcode == BOUND_FETCH_ERROR)
	391	fprintf_filtered (stream, "character*???");
	392	else
	393	fprintf_filtered (stream, "character*%d", upper_bound);
	394	}
	395	break;
	396
2a5e440c WZ	397	case TYPE_CODE_STRUCT:
	398	fprintfi_filtered (level, stream, "Type ");
	399	fputs_filtered (TYPE_TAG_NAME (type), stream);
	400	fputs_filtered ("\n", stream);
	401	for (index = 0; index < TYPE_NFIELDS (type); index++)
	402	{
	403	f_print_type (TYPE_FIELD_TYPE (type, index), "", stream, show, level + 4);
	404	fputs_filtered (" :: ", stream);
	405	fputs_filtered (TYPE_FIELD_NAME (type, index), stream);
	406	fputs_filtered ("\n", stream);
	407	}
	408	fprintfi_filtered (level, stream, "End Type ");
	409	fputs_filtered (TYPE_TAG_NAME (type), stream);
	410	break;
	411
c906108c SS	412	default_case:
	413	default:
	414	/* Handle types not explicitly handled by the other cases,
c5aa993b JM	415	such as fundamental types. For these, just print whatever
	416	the type name is, as recorded in the type itself. If there
	417	is no type name, then complain. */
c906108c	418	if (TYPE_NAME (type) != NULL)
848359ac	419	fprintfi_filtered (level, stream, "%s", TYPE_NAME (type));
c906108c	420	else
8a3fe4f8	421	error (_("Invalid type code (%d) in symbol table."), TYPE_CODE (type));
c906108c SS	422	break;
	423	}
	424	}