123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463 |
- /* Support for printing Fortran types for GDB, the GNU debugger.
- Copyright (C) 1986-2022 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 3 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, see <http://www.gnu.org/licenses/>. */
- #include "defs.h"
- #include "gdbsupport/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 "typeprint.h"
- #include "cli/cli-style.h"
- /* See f-lang.h. */
- void
- f_language::print_typedef (struct type *type, struct symbol *new_symbol,
- struct ui_file *stream) const
- {
- type = check_typedef (type);
- print_type (type, "", stream, 0, 0, &type_print_raw_options);
- }
- /* See f-lang.h. */
- void
- f_language::print_type (struct type *type, const char *varstring,
- struct ui_file *stream, int show, int level,
- const struct type_print_options *flags) const
- {
- enum type_code code;
- f_type_print_base (type, stream, show, level);
- code = type->code ();
- 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 () == 0)
- && (code == TYPE_CODE_FUNC
- || code == TYPE_CODE_METHOD
- || code == TYPE_CODE_ARRAY
- || ((code == TYPE_CODE_PTR
- || code == TYPE_CODE_REF)
- && (TYPE_TARGET_TYPE (type)->code () == TYPE_CODE_FUNC
- || (TYPE_TARGET_TYPE (type)->code ()
- == TYPE_CODE_METHOD)
- || (TYPE_TARGET_TYPE (type)->code ()
- == TYPE_CODE_ARRAY))))))
- gdb_puts (" ", stream);
- f_type_print_varspec_prefix (type, stream, show, 0);
- if (varstring != NULL)
- {
- int demangled_args;
- gdb_puts (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 != '\0'
- && varstring[strlen (varstring) - 1] == ')');
- f_type_print_varspec_suffix (type, stream, show, 0, demangled_args, 0, false);
- }
- }
- /* See f-lang.h. */
- void
- f_language::f_type_print_varspec_prefix (struct type *type,
- struct ui_file *stream,
- int show, int passed_a_ptr) const
- {
- if (type == 0)
- return;
- if (type->name () && show <= 0)
- return;
- QUIT;
- switch (type->code ())
- {
- 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)
- gdb_printf (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_NAMELIST:
- 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_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;
- }
- }
- /* See f-lang.h. */
- void
- f_language::f_type_print_varspec_suffix (struct type *type,
- struct ui_file *stream,
- int show, int passed_a_ptr,
- int demangled_args,
- int arrayprint_recurse_level,
- bool print_rank_only) const
- {
- /* No static variables are permitted as an error call may occur during
- execution of this function. */
- if (type == 0)
- return;
- if (type->name () && show <= 0)
- return;
- QUIT;
- switch (type->code ())
- {
- case TYPE_CODE_ARRAY:
- arrayprint_recurse_level++;
- if (arrayprint_recurse_level == 1)
- gdb_printf (stream, "(");
- if (type_not_associated (type))
- print_rank_only = true;
- else if (type_not_allocated (type))
- print_rank_only = true;
- else if ((TYPE_ASSOCIATED_PROP (type)
- && PROP_CONST != TYPE_ASSOCIATED_PROP (type)->kind ())
- || (TYPE_ALLOCATED_PROP (type)
- && PROP_CONST != TYPE_ALLOCATED_PROP (type)->kind ())
- || (TYPE_DATA_LOCATION (type)
- && PROP_CONST != TYPE_DATA_LOCATION (type)->kind ()))
- {
- /* This case exist when we ptype a typename which has the dynamic
- properties but cannot be resolved as there is no object. */
- print_rank_only = true;
- }
- if (TYPE_TARGET_TYPE (type)->code () == TYPE_CODE_ARRAY)
- f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
- 0, 0, arrayprint_recurse_level,
- print_rank_only);
- if (print_rank_only)
- gdb_printf (stream, ":");
- else
- {
- LONGEST lower_bound = f77_get_lowerbound (type);
- if (lower_bound != 1) /* Not the default. */
- gdb_printf (stream, "%s:", plongest (lower_bound));
- /* Make sure that, if we have an assumed size array, we
- print out a warning and print the upperbound as '*'. */
- if (type->bounds ()->high.kind () == PROP_UNDEFINED)
- gdb_printf (stream, "*");
- else
- {
- LONGEST upper_bound = f77_get_upperbound (type);
- gdb_puts (plongest (upper_bound), stream);
- }
- }
- if (TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_ARRAY)
- f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
- 0, 0, arrayprint_recurse_level,
- print_rank_only);
- if (arrayprint_recurse_level == 1)
- gdb_printf (stream, ")");
- else
- gdb_printf (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,
- arrayprint_recurse_level, false);
- gdb_printf (stream, " )");
- break;
- case TYPE_CODE_FUNC:
- {
- int i, nfields = type->num_fields ();
- f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
- passed_a_ptr, 0,
- arrayprint_recurse_level, false);
- if (passed_a_ptr)
- gdb_printf (stream, ") ");
- gdb_printf (stream, "(");
- if (nfields == 0 && type->is_prototyped ())
- print_type (builtin_f_type (type->arch ())->builtin_void,
- "", stream, -1, 0, 0);
- else
- for (i = 0; i < nfields; i++)
- {
- if (i > 0)
- {
- gdb_puts (", ", stream);
- stream->wrap_here (4);
- }
- print_type (type->field (i).type (), "", stream, -1, 0, 0);
- }
- gdb_printf (stream, ")");
- }
- break;
- case TYPE_CODE_UNDEF:
- case TYPE_CODE_STRUCT:
- case TYPE_CODE_UNION:
- case TYPE_CODE_NAMELIST:
- 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_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;
- }
- }
- /* See f-lang.h. */
- void
- f_language::f_type_print_derivation_info (struct type *type,
- struct ui_file *stream) const
- {
- /* Fortran doesn't support multiple inheritance. */
- const int i = 0;
- if (TYPE_N_BASECLASSES (type) > 0)
- gdb_printf (stream, ", extends(%s) ::", TYPE_BASECLASS (type, i)->name ());
- }
- /* See f-lang.h. */
- void
- f_language::f_type_print_base (struct type *type, struct ui_file *stream,
- int show, int level) const
- {
- int index;
- QUIT;
- stream->wrap_here (4);
- if (type == NULL)
- {
- fputs_styled ("<type unknown>", metadata_style.style (), 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 () != NULL))
- {
- const char *prefix = "";
- if (type->code () == TYPE_CODE_UNION)
- prefix = "Type, C_Union :: ";
- else if (type->code () == TYPE_CODE_STRUCT
- || type->code () == TYPE_CODE_NAMELIST)
- prefix = "Type ";
- gdb_printf (stream, "%*s%s%s", level, "", prefix, type->name ());
- return;
- }
- if (type->code () != TYPE_CODE_TYPEDEF)
- type = check_typedef (type);
- switch (type->code ())
- {
- case TYPE_CODE_TYPEDEF:
- f_type_print_base (TYPE_TARGET_TYPE (type), stream, 0, level);
- break;
- case TYPE_CODE_ARRAY:
- f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
- break;
- case TYPE_CODE_FUNC:
- if (TYPE_TARGET_TYPE (type) == NULL)
- type_print_unknown_return_type (stream);
- else
- f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
- break;
- case TYPE_CODE_PTR:
- gdb_printf (stream, "%*sPTR TO -> ( ", level, "");
- f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, 0);
- break;
- case TYPE_CODE_REF:
- gdb_printf (stream, "%*sREF TO -> ( ", level, "");
- f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, 0);
- break;
- case TYPE_CODE_VOID:
- {
- struct type *void_type = builtin_f_type (type->arch ())->builtin_void;
- gdb_printf (stream, "%*s%s", level, "", void_type->name ());
- }
- break;
- case TYPE_CODE_UNDEF:
- gdb_printf (stream, "%*sstruct <unknown>", level, "");
- break;
- case TYPE_CODE_ERROR:
- gdb_printf (stream, "%*s%s", level, "", TYPE_ERROR_NAME (type));
- break;
- case TYPE_CODE_RANGE:
- /* This should not occur. */
- gdb_printf (stream, "%*s<range type>", level, "");
- break;
- case TYPE_CODE_CHAR:
- 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 (), "char") == 0)
- gdb_printf (stream, "%*scharacter", level, "");
- else
- goto default_case;
- break;
- case TYPE_CODE_STRING:
- /* Strings may have dynamic upperbounds (lengths) like arrays. We
- check specifically for the PROP_CONST case to indicate that the
- dynamic type has been resolved. If we arrive here having been
- asked to print the type of a value with a dynamic type then the
- bounds will not have been resolved. */
- if (type->bounds ()->high.kind () == PROP_CONST)
- {
- LONGEST upper_bound = f77_get_upperbound (type);
- gdb_printf (stream, "character*%s", pulongest (upper_bound));
- }
- else
- gdb_printf (stream, "%*scharacter*(*)", level, "");
- break;
- case TYPE_CODE_STRUCT:
- case TYPE_CODE_UNION:
- case TYPE_CODE_NAMELIST:
- if (type->code () == TYPE_CODE_UNION)
- gdb_printf (stream, "%*sType, C_Union ::", level, "");
- else
- gdb_printf (stream, "%*sType", level, "");
- if (show > 0)
- f_type_print_derivation_info (type, stream);
- gdb_puts (" ", stream);
- gdb_puts (type->name (), stream);
- /* According to the definition,
- we only print structure elements in case show > 0. */
- if (show > 0)
- {
- gdb_puts ("\n", stream);
- for (index = 0; index < type->num_fields (); index++)
- {
- f_type_print_base (type->field (index).type (), stream,
- show - 1, level + 4);
- gdb_puts (" :: ", stream);
- fputs_styled (type->field (index).name (),
- variable_name_style.style (), stream);
- f_type_print_varspec_suffix (type->field (index).type (),
- stream, show - 1, 0, 0, 0, false);
- gdb_puts ("\n", stream);
- }
- gdb_printf (stream, "%*sEnd Type ", level, "");
- gdb_puts (type->name (), stream);
- }
- break;
- case TYPE_CODE_MODULE:
- gdb_printf (stream, "%*smodule %s", level, "", type->name ());
- 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 () != NULL)
- gdb_printf (stream, "%*s%s", level, "", type->name ());
- else
- error (_("Invalid type code (%d) in symbol table."), type->code ());
- break;
- }
- if (TYPE_IS_ALLOCATABLE (type))
- gdb_printf (stream, ", allocatable");
- }
|