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

/* Fortran language support routines for GDB, the GNU debugger.

   Copyright (C) 1993-2019 Free Software Foundation, Inc.

   Contributed by Motorola.  Adapted from the C parser 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 "symtab.h"
#include "gdbtypes.h"
#include "expression.h"
#include "parser-defs.h"
#include "language.h"
#include "varobj.h"
#include "gdbcore.h"
#include "f-lang.h"
#include "valprint.h"
#include "value.h"
#include "cp-support.h"
#include "charset.h"
#include "c-lang.h"


/* Local functions */

static void f_printchar (int c, struct type *type, struct ui_file * stream);
static void f_emit_char (int c, struct type *type,
			 struct ui_file * stream, int quoter);

/* Return the encoding that should be used for the character type
   TYPE.  */

static const char *
f_get_encoding (struct type *type)
{
  const char *encoding;

  switch (TYPE_LENGTH (type))
    {
    case 1:
      encoding = target_charset (get_type_arch (type));
      break;
    case 4:
      if (gdbarch_byte_order (get_type_arch (type)) == BFD_ENDIAN_BIG)
	encoding = "UTF-32BE";
      else
	encoding = "UTF-32LE";
      break;

    default:
      error (_("unrecognized character type"));
    }

  return encoding;
}

/* Print the character C on STREAM as part of the contents of a literal
   string whose delimiter is QUOTER.  Note that that format for printing
   characters and strings is language specific.
   FIXME:  This is a copy of the same function from c-exp.y.  It should
   be replaced with a true F77 version.  */

static void
f_emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
{
  const char *encoding = f_get_encoding (type);

  generic_emit_char (c, type, stream, quoter, encoding);
}

/* Implementation of la_printchar.  */

static void
f_printchar (int c, struct type *type, struct ui_file *stream)
{
  fputs_filtered ("'", stream);
  LA_EMIT_CHAR (c, type, stream, '\'');
  fputs_filtered ("'", stream);
}

/* Print the character string STRING, printing at most LENGTH characters.
   Printing stops early if the number hits print_max; repeat counts
   are printed as appropriate.  Print ellipses at the end if we
   had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
   FIXME:  This is a copy of the same function from c-exp.y.  It should
   be replaced with a true F77 version.  */

static void
f_printstr (struct ui_file *stream, struct type *type, const gdb_byte *string,
	    unsigned int length, const char *encoding, int force_ellipses,
	    const struct value_print_options *options)
{
  const char *type_encoding = f_get_encoding (type);

  if (TYPE_LENGTH (type) == 4)
    fputs_filtered ("4_", stream);

  if (!encoding || !*encoding)
    encoding = type_encoding;

  generic_printstr (stream, type, string, length, encoding,
		    force_ellipses, '\'', 0, options);
}
\f

/* Table of operators and their precedences for printing expressions.  */

static const struct op_print f_op_print_tab[] =
{
  {"+", BINOP_ADD, PREC_ADD, 0},
  {"+", UNOP_PLUS, PREC_PREFIX, 0},
  {"-", BINOP_SUB, PREC_ADD, 0},
  {"-", UNOP_NEG, PREC_PREFIX, 0},
  {"*", BINOP_MUL, PREC_MUL, 0},
  {"/", BINOP_DIV, PREC_MUL, 0},
  {"DIV", BINOP_INTDIV, PREC_MUL, 0},
  {"MOD", BINOP_REM, PREC_MUL, 0},
  {"=", BINOP_ASSIGN, PREC_ASSIGN, 1},
  {".OR.", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
  {".AND.", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
  {".NOT.", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
  {".EQ.", BINOP_EQUAL, PREC_EQUAL, 0},
  {".NE.", BINOP_NOTEQUAL, PREC_EQUAL, 0},
  {".LE.", BINOP_LEQ, PREC_ORDER, 0},
  {".GE.", BINOP_GEQ, PREC_ORDER, 0},
  {".GT.", BINOP_GTR, PREC_ORDER, 0},
  {".LT.", BINOP_LESS, PREC_ORDER, 0},
  {"**", UNOP_IND, PREC_PREFIX, 0},
  {"@", BINOP_REPEAT, PREC_REPEAT, 0},
  {NULL, OP_NULL, PREC_REPEAT, 0}
};
\f
enum f_primitive_types {
  f_primitive_type_character,
  f_primitive_type_logical,
  f_primitive_type_logical_s1,
  f_primitive_type_logical_s2,
  f_primitive_type_logical_s8,
  f_primitive_type_integer,
  f_primitive_type_integer_s2,
  f_primitive_type_real,
  f_primitive_type_real_s8,
  f_primitive_type_real_s16,
  f_primitive_type_complex_s8,
  f_primitive_type_complex_s16,
  f_primitive_type_void,
  nr_f_primitive_types
};

static void
f_language_arch_info (struct gdbarch *gdbarch,
		      struct language_arch_info *lai)
{
  const struct builtin_f_type *builtin = builtin_f_type (gdbarch);

  lai->string_char_type = builtin->builtin_character;
  lai->primitive_type_vector
    = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_f_primitive_types + 1,
                              struct type *);

  lai->primitive_type_vector [f_primitive_type_character]
    = builtin->builtin_character;
  lai->primitive_type_vector [f_primitive_type_logical]
    = builtin->builtin_logical;
  lai->primitive_type_vector [f_primitive_type_logical_s1]
    = builtin->builtin_logical_s1;
  lai->primitive_type_vector [f_primitive_type_logical_s2]
    = builtin->builtin_logical_s2;
  lai->primitive_type_vector [f_primitive_type_logical_s8]
    = builtin->builtin_logical_s8;
  lai->primitive_type_vector [f_primitive_type_real]
    = builtin->builtin_real;
  lai->primitive_type_vector [f_primitive_type_real_s8]
    = builtin->builtin_real_s8;
  lai->primitive_type_vector [f_primitive_type_real_s16]
    = builtin->builtin_real_s16;
  lai->primitive_type_vector [f_primitive_type_complex_s8]
    = builtin->builtin_complex_s8;
  lai->primitive_type_vector [f_primitive_type_complex_s16]
    = builtin->builtin_complex_s16;
  lai->primitive_type_vector [f_primitive_type_void]
    = builtin->builtin_void;

  lai->bool_type_symbol = "logical";
  lai->bool_type_default = builtin->builtin_logical_s2;
}

/* Remove the modules separator :: from the default break list.  */

static const char *
f_word_break_characters (void)
{
  static char *retval;

  if (!retval)
    {
      char *s;

      retval = xstrdup (default_word_break_characters ());
      s = strchr (retval, ':');
      if (s)
	{
	  char *last_char = &s[strlen (s) - 1];

	  *s = *last_char;
	  *last_char = 0;
	}
    }
  return retval;
}

/* Consider the modules separator :: as a valid symbol name character
   class.  */

static void
f_collect_symbol_completion_matches (completion_tracker &tracker,
				     complete_symbol_mode mode,
				     symbol_name_match_type compare_name,
				     const char *text, const char *word,
				     enum type_code code)
{
  default_collect_symbol_completion_matches_break_on (tracker, mode,
						      compare_name,
						      text, word, ":", code);
}

/* Special expression evaluation cases for Fortran.  */
struct value *
evaluate_subexp_f (struct type *expect_type, struct expression *exp,
		   int *pos, enum noside noside)
{
  struct value *arg1 = NULL;
  enum exp_opcode op;
  int pc;
  struct type *type;

  pc = *pos;
  *pos += 1;
  op = exp->elts[pc].opcode;

  switch (op)
    {
    default:
      *pos -= 1;
      return evaluate_subexp_standard (expect_type, exp, pos, noside);

    case UNOP_KIND:
      arg1 = evaluate_subexp (NULL, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
      type = value_type (arg1);

      switch (TYPE_CODE (type))
        {
          case TYPE_CODE_STRUCT:
          case TYPE_CODE_UNION:
          case TYPE_CODE_MODULE:
          case TYPE_CODE_FUNC:
            error (_("argument to kind must be an intrinsic type"));
        }

      if (!TYPE_TARGET_TYPE (type))
        return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
				   TYPE_LENGTH (type));
      return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
				 TYPE_LENGTH (TYPE_TARGET_TYPE(type)));
    }

  /* Should be unreachable.  */
  return nullptr;
}

static const char *f_extensions[] =
{
  ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
  ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08",
  NULL
};

/* Expression processing for Fortran.  */
static const struct exp_descriptor exp_descriptor_f =
{
  print_subexp_standard,
  operator_length_standard,
  operator_check_standard,
  op_name_standard,
  dump_subexp_body_standard,
  evaluate_subexp_f
};

extern const struct language_defn f_language_defn =
{
  "fortran",
  "Fortran",
  language_fortran,
  range_check_on,
  case_sensitive_off,
  array_column_major,
  macro_expansion_no,
  f_extensions,
  &exp_descriptor_f,
  f_parse,			/* parser */
  null_post_parser,
  f_printchar,			/* Print character constant */
  f_printstr,			/* function to print string constant */
  f_emit_char,			/* Function to print a single character */
  f_print_type,			/* Print a type using appropriate syntax */
  default_print_typedef,	/* Print a typedef using appropriate syntax */
  f_val_print,			/* Print a value using appropriate syntax */
  c_value_print,		/* FIXME */
  default_read_var_value,	/* la_read_var_value */
  NULL,				/* Language specific skip_trampoline */
  NULL,                    	/* name_of_this */
  false,			/* la_store_sym_names_in_linkage_form_p */
  cp_lookup_symbol_nonlocal,	/* lookup_symbol_nonlocal */
  basic_lookup_transparent_type,/* lookup_transparent_type */

  /* We could support demangling here to provide module namespaces
     also for inferiors with only minimal symbol table (ELF symbols).
     Just the mangling standard is not standardized across compilers
     and there is no DW_AT_producer available for inferiors with only
     the ELF symbols to check the mangling kind.  */
  NULL,				/* Language specific symbol demangler */
  NULL,
  NULL,				/* Language specific
				   class_name_from_physname */
  f_op_print_tab,		/* expression operators for printing */
  0,				/* arrays are first-class (not c-style) */
  1,				/* String lower bound */
  f_word_break_characters,
  f_collect_symbol_completion_matches,
  f_language_arch_info,
  default_print_array_index,
  default_pass_by_reference,
  default_get_string,
  c_watch_location_expression,
  NULL,				/* la_get_symbol_name_matcher */
  iterate_over_symbols,
  default_search_name_hash,
  &default_varobj_ops,
  NULL,
  NULL,
  LANG_MAGIC
};

static void *
build_fortran_types (struct gdbarch *gdbarch)
{
  struct builtin_f_type *builtin_f_type
    = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);

  builtin_f_type->builtin_void
    = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "VOID");

  builtin_f_type->builtin_character
    = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");

  builtin_f_type->builtin_logical_s1
    = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");

  builtin_f_type->builtin_integer_s2
    = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
			 "integer*2");

  builtin_f_type->builtin_logical_s2
    = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
			 "logical*2");

  builtin_f_type->builtin_logical_s8
    = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
			 "logical*8");

  builtin_f_type->builtin_integer
    = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
			 "integer");

  builtin_f_type->builtin_logical
    = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
			 "logical*4");

  builtin_f_type->builtin_real
    = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
		       "real", gdbarch_float_format (gdbarch));
  builtin_f_type->builtin_real_s8
    = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
		       "real*8", gdbarch_double_format (gdbarch));
  builtin_f_type->builtin_real_s16
    = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
		       "real*16", gdbarch_long_double_format (gdbarch));

  builtin_f_type->builtin_complex_s8
    = arch_complex_type (gdbarch, "complex*8",
			 builtin_f_type->builtin_real);
  builtin_f_type->builtin_complex_s16
    = arch_complex_type (gdbarch, "complex*16",
			 builtin_f_type->builtin_real_s8);
  builtin_f_type->builtin_complex_s32
    = arch_complex_type (gdbarch, "complex*32",
			 builtin_f_type->builtin_real_s16);

  return builtin_f_type;
}

static struct gdbarch_data *f_type_data;

const struct builtin_f_type *
builtin_f_type (struct gdbarch *gdbarch)
{
  return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
}

void
_initialize_f_language (void)
{
  f_type_data = gdbarch_data_register_post_init (build_fortran_types);
}

/* See f-lang.h.  */

struct value *
fortran_argument_convert (struct value *value, bool is_artificial)
{
  if (!is_artificial)
    {
      /* If the value is not in the inferior e.g. registers values,
	 convenience variables and user input.  */
      if (VALUE_LVAL (value) != lval_memory)
	{
	  struct type *type = value_type (value);
	  const int length = TYPE_LENGTH (type);
	  const CORE_ADDR addr
	    = value_as_long (value_allocate_space_in_inferior (length));
	  write_memory (addr, value_contents (value), length);
	  struct value *val
	    = value_from_contents_and_address (type, value_contents (value),
					       addr);
	  return value_addr (val);
	}
      else
	return value_addr (value); /* Program variables, e.g. arrays.  */
    }
    return value;
}

/* See f-lang.h.  */

struct type *
fortran_preserve_arg_pointer (struct value *arg, struct type *type)
{
  if (TYPE_CODE (value_type (arg)) == TYPE_CODE_PTR)
    return value_type (arg);
  return type;
}
Commit	Line	Data
c906108c	1	/* Fortran language support routines for GDB, the GNU debugger.
ce27fb25	2
42a4f53d	3	Copyright (C) 1993-2019 Free Software Foundation, Inc.
ce27fb25	4
c906108c SS	5	Contributed by Motorola. Adapted from the C parser by Farooq Butt
	6	(fmbutt@engage.sps.mot.com).
	7
c5aa993b	8	This file is part of GDB.
c906108c	9
c5aa993b JM	10	This program is free software; you can redistribute it and/or modify
c5aa993b JM	11	it under the terms of the GNU General Public License as published by
a9762ec7	12	the Free Software Foundation; either version 3 of the License, or
c5aa993b	13	(at your option) any later version.
c906108c	14
c5aa993b JM	15	This program is distributed in the hope that it will be useful,
	16	but WITHOUT ANY WARRANTY; without even the implied warranty of
	17	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	18	GNU General Public License for more details.
c906108c	19
c5aa993b	20	You should have received a copy of the GNU General Public License
a9762ec7	21	along with this program. If not, see <http://www.gnu.org/licenses/>. */
c906108c SS	22
c906108c SS	23	#include "defs.h"
c906108c SS	24	#include "symtab.h"
	25	#include "gdbtypes.h"
	26	#include "expression.h"
	27	#include "parser-defs.h"
	28	#include "language.h"
a53b64ea	29	#include "varobj.h"
aa3cfbda	30	#include "gdbcore.h"
c906108c	31	#include "f-lang.h"
745b8ca0	32	#include "valprint.h"
5f9a71c3	33	#include "value.h"
f55ee35c	34	#include "cp-support.h"
3b2b8fea	35	#include "charset.h"
8e069a98	36	#include "c-lang.h"
c906108c	37
c906108c	38
c906108c SS	39	/* Local functions */
c906108c SS	40
6c7a06a3 TT	41	static void f_printchar (int c, struct type type, struct ui_file stream);
	42	static void f_emit_char (int c, struct type *type,
	43	struct ui_file * stream, int quoter);
c906108c	44
3b2b8fea TT	45	/* Return the encoding that should be used for the character type
	46	TYPE. */
	47
	48	static const char *
	49	f_get_encoding (struct type *type)
	50	{
	51	const char *encoding;
	52
	53	switch (TYPE_LENGTH (type))
	54	{
	55	case 1:
	56	encoding = target_charset (get_type_arch (type));
	57	break;
	58	case 4:
	59	if (gdbarch_byte_order (get_type_arch (type)) == BFD_ENDIAN_BIG)
	60	encoding = "UTF-32BE";
	61	else
	62	encoding = "UTF-32LE";
	63	break;
	64
	65	default:
	66	error (_("unrecognized character type"));
	67	}
	68
	69	return encoding;
	70	}
	71
c906108c SS	72	/* Print the character C on STREAM as part of the contents of a literal
	73	string whose delimiter is QUOTER. Note that that format for printing
	74	characters and strings is language specific.
	75	FIXME: This is a copy of the same function from c-exp.y. It should
	76	be replaced with a true F77 version. */
	77
	78	static void
6c7a06a3	79	f_emit_char (int c, struct type type, struct ui_file stream, int quoter)
c906108c	80	{
3b2b8fea	81	const char *encoding = f_get_encoding (type);
c5aa993b	82
3b2b8fea	83	generic_emit_char (c, type, stream, quoter, encoding);
c906108c SS	84	}
c906108c SS	85
3b2b8fea	86	/* Implementation of la_printchar. */
c906108c SS	87
c906108c SS	88	static void
6c7a06a3	89	f_printchar (int c, struct type type, struct ui_file stream)
c906108c SS	90	{
c906108c SS	91	fputs_filtered ("'", stream);
6c7a06a3	92	LA_EMIT_CHAR (c, type, stream, '\'');
c906108c SS	93	fputs_filtered ("'", stream);
	94	}
	95
	96	/* Print the character string STRING, printing at most LENGTH characters.
	97	Printing stops early if the number hits print_max; repeat counts
	98	are printed as appropriate. Print ellipses at the end if we
	99	had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
	100	FIXME: This is a copy of the same function from c-exp.y. It should
0963b4bd	101	be replaced with a true F77 version. */
c906108c SS	102
c906108c SS	103	static void
6c7a06a3	104	f_printstr (struct ui_file stream, struct type type, const gdb_byte *string,
be759fcf	105	unsigned int length, const char *encoding, int force_ellipses,
79a45b7d	106	const struct value_print_options *options)
c906108c	107	{
3b2b8fea	108	const char *type_encoding = f_get_encoding (type);
c5aa993b	109
3b2b8fea TT	110	if (TYPE_LENGTH (type) == 4)
3b2b8fea TT	111	fputs_filtered ("4_", stream);
c5aa993b	112
3b2b8fea TT	113	if (!encoding \|\| !*encoding)
3b2b8fea TT	114	encoding = type_encoding;
c5aa993b	115
3b2b8fea TT	116	generic_printstr (stream, type, string, length, encoding,
3b2b8fea TT	117	force_ellipses, '\'', 0, options);
c906108c	118	}
c906108c	119	\f
c5aa993b	120
c906108c SS	121	/* Table of operators and their precedences for printing expressions. */
c906108c SS	122
c5aa993b JM	123	static const struct op_print f_op_print_tab[] =
	124	{
	125	{"+", BINOP_ADD, PREC_ADD, 0},
	126	{"+", UNOP_PLUS, PREC_PREFIX, 0},
	127	{"-", BINOP_SUB, PREC_ADD, 0},
	128	{"-", UNOP_NEG, PREC_PREFIX, 0},
	129	{"*", BINOP_MUL, PREC_MUL, 0},
	130	{"/", BINOP_DIV, PREC_MUL, 0},
	131	{"DIV", BINOP_INTDIV, PREC_MUL, 0},
	132	{"MOD", BINOP_REM, PREC_MUL, 0},
	133	{"=", BINOP_ASSIGN, PREC_ASSIGN, 1},
	134	{".OR.", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
	135	{".AND.", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
	136	{".NOT.", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
	137	{".EQ.", BINOP_EQUAL, PREC_EQUAL, 0},
	138	{".NE.", BINOP_NOTEQUAL, PREC_EQUAL, 0},
	139	{".LE.", BINOP_LEQ, PREC_ORDER, 0},
	140	{".GE.", BINOP_GEQ, PREC_ORDER, 0},
	141	{".GT.", BINOP_GTR, PREC_ORDER, 0},
	142	{".LT.", BINOP_LESS, PREC_ORDER, 0},
	143	{"**", UNOP_IND, PREC_PREFIX, 0},
	144	{"@", BINOP_REPEAT, PREC_REPEAT, 0},
f486487f	145	{NULL, OP_NULL, PREC_REPEAT, 0}
c906108c SS	146	};
c906108c SS	147	\f
cad351d1 UW	148	enum f_primitive_types {
	149	f_primitive_type_character,
	150	f_primitive_type_logical,
	151	f_primitive_type_logical_s1,
	152	f_primitive_type_logical_s2,
ce4b0682	153	f_primitive_type_logical_s8,
cad351d1 UW	154	f_primitive_type_integer,
	155	f_primitive_type_integer_s2,
	156	f_primitive_type_real,
	157	f_primitive_type_real_s8,
	158	f_primitive_type_real_s16,
	159	f_primitive_type_complex_s8,
	160	f_primitive_type_complex_s16,
	161	f_primitive_type_void,
	162	nr_f_primitive_types
c906108c SS	163	};
c906108c SS	164
cad351d1 UW	165	static void
	166	f_language_arch_info (struct gdbarch *gdbarch,
	167	struct language_arch_info *lai)
	168	{
54ef06c7 UW	169	const struct builtin_f_type *builtin = builtin_f_type (gdbarch);
	170
	171	lai->string_char_type = builtin->builtin_character;
cad351d1 UW	172	lai->primitive_type_vector
	173	= GDBARCH_OBSTACK_CALLOC (gdbarch, nr_f_primitive_types + 1,
	174	struct type *);
	175
	176	lai->primitive_type_vector [f_primitive_type_character]
54ef06c7	177	= builtin->builtin_character;
cad351d1	178	lai->primitive_type_vector [f_primitive_type_logical]
54ef06c7	179	= builtin->builtin_logical;
cad351d1	180	lai->primitive_type_vector [f_primitive_type_logical_s1]
54ef06c7	181	= builtin->builtin_logical_s1;
cad351d1	182	lai->primitive_type_vector [f_primitive_type_logical_s2]
54ef06c7	183	= builtin->builtin_logical_s2;
ce4b0682 SDJ	184	lai->primitive_type_vector [f_primitive_type_logical_s8]
ce4b0682 SDJ	185	= builtin->builtin_logical_s8;
cad351d1	186	lai->primitive_type_vector [f_primitive_type_real]
54ef06c7	187	= builtin->builtin_real;
cad351d1	188	lai->primitive_type_vector [f_primitive_type_real_s8]
54ef06c7	189	= builtin->builtin_real_s8;
cad351d1	190	lai->primitive_type_vector [f_primitive_type_real_s16]
54ef06c7	191	= builtin->builtin_real_s16;
cad351d1	192	lai->primitive_type_vector [f_primitive_type_complex_s8]
54ef06c7	193	= builtin->builtin_complex_s8;
cad351d1	194	lai->primitive_type_vector [f_primitive_type_complex_s16]
54ef06c7	195	= builtin->builtin_complex_s16;
cad351d1	196	lai->primitive_type_vector [f_primitive_type_void]
54ef06c7	197	= builtin->builtin_void;
fbb06eb1 UW	198
	199	lai->bool_type_symbol = "logical";
	200	lai->bool_type_default = builtin->builtin_logical_s2;
cad351d1 UW	201	}
cad351d1 UW	202
f55ee35c JK	203	/* Remove the modules separator :: from the default break list. */
f55ee35c JK	204
67cb5b2d	205	static const char *
f55ee35c JK	206	f_word_break_characters (void)
	207	{
	208	static char *retval;
	209
	210	if (!retval)
	211	{
	212	char *s;
	213
	214	retval = xstrdup (default_word_break_characters ());
	215	s = strchr (retval, ':');
	216	if (s)
	217	{
	218	char *last_char = &s[strlen (s) - 1];
	219
	220	s = last_char;
	221	*last_char = 0;
	222	}
	223	}
	224	return retval;
	225	}
	226
3e43a32a MS	227	/* Consider the modules separator :: as a valid symbol name character
3e43a32a MS	228	class. */
f55ee35c	229
eb3ff9a5 PA	230	static void
eb3ff9a5 PA	231	f_collect_symbol_completion_matches (completion_tracker &tracker,
c6756f62	232	complete_symbol_mode mode,
b5ec771e	233	symbol_name_match_type compare_name,
eb3ff9a5 PA	234	const char text, const char word,
eb3ff9a5 PA	235	enum type_code code)
f55ee35c	236	{
c6756f62	237	default_collect_symbol_completion_matches_break_on (tracker, mode,
b5ec771e	238	compare_name,
eb3ff9a5	239	text, word, ":", code);
f55ee35c JK	240	}
f55ee35c JK	241
9dad4a58 AB	242	/* Special expression evaluation cases for Fortran. */
	243	struct value *
	244	evaluate_subexp_f (struct type expect_type, struct expression exp,
	245	int *pos, enum noside noside)
	246	{
4d00f5d8 AB	247	struct value *arg1 = NULL;
	248	enum exp_opcode op;
	249	int pc;
	250	struct type *type;
	251
	252	pc = *pos;
	253	*pos += 1;
	254	op = exp->elts[pc].opcode;
	255
	256	switch (op)
	257	{
	258	default:
	259	*pos -= 1;
	260	return evaluate_subexp_standard (expect_type, exp, pos, noside);
	261
	262	case UNOP_KIND:
	263	arg1 = evaluate_subexp (NULL, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
	264	type = value_type (arg1);
	265
	266	switch (TYPE_CODE (type))
	267	{
	268	case TYPE_CODE_STRUCT:
	269	case TYPE_CODE_UNION:
	270	case TYPE_CODE_MODULE:
	271	case TYPE_CODE_FUNC:
	272	error (_("argument to kind must be an intrinsic type"));
	273	}
	274
	275	if (!TYPE_TARGET_TYPE (type))
	276	return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
	277	TYPE_LENGTH (type));
	278	return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
	279	TYPE_LENGTH (TYPE_TARGET_TYPE(type)));
	280	}
	281
	282	/* Should be unreachable. */
	283	return nullptr;
9dad4a58 AB	284	}
9dad4a58 AB	285
56618e20 TT	286	static const char *f_extensions[] =
	287	{
	288	".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
	289	".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08",
	290	NULL
	291	};
	292
9dad4a58 AB	293	/* Expression processing for Fortran. */
	294	static const struct exp_descriptor exp_descriptor_f =
	295	{
	296	print_subexp_standard,
	297	operator_length_standard,
	298	operator_check_standard,
	299	op_name_standard,
	300	dump_subexp_body_standard,
	301	evaluate_subexp_f
	302	};
	303
47e77640	304	extern const struct language_defn f_language_defn =
c5aa993b	305	{
c906108c	306	"fortran",
6abde28f	307	"Fortran",
c906108c	308	language_fortran,
c906108c	309	range_check_on,
63872f9d	310	case_sensitive_off,
7ca2d3a3	311	array_column_major,
9a044a89	312	macro_expansion_no,
56618e20	313	f_extensions,
9dad4a58	314	&exp_descriptor_f,
c906108c	315	f_parse, /* parser */
e85c3284	316	null_post_parser,
c906108c SS	317	f_printchar, /* Print character constant */
	318	f_printstr, /* function to print string constant */
	319	f_emit_char, /* Function to print a single character */
c5aa993b	320	f_print_type, /* Print a type using appropriate syntax */
5c6ce71d	321	default_print_typedef, /* Print a typedef using appropriate syntax */
c906108c	322	f_val_print, /* Print a value using appropriate syntax */
c5aa993b	323	c_value_print, /* FIXME */
a5ee536b	324	default_read_var_value, /* la_read_var_value */
f636b87d	325	NULL, /* Language specific skip_trampoline */
2b2d9e11	326	NULL, /* name_of_this */
59cc4834	327	false, /* la_store_sym_names_in_linkage_form_p */
f55ee35c	328	cp_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
b368761e	329	basic_lookup_transparent_type,/* lookup_transparent_type */
8b302db8 TT	330
	331	/* We could support demangling here to provide module namespaces
	332	also for inferiors with only minimal symbol table (ELF symbols).
	333	Just the mangling standard is not standardized across compilers
	334	and there is no DW_AT_producer available for inferiors with only
	335	the ELF symbols to check the mangling kind. */
9a3d7dfd	336	NULL, /* Language specific symbol demangler */
8b302db8	337	NULL,
3e43a32a MS	338	NULL, /* Language specific
3e43a32a MS	339	class_name_from_physname */
c906108c SS	340	f_op_print_tab, /* expression operators for printing */
	341	0, /* arrays are first-class (not c-style) */
	342	1, /* String lower bound */
f55ee35c	343	f_word_break_characters,
eb3ff9a5	344	f_collect_symbol_completion_matches,
cad351d1	345	f_language_arch_info,
e79af960	346	default_print_array_index,
41f1b697	347	default_pass_by_reference,
ae6a3a4c	348	default_get_string,
43cc5389	349	c_watch_location_expression,
b5ec771e	350	NULL, /* la_get_symbol_name_matcher */
f8eba3c6	351	iterate_over_symbols,
5ffa0793	352	default_search_name_hash,
a53b64ea	353	&default_varobj_ops,
bb2ec1b3 TT	354	NULL,
bb2ec1b3 TT	355	NULL,
c906108c	356	LANG_MAGIC
c5aa993b	357	};
c906108c	358
54ef06c7 UW	359	static void *
54ef06c7 UW	360	build_fortran_types (struct gdbarch *gdbarch)
c906108c	361	{
54ef06c7 UW	362	struct builtin_f_type *builtin_f_type
	363	= GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
	364
e9bb382b	365	builtin_f_type->builtin_void
77b7c781	366	= arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "VOID");
e9bb382b UW	367
	368	builtin_f_type->builtin_character
	369	= arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
	370
	371	builtin_f_type->builtin_logical_s1
	372	= arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
	373
	374	builtin_f_type->builtin_integer_s2
	375	= arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
	376	"integer*2");
	377
	378	builtin_f_type->builtin_logical_s2
	379	= arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
	380	"logical*2");
	381
ce4b0682 SDJ	382	builtin_f_type->builtin_logical_s8
	383	= arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
	384	"logical*8");
	385
e9bb382b UW	386	builtin_f_type->builtin_integer
	387	= arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
	388	"integer");
	389
	390	builtin_f_type->builtin_logical
	391	= arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
	392	"logical*4");
	393
	394	builtin_f_type->builtin_real
	395	= arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
49f190bc	396	"real", gdbarch_float_format (gdbarch));
e9bb382b UW	397	builtin_f_type->builtin_real_s8
e9bb382b UW	398	= arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
49f190bc	399	"real*8", gdbarch_double_format (gdbarch));
e9bb382b UW	400	builtin_f_type->builtin_real_s16
e9bb382b UW	401	= arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
49f190bc	402	"real*16", gdbarch_long_double_format (gdbarch));
e9bb382b UW	403
	404	builtin_f_type->builtin_complex_s8
	405	= arch_complex_type (gdbarch, "complex*8",
	406	builtin_f_type->builtin_real);
	407	builtin_f_type->builtin_complex_s16
	408	= arch_complex_type (gdbarch, "complex*16",
	409	builtin_f_type->builtin_real_s8);
	410	builtin_f_type->builtin_complex_s32
	411	= arch_complex_type (gdbarch, "complex*32",
	412	builtin_f_type->builtin_real_s16);
54ef06c7 UW	413
	414	return builtin_f_type;
	415	}
	416
	417	static struct gdbarch_data *f_type_data;
	418
	419	const struct builtin_f_type *
	420	builtin_f_type (struct gdbarch *gdbarch)
	421	{
9a3c8263	422	return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
4e845cd3 MS	423	}
	424
	425	void
	426	_initialize_f_language (void)
	427	{
54ef06c7	428	f_type_data = gdbarch_data_register_post_init (build_fortran_types);
c906108c	429	}
aa3cfbda RB	430
	431	/* See f-lang.h. */
	432
	433	struct value *
	434	fortran_argument_convert (struct value *value, bool is_artificial)
	435	{
	436	if (!is_artificial)
	437	{
	438	/* If the value is not in the inferior e.g. registers values,
	439	convenience variables and user input. */
	440	if (VALUE_LVAL (value) != lval_memory)
	441	{
	442	struct type *type = value_type (value);
	443	const int length = TYPE_LENGTH (type);
	444	const CORE_ADDR addr
	445	= value_as_long (value_allocate_space_in_inferior (length));
	446	write_memory (addr, value_contents (value), length);
	447	struct value *val
	448	= value_from_contents_and_address (type, value_contents (value),
	449	addr);
	450	return value_addr (val);
	451	}
	452	else
	453	return value_addr (value); /* Program variables, e.g. arrays. */
	454	}
	455	return value;
	456	}
	457
	458	/* See f-lang.h. */
	459
	460	struct type *
	461	fortran_preserve_arg_pointer (struct value arg, struct type type)
	462	{
	463	if (TYPE_CODE (value_type (arg)) == TYPE_CODE_PTR)
	464	return value_type (arg);
	465	return type;
	466	}