[thirdparty/binutils-gdb.git] / gdb / m2-lang.c

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

   Copyright (C) 1992-2020 Free Software Foundation, Inc.

   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 "m2-lang.h"
#include "c-lang.h"
#include "valprint.h"
#include "gdbarch.h"

static void m2_printchar (int, struct type *, struct ui_file *);

/* FIXME:  This is a copy of the same function from c-exp.y.  It should
   be replaced with a true Modula version.  */

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

static struct value *
evaluate_subexp_modula2 (struct type *expect_type, struct expression *exp,
			 int *pos, enum noside noside)
{
  enum exp_opcode op = exp->elts[*pos].opcode;
  struct value *arg1;
  struct value *arg2;
  struct type *type;

  switch (op)
    {
    case UNOP_HIGH:
      (*pos)++;
      arg1 = evaluate_subexp_with_coercion (exp, pos, noside);

      if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
	return arg1;
      else
	{
	  arg1 = coerce_ref (arg1);
	  type = check_typedef (value_type (arg1));

	  if (m2_is_unbounded_array (type))
	    {
	      struct value *temp = arg1;

	      type = type->field (1).type ();
	      /* i18n: Do not translate the "_m2_high" part!  */
	      arg1 = value_struct_elt (&temp, NULL, "_m2_high", NULL,
				       _("unbounded structure "
					 "missing _m2_high field"));
	  
	      if (value_type (arg1) != type)
		arg1 = value_cast (type, arg1);
	    }
	}
      return arg1;

    case BINOP_SUBSCRIPT:
      (*pos)++;
      arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
      arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
      if (noside == EVAL_SKIP)
	goto nosideret;
      /* If the user attempts to subscript something that is not an
         array or pointer type (like a plain int variable for example),
         then report this as an error.  */

      arg1 = coerce_ref (arg1);
      type = check_typedef (value_type (arg1));

      if (m2_is_unbounded_array (type))
	{
	  struct value *temp = arg1;
	  type = type->field (0).type ();
	  if (type == NULL || (type->code () != TYPE_CODE_PTR))
	    {
	      warning (_("internal error: unbounded "
			 "array structure is unknown"));
	      return evaluate_subexp_standard (expect_type, exp, pos, noside);
	    }
	  /* i18n: Do not translate the "_m2_contents" part!  */
	  arg1 = value_struct_elt (&temp, NULL, "_m2_contents", NULL,
				   _("unbounded structure "
				     "missing _m2_contents field"));
	  
	  if (value_type (arg1) != type)
	    arg1 = value_cast (type, arg1);

	  check_typedef (value_type (arg1));
	  return value_ind (value_ptradd (arg1, value_as_long (arg2)));
	}
      else
	if (type->code () != TYPE_CODE_ARRAY)
	  {
	    if (type->name ())
	      error (_("cannot subscript something of type `%s'"),
		     type->name ());
	    else
	      error (_("cannot subscript requested type"));
	  }

      if (noside == EVAL_AVOID_SIDE_EFFECTS)
	return value_zero (TYPE_TARGET_TYPE (type), VALUE_LVAL (arg1));
      else
	return value_subscript (arg1, value_as_long (arg2));

    default:
      return evaluate_subexp_standard (expect_type, exp, pos, noside);
    }

 nosideret:
  return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
}
\f

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

static const struct op_print m2_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},
  {"=", BINOP_EQUAL, PREC_EQUAL, 0},
  {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
  {"<=", BINOP_LEQ, PREC_ORDER, 0},
  {">=", BINOP_GEQ, PREC_ORDER, 0},
  {">", BINOP_GTR, PREC_ORDER, 0},
  {"<", BINOP_LESS, PREC_ORDER, 0},
  {"^", UNOP_IND, PREC_PREFIX, 0},
  {"@", BINOP_REPEAT, PREC_REPEAT, 0},
  {"CAP", UNOP_CAP, PREC_BUILTIN_FUNCTION, 0},
  {"CHR", UNOP_CHR, PREC_BUILTIN_FUNCTION, 0},
  {"ORD", UNOP_ORD, PREC_BUILTIN_FUNCTION, 0},
  {"FLOAT", UNOP_FLOAT, PREC_BUILTIN_FUNCTION, 0},
  {"HIGH", UNOP_HIGH, PREC_BUILTIN_FUNCTION, 0},
  {"MAX", UNOP_MAX, PREC_BUILTIN_FUNCTION, 0},
  {"MIN", UNOP_MIN, PREC_BUILTIN_FUNCTION, 0},
  {"ODD", UNOP_ODD, PREC_BUILTIN_FUNCTION, 0},
  {"TRUNC", UNOP_TRUNC, PREC_BUILTIN_FUNCTION, 0},
  {NULL, OP_NULL, PREC_BUILTIN_FUNCTION, 0}
};
\f
/* The built-in types of Modula-2.  */

enum m2_primitive_types {
  m2_primitive_type_char,
  m2_primitive_type_int,
  m2_primitive_type_card,
  m2_primitive_type_real,
  m2_primitive_type_bool,
  nr_m2_primitive_types
};

const struct exp_descriptor exp_descriptor_modula2 = 
{
  print_subexp_standard,
  operator_length_standard,
  operator_check_standard,
  op_name_standard,
  dump_subexp_body_standard,
  evaluate_subexp_modula2
};

/* Constant data describing the M2 language.  */

extern const struct language_data m2_language_data =
{
  "modula-2",
  "Modula-2",
  language_m2,
  range_check_on,
  case_sensitive_on,
  array_row_major,
  macro_expansion_no,
  NULL,
  &exp_descriptor_modula2,
  NULL,		                /* name_of_this */
  false,			/* la_store_sym_names_in_linkage_form_p */
  m2_op_print_tab,		/* expression operators for printing */
  0,				/* arrays are first-class (not c-style) */
  0,				/* String lower bound */
  &default_varobj_ops,
  "{...}"			/* la_struct_too_deep_ellipsis */
};

/* Class representing the M2 language.  */

class m2_language : public language_defn
{
public:
  m2_language ()
    : language_defn (language_m2, m2_language_data)
  { /* Nothing.  */ }

  /* See language.h.  */
  void language_arch_info (struct gdbarch *gdbarch,
			   struct language_arch_info *lai) const override
  {
    const struct builtin_m2_type *builtin = builtin_m2_type (gdbarch);

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

    lai->primitive_type_vector [m2_primitive_type_char]
      = builtin->builtin_char;
    lai->primitive_type_vector [m2_primitive_type_int]
      = builtin->builtin_int;
    lai->primitive_type_vector [m2_primitive_type_card]
      = builtin->builtin_card;
    lai->primitive_type_vector [m2_primitive_type_real]
      = builtin->builtin_real;
    lai->primitive_type_vector [m2_primitive_type_bool]
      = builtin->builtin_bool;

    lai->bool_type_symbol = "BOOLEAN";
    lai->bool_type_default = builtin->builtin_bool;
  }

  /* See language.h.  */

  void print_type (struct type *type, const char *varstring,
		   struct ui_file *stream, int show, int level,
		   const struct type_print_options *flags) const override
  {
    m2_print_type (type, varstring, stream, show, level, flags);
  }

  /* See language.h.  */

  void value_print_inner
	(struct value *val, struct ui_file *stream, int recurse,
	 const struct value_print_options *options) const override
  {
    return m2_value_print_inner (val, stream, recurse, options);
  }

  /* See language.h.  */

  int parser (struct parser_state *ps) const override
  {
    return m2_parse (ps);
  }

  /* See language.h.  */

  void emitchar (int ch, struct type *chtype,
		 struct ui_file *stream, int quoter) const override
  {
    ch &= 0xFF;			/* Avoid sign bit follies.  */

    if (PRINT_LITERAL_FORM (ch))
      {
	if (ch == '\\' || ch == quoter)
	  fputs_filtered ("\\", stream);
	fprintf_filtered (stream, "%c", ch);
      }
    else
      {
	switch (ch)
	  {
	  case '\n':
	    fputs_filtered ("\\n", stream);
	    break;
	  case '\b':
	    fputs_filtered ("\\b", stream);
	    break;
	  case '\t':
	    fputs_filtered ("\\t", stream);
	    break;
	  case '\f':
	    fputs_filtered ("\\f", stream);
	    break;
	  case '\r':
	    fputs_filtered ("\\r", stream);
	    break;
	  case '\033':
	    fputs_filtered ("\\e", stream);
	    break;
	  case '\007':
	    fputs_filtered ("\\a", stream);
	    break;
	  default:
	    fprintf_filtered (stream, "\\%.3o", (unsigned int) ch);
	    break;
	  }
      }
  }

  /* See language.h.  */

  void printchar (int ch, struct type *chtype,
		  struct ui_file *stream) const override
  {
    m2_printchar (ch, chtype, stream);
  }

  /* See language.h.  */

  void printstr (struct ui_file *stream, struct type *elttype,
		 const gdb_byte *string, unsigned int length,
		 const char *encoding, int force_ellipses,
		 const struct value_print_options *options) const override
  {
    unsigned int i;
    unsigned int things_printed = 0;
    int in_quotes = 0;
    int need_comma = 0;

    if (length == 0)
      {
	fputs_filtered ("\"\"", gdb_stdout);
	return;
      }

    for (i = 0; i < length && things_printed < options->print_max; ++i)
      {
	/* Position of the character we are examining
	   to see whether it is repeated.  */
	unsigned int rep1;
	/* Number of repetitions we have detected so far.  */
	unsigned int reps;

	QUIT;

	if (need_comma)
	  {
	    fputs_filtered (", ", stream);
	    need_comma = 0;
	  }

	rep1 = i + 1;
	reps = 1;
	while (rep1 < length && string[rep1] == string[i])
	  {
	    ++rep1;
	    ++reps;
	  }

	if (reps > options->repeat_count_threshold)
	  {
	    if (in_quotes)
	      {
		fputs_filtered ("\", ", stream);
		in_quotes = 0;
	      }
	    m2_printchar (string[i], elttype, stream);
	    fprintf_filtered (stream, " <repeats %u times>", reps);
	    i = rep1 - 1;
	    things_printed += options->repeat_count_threshold;
	    need_comma = 1;
	  }
	else
	  {
	    if (!in_quotes)
	      {
		fputs_filtered ("\"", stream);
		in_quotes = 1;
	      }
	    LA_EMIT_CHAR (string[i], elttype, stream, '"');
	    ++things_printed;
	  }
      }

    /* Terminate the quotes if necessary.  */
    if (in_quotes)
      fputs_filtered ("\"", stream);

    if (force_ellipses || i < length)
      fputs_filtered ("...", stream);
  }

  /* See language.h.  */

  void print_typedef (struct type *type, struct symbol *new_symbol,
		      struct ui_file *stream) const override
  {
    m2_print_typedef (type, new_symbol, stream);
  }

  /* See language.h.  */

  bool is_string_type_p (struct type *type) const override
  {
    type = check_typedef (type);
    if (type->code () == TYPE_CODE_ARRAY
	&& TYPE_LENGTH (type) > 0
	&& TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)
      {
	struct type *elttype = check_typedef (TYPE_TARGET_TYPE (type));

	if (TYPE_LENGTH (elttype) == 1
	    && (elttype->code () == TYPE_CODE_INT
		|| elttype->code () == TYPE_CODE_CHAR))
	  return true;
      }

    return false;
  }
};

/* Single instance of the M2 language.  */

static m2_language m2_language_defn;

static void *
build_m2_types (struct gdbarch *gdbarch)
{
  struct builtin_m2_type *builtin_m2_type
    = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_m2_type);

  /* Modula-2 "pervasive" types.  NOTE:  these can be redefined!!! */
  builtin_m2_type->builtin_int
    = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0, "INTEGER");
  builtin_m2_type->builtin_card
    = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "CARDINAL");
  builtin_m2_type->builtin_real
    = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch), "REAL",
		       gdbarch_float_format (gdbarch));
  builtin_m2_type->builtin_char
    = arch_character_type (gdbarch, TARGET_CHAR_BIT, 1, "CHAR");
  builtin_m2_type->builtin_bool
    = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "BOOLEAN");

  return builtin_m2_type;
}

static struct gdbarch_data *m2_type_data;

const struct builtin_m2_type *
builtin_m2_type (struct gdbarch *gdbarch)
{
  return (const struct builtin_m2_type *) gdbarch_data (gdbarch, m2_type_data);
}


/* Initialization for Modula-2 */

void _initialize_m2_language ();
void
_initialize_m2_language ()
{
  m2_type_data = gdbarch_data_register_post_init (build_m2_types);
}
Commit	Line	Data
c906108c	1	/* Modula 2 language support routines for GDB, the GNU debugger.
ce27fb25	2
b811d2c2	3	Copyright (C) 1992-2020 Free Software Foundation, Inc.
c906108c	4
c5aa993b	5	This file is part of GDB.
c906108c	6
c5aa993b JM	7	This program is free software; you can redistribute it and/or modify
c5aa993b JM	8	it under the terms of the GNU General Public License as published by
a9762ec7	9	the Free Software Foundation; either version 3 of the License, or
c5aa993b	10	(at your option) any later version.
c906108c	11
c5aa993b JM	12	This program is distributed in the hope that it will be useful,
	13	but WITHOUT ANY WARRANTY; without even the implied warranty of
	14	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	GNU General Public License for more details.
c906108c	16
c5aa993b	17	You should have received a copy of the GNU General Public License
a9762ec7	18	along with this program. If not, see <http://www.gnu.org/licenses/>. */
c906108c SS	19
	20	#include "defs.h"
	21	#include "symtab.h"
	22	#include "gdbtypes.h"
	23	#include "expression.h"
	24	#include "parser-defs.h"
	25	#include "language.h"
a53b64ea	26	#include "varobj.h"
c906108c SS	27	#include "m2-lang.h"
c906108c SS	28	#include "c-lang.h"
745b8ca0	29	#include "valprint.h"
0d12e84c	30	#include "gdbarch.h"
c906108c	31
6c7a06a3	32	static void m2_printchar (int, struct type , struct ui_file );
c906108c SS	33
c906108c SS	34	/* FIXME: This is a copy of the same function from c-exp.y. It should
844781a1	35	be replaced with a true Modula version. */
c906108c SS	36
c906108c SS	37	static void
6c7a06a3	38	m2_printchar (int c, struct type type, struct ui_file stream)
c906108c SS	39	{
c906108c SS	40	fputs_filtered ("'", stream);
6c7a06a3	41	LA_EMIT_CHAR (c, type, stream, '\'');
c906108c SS	42	fputs_filtered ("'", stream);
	43	}
	44
844781a1 GM	45	static struct value *
	46	evaluate_subexp_modula2 (struct type expect_type, struct expression exp,
	47	int *pos, enum noside noside)
	48	{
	49	enum exp_opcode op = exp->elts[*pos].opcode;
	50	struct value *arg1;
	51	struct value *arg2;
	52	struct type *type;
b8d56208	53
844781a1 GM	54	switch (op)
	55	{
	56	case UNOP_HIGH:
	57	(*pos)++;
	58	arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
	59
	60	if (noside == EVAL_SKIP \|\| noside == EVAL_AVOID_SIDE_EFFECTS)
	61	return arg1;
	62	else
	63	{
	64	arg1 = coerce_ref (arg1);
	65	type = check_typedef (value_type (arg1));
	66
	67	if (m2_is_unbounded_array (type))
	68	{
	69	struct value *temp = arg1;
b8d56208	70
940da03e	71	type = type->field (1).type ();
844781a1 GM	72	/* i18n: Do not translate the "_m2_high" part! */
	73	arg1 = value_struct_elt (&temp, NULL, "_m2_high", NULL,
	74	_("unbounded structure "
	75	"missing _m2_high field"));
	76
	77	if (value_type (arg1) != type)
	78	arg1 = value_cast (type, arg1);
	79	}
	80	}
	81	return arg1;
	82
	83	case BINOP_SUBSCRIPT:
	84	(*pos)++;
	85	arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
	86	arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
	87	if (noside == EVAL_SKIP)
	88	goto nosideret;
	89	/* If the user attempts to subscript something that is not an
	90	array or pointer type (like a plain int variable for example),
	91	then report this as an error. */
	92
	93	arg1 = coerce_ref (arg1);
	94	type = check_typedef (value_type (arg1));
	95
	96	if (m2_is_unbounded_array (type))
	97	{
	98	struct value *temp = arg1;
940da03e	99	type = type->field (0).type ();
78134374	100	if (type == NULL \|\| (type->code () != TYPE_CODE_PTR))
b8d56208	101	{
025bb325 MS	102	warning (_("internal error: unbounded "
025bb325 MS	103	"array structure is unknown"));
b8d56208 MS	104	return evaluate_subexp_standard (expect_type, exp, pos, noside);
b8d56208 MS	105	}
844781a1 GM	106	/* i18n: Do not translate the "_m2_contents" part! */
	107	arg1 = value_struct_elt (&temp, NULL, "_m2_contents", NULL,
	108	_("unbounded structure "
	109	"missing _m2_contents field"));
	110
	111	if (value_type (arg1) != type)
	112	arg1 = value_cast (type, arg1);
	113
976aa66e	114	check_typedef (value_type (arg1));
2497b498	115	return value_ind (value_ptradd (arg1, value_as_long (arg2)));
844781a1 GM	116	}
844781a1 GM	117	else
78134374	118	if (type->code () != TYPE_CODE_ARRAY)
844781a1	119	{
7d93a1e0	120	if (type->name ())
844781a1	121	error (_("cannot subscript something of type `%s'"),
7d93a1e0	122	type->name ());
844781a1 GM	123	else
	124	error (_("cannot subscript requested type"));
	125	}
	126
	127	if (noside == EVAL_AVOID_SIDE_EFFECTS)
	128	return value_zero (TYPE_TARGET_TYPE (type), VALUE_LVAL (arg1));
	129	else
2497b498	130	return value_subscript (arg1, value_as_long (arg2));
844781a1 GM	131
	132	default:
	133	return evaluate_subexp_standard (expect_type, exp, pos, noside);
	134	}
	135
	136	nosideret:
22601c15	137	return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
844781a1	138	}
c906108c	139	\f
c5aa993b	140
c906108c SS	141	/* Table of operators and their precedences for printing expressions. */
c906108c SS	142
c5aa993b JM	143	static const struct op_print m2_op_print_tab[] =
	144	{
	145	{"+", BINOP_ADD, PREC_ADD, 0},
	146	{"+", UNOP_PLUS, PREC_PREFIX, 0},
	147	{"-", BINOP_SUB, PREC_ADD, 0},
	148	{"-", UNOP_NEG, PREC_PREFIX, 0},
	149	{"*", BINOP_MUL, PREC_MUL, 0},
	150	{"/", BINOP_DIV, PREC_MUL, 0},
	151	{"DIV", BINOP_INTDIV, PREC_MUL, 0},
	152	{"MOD", BINOP_REM, PREC_MUL, 0},
	153	{":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
	154	{"OR", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
	155	{"AND", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
	156	{"NOT", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
	157	{"=", BINOP_EQUAL, PREC_EQUAL, 0},
	158	{"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
	159	{"<=", BINOP_LEQ, PREC_ORDER, 0},
	160	{">=", BINOP_GEQ, PREC_ORDER, 0},
	161	{">", BINOP_GTR, PREC_ORDER, 0},
	162	{"<", BINOP_LESS, PREC_ORDER, 0},
	163	{"^", UNOP_IND, PREC_PREFIX, 0},
	164	{"@", BINOP_REPEAT, PREC_REPEAT, 0},
	165	{"CAP", UNOP_CAP, PREC_BUILTIN_FUNCTION, 0},
	166	{"CHR", UNOP_CHR, PREC_BUILTIN_FUNCTION, 0},
	167	{"ORD", UNOP_ORD, PREC_BUILTIN_FUNCTION, 0},
	168	{"FLOAT", UNOP_FLOAT, PREC_BUILTIN_FUNCTION, 0},
	169	{"HIGH", UNOP_HIGH, PREC_BUILTIN_FUNCTION, 0},
	170	{"MAX", UNOP_MAX, PREC_BUILTIN_FUNCTION, 0},
	171	{"MIN", UNOP_MIN, PREC_BUILTIN_FUNCTION, 0},
	172	{"ODD", UNOP_ODD, PREC_BUILTIN_FUNCTION, 0},
	173	{"TRUNC", UNOP_TRUNC, PREC_BUILTIN_FUNCTION, 0},
f486487f	174	{NULL, OP_NULL, PREC_BUILTIN_FUNCTION, 0}
c906108c SS	175	};
	176	\f
	177	/* The built-in types of Modula-2. */
	178
cad351d1 UW	179	enum m2_primitive_types {
	180	m2_primitive_type_char,
	181	m2_primitive_type_int,
	182	m2_primitive_type_card,
	183	m2_primitive_type_real,
	184	m2_primitive_type_bool,
	185	nr_m2_primitive_types
c906108c SS	186	};
c906108c SS	187
844781a1 GM	188	const struct exp_descriptor exp_descriptor_modula2 =
	189	{
	190	print_subexp_standard,
	191	operator_length_standard,
c0201579	192	operator_check_standard,
844781a1 GM	193	op_name_standard,
	194	dump_subexp_body_standard,
	195	evaluate_subexp_modula2
	196	};
	197
0874fd07 AB	198	/* Constant data describing the M2 language. */
	199
	200	extern const struct language_data m2_language_data =
c5aa993b	201	{
c906108c	202	"modula-2",
6abde28f	203	"Modula-2",
c906108c	204	language_m2,
c906108c	205	range_check_on,
63872f9d	206	case_sensitive_on,
7ca2d3a3	207	array_row_major,
9a044a89	208	macro_expansion_no,
56618e20	209	NULL,
844781a1	210	&exp_descriptor_modula2,
2b2d9e11	211	NULL, /* name_of_this */
59cc4834	212	false, /* la_store_sym_names_in_linkage_form_p */
c906108c SS	213	m2_op_print_tab, /* expression operators for printing */
	214	0, /* arrays are first-class (not c-style) */
	215	0, /* String lower bound */
a53b64ea	216	&default_varobj_ops,
721b08c6	217	"{...}" /* la_struct_too_deep_ellipsis */
c906108c SS	218	};
c906108c SS	219
0874fd07 AB	220	/* Class representing the M2 language. */
	221
	222	class m2_language : public language_defn
	223	{
	224	public:
	225	m2_language ()
	226	: language_defn (language_m2, m2_language_data)
	227	{ /* Nothing. */ }
1fb314aa AB	228
	229	/* See language.h. */
	230	void language_arch_info (struct gdbarch *gdbarch,
	231	struct language_arch_info *lai) const override
	232	{
	233	const struct builtin_m2_type *builtin = builtin_m2_type (gdbarch);
	234
	235	lai->string_char_type = builtin->builtin_char;
	236	lai->primitive_type_vector
	237	= GDBARCH_OBSTACK_CALLOC (gdbarch, nr_m2_primitive_types + 1,
	238	struct type *);
	239
	240	lai->primitive_type_vector [m2_primitive_type_char]
	241	= builtin->builtin_char;
	242	lai->primitive_type_vector [m2_primitive_type_int]
	243	= builtin->builtin_int;
	244	lai->primitive_type_vector [m2_primitive_type_card]
	245	= builtin->builtin_card;
	246	lai->primitive_type_vector [m2_primitive_type_real]
	247	= builtin->builtin_real;
	248	lai->primitive_type_vector [m2_primitive_type_bool]
	249	= builtin->builtin_bool;
	250
	251	lai->bool_type_symbol = "BOOLEAN";
	252	lai->bool_type_default = builtin->builtin_bool;
	253	}
fbfb0a46 AB	254
	255	/* See language.h. */
	256
	257	void print_type (struct type type, const char varstring,
	258	struct ui_file *stream, int show, int level,
	259	const struct type_print_options *flags) const override
	260	{
	261	m2_print_type (type, varstring, stream, show, level, flags);
	262	}
ebe2334e AB	263
	264	/* See language.h. */
	265
	266	void value_print_inner
	267	(struct value val, struct ui_file stream, int recurse,
	268	const struct value_print_options *options) const override
	269	{
	270	return m2_value_print_inner (val, stream, recurse, options);
	271	}
87afa652 AB	272
	273	/* See language.h. */
	274
	275	int parser (struct parser_state *ps) const override
	276	{
	277	return m2_parse (ps);
	278	}
ec8cec5b AB	279
	280	/* See language.h. */
	281
	282	void emitchar (int ch, struct type *chtype,
	283	struct ui_file *stream, int quoter) const override
	284	{
	285	ch &= 0xFF; /* Avoid sign bit follies. */
	286
	287	if (PRINT_LITERAL_FORM (ch))
	288	{
	289	if (ch == '\\' \|\| ch == quoter)
	290	fputs_filtered ("\\", stream);
	291	fprintf_filtered (stream, "%c", ch);
	292	}
	293	else
	294	{
	295	switch (ch)
	296	{
	297	case '\n':
	298	fputs_filtered ("\\n", stream);
	299	break;
	300	case '\b':
	301	fputs_filtered ("\\b", stream);
	302	break;
	303	case '\t':
	304	fputs_filtered ("\\t", stream);
	305	break;
	306	case '\f':
	307	fputs_filtered ("\\f", stream);
	308	break;
	309	case '\r':
	310	fputs_filtered ("\\r", stream);
	311	break;
	312	case '\033':
	313	fputs_filtered ("\\e", stream);
	314	break;
	315	case '\007':
	316	fputs_filtered ("\\a", stream);
	317	break;
	318	default:
	319	fprintf_filtered (stream, "\\%.3o", (unsigned int) ch);
	320	break;
	321	}
	322	}
	323	}
52b50f2c AB	324
	325	/* See language.h. */
	326
	327	void printchar (int ch, struct type *chtype,
	328	struct ui_file *stream) const override
	329	{
	330	m2_printchar (ch, chtype, stream);
	331	}
d711ee67 AB	332
	333	/* See language.h. */
	334
	335	void printstr (struct ui_file stream, struct type elttype,
	336	const gdb_byte *string, unsigned int length,
	337	const char *encoding, int force_ellipses,
	338	const struct value_print_options *options) const override
	339	{
	340	unsigned int i;
	341	unsigned int things_printed = 0;
	342	int in_quotes = 0;
	343	int need_comma = 0;
	344
	345	if (length == 0)
	346	{
	347	fputs_filtered ("\"\"", gdb_stdout);
	348	return;
	349	}
	350
	351	for (i = 0; i < length && things_printed < options->print_max; ++i)
	352	{
	353	/* Position of the character we are examining
	354	to see whether it is repeated. */
	355	unsigned int rep1;
	356	/* Number of repetitions we have detected so far. */
	357	unsigned int reps;
	358
	359	QUIT;
	360
	361	if (need_comma)
	362	{
	363	fputs_filtered (", ", stream);
	364	need_comma = 0;
	365	}
	366
	367	rep1 = i + 1;
	368	reps = 1;
	369	while (rep1 < length && string[rep1] == string[i])
	370	{
	371	++rep1;
	372	++reps;
	373	}
	374
	375	if (reps > options->repeat_count_threshold)
	376	{
	377	if (in_quotes)
	378	{
	379	fputs_filtered ("\", ", stream);
	380	in_quotes = 0;
	381	}
	382	m2_printchar (string[i], elttype, stream);
	383	fprintf_filtered (stream, " <repeats %u times>", reps);
	384	i = rep1 - 1;
	385	things_printed += options->repeat_count_threshold;
	386	need_comma = 1;
	387	}
	388	else
	389	{
	390	if (!in_quotes)
	391	{
	392	fputs_filtered ("\"", stream);
	393	in_quotes = 1;
	394	}
	395	LA_EMIT_CHAR (string[i], elttype, stream, '"');
396	++things_printed;
397	}
398	}
399
400	/* Terminate the quotes if necessary. */
401	if (in_quotes)
402	fputs_filtered ("\"", stream);
403
404	if (force_ellipses \|\| i < length)
405	fputs_filtered ("...", stream);
406	}
4ffc13fb AB	407
	408	/* See language.h. */
	409
	410	void print_typedef (struct type type, struct symbol new_symbol,
	411	struct ui_file *stream) const override
	412	{
	413	m2_print_typedef (type, new_symbol, stream);
	414	}
	415
39e7ecca AB	416	/* See language.h. */
	417
	418	bool is_string_type_p (struct type *type) const override
	419	{
	420	type = check_typedef (type);
	421	if (type->code () == TYPE_CODE_ARRAY
	422	&& TYPE_LENGTH (type) > 0
	423	&& TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)
	424	{
	425	struct type *elttype = check_typedef (TYPE_TARGET_TYPE (type));
	426
	427	if (TYPE_LENGTH (elttype) == 1
	428	&& (elttype->code () == TYPE_CODE_INT
	429	\|\| elttype->code () == TYPE_CODE_CHAR))
	430	return true;
	431	}
	432
	433	return false;
	434	}
0874fd07 AB	435	};
	436
	437	/* Single instance of the M2 language. */
	438
	439	static m2_language m2_language_defn;
	440
5760b90a UW	441	static void *
5760b90a UW	442	build_m2_types (struct gdbarch *gdbarch)
c906108c	443	{
5760b90a UW	444	struct builtin_m2_type *builtin_m2_type
	445	= GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_m2_type);
	446
c906108c	447	/* Modula-2 "pervasive" types. NOTE: these can be redefined!!! */
e9bb382b UW	448	builtin_m2_type->builtin_int
	449	= arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0, "INTEGER");
	450	builtin_m2_type->builtin_card
	451	= arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "CARDINAL");
	452	builtin_m2_type->builtin_real
49f190bc UW	453	= arch_float_type (gdbarch, gdbarch_float_bit (gdbarch), "REAL",
49f190bc UW	454	gdbarch_float_format (gdbarch));
e9bb382b UW	455	builtin_m2_type->builtin_char
	456	= arch_character_type (gdbarch, TARGET_CHAR_BIT, 1, "CHAR");
	457	builtin_m2_type->builtin_bool
	458	= arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "BOOLEAN");
c906108c	459
5760b90a UW	460	return builtin_m2_type;
	461	}
	462
	463	static struct gdbarch_data *m2_type_data;
	464
	465	const struct builtin_m2_type *
	466	builtin_m2_type (struct gdbarch *gdbarch)
	467	{
9a3c8263	468	return (const struct builtin_m2_type *) gdbarch_data (gdbarch, m2_type_data);
5760b90a UW	469	}
	470
	471
	472	/* Initialization for Modula-2 */
	473
6c265988	474	void _initialize_m2_language ();
5760b90a	475	void
6c265988	476	_initialize_m2_language ()
5760b90a UW	477	{
5760b90a UW	478	m2_type_data = gdbarch_data_register_post_init (build_m2_types);
c906108c	479	}