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