1 /* Modula 2 language support routines for GDB, the GNU debugger.
3 Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 2000, 2002, 2003, 2004,
4 2005, 2007 Free Software Foundation, Inc.
6 This file is part of GDB.
8 This program is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3 of the License, or
11 (at your option) any later version.
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program. If not, see <http://www.gnu.org/licenses/>. */
24 #include "expression.h"
25 #include "parser-defs.h"
31 extern void _initialize_m2_language (void);
32 static struct type
*m2_create_fundamental_type (struct objfile
*, int);
33 static void m2_printchar (int, struct ui_file
*);
34 static void m2_emit_char (int, struct ui_file
*, int);
36 /* Print the character C on STREAM as part of the contents of a literal
37 string whose delimiter is QUOTER. Note that that format for printing
38 characters and strings is language specific.
39 FIXME: This is a copy of the same function from c-exp.y. It should
40 be replaced with a true Modula version. */
43 m2_emit_char (int c
, struct ui_file
*stream
, int quoter
)
46 c
&= 0xFF; /* Avoid sign bit follies */
48 if (PRINT_LITERAL_FORM (c
))
50 if (c
== '\\' || c
== quoter
)
52 fputs_filtered ("\\", stream
);
54 fprintf_filtered (stream
, "%c", c
);
61 fputs_filtered ("\\n", stream
);
64 fputs_filtered ("\\b", stream
);
67 fputs_filtered ("\\t", stream
);
70 fputs_filtered ("\\f", stream
);
73 fputs_filtered ("\\r", stream
);
76 fputs_filtered ("\\e", stream
);
79 fputs_filtered ("\\a", stream
);
82 fprintf_filtered (stream
, "\\%.3o", (unsigned int) c
);
88 /* FIXME: This is a copy of the same function from c-exp.y. It should
89 be replaced with a true Modula version. */
92 m2_printchar (int c
, struct ui_file
*stream
)
94 fputs_filtered ("'", stream
);
95 LA_EMIT_CHAR (c
, stream
, '\'');
96 fputs_filtered ("'", stream
);
99 /* Print the character string STRING, printing at most LENGTH characters.
100 Printing stops early if the number hits print_max; repeat counts
101 are printed as appropriate. Print ellipses at the end if we
102 had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
103 FIXME: This is a copy of the same function from c-exp.y. It should
104 be replaced with a true Modula version. */
107 m2_printstr (struct ui_file
*stream
, const gdb_byte
*string
,
108 unsigned int length
, int width
, int force_ellipses
)
111 unsigned int things_printed
= 0;
117 fputs_filtered ("\"\"", gdb_stdout
);
121 for (i
= 0; i
< length
&& things_printed
< print_max
; ++i
)
123 /* Position of the character we are examining
124 to see whether it is repeated. */
126 /* Number of repetitions we have detected so far. */
133 fputs_filtered (", ", stream
);
139 while (rep1
< length
&& string
[rep1
] == string
[i
])
145 if (reps
> repeat_count_threshold
)
150 fputs_filtered ("\\\", ", stream
);
152 fputs_filtered ("\", ", stream
);
155 m2_printchar (string
[i
], stream
);
156 fprintf_filtered (stream
, " <repeats %u times>", reps
);
158 things_printed
+= repeat_count_threshold
;
166 fputs_filtered ("\\\"", stream
);
168 fputs_filtered ("\"", stream
);
171 LA_EMIT_CHAR (string
[i
], stream
, '"');
176 /* Terminate the quotes if necessary. */
180 fputs_filtered ("\\\"", stream
);
182 fputs_filtered ("\"", stream
);
185 if (force_ellipses
|| i
< length
)
186 fputs_filtered ("...", stream
);
189 static struct value
*
190 evaluate_subexp_modula2 (struct type
*expect_type
, struct expression
*exp
,
191 int *pos
, enum noside noside
)
193 enum exp_opcode op
= exp
->elts
[*pos
].opcode
;
201 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
203 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
207 arg1
= coerce_ref (arg1
);
208 type
= check_typedef (value_type (arg1
));
210 if (m2_is_unbounded_array (type
))
212 struct value
*temp
= arg1
;
213 type
= TYPE_FIELD_TYPE (type
, 1);
214 /* i18n: Do not translate the "_m2_high" part! */
215 arg1
= value_struct_elt (&temp
, NULL
, "_m2_high", NULL
,
216 _("unbounded structure "
217 "missing _m2_high field"));
219 if (value_type (arg1
) != type
)
220 arg1
= value_cast (type
, arg1
);
225 case BINOP_SUBSCRIPT
:
227 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
228 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
229 if (noside
== EVAL_SKIP
)
231 /* If the user attempts to subscript something that is not an
232 array or pointer type (like a plain int variable for example),
233 then report this as an error. */
235 arg1
= coerce_ref (arg1
);
236 type
= check_typedef (value_type (arg1
));
238 if (m2_is_unbounded_array (type
))
240 struct value
*temp
= arg1
;
241 type
= TYPE_FIELD_TYPE (type
, 0);
242 if (type
== NULL
|| (TYPE_CODE (type
) != TYPE_CODE_PTR
)) {
243 warning (_("internal error: unbounded array structure is unknown"));
244 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
246 /* i18n: Do not translate the "_m2_contents" part! */
247 arg1
= value_struct_elt (&temp
, NULL
, "_m2_contents", NULL
,
248 _("unbounded structure "
249 "missing _m2_contents field"));
251 if (value_type (arg1
) != type
)
252 arg1
= value_cast (type
, arg1
);
254 type
= check_typedef (value_type (arg1
));
255 return value_ind (value_add (arg1
, arg2
));
258 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
260 if (TYPE_NAME (type
))
261 error (_("cannot subscript something of type `%s'"),
264 error (_("cannot subscript requested type"));
267 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
268 return value_zero (TYPE_TARGET_TYPE (type
), VALUE_LVAL (arg1
));
270 return value_subscript (arg1
, arg2
);
273 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
277 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
280 /* FIXME: This is a copy of c_create_fundamental_type(), before
281 all the non-C types were stripped from it. Needs to be fixed
282 by an experienced Modula programmer. */
285 m2_create_fundamental_type (struct objfile
*objfile
, int typeid)
287 struct type
*type
= NULL
;
292 /* FIXME: For now, if we are asked to produce a type not in this
293 language, create the equivalent of a C integer type with the
294 name "<?type?>". When all the dust settles from the type
295 reconstruction work, this should probably become an error. */
296 type
= init_type (TYPE_CODE_INT
,
297 gdbarch_int_bit (current_gdbarch
) / TARGET_CHAR_BIT
,
298 0, "<?type?>", objfile
);
299 warning (_("internal error: no Modula fundamental type %d"), typeid);
302 type
= init_type (TYPE_CODE_VOID
,
303 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
307 type
= init_type (TYPE_CODE_BOOL
,
308 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
309 TYPE_FLAG_UNSIGNED
, "boolean", objfile
);
312 type
= init_type (TYPE_CODE_STRING
,
313 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
314 0, "string", objfile
);
317 type
= init_type (TYPE_CODE_INT
,
318 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
322 type
= init_type (TYPE_CODE_INT
,
323 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
324 0, "signed char", objfile
);
326 case FT_UNSIGNED_CHAR
:
327 type
= init_type (TYPE_CODE_INT
,
328 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
329 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
332 type
= init_type (TYPE_CODE_INT
,
333 gdbarch_short_bit (current_gdbarch
) / TARGET_CHAR_BIT
,
334 0, "short", objfile
);
336 case FT_SIGNED_SHORT
:
337 type
= init_type (TYPE_CODE_INT
,
338 gdbarch_short_bit (current_gdbarch
) / TARGET_CHAR_BIT
,
339 0, "short", objfile
); /* FIXME-fnf */
341 case FT_UNSIGNED_SHORT
:
342 type
= init_type (TYPE_CODE_INT
,
343 gdbarch_short_bit (current_gdbarch
) / TARGET_CHAR_BIT
,
344 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
347 type
= init_type (TYPE_CODE_INT
,
348 gdbarch_int_bit (current_gdbarch
) / TARGET_CHAR_BIT
,
351 case FT_SIGNED_INTEGER
:
352 type
= init_type (TYPE_CODE_INT
,
353 gdbarch_int_bit (current_gdbarch
) / TARGET_CHAR_BIT
,
354 0, "int", objfile
); /* FIXME -fnf */
356 case FT_UNSIGNED_INTEGER
:
357 type
= init_type (TYPE_CODE_INT
,
358 gdbarch_int_bit (current_gdbarch
) / TARGET_CHAR_BIT
,
359 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
361 case FT_FIXED_DECIMAL
:
362 type
= init_type (TYPE_CODE_INT
,
363 gdbarch_int_bit (current_gdbarch
) / TARGET_CHAR_BIT
,
364 0, "fixed decimal", objfile
);
367 type
= init_type (TYPE_CODE_INT
,
368 gdbarch_long_bit (current_gdbarch
) / TARGET_CHAR_BIT
,
372 type
= init_type (TYPE_CODE_INT
,
373 gdbarch_long_bit (current_gdbarch
) / TARGET_CHAR_BIT
,
374 0, "long", objfile
); /* FIXME -fnf */
376 case FT_UNSIGNED_LONG
:
377 type
= init_type (TYPE_CODE_INT
,
378 gdbarch_long_bit (current_gdbarch
) / TARGET_CHAR_BIT
,
379 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
382 type
= init_type (TYPE_CODE_INT
,
383 gdbarch_long_long_bit (current_gdbarch
)
385 0, "long long", objfile
);
387 case FT_SIGNED_LONG_LONG
:
388 type
= init_type (TYPE_CODE_INT
,
389 gdbarch_long_long_bit (current_gdbarch
)
391 0, "signed long long", objfile
);
393 case FT_UNSIGNED_LONG_LONG
:
394 type
= init_type (TYPE_CODE_INT
,
395 gdbarch_long_long_bit (current_gdbarch
)
397 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
400 type
= init_type (TYPE_CODE_FLT
,
401 gdbarch_float_bit (current_gdbarch
) / TARGET_CHAR_BIT
,
402 0, "float", objfile
);
404 case FT_DBL_PREC_FLOAT
:
405 type
= init_type (TYPE_CODE_FLT
,
406 gdbarch_double_bit (current_gdbarch
) / TARGET_CHAR_BIT
,
407 0, "double", objfile
);
409 case FT_FLOAT_DECIMAL
:
410 type
= init_type (TYPE_CODE_FLT
,
411 gdbarch_double_bit (current_gdbarch
) / TARGET_CHAR_BIT
,
412 0, "floating decimal", objfile
);
414 case FT_EXT_PREC_FLOAT
:
415 type
= init_type (TYPE_CODE_FLT
,
416 gdbarch_long_double_bit (current_gdbarch
)
418 0, "long double", objfile
);
421 type
= init_type (TYPE_CODE_COMPLEX
,
422 2 * gdbarch_float_bit (current_gdbarch
)
424 0, "complex", objfile
);
425 TYPE_TARGET_TYPE (type
)
426 = m2_create_fundamental_type (objfile
, FT_FLOAT
);
428 case FT_DBL_PREC_COMPLEX
:
429 type
= init_type (TYPE_CODE_COMPLEX
,
430 2 * gdbarch_double_bit (current_gdbarch
)
432 0, "double complex", objfile
);
433 TYPE_TARGET_TYPE (type
)
434 = m2_create_fundamental_type (objfile
, FT_DBL_PREC_FLOAT
);
436 case FT_EXT_PREC_COMPLEX
:
437 type
= init_type (TYPE_CODE_COMPLEX
,
438 2 * gdbarch_long_double_bit (current_gdbarch
)
440 0, "long double complex", objfile
);
441 TYPE_TARGET_TYPE (type
)
442 = m2_create_fundamental_type (objfile
, FT_EXT_PREC_FLOAT
);
449 /* Table of operators and their precedences for printing expressions. */
451 static const struct op_print m2_op_print_tab
[] =
453 {"+", BINOP_ADD
, PREC_ADD
, 0},
454 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
455 {"-", BINOP_SUB
, PREC_ADD
, 0},
456 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
457 {"*", BINOP_MUL
, PREC_MUL
, 0},
458 {"/", BINOP_DIV
, PREC_MUL
, 0},
459 {"DIV", BINOP_INTDIV
, PREC_MUL
, 0},
460 {"MOD", BINOP_REM
, PREC_MUL
, 0},
461 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
462 {"OR", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
463 {"AND", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
464 {"NOT", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
465 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
466 {"<>", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
467 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
468 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
469 {">", BINOP_GTR
, PREC_ORDER
, 0},
470 {"<", BINOP_LESS
, PREC_ORDER
, 0},
471 {"^", UNOP_IND
, PREC_PREFIX
, 0},
472 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
473 {"CAP", UNOP_CAP
, PREC_BUILTIN_FUNCTION
, 0},
474 {"CHR", UNOP_CHR
, PREC_BUILTIN_FUNCTION
, 0},
475 {"ORD", UNOP_ORD
, PREC_BUILTIN_FUNCTION
, 0},
476 {"FLOAT", UNOP_FLOAT
, PREC_BUILTIN_FUNCTION
, 0},
477 {"HIGH", UNOP_HIGH
, PREC_BUILTIN_FUNCTION
, 0},
478 {"MAX", UNOP_MAX
, PREC_BUILTIN_FUNCTION
, 0},
479 {"MIN", UNOP_MIN
, PREC_BUILTIN_FUNCTION
, 0},
480 {"ODD", UNOP_ODD
, PREC_BUILTIN_FUNCTION
, 0},
481 {"TRUNC", UNOP_TRUNC
, PREC_BUILTIN_FUNCTION
, 0},
485 /* The built-in types of Modula-2. */
487 enum m2_primitive_types
{
488 m2_primitive_type_char
,
489 m2_primitive_type_int
,
490 m2_primitive_type_card
,
491 m2_primitive_type_real
,
492 m2_primitive_type_bool
,
493 nr_m2_primitive_types
497 m2_language_arch_info (struct gdbarch
*gdbarch
,
498 struct language_arch_info
*lai
)
500 const struct builtin_m2_type
*builtin
= builtin_m2_type (gdbarch
);
502 lai
->string_char_type
= builtin
->builtin_char
;
503 lai
->primitive_type_vector
504 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_m2_primitive_types
+ 1,
507 lai
->primitive_type_vector
[m2_primitive_type_char
]
508 = builtin
->builtin_char
;
509 lai
->primitive_type_vector
[m2_primitive_type_int
]
510 = builtin
->builtin_int
;
511 lai
->primitive_type_vector
[m2_primitive_type_card
]
512 = builtin
->builtin_card
;
513 lai
->primitive_type_vector
[m2_primitive_type_real
]
514 = builtin
->builtin_real
;
515 lai
->primitive_type_vector
[m2_primitive_type_bool
]
516 = builtin
->builtin_bool
;
519 const struct exp_descriptor exp_descriptor_modula2
=
521 print_subexp_standard
,
522 operator_length_standard
,
524 dump_subexp_body_standard
,
525 evaluate_subexp_modula2
528 const struct language_defn m2_language_defn
=
536 &exp_descriptor_modula2
,
537 m2_parse
, /* parser */
538 m2_error
, /* parser error function */
540 m2_printchar
, /* Print character constant */
541 m2_printstr
, /* function to print string constant */
542 m2_emit_char
, /* Function to print a single character */
543 m2_create_fundamental_type
, /* Create fundamental type in this language */
544 m2_print_type
, /* Print a type using appropriate syntax */
545 m2_val_print
, /* Print a value using appropriate syntax */
546 c_value_print
, /* Print a top-level value */
547 NULL
, /* Language specific skip_trampoline */
548 value_of_this
, /* value_of_this */
549 basic_lookup_symbol_nonlocal
, /* lookup_symbol_nonlocal */
550 basic_lookup_transparent_type
,/* lookup_transparent_type */
551 NULL
, /* Language specific symbol demangler */
552 NULL
, /* Language specific class_name_from_physname */
553 m2_op_print_tab
, /* expression operators for printing */
554 0, /* arrays are first-class (not c-style) */
555 0, /* String lower bound */
556 default_word_break_characters
,
557 m2_language_arch_info
,
558 default_print_array_index
,
559 default_pass_by_reference
,
564 build_m2_types (struct gdbarch
*gdbarch
)
566 struct builtin_m2_type
*builtin_m2_type
567 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_m2_type
);
569 /* Modula-2 "pervasive" types. NOTE: these can be redefined!!! */
570 builtin_m2_type
->builtin_int
=
571 init_type (TYPE_CODE_INT
,
572 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
573 0, "INTEGER", (struct objfile
*) NULL
);
574 builtin_m2_type
->builtin_card
=
575 init_type (TYPE_CODE_INT
,
576 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
578 "CARDINAL", (struct objfile
*) NULL
);
579 builtin_m2_type
->builtin_real
=
580 init_type (TYPE_CODE_FLT
,
581 gdbarch_float_bit (gdbarch
) / TARGET_CHAR_BIT
,
583 "REAL", (struct objfile
*) NULL
);
584 builtin_m2_type
->builtin_char
=
585 init_type (TYPE_CODE_CHAR
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
587 "CHAR", (struct objfile
*) NULL
);
588 builtin_m2_type
->builtin_bool
=
589 init_type (TYPE_CODE_BOOL
,
590 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
592 "BOOLEAN", (struct objfile
*) NULL
);
594 return builtin_m2_type
;
597 static struct gdbarch_data
*m2_type_data
;
599 const struct builtin_m2_type
*
600 builtin_m2_type (struct gdbarch
*gdbarch
)
602 return gdbarch_data (gdbarch
, m2_type_data
);
606 /* Initialization for Modula-2 */
609 _initialize_m2_language (void)
611 m2_type_data
= gdbarch_data_register_post_init (build_m2_types
);
613 add_language (&m2_language_defn
);