]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blob - gdb/p-lang.c
Switch the license of all .c files to GPLv3.
[thirdparty/binutils-gdb.git] / gdb / p-lang.c
1 /* Pascal language support routines for GDB, the GNU debugger.
2
3 Copyright (C) 2000, 2002, 2003, 2004, 2005, 2007
4 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 /* This file is derived from c-lang.c */
22
23 #include "defs.h"
24 #include "gdb_string.h"
25 #include "symtab.h"
26 #include "gdbtypes.h"
27 #include "expression.h"
28 #include "parser-defs.h"
29 #include "language.h"
30 #include "p-lang.h"
31 #include "valprint.h"
32 #include "value.h"
33 #include <ctype.h>
34
35 extern void _initialize_pascal_language (void);
36
37
38 /* Determines if type TYPE is a pascal string type.
39 Returns 1 if the type is a known pascal type
40 This function is used by p-valprint.c code to allow better string display.
41 If it is a pascal string type, then it also sets info needed
42 to get the length and the data of the string
43 length_pos, length_size and string_pos are given in bytes.
44 char_size gives the element size in bytes.
45 FIXME: if the position or the size of these fields
46 are not multiple of TARGET_CHAR_BIT then the results are wrong
47 but this does not happen for Free Pascal nor for GPC. */
48 int
49 is_pascal_string_type (struct type *type,int *length_pos,
50 int *length_size, int *string_pos, int *char_size,
51 char **arrayname)
52 {
53 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
54 {
55 /* Old Borland type pascal strings from Free Pascal Compiler. */
56 /* Two fields: length and st. */
57 if (TYPE_NFIELDS (type) == 2
58 && strcmp (TYPE_FIELDS (type)[0].name, "length") == 0
59 && strcmp (TYPE_FIELDS (type)[1].name, "st") == 0)
60 {
61 if (length_pos)
62 *length_pos = TYPE_FIELD_BITPOS (type, 0) / TARGET_CHAR_BIT;
63 if (length_size)
64 *length_size = TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
65 if (string_pos)
66 *string_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;
67 if (char_size)
68 *char_size = 1;
69 if (arrayname)
70 *arrayname = TYPE_FIELDS (type)[1].name;
71 return 2;
72 };
73 /* GNU pascal strings. */
74 /* Three fields: Capacity, length and schema$ or _p_schema. */
75 if (TYPE_NFIELDS (type) == 3
76 && strcmp (TYPE_FIELDS (type)[0].name, "Capacity") == 0
77 && strcmp (TYPE_FIELDS (type)[1].name, "length") == 0)
78 {
79 if (length_pos)
80 *length_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;
81 if (length_size)
82 *length_size = TYPE_LENGTH (TYPE_FIELD_TYPE (type, 1));
83 if (string_pos)
84 *string_pos = TYPE_FIELD_BITPOS (type, 2) / TARGET_CHAR_BIT;
85 /* FIXME: how can I detect wide chars in GPC ?? */
86 if (char_size)
87 *char_size = 1;
88 if (arrayname)
89 *arrayname = TYPE_FIELDS (type)[2].name;
90 return 3;
91 };
92 }
93 return 0;
94 }
95
96 static void pascal_one_char (int, struct ui_file *, int *);
97
98 /* Print the character C on STREAM as part of the contents of a literal
99 string.
100 In_quotes is reset to 0 if a char is written with #4 notation */
101
102 static void
103 pascal_one_char (int c, struct ui_file *stream, int *in_quotes)
104 {
105
106 c &= 0xFF; /* Avoid sign bit follies */
107
108 if ((c == '\'') || (PRINT_LITERAL_FORM (c)))
109 {
110 if (!(*in_quotes))
111 fputs_filtered ("'", stream);
112 *in_quotes = 1;
113 if (c == '\'')
114 {
115 fputs_filtered ("''", stream);
116 }
117 else
118 fprintf_filtered (stream, "%c", c);
119 }
120 else
121 {
122 if (*in_quotes)
123 fputs_filtered ("'", stream);
124 *in_quotes = 0;
125 fprintf_filtered (stream, "#%d", (unsigned int) c);
126 }
127 }
128
129 static void pascal_emit_char (int c, struct ui_file *stream, int quoter);
130
131 /* Print the character C on STREAM as part of the contents of a literal
132 string whose delimiter is QUOTER. Note that that format for printing
133 characters and strings is language specific. */
134
135 static void
136 pascal_emit_char (int c, struct ui_file *stream, int quoter)
137 {
138 int in_quotes = 0;
139 pascal_one_char (c, stream, &in_quotes);
140 if (in_quotes)
141 fputs_filtered ("'", stream);
142 }
143
144 void
145 pascal_printchar (int c, struct ui_file *stream)
146 {
147 int in_quotes = 0;
148 pascal_one_char (c, stream, &in_quotes);
149 if (in_quotes)
150 fputs_filtered ("'", stream);
151 }
152
153 /* Print the character string STRING, printing at most LENGTH characters.
154 Printing stops early if the number hits print_max; repeat counts
155 are printed as appropriate. Print ellipses at the end if we
156 had to stop before printing LENGTH characters, or if FORCE_ELLIPSES. */
157
158 void
159 pascal_printstr (struct ui_file *stream, const gdb_byte *string,
160 unsigned int length, int width, int force_ellipses)
161 {
162 unsigned int i;
163 unsigned int things_printed = 0;
164 int in_quotes = 0;
165 int need_comma = 0;
166
167 /* If the string was not truncated due to `set print elements', and
168 the last byte of it is a null, we don't print that, in traditional C
169 style. */
170 if ((!force_ellipses) && length > 0 && string[length - 1] == '\0')
171 length--;
172
173 if (length == 0)
174 {
175 fputs_filtered ("''", stream);
176 return;
177 }
178
179 for (i = 0; i < length && things_printed < print_max; ++i)
180 {
181 /* Position of the character we are examining
182 to see whether it is repeated. */
183 unsigned int rep1;
184 /* Number of repetitions we have detected so far. */
185 unsigned int reps;
186
187 QUIT;
188
189 if (need_comma)
190 {
191 fputs_filtered (", ", stream);
192 need_comma = 0;
193 }
194
195 rep1 = i + 1;
196 reps = 1;
197 while (rep1 < length && string[rep1] == string[i])
198 {
199 ++rep1;
200 ++reps;
201 }
202
203 if (reps > repeat_count_threshold)
204 {
205 if (in_quotes)
206 {
207 if (inspect_it)
208 fputs_filtered ("\\', ", stream);
209 else
210 fputs_filtered ("', ", stream);
211 in_quotes = 0;
212 }
213 pascal_printchar (string[i], stream);
214 fprintf_filtered (stream, " <repeats %u times>", reps);
215 i = rep1 - 1;
216 things_printed += repeat_count_threshold;
217 need_comma = 1;
218 }
219 else
220 {
221 int c = string[i];
222 if ((!in_quotes) && (PRINT_LITERAL_FORM (c)))
223 {
224 if (inspect_it)
225 fputs_filtered ("\\'", stream);
226 else
227 fputs_filtered ("'", stream);
228 in_quotes = 1;
229 }
230 pascal_one_char (c, stream, &in_quotes);
231 ++things_printed;
232 }
233 }
234
235 /* Terminate the quotes if necessary. */
236 if (in_quotes)
237 {
238 if (inspect_it)
239 fputs_filtered ("\\'", stream);
240 else
241 fputs_filtered ("'", stream);
242 }
243
244 if (force_ellipses || i < length)
245 fputs_filtered ("...", stream);
246 }
247
248 /* Create a fundamental Pascal type using default reasonable for the current
249 target machine.
250
251 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
252 define fundamental types such as "int" or "double". Others (stabs or
253 DWARF version 2, etc) do define fundamental types. For the formats which
254 don't provide fundamental types, gdb can create such types using this
255 function.
256
257 FIXME: Some compilers distinguish explicitly signed integral types
258 (signed short, signed int, signed long) from "regular" integral types
259 (short, int, long) in the debugging information. There is some dis-
260 agreement as to how useful this feature is. In particular, gcc does
261 not support this. Also, only some debugging formats allow the
262 distinction to be passed on to a debugger. For now, we always just
263 use "short", "int", or "long" as the type name, for both the implicit
264 and explicitly signed types. This also makes life easier for the
265 gdb test suite since we don't have to account for the differences
266 in output depending upon what the compiler and debugging format
267 support. We will probably have to re-examine the issue when gdb
268 starts taking it's fundamental type information directly from the
269 debugging information supplied by the compiler. fnf@cygnus.com */
270
271 /* Note there might be some discussion about the choosen correspondance
272 because it mainly reflects Free Pascal Compiler setup for now PM */
273
274
275 struct type *
276 pascal_create_fundamental_type (struct objfile *objfile, int typeid)
277 {
278 struct type *type = NULL;
279
280 switch (typeid)
281 {
282 default:
283 /* FIXME: For now, if we are asked to produce a type not in this
284 language, create the equivalent of a C integer type with the
285 name "<?type?>". When all the dust settles from the type
286 reconstruction work, this should probably become an error. */
287 type = init_type (TYPE_CODE_INT,
288 gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
289 0, "<?type?>", objfile);
290 warning (_("internal error: no Pascal fundamental type %d"), typeid);
291 break;
292 case FT_VOID:
293 type = init_type (TYPE_CODE_VOID,
294 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
295 0, "void", objfile);
296 break;
297 case FT_CHAR:
298 type = init_type (TYPE_CODE_CHAR,
299 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
300 0, "char", objfile);
301 break;
302 case FT_SIGNED_CHAR:
303 type = init_type (TYPE_CODE_INT,
304 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
305 0, "shortint", objfile);
306 break;
307 case FT_UNSIGNED_CHAR:
308 type = init_type (TYPE_CODE_INT,
309 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
310 TYPE_FLAG_UNSIGNED, "byte", objfile);
311 break;
312 case FT_SHORT:
313 type = init_type (TYPE_CODE_INT,
314 gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
315 0, "integer", objfile);
316 break;
317 case FT_SIGNED_SHORT:
318 type = init_type (TYPE_CODE_INT,
319 gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
320 0, "integer", objfile); /* FIXME-fnf */
321 break;
322 case FT_UNSIGNED_SHORT:
323 type = init_type (TYPE_CODE_INT,
324 gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
325 TYPE_FLAG_UNSIGNED, "word", objfile);
326 break;
327 case FT_INTEGER:
328 type = init_type (TYPE_CODE_INT,
329 gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
330 0, "longint", objfile);
331 break;
332 case FT_SIGNED_INTEGER:
333 type = init_type (TYPE_CODE_INT,
334 gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
335 0, "longint", objfile); /* FIXME -fnf */
336 break;
337 case FT_UNSIGNED_INTEGER:
338 type = init_type (TYPE_CODE_INT,
339 gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
340 TYPE_FLAG_UNSIGNED, "cardinal", objfile);
341 break;
342 case FT_LONG:
343 type = init_type (TYPE_CODE_INT,
344 gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
345 0, "long", objfile);
346 break;
347 case FT_SIGNED_LONG:
348 type = init_type (TYPE_CODE_INT,
349 gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
350 0, "long", objfile); /* FIXME -fnf */
351 break;
352 case FT_UNSIGNED_LONG:
353 type = init_type (TYPE_CODE_INT,
354 gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
355 TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
356 break;
357 case FT_LONG_LONG:
358 type = init_type (TYPE_CODE_INT,
359 gdbarch_long_long_bit
360 (current_gdbarch) / TARGET_CHAR_BIT,
361 0, "long long", objfile);
362 break;
363 case FT_SIGNED_LONG_LONG:
364 type = init_type (TYPE_CODE_INT,
365 gdbarch_long_long_bit
366 (current_gdbarch) / TARGET_CHAR_BIT,
367 0, "signed long long", objfile);
368 break;
369 case FT_UNSIGNED_LONG_LONG:
370 type = init_type (TYPE_CODE_INT,
371 gdbarch_long_long_bit
372 (current_gdbarch) / TARGET_CHAR_BIT,
373 TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
374 break;
375 case FT_FLOAT:
376 type = init_type (TYPE_CODE_FLT,
377 gdbarch_float_bit (current_gdbarch) / TARGET_CHAR_BIT,
378 0, "float", objfile);
379 break;
380 case FT_DBL_PREC_FLOAT:
381 type = init_type (TYPE_CODE_FLT,
382 gdbarch_double_bit (current_gdbarch) / TARGET_CHAR_BIT,
383 0, "double", objfile);
384 break;
385 case FT_EXT_PREC_FLOAT:
386 type = init_type (TYPE_CODE_FLT,
387 gdbarch_long_double_bit (current_gdbarch)
388 / TARGET_CHAR_BIT,
389 0, "extended", objfile);
390 break;
391 }
392 return (type);
393 }
394 \f
395
396 /* Table mapping opcodes into strings for printing operators
397 and precedences of the operators. */
398
399 const struct op_print pascal_op_print_tab[] =
400 {
401 {",", BINOP_COMMA, PREC_COMMA, 0},
402 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
403 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
404 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
405 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
406 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
407 {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
408 {"<=", BINOP_LEQ, PREC_ORDER, 0},
409 {">=", BINOP_GEQ, PREC_ORDER, 0},
410 {">", BINOP_GTR, PREC_ORDER, 0},
411 {"<", BINOP_LESS, PREC_ORDER, 0},
412 {"shr", BINOP_RSH, PREC_SHIFT, 0},
413 {"shl", BINOP_LSH, PREC_SHIFT, 0},
414 {"+", BINOP_ADD, PREC_ADD, 0},
415 {"-", BINOP_SUB, PREC_ADD, 0},
416 {"*", BINOP_MUL, PREC_MUL, 0},
417 {"/", BINOP_DIV, PREC_MUL, 0},
418 {"div", BINOP_INTDIV, PREC_MUL, 0},
419 {"mod", BINOP_REM, PREC_MUL, 0},
420 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
421 {"-", UNOP_NEG, PREC_PREFIX, 0},
422 {"not", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
423 {"^", UNOP_IND, PREC_SUFFIX, 1},
424 {"@", UNOP_ADDR, PREC_PREFIX, 0},
425 {"sizeof", UNOP_SIZEOF, PREC_PREFIX, 0},
426 {NULL, 0, 0, 0}
427 };
428 \f
429 enum pascal_primitive_types {
430 pascal_primitive_type_int,
431 pascal_primitive_type_long,
432 pascal_primitive_type_short,
433 pascal_primitive_type_char,
434 pascal_primitive_type_float,
435 pascal_primitive_type_double,
436 pascal_primitive_type_void,
437 pascal_primitive_type_long_long,
438 pascal_primitive_type_signed_char,
439 pascal_primitive_type_unsigned_char,
440 pascal_primitive_type_unsigned_short,
441 pascal_primitive_type_unsigned_int,
442 pascal_primitive_type_unsigned_long,
443 pascal_primitive_type_unsigned_long_long,
444 pascal_primitive_type_long_double,
445 pascal_primitive_type_complex,
446 pascal_primitive_type_double_complex,
447 nr_pascal_primitive_types
448 };
449
450 static void
451 pascal_language_arch_info (struct gdbarch *gdbarch,
452 struct language_arch_info *lai)
453 {
454 const struct builtin_type *builtin = builtin_type (gdbarch);
455 lai->string_char_type = builtin->builtin_char;
456 lai->primitive_type_vector
457 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_pascal_primitive_types + 1,
458 struct type *);
459 lai->primitive_type_vector [pascal_primitive_type_int]
460 = builtin->builtin_int;
461 lai->primitive_type_vector [pascal_primitive_type_long]
462 = builtin->builtin_long;
463 lai->primitive_type_vector [pascal_primitive_type_short]
464 = builtin->builtin_short;
465 lai->primitive_type_vector [pascal_primitive_type_char]
466 = builtin->builtin_char;
467 lai->primitive_type_vector [pascal_primitive_type_float]
468 = builtin->builtin_float;
469 lai->primitive_type_vector [pascal_primitive_type_double]
470 = builtin->builtin_double;
471 lai->primitive_type_vector [pascal_primitive_type_void]
472 = builtin->builtin_void;
473 lai->primitive_type_vector [pascal_primitive_type_long_long]
474 = builtin->builtin_long_long;
475 lai->primitive_type_vector [pascal_primitive_type_signed_char]
476 = builtin->builtin_signed_char;
477 lai->primitive_type_vector [pascal_primitive_type_unsigned_char]
478 = builtin->builtin_unsigned_char;
479 lai->primitive_type_vector [pascal_primitive_type_unsigned_short]
480 = builtin->builtin_unsigned_short;
481 lai->primitive_type_vector [pascal_primitive_type_unsigned_int]
482 = builtin->builtin_unsigned_int;
483 lai->primitive_type_vector [pascal_primitive_type_unsigned_long]
484 = builtin->builtin_unsigned_long;
485 lai->primitive_type_vector [pascal_primitive_type_unsigned_long_long]
486 = builtin->builtin_unsigned_long_long;
487 lai->primitive_type_vector [pascal_primitive_type_long_double]
488 = builtin->builtin_long_double;
489 lai->primitive_type_vector [pascal_primitive_type_complex]
490 = builtin->builtin_complex;
491 lai->primitive_type_vector [pascal_primitive_type_double_complex]
492 = builtin->builtin_double_complex;
493 }
494
495 const struct language_defn pascal_language_defn =
496 {
497 "pascal", /* Language name */
498 language_pascal,
499 NULL,
500 range_check_on,
501 type_check_on,
502 case_sensitive_on,
503 array_row_major,
504 &exp_descriptor_standard,
505 pascal_parse,
506 pascal_error,
507 null_post_parser,
508 pascal_printchar, /* Print a character constant */
509 pascal_printstr, /* Function to print string constant */
510 pascal_emit_char, /* Print a single char */
511 pascal_create_fundamental_type, /* Create fundamental type in this language */
512 pascal_print_type, /* Print a type using appropriate syntax */
513 pascal_val_print, /* Print a value using appropriate syntax */
514 pascal_value_print, /* Print a top-level value */
515 NULL, /* Language specific skip_trampoline */
516 value_of_this, /* value_of_this */
517 basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
518 basic_lookup_transparent_type,/* lookup_transparent_type */
519 NULL, /* Language specific symbol demangler */
520 NULL, /* Language specific class_name_from_physname */
521 pascal_op_print_tab, /* expression operators for printing */
522 1, /* c-style arrays */
523 0, /* String lower bound */
524 NULL,
525 default_word_break_characters,
526 pascal_language_arch_info,
527 default_print_array_index,
528 LANG_MAGIC
529 };
530
531 void
532 _initialize_pascal_language (void)
533 {
534 add_language (&pascal_language_defn);
535 }