* language.h (struct language_arch_info): New members
[external/binutils.git] / gdb / m2-lang.c
1 /* Modula 2 language support routines for GDB, the GNU debugger.
2
3    Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 2000, 2002, 2003, 2004,
4    2005, 2007, 2008 Free Software Foundation, Inc.
5
6    This file is part of GDB.
7
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.
12
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.
17
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/>.  */
20
21 #include "defs.h"
22 #include "symtab.h"
23 #include "gdbtypes.h"
24 #include "expression.h"
25 #include "parser-defs.h"
26 #include "language.h"
27 #include "m2-lang.h"
28 #include "c-lang.h"
29 #include "valprint.h"
30
31 extern void _initialize_m2_language (void);
32 static void m2_printchar (int, struct ui_file *);
33 static void m2_emit_char (int, struct ui_file *, int);
34
35 /* Print the character C on STREAM as part of the contents of a literal
36    string whose delimiter is QUOTER.  Note that that format for printing
37    characters and strings is language specific.
38    FIXME:  This is a copy of the same function from c-exp.y.  It should
39    be replaced with a true Modula version.  */
40
41 static void
42 m2_emit_char (int c, struct ui_file *stream, int quoter)
43 {
44
45   c &= 0xFF;                    /* Avoid sign bit follies */
46
47   if (PRINT_LITERAL_FORM (c))
48     {
49       if (c == '\\' || c == quoter)
50         {
51           fputs_filtered ("\\", stream);
52         }
53       fprintf_filtered (stream, "%c", c);
54     }
55   else
56     {
57       switch (c)
58         {
59         case '\n':
60           fputs_filtered ("\\n", stream);
61           break;
62         case '\b':
63           fputs_filtered ("\\b", stream);
64           break;
65         case '\t':
66           fputs_filtered ("\\t", stream);
67           break;
68         case '\f':
69           fputs_filtered ("\\f", stream);
70           break;
71         case '\r':
72           fputs_filtered ("\\r", stream);
73           break;
74         case '\033':
75           fputs_filtered ("\\e", stream);
76           break;
77         case '\007':
78           fputs_filtered ("\\a", stream);
79           break;
80         default:
81           fprintf_filtered (stream, "\\%.3o", (unsigned int) c);
82           break;
83         }
84     }
85 }
86
87 /* FIXME:  This is a copy of the same function from c-exp.y.  It should
88    be replaced with a true Modula version.  */
89
90 static void
91 m2_printchar (int c, struct ui_file *stream)
92 {
93   fputs_filtered ("'", stream);
94   LA_EMIT_CHAR (c, stream, '\'');
95   fputs_filtered ("'", stream);
96 }
97
98 /* Print the character string STRING, printing at most LENGTH characters.
99    Printing stops early if the number hits print_max; repeat counts
100    are printed as appropriate.  Print ellipses at the end if we
101    had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
102    FIXME:  This is a copy of the same function from c-exp.y.  It should
103    be replaced with a true Modula version.  */
104
105 static void
106 m2_printstr (struct ui_file *stream, const gdb_byte *string,
107              unsigned int length, int width, int force_ellipses)
108 {
109   unsigned int i;
110   unsigned int things_printed = 0;
111   int in_quotes = 0;
112   int need_comma = 0;
113
114   if (length == 0)
115     {
116       fputs_filtered ("\"\"", gdb_stdout);
117       return;
118     }
119
120   for (i = 0; i < length && things_printed < print_max; ++i)
121     {
122       /* Position of the character we are examining
123          to see whether it is repeated.  */
124       unsigned int rep1;
125       /* Number of repetitions we have detected so far.  */
126       unsigned int reps;
127
128       QUIT;
129
130       if (need_comma)
131         {
132           fputs_filtered (", ", stream);
133           need_comma = 0;
134         }
135
136       rep1 = i + 1;
137       reps = 1;
138       while (rep1 < length && string[rep1] == string[i])
139         {
140           ++rep1;
141           ++reps;
142         }
143
144       if (reps > repeat_count_threshold)
145         {
146           if (in_quotes)
147             {
148               if (inspect_it)
149                 fputs_filtered ("\\\", ", stream);
150               else
151                 fputs_filtered ("\", ", stream);
152               in_quotes = 0;
153             }
154           m2_printchar (string[i], stream);
155           fprintf_filtered (stream, " <repeats %u times>", reps);
156           i = rep1 - 1;
157           things_printed += repeat_count_threshold;
158           need_comma = 1;
159         }
160       else
161         {
162           if (!in_quotes)
163             {
164               if (inspect_it)
165                 fputs_filtered ("\\\"", stream);
166               else
167                 fputs_filtered ("\"", stream);
168               in_quotes = 1;
169             }
170           LA_EMIT_CHAR (string[i], stream, '"');
171           ++things_printed;
172         }
173     }
174
175   /* Terminate the quotes if necessary.  */
176   if (in_quotes)
177     {
178       if (inspect_it)
179         fputs_filtered ("\\\"", stream);
180       else
181         fputs_filtered ("\"", stream);
182     }
183
184   if (force_ellipses || i < length)
185     fputs_filtered ("...", stream);
186 }
187
188 static struct value *
189 evaluate_subexp_modula2 (struct type *expect_type, struct expression *exp,
190                          int *pos, enum noside noside)
191 {
192   enum exp_opcode op = exp->elts[*pos].opcode;
193   struct value *arg1;
194   struct value *arg2;
195   struct type *type;
196   switch (op)
197     {
198     case UNOP_HIGH:
199       (*pos)++;
200       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
201
202       if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
203         return arg1;
204       else
205         {
206           arg1 = coerce_ref (arg1);
207           type = check_typedef (value_type (arg1));
208
209           if (m2_is_unbounded_array (type))
210             {
211               struct value *temp = arg1;
212               type = TYPE_FIELD_TYPE (type, 1);
213               /* i18n: Do not translate the "_m2_high" part!  */
214               arg1 = value_struct_elt (&temp, NULL, "_m2_high", NULL,
215                                        _("unbounded structure "
216                                          "missing _m2_high field"));
217           
218               if (value_type (arg1) != type)
219                 arg1 = value_cast (type, arg1);
220             }
221         }
222       return arg1;
223
224     case BINOP_SUBSCRIPT:
225       (*pos)++;
226       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
227       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
228       if (noside == EVAL_SKIP)
229         goto nosideret;
230       /* If the user attempts to subscript something that is not an
231          array or pointer type (like a plain int variable for example),
232          then report this as an error.  */
233
234       arg1 = coerce_ref (arg1);
235       type = check_typedef (value_type (arg1));
236
237       if (m2_is_unbounded_array (type))
238         {
239           struct value *temp = arg1;
240           type = TYPE_FIELD_TYPE (type, 0);
241           if (type == NULL || (TYPE_CODE (type) != TYPE_CODE_PTR)) {
242             warning (_("internal error: unbounded array structure is unknown"));
243             return evaluate_subexp_standard (expect_type, exp, pos, noside);
244           }
245           /* i18n: Do not translate the "_m2_contents" part!  */
246           arg1 = value_struct_elt (&temp, NULL, "_m2_contents", NULL,
247                                    _("unbounded structure "
248                                      "missing _m2_contents field"));
249           
250           if (value_type (arg1) != type)
251             arg1 = value_cast (type, arg1);
252
253           type = check_typedef (value_type (arg1));
254           return value_ind (value_add (arg1, arg2));
255         }
256       else
257         if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
258           {
259             if (TYPE_NAME (type))
260               error (_("cannot subscript something of type `%s'"),
261                      TYPE_NAME (type));
262             else
263               error (_("cannot subscript requested type"));
264           }
265
266       if (noside == EVAL_AVOID_SIDE_EFFECTS)
267         return value_zero (TYPE_TARGET_TYPE (type), VALUE_LVAL (arg1));
268       else
269         return value_subscript (arg1, arg2);
270
271     default:
272       return evaluate_subexp_standard (expect_type, exp, pos, noside);
273     }
274
275  nosideret:
276   return value_from_longest (builtin_type_long, (LONGEST) 1);
277 }
278 \f
279
280 /* Table of operators and their precedences for printing expressions.  */
281
282 static const struct op_print m2_op_print_tab[] =
283 {
284   {"+", BINOP_ADD, PREC_ADD, 0},
285   {"+", UNOP_PLUS, PREC_PREFIX, 0},
286   {"-", BINOP_SUB, PREC_ADD, 0},
287   {"-", UNOP_NEG, PREC_PREFIX, 0},
288   {"*", BINOP_MUL, PREC_MUL, 0},
289   {"/", BINOP_DIV, PREC_MUL, 0},
290   {"DIV", BINOP_INTDIV, PREC_MUL, 0},
291   {"MOD", BINOP_REM, PREC_MUL, 0},
292   {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
293   {"OR", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
294   {"AND", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
295   {"NOT", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
296   {"=", BINOP_EQUAL, PREC_EQUAL, 0},
297   {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
298   {"<=", BINOP_LEQ, PREC_ORDER, 0},
299   {">=", BINOP_GEQ, PREC_ORDER, 0},
300   {">", BINOP_GTR, PREC_ORDER, 0},
301   {"<", BINOP_LESS, PREC_ORDER, 0},
302   {"^", UNOP_IND, PREC_PREFIX, 0},
303   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
304   {"CAP", UNOP_CAP, PREC_BUILTIN_FUNCTION, 0},
305   {"CHR", UNOP_CHR, PREC_BUILTIN_FUNCTION, 0},
306   {"ORD", UNOP_ORD, PREC_BUILTIN_FUNCTION, 0},
307   {"FLOAT", UNOP_FLOAT, PREC_BUILTIN_FUNCTION, 0},
308   {"HIGH", UNOP_HIGH, PREC_BUILTIN_FUNCTION, 0},
309   {"MAX", UNOP_MAX, PREC_BUILTIN_FUNCTION, 0},
310   {"MIN", UNOP_MIN, PREC_BUILTIN_FUNCTION, 0},
311   {"ODD", UNOP_ODD, PREC_BUILTIN_FUNCTION, 0},
312   {"TRUNC", UNOP_TRUNC, PREC_BUILTIN_FUNCTION, 0},
313   {NULL, 0, 0, 0}
314 };
315 \f
316 /* The built-in types of Modula-2.  */
317
318 enum m2_primitive_types {
319   m2_primitive_type_char,
320   m2_primitive_type_int,
321   m2_primitive_type_card,
322   m2_primitive_type_real,
323   m2_primitive_type_bool,
324   nr_m2_primitive_types
325 };
326
327 static void
328 m2_language_arch_info (struct gdbarch *gdbarch,
329                        struct language_arch_info *lai)
330 {
331   const struct builtin_m2_type *builtin = builtin_m2_type (gdbarch);
332
333   lai->string_char_type = builtin->builtin_char;
334   lai->primitive_type_vector
335     = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_m2_primitive_types + 1,
336                               struct type *);
337
338   lai->primitive_type_vector [m2_primitive_type_char]
339     = builtin->builtin_char;
340   lai->primitive_type_vector [m2_primitive_type_int]
341     = builtin->builtin_int;
342   lai->primitive_type_vector [m2_primitive_type_card]
343     = builtin->builtin_card;
344   lai->primitive_type_vector [m2_primitive_type_real]
345     = builtin->builtin_real;
346   lai->primitive_type_vector [m2_primitive_type_bool]
347     = builtin->builtin_bool;
348
349   lai->bool_type_symbol = "BOOLEAN";
350   lai->bool_type_default = builtin->builtin_bool;
351 }
352
353 const struct exp_descriptor exp_descriptor_modula2 = 
354 {
355   print_subexp_standard,
356   operator_length_standard,
357   op_name_standard,
358   dump_subexp_body_standard,
359   evaluate_subexp_modula2
360 };
361
362 const struct language_defn m2_language_defn =
363 {
364   "modula-2",
365   language_m2,
366   range_check_on,
367   type_check_on,
368   case_sensitive_on,
369   array_row_major,
370   &exp_descriptor_modula2,
371   m2_parse,                     /* parser */
372   m2_error,                     /* parser error function */
373   null_post_parser,
374   m2_printchar,                 /* Print character constant */
375   m2_printstr,                  /* function to print string constant */
376   m2_emit_char,                 /* Function to print a single character */
377   m2_print_type,                /* Print a type using appropriate syntax */
378   m2_val_print,                 /* Print a value using appropriate syntax */
379   c_value_print,                /* Print a top-level value */
380   NULL,                         /* Language specific skip_trampoline */
381   NULL,                         /* name_of_this */
382   basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
383   basic_lookup_transparent_type,/* lookup_transparent_type */
384   NULL,                         /* Language specific symbol demangler */
385   NULL,                         /* Language specific class_name_from_physname */
386   m2_op_print_tab,              /* expression operators for printing */
387   0,                            /* arrays are first-class (not c-style) */
388   0,                            /* String lower bound */
389   default_word_break_characters,
390   default_make_symbol_completion_list,
391   m2_language_arch_info,
392   default_print_array_index,
393   default_pass_by_reference,
394   LANG_MAGIC
395 };
396
397 static void *
398 build_m2_types (struct gdbarch *gdbarch)
399 {
400   struct builtin_m2_type *builtin_m2_type
401     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_m2_type);
402
403   /* Modula-2 "pervasive" types.  NOTE:  these can be redefined!!! */
404   builtin_m2_type->builtin_int =
405     init_type (TYPE_CODE_INT,
406                gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
407                0, "INTEGER", (struct objfile *) NULL);
408   builtin_m2_type->builtin_card =
409     init_type (TYPE_CODE_INT, 
410                gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
411                TYPE_FLAG_UNSIGNED,
412                "CARDINAL", (struct objfile *) NULL);
413   builtin_m2_type->builtin_real =
414     init_type (TYPE_CODE_FLT,
415                gdbarch_float_bit (gdbarch) / TARGET_CHAR_BIT,
416                0,
417                "REAL", (struct objfile *) NULL);
418   builtin_m2_type->builtin_char =
419     init_type (TYPE_CODE_CHAR, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
420                TYPE_FLAG_UNSIGNED,
421                "CHAR", (struct objfile *) NULL);
422   builtin_m2_type->builtin_bool =
423     init_type (TYPE_CODE_BOOL, 
424                gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
425                TYPE_FLAG_UNSIGNED,
426                "BOOLEAN", (struct objfile *) NULL);
427
428   return builtin_m2_type;
429 }
430
431 static struct gdbarch_data *m2_type_data;
432
433 const struct builtin_m2_type *
434 builtin_m2_type (struct gdbarch *gdbarch)
435 {
436   return gdbarch_data (gdbarch, m2_type_data);
437 }
438
439
440 /* Initialization for Modula-2 */
441
442 void
443 _initialize_m2_language (void)
444 {
445   m2_type_data = gdbarch_data_register_post_init (build_m2_types);
446
447   add_language (&m2_language_defn);
448 }