Tweak to match output of autoconf 2.9 with same cygnus local patch as
[deliverable/binutils-gdb.git] / gdb / ch-lang.c
1 /* Chill language support routines for GDB, the GNU debugger.
2 Copyright 1992, 1995, 1996 Free Software Foundation, Inc.
3
4 This file is part of GDB.
5
6 This program is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2 of the License, or
9 (at your option) any later version.
10
11 This program is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with this program; if not, write to the Free Software
18 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
19
20 #include "defs.h"
21 #include "symtab.h"
22 #include "gdbtypes.h"
23 #include "value.h"
24 #include "expression.h"
25 #include "parser-defs.h"
26 #include "language.h"
27 #include "ch-lang.h"
28
29
30 /* For now, Chill uses a simple mangling algorithm whereby you simply
31 discard everything after the occurance of two successive CPLUS_MARKER
32 characters to derive the demangled form. */
33
34 char *
35 chill_demangle (mangled)
36 const char *mangled;
37 {
38 const char *joiner = NULL;
39 char *demangled;
40 const char *cp = mangled;
41
42 while (*cp)
43 {
44 if (is_cplus_marker (*cp))
45 {
46 joiner = cp;
47 break;
48 }
49 cp++;
50 }
51 if (joiner != NULL && *(joiner + 1) == *joiner)
52 {
53 demangled = savestring (mangled, joiner - mangled);
54 }
55 else
56 {
57 demangled = NULL;
58 }
59 return (demangled);
60 }
61
62 static void
63 chill_printchar (c, stream)
64 register int c;
65 GDB_FILE *stream;
66 {
67 c &= 0xFF; /* Avoid sign bit follies */
68
69 if (PRINT_LITERAL_FORM (c))
70 {
71 if (c == '\'' || c == '^')
72 fprintf_filtered (stream, "'%c%c'", c, c);
73 else
74 fprintf_filtered (stream, "'%c'", c);
75 }
76 else
77 {
78 fprintf_filtered (stream, "'^(%u)'", (unsigned int) c);
79 }
80 }
81
82 /* Print the character string STRING, printing at most LENGTH characters.
83 Printing stops early if the number hits print_max; repeat counts
84 are printed as appropriate. Print ellipses at the end if we
85 had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
86 Note that gdb maintains the length of strings without counting the
87 terminating null byte, while chill strings are typically written with
88 an explicit null byte. So we always assume an implied null byte
89 until gdb is able to maintain non-null terminated strings as well
90 as null terminated strings (FIXME).
91 */
92
93 static void
94 chill_printstr (stream, string, length, force_ellipses)
95 GDB_FILE *stream;
96 char *string;
97 unsigned int length;
98 int force_ellipses;
99 {
100 register unsigned int i;
101 unsigned int things_printed = 0;
102 int in_literal_form = 0;
103 int in_control_form = 0;
104 int need_slashslash = 0;
105 unsigned int c;
106 extern int repeat_count_threshold;
107 extern int print_max;
108
109 if (length == 0)
110 {
111 fputs_filtered ("\"\"", stream);
112 return;
113 }
114
115 for (i = 0; i < length && things_printed < print_max; ++i)
116 {
117 /* Position of the character we are examining
118 to see whether it is repeated. */
119 unsigned int rep1;
120 /* Number of repetitions we have detected so far. */
121 unsigned int reps;
122
123 QUIT;
124
125 if (need_slashslash)
126 {
127 fputs_filtered ("//", stream);
128 need_slashslash = 0;
129 }
130
131 rep1 = i + 1;
132 reps = 1;
133 while (rep1 < length && string[rep1] == string[i])
134 {
135 ++rep1;
136 ++reps;
137 }
138
139 c = string[i];
140 if (reps > repeat_count_threshold)
141 {
142 if (in_control_form || in_literal_form)
143 {
144 if (in_control_form)
145 fputs_filtered (")", stream);
146 fputs_filtered ("\"//", stream);
147 in_control_form = in_literal_form = 0;
148 }
149 chill_printchar (c, stream);
150 fprintf_filtered (stream, "<repeats %u times>", reps);
151 i = rep1 - 1;
152 things_printed += repeat_count_threshold;
153 need_slashslash = 1;
154 }
155 else
156 {
157 if (! in_literal_form && ! in_control_form)
158 fputs_filtered ("\"", stream);
159 if (PRINT_LITERAL_FORM (c))
160 {
161 if (!in_literal_form)
162 {
163 if (in_control_form)
164 {
165 fputs_filtered (")", stream);
166 in_control_form = 0;
167 }
168 in_literal_form = 1;
169 }
170 fprintf_filtered (stream, "%c", c);
171 if (c == '"' || c == '^')
172 /* duplicate this one as must be done at input */
173 fprintf_filtered (stream, "%c", c);
174 }
175 else
176 {
177 if (!in_control_form)
178 {
179 if (in_literal_form)
180 {
181 in_literal_form = 0;
182 }
183 fputs_filtered ("^(", stream);
184 in_control_form = 1;
185 }
186 else
187 fprintf_filtered (stream, ",");
188 c = c & 0xff;
189 fprintf_filtered (stream, "%u", (unsigned int) c);
190 }
191 ++things_printed;
192 }
193 }
194
195 /* Terminate the quotes if necessary. */
196 if (in_control_form)
197 {
198 fputs_filtered (")", stream);
199 }
200 if (in_literal_form || in_control_form)
201 {
202 fputs_filtered ("\"", stream);
203 }
204 if (force_ellipses || (i < length))
205 {
206 fputs_filtered ("...", stream);
207 }
208 }
209
210 static struct type *
211 chill_create_fundamental_type (objfile, typeid)
212 struct objfile *objfile;
213 int typeid;
214 {
215 register struct type *type = NULL;
216
217 switch (typeid)
218 {
219 default:
220 /* FIXME: For now, if we are asked to produce a type not in this
221 language, create the equivalent of a C integer type with the
222 name "<?type?>". When all the dust settles from the type
223 reconstruction work, this should probably become an error. */
224 type = init_type (TYPE_CODE_INT, 2, 0, "<?type?>", objfile);
225 warning ("internal error: no chill fundamental type %d", typeid);
226 break;
227 case FT_VOID:
228 /* FIXME: Currently the GNU Chill compiler emits some DWARF entries for
229 typedefs, unrelated to anything directly in the code being compiled,
230 that have some FT_VOID types. Just fake it for now. */
231 type = init_type (TYPE_CODE_VOID, 0, 0, "<?VOID?>", objfile);
232 break;
233 case FT_BOOLEAN:
234 type = init_type (TYPE_CODE_BOOL, 1, TYPE_FLAG_UNSIGNED, "BOOL", objfile);
235 break;
236 case FT_CHAR:
237 type = init_type (TYPE_CODE_CHAR, 1, TYPE_FLAG_UNSIGNED, "CHAR", objfile);
238 break;
239 case FT_SIGNED_CHAR:
240 type = init_type (TYPE_CODE_INT, 1, 0, "BYTE", objfile);
241 break;
242 case FT_UNSIGNED_CHAR:
243 type = init_type (TYPE_CODE_INT, 1, TYPE_FLAG_UNSIGNED, "UBYTE", objfile);
244 break;
245 case FT_SHORT: /* Chill ints are 2 bytes */
246 type = init_type (TYPE_CODE_INT, 2, 0, "INT", objfile);
247 break;
248 case FT_UNSIGNED_SHORT: /* Chill ints are 2 bytes */
249 type = init_type (TYPE_CODE_INT, 2, TYPE_FLAG_UNSIGNED, "UINT", objfile);
250 break;
251 case FT_INTEGER: /* FIXME? */
252 case FT_SIGNED_INTEGER: /* FIXME? */
253 case FT_LONG: /* Chill longs are 4 bytes */
254 case FT_SIGNED_LONG: /* Chill longs are 4 bytes */
255 type = init_type (TYPE_CODE_INT, 4, 0, "LONG", objfile);
256 break;
257 case FT_UNSIGNED_INTEGER: /* FIXME? */
258 case FT_UNSIGNED_LONG: /* Chill longs are 4 bytes */
259 type = init_type (TYPE_CODE_INT, 4, TYPE_FLAG_UNSIGNED, "ULONG", objfile);
260 break;
261 case FT_FLOAT:
262 type = init_type (TYPE_CODE_FLT, 4, 0, "REAL", objfile);
263 break;
264 case FT_DBL_PREC_FLOAT:
265 type = init_type (TYPE_CODE_FLT, 8, 0, "LONG_REAL", objfile);
266 break;
267 }
268 return (type);
269 }
270
271 \f
272 /* Table of operators and their precedences for printing expressions. */
273
274 static const struct op_print chill_op_print_tab[] = {
275 {"AND", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
276 {"OR", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
277 {"NOT", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
278 {"MOD", BINOP_MOD, PREC_MUL, 0},
279 {"REM", BINOP_REM, PREC_MUL, 0},
280 {"SIZE",UNOP_SIZEOF, PREC_BUILTIN_FUNCTION, 0},
281 {"LOWER",UNOP_LOWER, PREC_BUILTIN_FUNCTION, 0},
282 {"UPPER",UNOP_UPPER, PREC_BUILTIN_FUNCTION, 0},
283 {"CARD",UNOP_CARD, PREC_BUILTIN_FUNCTION, 0},
284 {"MAX",UNOP_CHMAX, PREC_BUILTIN_FUNCTION, 0},
285 {"MIN",UNOP_CHMIN, PREC_BUILTIN_FUNCTION, 0},
286 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
287 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
288 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
289 {"<=", BINOP_LEQ, PREC_ORDER, 0},
290 {">=", BINOP_GEQ, PREC_ORDER, 0},
291 {">", BINOP_GTR, PREC_ORDER, 0},
292 {"<", BINOP_LESS, PREC_ORDER, 0},
293 {"+", BINOP_ADD, PREC_ADD, 0},
294 {"-", BINOP_SUB, PREC_ADD, 0},
295 {"*", BINOP_MUL, PREC_MUL, 0},
296 {"/", BINOP_DIV, PREC_MUL, 0},
297 {"//", BINOP_CONCAT, PREC_PREFIX, 0}, /* FIXME: precedence? */
298 {"-", UNOP_NEG, PREC_PREFIX, 0},
299 {"->", UNOP_IND, PREC_SUFFIX, 1},
300 {"->", UNOP_ADDR, PREC_PREFIX, 0},
301 {":", BINOP_RANGE, PREC_ASSIGN, 0},
302 {NULL, 0, 0, 0}
303 };
304 \f
305 /* The built-in types of Chill. */
306
307 struct type *builtin_type_chill_bool;
308 struct type *builtin_type_chill_char;
309 struct type *builtin_type_chill_long;
310 struct type *builtin_type_chill_ulong;
311 struct type *builtin_type_chill_real;
312
313 struct type ** const (chill_builtin_types[]) =
314 {
315 &builtin_type_chill_bool,
316 &builtin_type_chill_char,
317 &builtin_type_chill_long,
318 &builtin_type_chill_ulong,
319 &builtin_type_chill_real,
320 0
321 };
322
323 /* Calculate LOWER or UPPER of TYPE.
324 Returns the result as an integer.
325 *RESULT_TYPE is the appropriate type for the result. */
326
327 LONGEST
328 type_lower_upper (op, type, result_type)
329 enum exp_opcode op; /* Either UNOP_LOWER or UNOP_UPPER */
330 struct type *type;
331 struct type **result_type;
332 {
333 LONGEST low, high;
334 *result_type = type;
335 CHECK_TYPEDEF (type);
336 switch (TYPE_CODE (type))
337 {
338 case TYPE_CODE_STRUCT:
339 *result_type = builtin_type_int;
340 if (chill_varying_type (type))
341 return type_lower_upper (op, TYPE_FIELD_TYPE (type, 1), result_type);
342 break;
343 case TYPE_CODE_ARRAY:
344 case TYPE_CODE_BITSTRING:
345 case TYPE_CODE_STRING:
346 type = TYPE_FIELD_TYPE (type, 0); /* Get index type */
347
348 /* ... fall through ... */
349 case TYPE_CODE_RANGE:
350 *result_type = TYPE_TARGET_TYPE (type);
351 return op == UNOP_LOWER ? TYPE_LOW_BOUND (type) : TYPE_HIGH_BOUND (type);
352
353 case TYPE_CODE_ENUM:
354 case TYPE_CODE_BOOL:
355 case TYPE_CODE_INT:
356 case TYPE_CODE_CHAR:
357 if (get_discrete_bounds (type, &low, &high) >= 0)
358 {
359 *result_type = type;
360 return op == UNOP_LOWER ? low : high;
361 }
362 break;
363 case TYPE_CODE_UNDEF:
364 case TYPE_CODE_PTR:
365 case TYPE_CODE_UNION:
366 case TYPE_CODE_FUNC:
367 case TYPE_CODE_FLT:
368 case TYPE_CODE_VOID:
369 case TYPE_CODE_SET:
370 case TYPE_CODE_ERROR:
371 case TYPE_CODE_MEMBER:
372 case TYPE_CODE_METHOD:
373 case TYPE_CODE_REF:
374 case TYPE_CODE_COMPLEX:
375 default:
376 break;
377 }
378 error ("unknown mode for LOWER/UPPER builtin");
379 }
380
381 static value_ptr
382 value_chill_length (val)
383 value_ptr val;
384 {
385 LONGEST tmp;
386 struct type *type = VALUE_TYPE (val);
387 struct type *ttype;
388 CHECK_TYPEDEF (type);
389 switch (TYPE_CODE (type))
390 {
391 case TYPE_CODE_ARRAY:
392 case TYPE_CODE_BITSTRING:
393 case TYPE_CODE_STRING:
394 tmp = type_lower_upper (UNOP_UPPER, type, &ttype)
395 - type_lower_upper (UNOP_LOWER, type, &ttype) + 1;
396 break;
397 case TYPE_CODE_STRUCT:
398 if (chill_varying_type (type))
399 {
400 tmp = unpack_long (TYPE_FIELD_TYPE (type, 0), VALUE_CONTENTS (val));
401 break;
402 }
403 /* ... else fall through ... */
404 default:
405 error ("bad argument to LENGTH builtin");
406 }
407 return value_from_longest (builtin_type_int, tmp);
408 }
409
410 static value_ptr
411 value_chill_card (val)
412 value_ptr val;
413 {
414 LONGEST tmp = 0;
415 struct type *type = VALUE_TYPE (val);
416 CHECK_TYPEDEF (type);
417
418 if (TYPE_CODE (type) == TYPE_CODE_SET)
419 {
420 struct type *range_type = TYPE_INDEX_TYPE (type);
421 LONGEST lower_bound, upper_bound;
422 int i;
423
424 get_discrete_bounds (range_type, &lower_bound, &upper_bound);
425 for (i = lower_bound; i <= upper_bound; i++)
426 if (value_bit_index (type, VALUE_CONTENTS (val), i) > 0)
427 tmp++;
428 }
429 else
430 error ("bad argument to CARD builtin");
431
432 return value_from_longest (builtin_type_int, tmp);
433 }
434
435 static value_ptr
436 value_chill_max_min (op, val)
437 enum exp_opcode op;
438 value_ptr val;
439 {
440 LONGEST tmp = 0;
441 struct type *type = VALUE_TYPE (val);
442 struct type *elttype;
443 CHECK_TYPEDEF (type);
444
445 if (TYPE_CODE (type) == TYPE_CODE_SET)
446 {
447 LONGEST lower_bound, upper_bound;
448 int i, empty = 1;
449
450 elttype = TYPE_INDEX_TYPE (type);
451 CHECK_TYPEDEF (elttype);
452 get_discrete_bounds (elttype, &lower_bound, &upper_bound);
453
454 if (op == UNOP_CHMAX)
455 {
456 for (i = upper_bound; i >= lower_bound; i--)
457 {
458 if (value_bit_index (type, VALUE_CONTENTS (val), i) > 0)
459 {
460 tmp = i;
461 empty = 0;
462 break;
463 }
464 }
465 }
466 else
467 {
468 for (i = lower_bound; i <= upper_bound; i++)
469 {
470 if (value_bit_index (type, VALUE_CONTENTS (val), i) > 0)
471 {
472 tmp = i;
473 empty = 0;
474 break;
475 }
476 }
477 }
478 if (empty)
479 error ("%s for empty powerset", op == UNOP_CHMAX ? "MAX" : "MIN");
480 }
481 else
482 error ("bad argument to %s builtin", op == UNOP_CHMAX ? "MAX" : "MIN");
483
484 return value_from_longest (TYPE_CODE (elttype) == TYPE_CODE_RANGE
485 ? TYPE_TARGET_TYPE (elttype)
486 : elttype,
487 tmp);
488 }
489
490 static value_ptr
491 evaluate_subexp_chill (expect_type, exp, pos, noside)
492 struct type *expect_type;
493 register struct expression *exp;
494 register int *pos;
495 enum noside noside;
496 {
497 int pc = *pos;
498 struct type *type;
499 int tem, nargs;
500 value_ptr arg1;
501 value_ptr *argvec;
502 enum exp_opcode op = exp->elts[*pos].opcode;
503 switch (op)
504 {
505 case MULTI_SUBSCRIPT:
506 if (noside == EVAL_SKIP)
507 break;
508 (*pos) += 3;
509 nargs = longest_to_int (exp->elts[pc + 1].longconst);
510 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
511 type = check_typedef (VALUE_TYPE (arg1));
512
513 if (nargs == 1 && TYPE_CODE (type) == TYPE_CODE_INT)
514 {
515 /* Looks like string repetition. */
516 value_ptr string = evaluate_subexp_with_coercion (exp, pos, noside);
517 return value_concat (arg1, string);
518 }
519
520 switch (TYPE_CODE (type))
521 {
522 case TYPE_CODE_PTR:
523 type = check_typedef (TYPE_TARGET_TYPE (type));
524 if (!type || TYPE_CODE (type) != TYPE_CODE_FUNC)
525 error ("reference value used as function");
526 /* ... fall through ... */
527 case TYPE_CODE_FUNC:
528 /* It's a function call. */
529 if (noside == EVAL_AVOID_SIDE_EFFECTS)
530 break;
531
532 /* Allocate arg vector, including space for the function to be
533 called in argvec[0] and a terminating NULL */
534 argvec = (value_ptr *) alloca (sizeof (value_ptr) * (nargs + 2));
535 argvec[0] = arg1;
536 tem = 1;
537 for (; tem <= nargs && tem <= TYPE_NFIELDS (type); tem++)
538 {
539 argvec[tem]
540 = evaluate_subexp_chill (TYPE_FIELD_TYPE (type, tem-1),
541 exp, pos, noside);
542 }
543 for (; tem <= nargs; tem++)
544 argvec[tem] = evaluate_subexp_with_coercion (exp, pos, noside);
545 argvec[tem] = 0; /* signal end of arglist */
546
547 return call_function_by_hand (argvec[0], nargs, argvec + 1);
548 default:
549 break;
550 }
551
552 while (nargs-- > 0)
553 {
554 value_ptr index = evaluate_subexp_with_coercion (exp, pos, noside);
555 arg1 = value_subscript (arg1, index);
556 }
557 return (arg1);
558
559 case UNOP_LOWER:
560 case UNOP_UPPER:
561 (*pos)++;
562 if (noside == EVAL_SKIP)
563 {
564 (*exp->language_defn->evaluate_exp) (NULL_TYPE, exp, pos, EVAL_SKIP);
565 goto nosideret;
566 }
567 arg1 = (*exp->language_defn->evaluate_exp) (NULL_TYPE, exp, pos,
568 EVAL_AVOID_SIDE_EFFECTS);
569 tem = type_lower_upper (op, VALUE_TYPE (arg1), &type);
570 return value_from_longest (type, tem);
571
572 case UNOP_LENGTH:
573 (*pos)++;
574 arg1 = (*exp->language_defn->evaluate_exp) (NULL_TYPE, exp, pos, noside);
575 return value_chill_length (arg1);
576
577 case UNOP_CARD:
578 (*pos)++;
579 arg1 = (*exp->language_defn->evaluate_exp) (NULL_TYPE, exp, pos, noside);
580 return value_chill_card (arg1);
581
582 case UNOP_CHMAX:
583 case UNOP_CHMIN:
584 (*pos)++;
585 arg1 = (*exp->language_defn->evaluate_exp) (NULL_TYPE, exp, pos, noside);
586 return value_chill_max_min (op, arg1);
587
588 case BINOP_COMMA:
589 error ("',' operator used in invalid context");
590
591 default:
592 break;
593 }
594
595 return evaluate_subexp_standard (expect_type, exp, pos, noside);
596 nosideret:
597 return value_from_longest (builtin_type_long, (LONGEST) 1);
598 }
599
600 const struct language_defn chill_language_defn = {
601 "chill",
602 language_chill,
603 chill_builtin_types,
604 range_check_on,
605 type_check_on,
606 chill_parse, /* parser */
607 chill_error, /* parser error function */
608 evaluate_subexp_chill,
609 chill_printchar, /* print a character constant */
610 chill_printstr, /* function to print a string constant */
611 chill_create_fundamental_type,/* Create fundamental type in this language */
612 chill_print_type, /* Print a type using appropriate syntax */
613 chill_val_print, /* Print a value using appropriate syntax */
614 chill_value_print, /* Print a top-levl value */
615 {"", "B'", "", ""}, /* Binary format info */
616 {"O'%lo", "O'", "o", ""}, /* Octal format info */
617 {"D'%ld", "D'", "d", ""}, /* Decimal format info */
618 {"H'%lx", "H'", "x", ""}, /* Hex format info */
619 chill_op_print_tab, /* expression operators for printing */
620 0, /* arrays are first-class (not c-style) */
621 0, /* String lower bound */
622 &builtin_type_chill_char, /* Type of string elements */
623 LANG_MAGIC
624 };
625
626 /* Initialization for Chill */
627
628 void
629 _initialize_chill_language ()
630 {
631 builtin_type_chill_bool =
632 init_type (TYPE_CODE_BOOL, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
633 TYPE_FLAG_UNSIGNED,
634 "BOOL", (struct objfile *) NULL);
635 builtin_type_chill_char =
636 init_type (TYPE_CODE_CHAR, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
637 TYPE_FLAG_UNSIGNED,
638 "CHAR", (struct objfile *) NULL);
639 builtin_type_chill_long =
640 init_type (TYPE_CODE_INT, TARGET_LONG_BIT / TARGET_CHAR_BIT,
641 0,
642 "LONG", (struct objfile *) NULL);
643 builtin_type_chill_ulong =
644 init_type (TYPE_CODE_INT, TARGET_LONG_BIT / TARGET_CHAR_BIT,
645 TYPE_FLAG_UNSIGNED,
646 "ULONG", (struct objfile *) NULL);
647 builtin_type_chill_real =
648 init_type (TYPE_CODE_FLT, TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
649 0,
650 "LONG_REAL", (struct objfile *) NULL);
651
652 add_language (&chill_language_defn);
653 }
This page took 0.042229 seconds and 4 git commands to generate.