1 /* Modula 2 language support routines for GDB, the GNU debugger.
3 Copyright (C) 1992-2020 Free Software Foundation, Inc.
5 This file is part of GDB.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
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.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
23 #include "expression.h"
24 #include "parser-defs.h"
32 static void m2_printchar (int, struct type
*, struct ui_file
*);
34 /* FIXME: This is a copy of the same function from c-exp.y. It should
35 be replaced with a true Modula version. */
38 m2_printchar (int c
, struct type
*type
, struct ui_file
*stream
)
40 fputs_filtered ("'", stream
);
41 LA_EMIT_CHAR (c
, type
, stream
, '\'');
42 fputs_filtered ("'", stream
);
46 evaluate_subexp_modula2 (struct type
*expect_type
, struct expression
*exp
,
47 int *pos
, enum noside noside
)
49 enum exp_opcode op
= exp
->elts
[*pos
].opcode
;
58 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
60 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
64 arg1
= coerce_ref (arg1
);
65 type
= check_typedef (value_type (arg1
));
67 if (m2_is_unbounded_array (type
))
69 struct value
*temp
= arg1
;
71 type
= type
->field (1).type ();
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"));
77 if (value_type (arg1
) != type
)
78 arg1
= value_cast (type
, arg1
);
85 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
86 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
87 if (noside
== EVAL_SKIP
)
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. */
93 arg1
= coerce_ref (arg1
);
94 type
= check_typedef (value_type (arg1
));
96 if (m2_is_unbounded_array (type
))
98 struct value
*temp
= arg1
;
99 type
= type
->field (0).type ();
100 if (type
== NULL
|| (type
->code () != TYPE_CODE_PTR
))
102 warning (_("internal error: unbounded "
103 "array structure is unknown"));
104 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
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"));
111 if (value_type (arg1
) != type
)
112 arg1
= value_cast (type
, arg1
);
114 check_typedef (value_type (arg1
));
115 return value_ind (value_ptradd (arg1
, value_as_long (arg2
)));
118 if (type
->code () != TYPE_CODE_ARRAY
)
121 error (_("cannot subscript something of type `%s'"),
124 error (_("cannot subscript requested type"));
127 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
128 return value_zero (TYPE_TARGET_TYPE (type
), VALUE_LVAL (arg1
));
130 return value_subscript (arg1
, value_as_long (arg2
));
133 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
137 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
, 1);
141 /* Table of operators and their precedences for printing expressions. */
143 static const struct op_print m2_op_print_tab
[] =
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},
174 {NULL
, OP_NULL
, PREC_BUILTIN_FUNCTION
, 0}
177 /* The built-in types of Modula-2. */
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
188 const struct exp_descriptor exp_descriptor_modula2
=
190 print_subexp_standard
,
191 operator_length_standard
,
192 operator_check_standard
,
194 dump_subexp_body_standard
,
195 evaluate_subexp_modula2
198 /* Constant data describing the M2 language. */
200 extern const struct language_data m2_language_data
=
202 m2_op_print_tab
, /* expression operators for printing */
205 /* Class representing the M2 language. */
207 class m2_language
: public language_defn
211 : language_defn (language_m2
, m2_language_data
)
214 /* See language.h. */
216 const char *name () const override
217 { return "modula-2"; }
219 /* See language.h. */
221 const char *natural_name () const override
222 { return "Modula-2"; }
224 /* See language.h. */
225 void language_arch_info (struct gdbarch
*gdbarch
,
226 struct language_arch_info
*lai
) const override
228 const struct builtin_m2_type
*builtin
= builtin_m2_type (gdbarch
);
230 lai
->string_char_type
= builtin
->builtin_char
;
231 lai
->primitive_type_vector
232 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_m2_primitive_types
+ 1,
235 lai
->primitive_type_vector
[m2_primitive_type_char
]
236 = builtin
->builtin_char
;
237 lai
->primitive_type_vector
[m2_primitive_type_int
]
238 = builtin
->builtin_int
;
239 lai
->primitive_type_vector
[m2_primitive_type_card
]
240 = builtin
->builtin_card
;
241 lai
->primitive_type_vector
[m2_primitive_type_real
]
242 = builtin
->builtin_real
;
243 lai
->primitive_type_vector
[m2_primitive_type_bool
]
244 = builtin
->builtin_bool
;
246 lai
->bool_type_symbol
= "BOOLEAN";
247 lai
->bool_type_default
= builtin
->builtin_bool
;
250 /* See language.h. */
252 void print_type (struct type
*type
, const char *varstring
,
253 struct ui_file
*stream
, int show
, int level
,
254 const struct type_print_options
*flags
) const override
256 m2_print_type (type
, varstring
, stream
, show
, level
, flags
);
259 /* See language.h. */
261 void value_print_inner
262 (struct value
*val
, struct ui_file
*stream
, int recurse
,
263 const struct value_print_options
*options
) const override
265 return m2_value_print_inner (val
, stream
, recurse
, options
);
268 /* See language.h. */
270 int parser (struct parser_state
*ps
) const override
272 return m2_parse (ps
);
275 /* See language.h. */
277 void emitchar (int ch
, struct type
*chtype
,
278 struct ui_file
*stream
, int quoter
) const override
280 ch
&= 0xFF; /* Avoid sign bit follies. */
282 if (PRINT_LITERAL_FORM (ch
))
284 if (ch
== '\\' || ch
== quoter
)
285 fputs_filtered ("\\", stream
);
286 fprintf_filtered (stream
, "%c", ch
);
293 fputs_filtered ("\\n", stream
);
296 fputs_filtered ("\\b", stream
);
299 fputs_filtered ("\\t", stream
);
302 fputs_filtered ("\\f", stream
);
305 fputs_filtered ("\\r", stream
);
308 fputs_filtered ("\\e", stream
);
311 fputs_filtered ("\\a", stream
);
314 fprintf_filtered (stream
, "\\%.3o", (unsigned int) ch
);
320 /* See language.h. */
322 void printchar (int ch
, struct type
*chtype
,
323 struct ui_file
*stream
) const override
325 m2_printchar (ch
, chtype
, stream
);
328 /* See language.h. */
330 void printstr (struct ui_file
*stream
, struct type
*elttype
,
331 const gdb_byte
*string
, unsigned int length
,
332 const char *encoding
, int force_ellipses
,
333 const struct value_print_options
*options
) const override
336 unsigned int things_printed
= 0;
342 fputs_filtered ("\"\"", gdb_stdout
);
346 for (i
= 0; i
< length
&& things_printed
< options
->print_max
; ++i
)
348 /* Position of the character we are examining
349 to see whether it is repeated. */
351 /* Number of repetitions we have detected so far. */
358 fputs_filtered (", ", stream
);
364 while (rep1
< length
&& string
[rep1
] == string
[i
])
370 if (reps
> options
->repeat_count_threshold
)
374 fputs_filtered ("\", ", stream
);
377 m2_printchar (string
[i
], elttype
, stream
);
378 fprintf_filtered (stream
, " <repeats %u times>", reps
);
380 things_printed
+= options
->repeat_count_threshold
;
387 fputs_filtered ("\"", stream
);
390 LA_EMIT_CHAR (string
[i
], elttype
, stream
, '"');
395 /* Terminate the quotes if necessary. */
397 fputs_filtered ("\"", stream
);
399 if (force_ellipses
|| i
< length
)
400 fputs_filtered ("...", stream
);
403 /* See language.h. */
405 void print_typedef (struct type
*type
, struct symbol
*new_symbol
,
406 struct ui_file
*stream
) const override
408 m2_print_typedef (type
, new_symbol
, stream
);
411 /* See language.h. */
413 bool is_string_type_p (struct type
*type
) const override
415 type
= check_typedef (type
);
416 if (type
->code () == TYPE_CODE_ARRAY
417 && TYPE_LENGTH (type
) > 0
418 && TYPE_LENGTH (TYPE_TARGET_TYPE (type
)) > 0)
420 struct type
*elttype
= check_typedef (TYPE_TARGET_TYPE (type
));
422 if (TYPE_LENGTH (elttype
) == 1
423 && (elttype
->code () == TYPE_CODE_INT
424 || elttype
->code () == TYPE_CODE_CHAR
))
431 /* See language.h. */
433 bool c_style_arrays_p () const override
436 /* See language.h. Despite not having C-style arrays, Modula-2 uses 0
437 for its string lower bounds. */
439 char string_lower_bound () const override
442 /* See language.h. */
444 bool range_checking_on_by_default () const override
447 /* See language.h. */
449 const struct exp_descriptor
*expression_ops () const override
450 { return &exp_descriptor_modula2
; }
453 /* Single instance of the M2 language. */
455 static m2_language m2_language_defn
;
458 build_m2_types (struct gdbarch
*gdbarch
)
460 struct builtin_m2_type
*builtin_m2_type
461 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_m2_type
);
463 /* Modula-2 "pervasive" types. NOTE: these can be redefined!!! */
464 builtin_m2_type
->builtin_int
465 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0, "INTEGER");
466 builtin_m2_type
->builtin_card
467 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1, "CARDINAL");
468 builtin_m2_type
->builtin_real
469 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
), "REAL",
470 gdbarch_float_format (gdbarch
));
471 builtin_m2_type
->builtin_char
472 = arch_character_type (gdbarch
, TARGET_CHAR_BIT
, 1, "CHAR");
473 builtin_m2_type
->builtin_bool
474 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1, "BOOLEAN");
476 return builtin_m2_type
;
479 static struct gdbarch_data
*m2_type_data
;
481 const struct builtin_m2_type
*
482 builtin_m2_type (struct gdbarch
*gdbarch
)
484 return (const struct builtin_m2_type
*) gdbarch_data (gdbarch
, m2_type_data
);
488 /* Initialization for Modula-2 */
490 void _initialize_m2_language ();
492 _initialize_m2_language ()
494 m2_type_data
= gdbarch_data_register_post_init (build_m2_types
);