[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)
{
  /* Currently no special handling is required. */
  return evaluate_subexp_standard (expect_type, exp, pos, noside);
}

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
	1	/* Fortran language support routines for GDB, the GNU debugger.
	2
	3	Copyright (C) 1993-2019 Free Software Foundation, Inc.
	4
	5	Contributed by Motorola. Adapted from the C parser by Farooq Butt
	6	(fmbutt@engage.sps.mot.com).
	7
	8	This file is part of GDB.
	9
	10	This program is free software; you can redistribute it and/or modify
	11	it under the terms of the GNU General Public License as published by
	12	the Free Software Foundation; either version 3 of the License, or
	13	(at your option) any later version.
	14
	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.
	19
	20	You should have received a copy of the GNU General Public License
	21	along with this program. If not, see <http://www.gnu.org/licenses/>. */
	22
	23	#include "defs.h"
	24	#include "symtab.h"
	25	#include "gdbtypes.h"
	26	#include "expression.h"
	27	#include "parser-defs.h"
	28	#include "language.h"
	29	#include "varobj.h"
	30	#include "gdbcore.h"
	31	#include "f-lang.h"
	32	#include "valprint.h"
	33	#include "value.h"
	34	#include "cp-support.h"
	35	#include "charset.h"
	36	#include "c-lang.h"
	37
	38
	39	/* Local functions */
	40
	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);
	44
	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
	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
	79	f_emit_char (int c, struct type type, struct ui_file stream, int quoter)
	80	{
	81	const char *encoding = f_get_encoding (type);
	82
	83	generic_emit_char (c, type, stream, quoter, encoding);
	84	}
	85
	86	/* Implementation of la_printchar. */
	87
	88	static void
	89	f_printchar (int c, struct type type, struct ui_file stream)
	90	{
	91	fputs_filtered ("'", stream);
	92	LA_EMIT_CHAR (c, type, stream, '\'');
	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
	101	be replaced with a true F77 version. */
	102
	103	static void
	104	f_printstr (struct ui_file stream, struct type type, const gdb_byte *string,
	105	unsigned int length, const char *encoding, int force_ellipses,
	106	const struct value_print_options *options)
	107	{
	108	const char *type_encoding = f_get_encoding (type);
	109
	110	if (TYPE_LENGTH (type) == 4)
	111	fputs_filtered ("4_", stream);
	112
	113	if (!encoding \|\| !*encoding)
	114	encoding = type_encoding;
	115
	116	generic_printstr (stream, type, string, length, encoding,
	117	force_ellipses, '\'', 0, options);
	118	}
	119	\f
	120
	121	/* Table of operators and their precedences for printing expressions. */
	122
	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},
	145	{NULL, OP_NULL, PREC_REPEAT, 0}
	146	};
	147	\f
	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,
	153	f_primitive_type_logical_s8,
	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
	163	};
	164
	165	static void
	166	f_language_arch_info (struct gdbarch *gdbarch,
	167	struct language_arch_info *lai)
	168	{
	169	const struct builtin_f_type *builtin = builtin_f_type (gdbarch);
	170
	171	lai->string_char_type = builtin->builtin_character;
	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]
	177	= builtin->builtin_character;
	178	lai->primitive_type_vector [f_primitive_type_logical]
	179	= builtin->builtin_logical;
	180	lai->primitive_type_vector [f_primitive_type_logical_s1]
	181	= builtin->builtin_logical_s1;
	182	lai->primitive_type_vector [f_primitive_type_logical_s2]
	183	= builtin->builtin_logical_s2;
	184	lai->primitive_type_vector [f_primitive_type_logical_s8]
	185	= builtin->builtin_logical_s8;
	186	lai->primitive_type_vector [f_primitive_type_real]
	187	= builtin->builtin_real;
	188	lai->primitive_type_vector [f_primitive_type_real_s8]
	189	= builtin->builtin_real_s8;
	190	lai->primitive_type_vector [f_primitive_type_real_s16]
	191	= builtin->builtin_real_s16;
	192	lai->primitive_type_vector [f_primitive_type_complex_s8]
	193	= builtin->builtin_complex_s8;
	194	lai->primitive_type_vector [f_primitive_type_complex_s16]
	195	= builtin->builtin_complex_s16;
	196	lai->primitive_type_vector [f_primitive_type_void]
	197	= builtin->builtin_void;
	198
	199	lai->bool_type_symbol = "logical";
	200	lai->bool_type_default = builtin->builtin_logical_s2;
	201	}
	202
	203	/* Remove the modules separator :: from the default break list. */
	204
	205	static const char *
	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
	227	/* Consider the modules separator :: as a valid symbol name character
	228	class. */
	229
	230	static void
	231	f_collect_symbol_completion_matches (completion_tracker &tracker,
	232	complete_symbol_mode mode,
	233	symbol_name_match_type compare_name,
	234	const char text, const char word,
	235	enum type_code code)
	236	{
	237	default_collect_symbol_completion_matches_break_on (tracker, mode,
	238	compare_name,
	239	text, word, ":", code);
	240	}
	241
	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	{
	247	/* Currently no special handling is required. */
	248	return evaluate_subexp_standard (expect_type, exp, pos, noside);
	249	}
	250
	251	static const char *f_extensions[] =
	252	{
	253	".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
	254	".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08",
	255	NULL
	256	};
	257
	258	/* Expression processing for Fortran. */
	259	static const struct exp_descriptor exp_descriptor_f =
	260	{
	261	print_subexp_standard,
	262	operator_length_standard,
	263	operator_check_standard,
	264	op_name_standard,
	265	dump_subexp_body_standard,
	266	evaluate_subexp_f
	267	};
	268
	269	extern const struct language_defn f_language_defn =
	270	{
	271	"fortran",
	272	"Fortran",
	273	language_fortran,
	274	range_check_on,
	275	case_sensitive_off,
	276	array_column_major,
	277	macro_expansion_no,
	278	f_extensions,
	279	&exp_descriptor_f,
	280	f_parse, /* parser */
	281	null_post_parser,
	282	f_printchar, /* Print character constant */
	283	f_printstr, /* function to print string constant */
	284	f_emit_char, /* Function to print a single character */
	285	f_print_type, /* Print a type using appropriate syntax */
	286	default_print_typedef, /* Print a typedef using appropriate syntax */
	287	f_val_print, /* Print a value using appropriate syntax */
	288	c_value_print, /* FIXME */
	289	default_read_var_value, /* la_read_var_value */
	290	NULL, /* Language specific skip_trampoline */
	291	NULL, /* name_of_this */
	292	false, /* la_store_sym_names_in_linkage_form_p */
	293	cp_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
	294	basic_lookup_transparent_type,/* lookup_transparent_type */
	295
	296	/* We could support demangling here to provide module namespaces
	297	also for inferiors with only minimal symbol table (ELF symbols).
	298	Just the mangling standard is not standardized across compilers
	299	and there is no DW_AT_producer available for inferiors with only
	300	the ELF symbols to check the mangling kind. */
	301	NULL, /* Language specific symbol demangler */
	302	NULL,
	303	NULL, /* Language specific
	304	class_name_from_physname */
	305	f_op_print_tab, /* expression operators for printing */
	306	0, /* arrays are first-class (not c-style) */
	307	1, /* String lower bound */
	308	f_word_break_characters,
	309	f_collect_symbol_completion_matches,
	310	f_language_arch_info,
	311	default_print_array_index,
	312	default_pass_by_reference,
	313	default_get_string,
	314	c_watch_location_expression,
	315	NULL, /* la_get_symbol_name_matcher */
	316	iterate_over_symbols,
	317	default_search_name_hash,
	318	&default_varobj_ops,
	319	NULL,
	320	NULL,
	321	LANG_MAGIC
	322	};
	323
	324	static void *
	325	build_fortran_types (struct gdbarch *gdbarch)
	326	{
	327	struct builtin_f_type *builtin_f_type
	328	= GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
	329
	330	builtin_f_type->builtin_void
	331	= arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "VOID");
	332
	333	builtin_f_type->builtin_character
	334	= arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
	335
	336	builtin_f_type->builtin_logical_s1
	337	= arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
	338
	339	builtin_f_type->builtin_integer_s2
	340	= arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
	341	"integer*2");
	342
	343	builtin_f_type->builtin_logical_s2
	344	= arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
	345	"logical*2");
	346
	347	builtin_f_type->builtin_logical_s8
	348	= arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
	349	"logical*8");
	350
	351	builtin_f_type->builtin_integer
	352	= arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
	353	"integer");
	354
	355	builtin_f_type->builtin_logical
	356	= arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
	357	"logical*4");
	358
	359	builtin_f_type->builtin_real
	360	= arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
	361	"real", gdbarch_float_format (gdbarch));
	362	builtin_f_type->builtin_real_s8
	363	= arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
	364	"real*8", gdbarch_double_format (gdbarch));
	365	builtin_f_type->builtin_real_s16
	366	= arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
	367	"real*16", gdbarch_long_double_format (gdbarch));
	368
	369	builtin_f_type->builtin_complex_s8
	370	= arch_complex_type (gdbarch, "complex*8",
	371	builtin_f_type->builtin_real);
	372	builtin_f_type->builtin_complex_s16
	373	= arch_complex_type (gdbarch, "complex*16",
	374	builtin_f_type->builtin_real_s8);
	375	builtin_f_type->builtin_complex_s32
	376	= arch_complex_type (gdbarch, "complex*32",
	377	builtin_f_type->builtin_real_s16);
	378
	379	return builtin_f_type;
	380	}
	381
	382	static struct gdbarch_data *f_type_data;
	383
	384	const struct builtin_f_type *
	385	builtin_f_type (struct gdbarch *gdbarch)
	386	{
	387	return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
	388	}
	389
	390	void
	391	_initialize_f_language (void)
	392	{
	393	f_type_data = gdbarch_data_register_post_init (build_fortran_types);
	394	}
	395
	396	/* See f-lang.h. */
	397
	398	struct value *
	399	fortran_argument_convert (struct value *value, bool is_artificial)
	400	{
	401	if (!is_artificial)
	402	{
	403	/* If the value is not in the inferior e.g. registers values,
	404	convenience variables and user input. */
	405	if (VALUE_LVAL (value) != lval_memory)
	406	{
	407	struct type *type = value_type (value);
	408	const int length = TYPE_LENGTH (type);
	409	const CORE_ADDR addr
	410	= value_as_long (value_allocate_space_in_inferior (length));
	411	write_memory (addr, value_contents (value), length);
	412	struct value *val
	413	= value_from_contents_and_address (type, value_contents (value),
	414	addr);
	415	return value_addr (val);
	416	}
	417	else
	418	return value_addr (value); /* Program variables, e.g. arrays. */
	419	}
	420	return value;
	421	}
	422
	423	/* See f-lang.h. */
	424
	425	struct type *
	426	fortran_preserve_arg_pointer (struct value arg, struct type type)
	427	{
	428	if (TYPE_CODE (value_type (arg)) == TYPE_CODE_PTR)
	429	return value_type (arg);
	430	return type;
	431	}