[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
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	{
	247	/* Currently no special handling is required. */
	248	return evaluate_subexp_standard (expect_type, exp, pos, noside);
	249	}
	250
56618e20 TT	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
9dad4a58 AB	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
47e77640	269	extern const struct language_defn f_language_defn =
c5aa993b	270	{
c906108c	271	"fortran",
6abde28f	272	"Fortran",
c906108c	273	language_fortran,
c906108c	274	range_check_on,
63872f9d	275	case_sensitive_off,
7ca2d3a3	276	array_column_major,
9a044a89	277	macro_expansion_no,
56618e20	278	f_extensions,
9dad4a58	279	&exp_descriptor_f,
c906108c	280	f_parse, /* parser */
e85c3284	281	null_post_parser,
c906108c SS	282	f_printchar, /* Print character constant */
	283	f_printstr, /* function to print string constant */
	284	f_emit_char, /* Function to print a single character */
c5aa993b	285	f_print_type, /* Print a type using appropriate syntax */
5c6ce71d	286	default_print_typedef, /* Print a typedef using appropriate syntax */
c906108c	287	f_val_print, /* Print a value using appropriate syntax */
c5aa993b	288	c_value_print, /* FIXME */
a5ee536b	289	default_read_var_value, /* la_read_var_value */
f636b87d	290	NULL, /* Language specific skip_trampoline */
2b2d9e11	291	NULL, /* name_of_this */
59cc4834	292	false, /* la_store_sym_names_in_linkage_form_p */
f55ee35c	293	cp_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
b368761e	294	basic_lookup_transparent_type,/* lookup_transparent_type */
8b302db8 TT	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. */
9a3d7dfd	301	NULL, /* Language specific symbol demangler */
8b302db8	302	NULL,
3e43a32a MS	303	NULL, /* Language specific
3e43a32a MS	304	class_name_from_physname */
c906108c SS	305	f_op_print_tab, /* expression operators for printing */
	306	0, /* arrays are first-class (not c-style) */
	307	1, /* String lower bound */
f55ee35c	308	f_word_break_characters,
eb3ff9a5	309	f_collect_symbol_completion_matches,
cad351d1	310	f_language_arch_info,
e79af960	311	default_print_array_index,
41f1b697	312	default_pass_by_reference,
ae6a3a4c	313	default_get_string,
43cc5389	314	c_watch_location_expression,
b5ec771e	315	NULL, /* la_get_symbol_name_matcher */
f8eba3c6	316	iterate_over_symbols,
5ffa0793	317	default_search_name_hash,
a53b64ea	318	&default_varobj_ops,
bb2ec1b3 TT	319	NULL,
bb2ec1b3 TT	320	NULL,
c906108c	321	LANG_MAGIC
c5aa993b	322	};
c906108c	323
54ef06c7 UW	324	static void *
54ef06c7 UW	325	build_fortran_types (struct gdbarch *gdbarch)
c906108c	326	{
54ef06c7 UW	327	struct builtin_f_type *builtin_f_type
	328	= GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
	329
e9bb382b	330	builtin_f_type->builtin_void
77b7c781	331	= arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "VOID");
e9bb382b UW	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
ce4b0682 SDJ	347	builtin_f_type->builtin_logical_s8
	348	= arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
	349	"logical*8");
	350
e9bb382b UW	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),
49f190bc	361	"real", gdbarch_float_format (gdbarch));
e9bb382b UW	362	builtin_f_type->builtin_real_s8
e9bb382b UW	363	= arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
49f190bc	364	"real*8", gdbarch_double_format (gdbarch));
e9bb382b UW	365	builtin_f_type->builtin_real_s16
e9bb382b UW	366	= arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
49f190bc	367	"real*16", gdbarch_long_double_format (gdbarch));
e9bb382b UW	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);
54ef06c7 UW	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	{
9a3c8263	387	return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
4e845cd3 MS	388	}
	389
	390	void
	391	_initialize_f_language (void)
	392	{
54ef06c7	393	f_type_data = gdbarch_data_register_post_init (build_fortran_types);
c906108c	394	}
aa3cfbda RB	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	}