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, Boston, MA 02111-1307, USA. */
24 #include "expression.h"
25 #include "parser-defs.h"
29 extern void _initialize_chill_language
PARAMS ((void));
32 evaluate_subexp_chill
PARAMS ((struct type
*, struct expression
*, int *, enum noside
));
35 value_chill_max_min
PARAMS ((enum exp_opcode
, value_ptr
));
38 value_chill_card
PARAMS ((value_ptr
));
41 value_chill_length
PARAMS ((value_ptr
));
44 chill_create_fundamental_type
PARAMS ((struct objfile
*, int));
47 chill_printstr
PARAMS ((GDB_FILE
*stream
, char *string
, unsigned int length
, int width
, int force_ellipses
));
50 chill_printchar
PARAMS ((int, GDB_FILE
*));
52 /* For now, Chill uses a simple mangling algorithm whereby you simply
53 discard everything after the occurance of two successive CPLUS_MARKER
54 characters to derive the demangled form. */
57 chill_demangle (mangled
)
60 const char *joiner
= NULL
;
62 const char *cp
= mangled
;
66 if (is_cplus_marker (*cp
))
73 if (joiner
!= NULL
&& *(joiner
+ 1) == *joiner
)
75 demangled
= savestring (mangled
, joiner
- mangled
);
85 chill_printchar (c
, stream
)
89 c
&= 0xFF; /* Avoid sign bit follies */
91 if (PRINT_LITERAL_FORM (c
))
93 if (c
== '\'' || c
== '^')
94 fprintf_filtered (stream
, "'%c%c'", c
, c
);
96 fprintf_filtered (stream
, "'%c'", c
);
100 fprintf_filtered (stream
, "'^(%u)'", (unsigned int) c
);
104 /* Print the character string STRING, printing at most LENGTH characters.
105 Printing stops early if the number hits print_max; repeat counts
106 are printed as appropriate. Print ellipses at the end if we
107 had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
108 Note that gdb maintains the length of strings without counting the
109 terminating null byte, while chill strings are typically written with
110 an explicit null byte. So we always assume an implied null byte
111 until gdb is able to maintain non-null terminated strings as well
112 as null terminated strings (FIXME).
116 chill_printstr (stream
, string
, length
, width
, force_ellipses
)
123 register unsigned int i
;
124 unsigned int things_printed
= 0;
125 int in_literal_form
= 0;
126 int in_control_form
= 0;
127 int need_slashslash
= 0;
129 extern int repeat_count_threshold
;
130 extern int print_max
;
134 fputs_filtered ("\"\"", stream
);
138 for (i
= 0; i
< length
&& things_printed
< print_max
; ++i
)
140 /* Position of the character we are examining
141 to see whether it is repeated. */
143 /* Number of repetitions we have detected so far. */
150 fputs_filtered ("//", stream
);
156 while (rep1
< length
&& string
[rep1
] == string
[i
])
163 if (reps
> repeat_count_threshold
)
165 if (in_control_form
|| in_literal_form
)
168 fputs_filtered (")", stream
);
169 fputs_filtered ("\"//", stream
);
170 in_control_form
= in_literal_form
= 0;
172 chill_printchar (c
, stream
);
173 fprintf_filtered (stream
, "<repeats %u times>", reps
);
175 things_printed
+= repeat_count_threshold
;
180 if (! in_literal_form
&& ! in_control_form
)
181 fputs_filtered ("\"", stream
);
182 if (PRINT_LITERAL_FORM (c
))
184 if (!in_literal_form
)
188 fputs_filtered (")", stream
);
193 fprintf_filtered (stream
, "%c", c
);
194 if (c
== '"' || c
== '^')
195 /* duplicate this one as must be done at input */
196 fprintf_filtered (stream
, "%c", c
);
200 if (!in_control_form
)
206 fputs_filtered ("^(", stream
);
210 fprintf_filtered (stream
, ",");
212 fprintf_filtered (stream
, "%u", (unsigned int) c
);
218 /* Terminate the quotes if necessary. */
221 fputs_filtered (")", stream
);
223 if (in_literal_form
|| in_control_form
)
225 fputs_filtered ("\"", stream
);
227 if (force_ellipses
|| (i
< length
))
229 fputs_filtered ("...", stream
);
234 chill_create_fundamental_type (objfile
, typeid)
235 struct objfile
*objfile
;
238 register struct type
*type
= NULL
;
243 /* FIXME: For now, if we are asked to produce a type not in this
244 language, create the equivalent of a C integer type with the
245 name "<?type?>". When all the dust settles from the type
246 reconstruction work, this should probably become an error. */
247 type
= init_type (TYPE_CODE_INT
, 2, 0, "<?type?>", objfile
);
248 warning ("internal error: no chill fundamental type %d", typeid);
251 /* FIXME: Currently the GNU Chill compiler emits some DWARF entries for
252 typedefs, unrelated to anything directly in the code being compiled,
253 that have some FT_VOID types. Just fake it for now. */
254 type
= init_type (TYPE_CODE_VOID
, 0, 0, "<?VOID?>", objfile
);
257 type
= init_type (TYPE_CODE_BOOL
, 1, TYPE_FLAG_UNSIGNED
, "BOOL", objfile
);
260 type
= init_type (TYPE_CODE_CHAR
, 1, TYPE_FLAG_UNSIGNED
, "CHAR", objfile
);
263 type
= init_type (TYPE_CODE_INT
, 1, 0, "BYTE", objfile
);
265 case FT_UNSIGNED_CHAR
:
266 type
= init_type (TYPE_CODE_INT
, 1, TYPE_FLAG_UNSIGNED
, "UBYTE", objfile
);
268 case FT_SHORT
: /* Chill ints are 2 bytes */
269 type
= init_type (TYPE_CODE_INT
, 2, 0, "INT", objfile
);
271 case FT_UNSIGNED_SHORT
: /* Chill ints are 2 bytes */
272 type
= init_type (TYPE_CODE_INT
, 2, TYPE_FLAG_UNSIGNED
, "UINT", objfile
);
274 case FT_INTEGER
: /* FIXME? */
275 case FT_SIGNED_INTEGER
: /* FIXME? */
276 case FT_LONG
: /* Chill longs are 4 bytes */
277 case FT_SIGNED_LONG
: /* Chill longs are 4 bytes */
278 type
= init_type (TYPE_CODE_INT
, 4, 0, "LONG", objfile
);
280 case FT_UNSIGNED_INTEGER
: /* FIXME? */
281 case FT_UNSIGNED_LONG
: /* Chill longs are 4 bytes */
282 type
= init_type (TYPE_CODE_INT
, 4, TYPE_FLAG_UNSIGNED
, "ULONG", objfile
);
285 type
= init_type (TYPE_CODE_FLT
, 4, 0, "REAL", objfile
);
287 case FT_DBL_PREC_FLOAT
:
288 type
= init_type (TYPE_CODE_FLT
, 8, 0, "LONG_REAL", objfile
);
295 /* Table of operators and their precedences for printing expressions. */
297 static const struct op_print chill_op_print_tab
[] = {
298 {"AND", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
299 {"OR", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
300 {"NOT", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
301 {"MOD", BINOP_MOD
, PREC_MUL
, 0},
302 {"REM", BINOP_REM
, PREC_MUL
, 0},
303 {"SIZE",UNOP_SIZEOF
, PREC_BUILTIN_FUNCTION
, 0},
304 {"LOWER",UNOP_LOWER
, PREC_BUILTIN_FUNCTION
, 0},
305 {"UPPER",UNOP_UPPER
, PREC_BUILTIN_FUNCTION
, 0},
306 {"CARD",UNOP_CARD
, PREC_BUILTIN_FUNCTION
, 0},
307 {"MAX",UNOP_CHMAX
, PREC_BUILTIN_FUNCTION
, 0},
308 {"MIN",UNOP_CHMIN
, PREC_BUILTIN_FUNCTION
, 0},
309 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
310 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
311 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
312 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
313 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
314 {">", BINOP_GTR
, PREC_ORDER
, 0},
315 {"<", BINOP_LESS
, PREC_ORDER
, 0},
316 {"+", BINOP_ADD
, PREC_ADD
, 0},
317 {"-", BINOP_SUB
, PREC_ADD
, 0},
318 {"*", BINOP_MUL
, PREC_MUL
, 0},
319 {"/", BINOP_DIV
, PREC_MUL
, 0},
320 {"//", BINOP_CONCAT
, PREC_PREFIX
, 0}, /* FIXME: precedence? */
321 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
322 {"->", UNOP_IND
, PREC_SUFFIX
, 1},
323 {"->", UNOP_ADDR
, PREC_PREFIX
, 0},
324 {":", BINOP_RANGE
, PREC_ASSIGN
, 0},
328 /* The built-in types of Chill. */
330 struct type
*builtin_type_chill_bool
;
331 struct type
*builtin_type_chill_char
;
332 struct type
*builtin_type_chill_long
;
333 struct type
*builtin_type_chill_ulong
;
334 struct type
*builtin_type_chill_real
;
336 struct type
** CONST_PTR (chill_builtin_types
[]) =
338 &builtin_type_chill_bool
,
339 &builtin_type_chill_char
,
340 &builtin_type_chill_long
,
341 &builtin_type_chill_ulong
,
342 &builtin_type_chill_real
,
346 /* Calculate LOWER or UPPER of TYPE.
347 Returns the result as an integer.
348 *RESULT_TYPE is the appropriate type for the result. */
351 type_lower_upper (op
, type
, result_type
)
352 enum exp_opcode op
; /* Either UNOP_LOWER or UNOP_UPPER */
354 struct type
**result_type
;
358 CHECK_TYPEDEF (type
);
359 switch (TYPE_CODE (type
))
361 case TYPE_CODE_STRUCT
:
362 *result_type
= builtin_type_int
;
363 if (chill_varying_type (type
))
364 return type_lower_upper (op
, TYPE_FIELD_TYPE (type
, 1), result_type
);
366 case TYPE_CODE_ARRAY
:
367 case TYPE_CODE_BITSTRING
:
368 case TYPE_CODE_STRING
:
369 type
= TYPE_FIELD_TYPE (type
, 0); /* Get index type */
371 /* ... fall through ... */
372 case TYPE_CODE_RANGE
:
373 *result_type
= TYPE_TARGET_TYPE (type
);
374 return op
== UNOP_LOWER
? TYPE_LOW_BOUND (type
) : TYPE_HIGH_BOUND (type
);
380 if (get_discrete_bounds (type
, &low
, &high
) >= 0)
383 return op
== UNOP_LOWER
? low
: high
;
386 case TYPE_CODE_UNDEF
:
388 case TYPE_CODE_UNION
:
393 case TYPE_CODE_ERROR
:
394 case TYPE_CODE_MEMBER
:
395 case TYPE_CODE_METHOD
:
397 case TYPE_CODE_COMPLEX
:
401 error ("unknown mode for LOWER/UPPER builtin");
405 value_chill_length (val
)
409 struct type
*type
= VALUE_TYPE (val
);
411 CHECK_TYPEDEF (type
);
412 switch (TYPE_CODE (type
))
414 case TYPE_CODE_ARRAY
:
415 case TYPE_CODE_BITSTRING
:
416 case TYPE_CODE_STRING
:
417 tmp
= type_lower_upper (UNOP_UPPER
, type
, &ttype
)
418 - type_lower_upper (UNOP_LOWER
, type
, &ttype
) + 1;
420 case TYPE_CODE_STRUCT
:
421 if (chill_varying_type (type
))
423 tmp
= unpack_long (TYPE_FIELD_TYPE (type
, 0), VALUE_CONTENTS (val
));
426 /* ... else fall through ... */
428 error ("bad argument to LENGTH builtin");
430 return value_from_longest (builtin_type_int
, tmp
);
434 value_chill_card (val
)
438 struct type
*type
= VALUE_TYPE (val
);
439 CHECK_TYPEDEF (type
);
441 if (TYPE_CODE (type
) == TYPE_CODE_SET
)
443 struct type
*range_type
= TYPE_INDEX_TYPE (type
);
444 LONGEST lower_bound
, upper_bound
;
447 get_discrete_bounds (range_type
, &lower_bound
, &upper_bound
);
448 for (i
= lower_bound
; i
<= upper_bound
; i
++)
449 if (value_bit_index (type
, VALUE_CONTENTS (val
), i
) > 0)
453 error ("bad argument to CARD builtin");
455 return value_from_longest (builtin_type_int
, tmp
);
459 value_chill_max_min (op
, val
)
464 struct type
*type
= VALUE_TYPE (val
);
465 struct type
*elttype
;
466 CHECK_TYPEDEF (type
);
468 if (TYPE_CODE (type
) == TYPE_CODE_SET
)
470 LONGEST lower_bound
, upper_bound
;
473 elttype
= TYPE_INDEX_TYPE (type
);
474 CHECK_TYPEDEF (elttype
);
475 get_discrete_bounds (elttype
, &lower_bound
, &upper_bound
);
477 if (op
== UNOP_CHMAX
)
479 for (i
= upper_bound
; i
>= lower_bound
; i
--)
481 if (value_bit_index (type
, VALUE_CONTENTS (val
), i
) > 0)
491 for (i
= lower_bound
; i
<= upper_bound
; i
++)
493 if (value_bit_index (type
, VALUE_CONTENTS (val
), i
) > 0)
502 error ("%s for empty powerset", op
== UNOP_CHMAX
? "MAX" : "MIN");
505 error ("bad argument to %s builtin", op
== UNOP_CHMAX
? "MAX" : "MIN");
507 return value_from_longest (TYPE_CODE (elttype
) == TYPE_CODE_RANGE
508 ? TYPE_TARGET_TYPE (elttype
)
514 evaluate_subexp_chill (expect_type
, exp
, pos
, noside
)
515 struct type
*expect_type
;
516 register struct expression
*exp
;
525 enum exp_opcode op
= exp
->elts
[*pos
].opcode
;
528 case MULTI_SUBSCRIPT
:
529 if (noside
== EVAL_SKIP
)
532 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
533 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
534 type
= check_typedef (VALUE_TYPE (arg1
));
536 if (nargs
== 1 && TYPE_CODE (type
) == TYPE_CODE_INT
)
538 /* Looks like string repetition. */
539 value_ptr string
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
540 return value_concat (arg1
, string
);
543 switch (TYPE_CODE (type
))
546 type
= check_typedef (TYPE_TARGET_TYPE (type
));
547 if (!type
|| TYPE_CODE (type
) != TYPE_CODE_FUNC
)
548 error ("reference value used as function");
549 /* ... fall through ... */
551 /* It's a function call. */
552 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
555 /* Allocate arg vector, including space for the function to be
556 called in argvec[0] and a terminating NULL */
557 argvec
= (value_ptr
*) alloca (sizeof (value_ptr
) * (nargs
+ 2));
560 for (; tem
<= nargs
&& tem
<= TYPE_NFIELDS (type
); tem
++)
563 = evaluate_subexp_chill (TYPE_FIELD_TYPE (type
, tem
-1),
566 for (; tem
<= nargs
; tem
++)
567 argvec
[tem
] = evaluate_subexp_with_coercion (exp
, pos
, noside
);
568 argvec
[tem
] = 0; /* signal end of arglist */
570 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
577 value_ptr index
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
578 arg1
= value_subscript (arg1
, index
);
585 if (noside
== EVAL_SKIP
)
587 (*exp
->language_defn
->evaluate_exp
) (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
590 arg1
= (*exp
->language_defn
->evaluate_exp
) (NULL_TYPE
, exp
, pos
,
591 EVAL_AVOID_SIDE_EFFECTS
);
592 tem
= type_lower_upper (op
, VALUE_TYPE (arg1
), &type
);
593 return value_from_longest (type
, tem
);
597 arg1
= (*exp
->language_defn
->evaluate_exp
) (NULL_TYPE
, exp
, pos
, noside
);
598 return value_chill_length (arg1
);
602 arg1
= (*exp
->language_defn
->evaluate_exp
) (NULL_TYPE
, exp
, pos
, noside
);
603 return value_chill_card (arg1
);
608 arg1
= (*exp
->language_defn
->evaluate_exp
) (NULL_TYPE
, exp
, pos
, noside
);
609 return value_chill_max_min (op
, arg1
);
612 error ("',' operator used in invalid context");
618 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
620 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
623 const struct language_defn chill_language_defn
= {
629 chill_parse
, /* parser */
630 chill_error
, /* parser error function */
631 evaluate_subexp_chill
,
632 chill_printchar
, /* print a character constant */
633 chill_printstr
, /* function to print a string constant */
634 NULL
, /* Function to print a single char */
635 chill_create_fundamental_type
,/* Create fundamental type in this language */
636 chill_print_type
, /* Print a type using appropriate syntax */
637 chill_val_print
, /* Print a value using appropriate syntax */
638 chill_value_print
, /* Print a top-levl value */
639 {"", "B'", "", ""}, /* Binary format info */
640 {"O'%lo", "O'", "o", ""}, /* Octal format info */
641 {"D'%ld", "D'", "d", ""}, /* Decimal format info */
642 {"H'%lx", "H'", "x", ""}, /* Hex format info */
643 chill_op_print_tab
, /* expression operators for printing */
644 0, /* arrays are first-class (not c-style) */
645 0, /* String lower bound */
646 &builtin_type_chill_char
, /* Type of string elements */
650 /* Initialization for Chill */
653 _initialize_chill_language ()
655 builtin_type_chill_bool
=
656 init_type (TYPE_CODE_BOOL
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
658 "BOOL", (struct objfile
*) NULL
);
659 builtin_type_chill_char
=
660 init_type (TYPE_CODE_CHAR
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
662 "CHAR", (struct objfile
*) NULL
);
663 builtin_type_chill_long
=
664 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
666 "LONG", (struct objfile
*) NULL
);
667 builtin_type_chill_ulong
=
668 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
670 "ULONG", (struct objfile
*) NULL
);
671 builtin_type_chill_real
=
672 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
674 "LONG_REAL", (struct objfile
*) NULL
);
676 add_language (&chill_language_defn
);