1 /* Chill language support routines for GDB, the GNU debugger.
2 Copyright 1992, 1995, 1996 Free Software Foundation, Inc.
4 This file is part of GDB.
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.
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.
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,
19 Boston, MA 02111-1307, USA. */
25 #include "expression.h"
26 #include "parser-defs.h"
30 extern void _initialize_chill_language
PARAMS ((void));
33 evaluate_subexp_chill
PARAMS ((struct type
*, struct expression
*, int *, enum noside
));
36 value_chill_max_min
PARAMS ((enum exp_opcode
, value_ptr
));
39 value_chill_card
PARAMS ((value_ptr
));
42 value_chill_length
PARAMS ((value_ptr
));
45 chill_create_fundamental_type
PARAMS ((struct objfile
*, int));
48 chill_printstr
PARAMS ((GDB_FILE
* stream
, char *string
, unsigned int length
, int width
, int force_ellipses
));
51 chill_printchar
PARAMS ((int, GDB_FILE
*));
53 /* For now, Chill uses a simple mangling algorithm whereby you simply
54 discard everything after the occurance of two successive CPLUS_MARKER
55 characters to derive the demangled form. */
58 chill_demangle (mangled
)
61 const char *joiner
= NULL
;
63 const char *cp
= mangled
;
67 if (is_cplus_marker (*cp
))
74 if (joiner
!= NULL
&& *(joiner
+ 1) == *joiner
)
76 demangled
= savestring (mangled
, joiner
- mangled
);
86 chill_printchar (c
, stream
)
90 c
&= 0xFF; /* Avoid sign bit follies */
92 if (PRINT_LITERAL_FORM (c
))
94 if (c
== '\'' || c
== '^')
95 fprintf_filtered (stream
, "'%c%c'", c
, c
);
97 fprintf_filtered (stream
, "'%c'", c
);
101 fprintf_filtered (stream
, "'^(%u)'", (unsigned int) c
);
105 /* Print the character string STRING, printing at most LENGTH characters.
106 Printing stops early if the number hits print_max; repeat counts
107 are printed as appropriate. Print ellipses at the end if we
108 had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
109 Note that gdb maintains the length of strings without counting the
110 terminating null byte, while chill strings are typically written with
111 an explicit null byte. So we always assume an implied null byte
112 until gdb is able to maintain non-null terminated strings as well
113 as null terminated strings (FIXME).
117 chill_printstr (stream
, string
, length
, width
, force_ellipses
)
124 register unsigned int i
;
125 unsigned int things_printed
= 0;
126 int in_literal_form
= 0;
127 int in_control_form
= 0;
128 int need_slashslash
= 0;
130 extern int repeat_count_threshold
;
131 extern int print_max
;
135 fputs_filtered ("\"\"", stream
);
139 for (i
= 0; i
< length
&& things_printed
< print_max
; ++i
)
141 /* Position of the character we are examining
142 to see whether it is repeated. */
144 /* Number of repetitions we have detected so far. */
151 fputs_filtered ("//", stream
);
157 while (rep1
< length
&& string
[rep1
] == string
[i
])
164 if (reps
> repeat_count_threshold
)
166 if (in_control_form
|| in_literal_form
)
169 fputs_filtered (")", stream
);
170 fputs_filtered ("\"//", stream
);
171 in_control_form
= in_literal_form
= 0;
173 chill_printchar (c
, stream
);
174 fprintf_filtered (stream
, "<repeats %u times>", reps
);
176 things_printed
+= repeat_count_threshold
;
181 if (!in_literal_form
&& !in_control_form
)
182 fputs_filtered ("\"", stream
);
183 if (PRINT_LITERAL_FORM (c
))
185 if (!in_literal_form
)
189 fputs_filtered (")", stream
);
194 fprintf_filtered (stream
, "%c", c
);
195 if (c
== '"' || c
== '^')
196 /* duplicate this one as must be done at input */
197 fprintf_filtered (stream
, "%c", c
);
201 if (!in_control_form
)
207 fputs_filtered ("^(", stream
);
211 fprintf_filtered (stream
, ",");
213 fprintf_filtered (stream
, "%u", (unsigned int) c
);
219 /* Terminate the quotes if necessary. */
222 fputs_filtered (")", stream
);
224 if (in_literal_form
|| in_control_form
)
226 fputs_filtered ("\"", stream
);
228 if (force_ellipses
|| (i
< length
))
230 fputs_filtered ("...", stream
);
235 chill_create_fundamental_type (objfile
, typeid)
236 struct objfile
*objfile
;
239 register struct type
*type
= NULL
;
244 /* FIXME: For now, if we are asked to produce a type not in this
245 language, create the equivalent of a C integer type with the
246 name "<?type?>". When all the dust settles from the type
247 reconstruction work, this should probably become an error. */
248 type
= init_type (TYPE_CODE_INT
, 2, 0, "<?type?>", objfile
);
249 warning ("internal error: no chill fundamental type %d", typeid);
252 /* FIXME: Currently the GNU Chill compiler emits some DWARF entries for
253 typedefs, unrelated to anything directly in the code being compiled,
254 that have some FT_VOID types. Just fake it for now. */
255 type
= init_type (TYPE_CODE_VOID
, 0, 0, "<?VOID?>", objfile
);
258 type
= init_type (TYPE_CODE_BOOL
, 1, TYPE_FLAG_UNSIGNED
, "BOOL", objfile
);
261 type
= init_type (TYPE_CODE_CHAR
, 1, TYPE_FLAG_UNSIGNED
, "CHAR", objfile
);
264 type
= init_type (TYPE_CODE_INT
, 1, 0, "BYTE", objfile
);
266 case FT_UNSIGNED_CHAR
:
267 type
= init_type (TYPE_CODE_INT
, 1, TYPE_FLAG_UNSIGNED
, "UBYTE", objfile
);
269 case FT_SHORT
: /* Chill ints are 2 bytes */
270 type
= init_type (TYPE_CODE_INT
, 2, 0, "INT", objfile
);
272 case FT_UNSIGNED_SHORT
: /* Chill ints are 2 bytes */
273 type
= init_type (TYPE_CODE_INT
, 2, TYPE_FLAG_UNSIGNED
, "UINT", objfile
);
275 case FT_INTEGER
: /* FIXME? */
276 case FT_SIGNED_INTEGER
: /* FIXME? */
277 case FT_LONG
: /* Chill longs are 4 bytes */
278 case FT_SIGNED_LONG
: /* Chill longs are 4 bytes */
279 type
= init_type (TYPE_CODE_INT
, 4, 0, "LONG", objfile
);
281 case FT_UNSIGNED_INTEGER
: /* FIXME? */
282 case FT_UNSIGNED_LONG
: /* Chill longs are 4 bytes */
283 type
= init_type (TYPE_CODE_INT
, 4, TYPE_FLAG_UNSIGNED
, "ULONG", objfile
);
286 type
= init_type (TYPE_CODE_FLT
, 4, 0, "REAL", objfile
);
288 case FT_DBL_PREC_FLOAT
:
289 type
= init_type (TYPE_CODE_FLT
, 8, 0, "LONG_REAL", objfile
);
296 /* Table of operators and their precedences for printing expressions. */
298 static const struct op_print chill_op_print_tab
[] =
300 {"AND", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
301 {"OR", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
302 {"NOT", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
303 {"MOD", BINOP_MOD
, PREC_MUL
, 0},
304 {"REM", BINOP_REM
, PREC_MUL
, 0},
305 {"SIZE", UNOP_SIZEOF
, PREC_BUILTIN_FUNCTION
, 0},
306 {"LOWER", UNOP_LOWER
, PREC_BUILTIN_FUNCTION
, 0},
307 {"UPPER", UNOP_UPPER
, PREC_BUILTIN_FUNCTION
, 0},
308 {"CARD", UNOP_CARD
, PREC_BUILTIN_FUNCTION
, 0},
309 {"MAX", UNOP_CHMAX
, PREC_BUILTIN_FUNCTION
, 0},
310 {"MIN", UNOP_CHMIN
, PREC_BUILTIN_FUNCTION
, 0},
311 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
312 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
313 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
314 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
315 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
316 {">", BINOP_GTR
, PREC_ORDER
, 0},
317 {"<", BINOP_LESS
, PREC_ORDER
, 0},
318 {"+", BINOP_ADD
, PREC_ADD
, 0},
319 {"-", BINOP_SUB
, PREC_ADD
, 0},
320 {"*", BINOP_MUL
, PREC_MUL
, 0},
321 {"/", BINOP_DIV
, PREC_MUL
, 0},
322 {"//", BINOP_CONCAT
, PREC_PREFIX
, 0}, /* FIXME: precedence? */
323 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
324 {"->", UNOP_IND
, PREC_SUFFIX
, 1},
325 {"->", UNOP_ADDR
, PREC_PREFIX
, 0},
326 {":", BINOP_RANGE
, PREC_ASSIGN
, 0},
330 /* The built-in types of Chill. */
332 struct type
*builtin_type_chill_bool
;
333 struct type
*builtin_type_chill_char
;
334 struct type
*builtin_type_chill_long
;
335 struct type
*builtin_type_chill_ulong
;
336 struct type
*builtin_type_chill_real
;
338 struct type
**CONST_PTR (chill_builtin_types
[]) =
340 &builtin_type_chill_bool
,
341 &builtin_type_chill_char
,
342 &builtin_type_chill_long
,
343 &builtin_type_chill_ulong
,
344 &builtin_type_chill_real
,
348 /* Calculate LOWER or UPPER of TYPE.
349 Returns the result as an integer.
350 *RESULT_TYPE is the appropriate type for the result. */
353 type_lower_upper (op
, type
, result_type
)
354 enum exp_opcode op
; /* Either UNOP_LOWER or UNOP_UPPER */
356 struct type
**result_type
;
360 CHECK_TYPEDEF (type
);
361 switch (TYPE_CODE (type
))
363 case TYPE_CODE_STRUCT
:
364 *result_type
= builtin_type_int
;
365 if (chill_varying_type (type
))
366 return type_lower_upper (op
, TYPE_FIELD_TYPE (type
, 1), result_type
);
368 case TYPE_CODE_ARRAY
:
369 case TYPE_CODE_BITSTRING
:
370 case TYPE_CODE_STRING
:
371 type
= TYPE_FIELD_TYPE (type
, 0); /* Get index type */
373 /* ... fall through ... */
374 case TYPE_CODE_RANGE
:
375 *result_type
= TYPE_TARGET_TYPE (type
);
376 return op
== UNOP_LOWER
? TYPE_LOW_BOUND (type
) : TYPE_HIGH_BOUND (type
);
382 if (get_discrete_bounds (type
, &low
, &high
) >= 0)
385 return op
== UNOP_LOWER
? low
: high
;
388 case TYPE_CODE_UNDEF
:
390 case TYPE_CODE_UNION
:
395 case TYPE_CODE_ERROR
:
396 case TYPE_CODE_MEMBER
:
397 case TYPE_CODE_METHOD
:
399 case TYPE_CODE_COMPLEX
:
403 error ("unknown mode for LOWER/UPPER builtin");
407 value_chill_length (val
)
411 struct type
*type
= VALUE_TYPE (val
);
413 CHECK_TYPEDEF (type
);
414 switch (TYPE_CODE (type
))
416 case TYPE_CODE_ARRAY
:
417 case TYPE_CODE_BITSTRING
:
418 case TYPE_CODE_STRING
:
419 tmp
= type_lower_upper (UNOP_UPPER
, type
, &ttype
)
420 - type_lower_upper (UNOP_LOWER
, type
, &ttype
) + 1;
422 case TYPE_CODE_STRUCT
:
423 if (chill_varying_type (type
))
425 tmp
= unpack_long (TYPE_FIELD_TYPE (type
, 0), VALUE_CONTENTS (val
));
428 /* ... else fall through ... */
430 error ("bad argument to LENGTH builtin");
432 return value_from_longest (builtin_type_int
, tmp
);
436 value_chill_card (val
)
440 struct type
*type
= VALUE_TYPE (val
);
441 CHECK_TYPEDEF (type
);
443 if (TYPE_CODE (type
) == TYPE_CODE_SET
)
445 struct type
*range_type
= TYPE_INDEX_TYPE (type
);
446 LONGEST lower_bound
, upper_bound
;
449 get_discrete_bounds (range_type
, &lower_bound
, &upper_bound
);
450 for (i
= lower_bound
; i
<= upper_bound
; i
++)
451 if (value_bit_index (type
, VALUE_CONTENTS (val
), i
) > 0)
455 error ("bad argument to CARD builtin");
457 return value_from_longest (builtin_type_int
, tmp
);
461 value_chill_max_min (op
, val
)
466 struct type
*type
= VALUE_TYPE (val
);
467 struct type
*elttype
;
468 CHECK_TYPEDEF (type
);
470 if (TYPE_CODE (type
) == TYPE_CODE_SET
)
472 LONGEST lower_bound
, upper_bound
;
475 elttype
= TYPE_INDEX_TYPE (type
);
476 CHECK_TYPEDEF (elttype
);
477 get_discrete_bounds (elttype
, &lower_bound
, &upper_bound
);
479 if (op
== UNOP_CHMAX
)
481 for (i
= upper_bound
; i
>= lower_bound
; i
--)
483 if (value_bit_index (type
, VALUE_CONTENTS (val
), i
) > 0)
493 for (i
= lower_bound
; i
<= upper_bound
; i
++)
495 if (value_bit_index (type
, VALUE_CONTENTS (val
), i
) > 0)
504 error ("%s for empty powerset", op
== UNOP_CHMAX
? "MAX" : "MIN");
507 error ("bad argument to %s builtin", op
== UNOP_CHMAX
? "MAX" : "MIN");
509 return value_from_longest (TYPE_CODE (elttype
) == TYPE_CODE_RANGE
510 ? TYPE_TARGET_TYPE (elttype
)
516 evaluate_subexp_chill (expect_type
, exp
, pos
, noside
)
517 struct type
*expect_type
;
518 register struct expression
*exp
;
527 enum exp_opcode op
= exp
->elts
[*pos
].opcode
;
530 case MULTI_SUBSCRIPT
:
531 if (noside
== EVAL_SKIP
)
534 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
535 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
536 type
= check_typedef (VALUE_TYPE (arg1
));
538 if (nargs
== 1 && TYPE_CODE (type
) == TYPE_CODE_INT
)
540 /* Looks like string repetition. */
541 value_ptr string
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
542 return value_concat (arg1
, string
);
545 switch (TYPE_CODE (type
))
548 type
= check_typedef (TYPE_TARGET_TYPE (type
));
549 if (!type
|| TYPE_CODE (type
) != TYPE_CODE_FUNC
)
550 error ("reference value used as function");
551 /* ... fall through ... */
553 /* It's a function call. */
554 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
557 /* Allocate arg vector, including space for the function to be
558 called in argvec[0] and a terminating NULL */
559 argvec
= (value_ptr
*) alloca (sizeof (value_ptr
) * (nargs
+ 2));
562 for (; tem
<= nargs
&& tem
<= TYPE_NFIELDS (type
); tem
++)
565 = evaluate_subexp_chill (TYPE_FIELD_TYPE (type
, tem
- 1),
568 for (; tem
<= nargs
; tem
++)
569 argvec
[tem
] = evaluate_subexp_with_coercion (exp
, pos
, noside
);
570 argvec
[tem
] = 0; /* signal end of arglist */
572 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
579 value_ptr index
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
580 arg1
= value_subscript (arg1
, index
);
587 if (noside
== EVAL_SKIP
)
589 (*exp
->language_defn
->evaluate_exp
) (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
592 arg1
= (*exp
->language_defn
->evaluate_exp
) (NULL_TYPE
, exp
, pos
,
593 EVAL_AVOID_SIDE_EFFECTS
);
594 tem
= type_lower_upper (op
, VALUE_TYPE (arg1
), &type
);
595 return value_from_longest (type
, tem
);
599 arg1
= (*exp
->language_defn
->evaluate_exp
) (NULL_TYPE
, exp
, pos
, noside
);
600 return value_chill_length (arg1
);
604 arg1
= (*exp
->language_defn
->evaluate_exp
) (NULL_TYPE
, exp
, pos
, noside
);
605 return value_chill_card (arg1
);
610 arg1
= (*exp
->language_defn
->evaluate_exp
) (NULL_TYPE
, exp
, pos
, noside
);
611 return value_chill_max_min (op
, arg1
);
614 error ("',' operator used in invalid context");
620 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
622 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
625 const struct language_defn chill_language_defn
=
632 chill_parse
, /* parser */
633 chill_error
, /* parser error function */
634 evaluate_subexp_chill
,
635 chill_printchar
, /* print a character constant */
636 chill_printstr
, /* function to print a string constant */
637 NULL
, /* Function to print a single char */
638 chill_create_fundamental_type
, /* Create fundamental type in this language */
639 chill_print_type
, /* Print a type using appropriate syntax */
640 chill_val_print
, /* Print a value using appropriate syntax */
641 chill_value_print
, /* Print a top-levl value */
642 {"", "B'", "", ""}, /* Binary format info */
643 {"O'%lo", "O'", "o", ""}, /* Octal format info */
644 {"D'%ld", "D'", "d", ""}, /* Decimal format info */
645 {"H'%lx", "H'", "x", ""}, /* Hex format info */
646 chill_op_print_tab
, /* expression operators for printing */
647 0, /* arrays are first-class (not c-style) */
648 0, /* String lower bound */
649 &builtin_type_chill_char
, /* Type of string elements */
653 /* Initialization for Chill */
656 _initialize_chill_language ()
658 builtin_type_chill_bool
=
659 init_type (TYPE_CODE_BOOL
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
661 "BOOL", (struct objfile
*) NULL
);
662 builtin_type_chill_char
=
663 init_type (TYPE_CODE_CHAR
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
665 "CHAR", (struct objfile
*) NULL
);
666 builtin_type_chill_long
=
667 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
669 "LONG", (struct objfile
*) NULL
);
670 builtin_type_chill_ulong
=
671 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
673 "ULONG", (struct objfile
*) NULL
);
674 builtin_type_chill_real
=
675 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
677 "LONG_REAL", (struct objfile
*) NULL
);
679 add_language (&chill_language_defn
);