Commit | Line | Data |
---|---|---|
373a8247 | 1 | /* Pascal language support routines for GDB, the GNU debugger. |
ce27fb25 | 2 | |
b811d2c2 | 3 | Copyright (C) 2000-2020 Free Software Foundation, Inc. |
373a8247 PM |
4 | |
5 | This file is part of GDB. | |
6 | ||
7 | This program is free software; you can redistribute it and/or modify | |
8 | it under the terms of the GNU General Public License as published by | |
a9762ec7 | 9 | the Free Software Foundation; either version 3 of the License, or |
373a8247 PM |
10 | (at your option) any later version. |
11 | ||
12 | This program is distributed in the hope that it will be useful, | |
13 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | GNU General Public License for more details. | |
16 | ||
17 | You should have received a copy of the GNU General Public License | |
a9762ec7 | 18 | along with this program. If not, see <http://www.gnu.org/licenses/>. */ |
373a8247 | 19 | |
5598ce11 | 20 | /* This file is derived from c-lang.c */ |
373a8247 PM |
21 | |
22 | #include "defs.h" | |
23 | #include "symtab.h" | |
24 | #include "gdbtypes.h" | |
25 | #include "expression.h" | |
26 | #include "parser-defs.h" | |
27 | #include "language.h" | |
a53b64ea | 28 | #include "varobj.h" |
373a8247 PM |
29 | #include "p-lang.h" |
30 | #include "valprint.h" | |
5f9a71c3 | 31 | #include "value.h" |
5598ce11 | 32 | #include <ctype.h> |
43cc5389 | 33 | #include "c-lang.h" |
0d12e84c | 34 | #include "gdbarch.h" |
7f6aba03 | 35 | #include "cli/cli-style.h" |
6ced1581 | 36 | |
cd6c7346 | 37 | /* All GPC versions until now (2007-09-27) also define a symbol called |
0df8b418 | 38 | '_p_initialize'. Check for the presence of this symbol first. */ |
cd6c7346 PM |
39 | static const char GPC_P_INITIALIZE[] = "_p_initialize"; |
40 | ||
41 | /* The name of the symbol that GPC uses as the name of the main | |
42 | procedure (since version 20050212). */ | |
43 | static const char GPC_MAIN_PROGRAM_NAME_1[] = "_p__M0_main_program"; | |
44 | ||
45 | /* Older versions of GPC (versions older than 20050212) were using | |
46 | a different name for the main procedure. */ | |
47 | static const char GPC_MAIN_PROGRAM_NAME_2[] = "pascal_main_program"; | |
48 | ||
49 | /* Function returning the special symbol name used | |
50 | by GPC for the main procedure in the main program | |
51 | if it is found in minimal symbol list. | |
52 | This function tries to find minimal symbols generated by GPC | |
53 | so that it finds the even if the program was compiled | |
54 | without debugging information. | |
55 | According to information supplied by Waldeck Hebisch, | |
0df8b418 | 56 | this should work for all versions posterior to June 2000. */ |
cd6c7346 PM |
57 | |
58 | const char * | |
59 | pascal_main_name (void) | |
60 | { | |
3b7344d5 | 61 | struct bound_minimal_symbol msym; |
cd6c7346 PM |
62 | |
63 | msym = lookup_minimal_symbol (GPC_P_INITIALIZE, NULL, NULL); | |
64 | ||
65 | /* If '_p_initialize' was not found, the main program is likely not | |
66 | written in Pascal. */ | |
3b7344d5 | 67 | if (msym.minsym == NULL) |
cd6c7346 PM |
68 | return NULL; |
69 | ||
70 | msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_1, NULL, NULL); | |
3b7344d5 | 71 | if (msym.minsym != NULL) |
cd6c7346 PM |
72 | { |
73 | return GPC_MAIN_PROGRAM_NAME_1; | |
74 | } | |
75 | ||
76 | msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_2, NULL, NULL); | |
3b7344d5 | 77 | if (msym.minsym != NULL) |
cd6c7346 PM |
78 | { |
79 | return GPC_MAIN_PROGRAM_NAME_2; | |
80 | } | |
81 | ||
82 | /* No known entry procedure found, the main program is probably | |
83 | not compiled with GPC. */ | |
84 | return NULL; | |
85 | } | |
86 | ||
5598ce11 | 87 | /* Determines if type TYPE is a pascal string type. |
58159490 | 88 | Returns a positive value if the type is a known pascal string type. |
5598ce11 PM |
89 | This function is used by p-valprint.c code to allow better string display. |
90 | If it is a pascal string type, then it also sets info needed | |
91 | to get the length and the data of the string | |
92 | length_pos, length_size and string_pos are given in bytes. | |
93 | char_size gives the element size in bytes. | |
94 | FIXME: if the position or the size of these fields | |
95 | are not multiple of TARGET_CHAR_BIT then the results are wrong | |
96 | but this does not happen for Free Pascal nor for GPC. */ | |
97 | int | |
98 | is_pascal_string_type (struct type *type,int *length_pos, | |
6c7a06a3 TT |
99 | int *length_size, int *string_pos, |
100 | struct type **char_type, | |
0d5cff50 | 101 | const char **arrayname) |
5598ce11 | 102 | { |
78134374 | 103 | if (type != NULL && type->code () == TYPE_CODE_STRUCT) |
5598ce11 PM |
104 | { |
105 | /* Old Borland type pascal strings from Free Pascal Compiler. */ | |
106 | /* Two fields: length and st. */ | |
1f704f76 | 107 | if (type->num_fields () == 2 |
dae71413 | 108 | && TYPE_FIELD_NAME (type, 0) |
6ced1581 | 109 | && strcmp (TYPE_FIELD_NAME (type, 0), "length") == 0 |
dae71413 PM |
110 | && TYPE_FIELD_NAME (type, 1) |
111 | && strcmp (TYPE_FIELD_NAME (type, 1), "st") == 0) | |
5598ce11 | 112 | { |
e2625b33 PM |
113 | if (length_pos) |
114 | *length_pos = TYPE_FIELD_BITPOS (type, 0) / TARGET_CHAR_BIT; | |
115 | if (length_size) | |
940da03e | 116 | *length_size = TYPE_LENGTH (type->field (0).type ()); |
e2625b33 PM |
117 | if (string_pos) |
118 | *string_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT; | |
6c7a06a3 | 119 | if (char_type) |
940da03e | 120 | *char_type = TYPE_TARGET_TYPE (type->field (1).type ()); |
e2625b33 | 121 | if (arrayname) |
dae71413 | 122 | *arrayname = TYPE_FIELD_NAME (type, 1); |
e2625b33 | 123 | return 2; |
5598ce11 PM |
124 | }; |
125 | /* GNU pascal strings. */ | |
126 | /* Three fields: Capacity, length and schema$ or _p_schema. */ | |
1f704f76 | 127 | if (type->num_fields () == 3 |
dae71413 PM |
128 | && TYPE_FIELD_NAME (type, 0) |
129 | && strcmp (TYPE_FIELD_NAME (type, 0), "Capacity") == 0 | |
130 | && TYPE_FIELD_NAME (type, 1) | |
131 | && strcmp (TYPE_FIELD_NAME (type, 1), "length") == 0) | |
5598ce11 | 132 | { |
58159490 | 133 | if (length_pos) |
e2625b33 | 134 | *length_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT; |
58159490 | 135 | if (length_size) |
940da03e | 136 | *length_size = TYPE_LENGTH (type->field (1).type ()); |
58159490 | 137 | if (string_pos) |
e2625b33 | 138 | *string_pos = TYPE_FIELD_BITPOS (type, 2) / TARGET_CHAR_BIT; |
0df8b418 | 139 | /* FIXME: how can I detect wide chars in GPC ?? */ |
6c7a06a3 | 140 | if (char_type) |
58159490 | 141 | { |
940da03e | 142 | *char_type = TYPE_TARGET_TYPE (type->field (2).type ()); |
ad3bbd48 | 143 | |
78134374 | 144 | if ((*char_type)->code () == TYPE_CODE_ARRAY) |
6c7a06a3 | 145 | *char_type = TYPE_TARGET_TYPE (*char_type); |
58159490 | 146 | } |
e2625b33 | 147 | if (arrayname) |
dae71413 | 148 | *arrayname = TYPE_FIELD_NAME (type, 2); |
e2625b33 | 149 | return 3; |
5598ce11 PM |
150 | }; |
151 | } | |
152 | return 0; | |
153 | } | |
154 | ||
373a8247 PM |
155 | static void pascal_one_char (int, struct ui_file *, int *); |
156 | ||
157 | /* Print the character C on STREAM as part of the contents of a literal | |
158 | string. | |
0df8b418 | 159 | In_quotes is reset to 0 if a char is written with #4 notation. */ |
373a8247 PM |
160 | |
161 | static void | |
f86f5ca3 | 162 | pascal_one_char (int c, struct ui_file *stream, int *in_quotes) |
373a8247 | 163 | { |
9b79b476 | 164 | if (c == '\'' || ((unsigned int) c <= 0xff && (PRINT_LITERAL_FORM (c)))) |
373a8247 PM |
165 | { |
166 | if (!(*in_quotes)) | |
167 | fputs_filtered ("'", stream); | |
168 | *in_quotes = 1; | |
169 | if (c == '\'') | |
170 | { | |
171 | fputs_filtered ("''", stream); | |
172 | } | |
173 | else | |
174 | fprintf_filtered (stream, "%c", c); | |
175 | } | |
176 | else | |
177 | { | |
178 | if (*in_quotes) | |
179 | fputs_filtered ("'", stream); | |
180 | *in_quotes = 0; | |
181 | fprintf_filtered (stream, "#%d", (unsigned int) c); | |
182 | } | |
183 | } | |
184 | ||
373a8247 | 185 | void |
6c7a06a3 | 186 | pascal_printchar (int c, struct type *type, struct ui_file *stream) |
373a8247 PM |
187 | { |
188 | int in_quotes = 0; | |
ad3bbd48 | 189 | |
373a8247 PM |
190 | pascal_one_char (c, stream, &in_quotes); |
191 | if (in_quotes) | |
192 | fputs_filtered ("'", stream); | |
193 | } | |
194 | ||
373a8247 PM |
195 | \f |
196 | ||
197 | /* Table mapping opcodes into strings for printing operators | |
198 | and precedences of the operators. */ | |
199 | ||
200 | const struct op_print pascal_op_print_tab[] = | |
201 | { | |
202 | {",", BINOP_COMMA, PREC_COMMA, 0}, | |
203 | {":=", BINOP_ASSIGN, PREC_ASSIGN, 1}, | |
204 | {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0}, | |
205 | {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0}, | |
206 | {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0}, | |
207 | {"=", BINOP_EQUAL, PREC_EQUAL, 0}, | |
208 | {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0}, | |
209 | {"<=", BINOP_LEQ, PREC_ORDER, 0}, | |
210 | {">=", BINOP_GEQ, PREC_ORDER, 0}, | |
211 | {">", BINOP_GTR, PREC_ORDER, 0}, | |
212 | {"<", BINOP_LESS, PREC_ORDER, 0}, | |
213 | {"shr", BINOP_RSH, PREC_SHIFT, 0}, | |
214 | {"shl", BINOP_LSH, PREC_SHIFT, 0}, | |
215 | {"+", BINOP_ADD, PREC_ADD, 0}, | |
216 | {"-", BINOP_SUB, PREC_ADD, 0}, | |
217 | {"*", BINOP_MUL, PREC_MUL, 0}, | |
218 | {"/", BINOP_DIV, PREC_MUL, 0}, | |
219 | {"div", BINOP_INTDIV, PREC_MUL, 0}, | |
220 | {"mod", BINOP_REM, PREC_MUL, 0}, | |
221 | {"@", BINOP_REPEAT, PREC_REPEAT, 0}, | |
222 | {"-", UNOP_NEG, PREC_PREFIX, 0}, | |
223 | {"not", UNOP_LOGICAL_NOT, PREC_PREFIX, 0}, | |
224 | {"^", UNOP_IND, PREC_SUFFIX, 1}, | |
225 | {"@", UNOP_ADDR, PREC_PREFIX, 0}, | |
226 | {"sizeof", UNOP_SIZEOF, PREC_PREFIX, 0}, | |
f486487f | 227 | {NULL, OP_NULL, PREC_PREFIX, 0} |
373a8247 PM |
228 | }; |
229 | \f | |
cad351d1 UW |
230 | enum pascal_primitive_types { |
231 | pascal_primitive_type_int, | |
232 | pascal_primitive_type_long, | |
233 | pascal_primitive_type_short, | |
234 | pascal_primitive_type_char, | |
235 | pascal_primitive_type_float, | |
236 | pascal_primitive_type_double, | |
237 | pascal_primitive_type_void, | |
238 | pascal_primitive_type_long_long, | |
239 | pascal_primitive_type_signed_char, | |
240 | pascal_primitive_type_unsigned_char, | |
241 | pascal_primitive_type_unsigned_short, | |
242 | pascal_primitive_type_unsigned_int, | |
243 | pascal_primitive_type_unsigned_long, | |
244 | pascal_primitive_type_unsigned_long_long, | |
245 | pascal_primitive_type_long_double, | |
246 | pascal_primitive_type_complex, | |
247 | pascal_primitive_type_double_complex, | |
248 | nr_pascal_primitive_types | |
373a8247 PM |
249 | }; |
250 | ||
56618e20 TT |
251 | static const char *p_extensions[] = |
252 | { | |
253 | ".pas", ".p", ".pp", NULL | |
254 | }; | |
255 | ||
0874fd07 AB |
256 | /* Constant data representing the Pascal language. */ |
257 | ||
258 | extern const struct language_data pascal_language_data = | |
373a8247 PM |
259 | { |
260 | "pascal", /* Language name */ | |
6abde28f | 261 | "Pascal", |
373a8247 | 262 | language_pascal, |
373a8247 | 263 | range_check_on, |
63872f9d | 264 | case_sensitive_on, |
7ca2d3a3 | 265 | array_row_major, |
9a044a89 | 266 | macro_expansion_no, |
56618e20 | 267 | p_extensions, |
5f9769d1 | 268 | &exp_descriptor_standard, |
2b2d9e11 | 269 | "this", /* name_of_this */ |
59cc4834 | 270 | false, /* la_store_sym_names_in_linkage_form_p */ |
373a8247 PM |
271 | pascal_op_print_tab, /* expression operators for printing */ |
272 | 1, /* c-style arrays */ | |
273 | 0, /* String lower bound */ | |
a53b64ea | 274 | &default_varobj_ops, |
721b08c6 | 275 | "{...}" /* la_struct_too_deep_ellipsis */ |
373a8247 | 276 | }; |
0874fd07 AB |
277 | |
278 | /* Class representing the Pascal language. */ | |
279 | ||
280 | class pascal_language : public language_defn | |
281 | { | |
282 | public: | |
283 | pascal_language () | |
284 | : language_defn (language_pascal, pascal_language_data) | |
285 | { /* Nothing. */ } | |
1fb314aa AB |
286 | |
287 | /* See language.h. */ | |
288 | void language_arch_info (struct gdbarch *gdbarch, | |
289 | struct language_arch_info *lai) const override | |
290 | { | |
291 | const struct builtin_type *builtin = builtin_type (gdbarch); | |
292 | ||
293 | lai->string_char_type = builtin->builtin_char; | |
294 | lai->primitive_type_vector | |
295 | = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_pascal_primitive_types + 1, | |
296 | struct type *); | |
297 | lai->primitive_type_vector [pascal_primitive_type_int] | |
298 | = builtin->builtin_int; | |
299 | lai->primitive_type_vector [pascal_primitive_type_long] | |
300 | = builtin->builtin_long; | |
301 | lai->primitive_type_vector [pascal_primitive_type_short] | |
302 | = builtin->builtin_short; | |
303 | lai->primitive_type_vector [pascal_primitive_type_char] | |
304 | = builtin->builtin_char; | |
305 | lai->primitive_type_vector [pascal_primitive_type_float] | |
306 | = builtin->builtin_float; | |
307 | lai->primitive_type_vector [pascal_primitive_type_double] | |
308 | = builtin->builtin_double; | |
309 | lai->primitive_type_vector [pascal_primitive_type_void] | |
310 | = builtin->builtin_void; | |
311 | lai->primitive_type_vector [pascal_primitive_type_long_long] | |
312 | = builtin->builtin_long_long; | |
313 | lai->primitive_type_vector [pascal_primitive_type_signed_char] | |
314 | = builtin->builtin_signed_char; | |
315 | lai->primitive_type_vector [pascal_primitive_type_unsigned_char] | |
316 | = builtin->builtin_unsigned_char; | |
317 | lai->primitive_type_vector [pascal_primitive_type_unsigned_short] | |
318 | = builtin->builtin_unsigned_short; | |
319 | lai->primitive_type_vector [pascal_primitive_type_unsigned_int] | |
320 | = builtin->builtin_unsigned_int; | |
321 | lai->primitive_type_vector [pascal_primitive_type_unsigned_long] | |
322 | = builtin->builtin_unsigned_long; | |
323 | lai->primitive_type_vector [pascal_primitive_type_unsigned_long_long] | |
324 | = builtin->builtin_unsigned_long_long; | |
325 | lai->primitive_type_vector [pascal_primitive_type_long_double] | |
326 | = builtin->builtin_long_double; | |
327 | lai->primitive_type_vector [pascal_primitive_type_complex] | |
328 | = builtin->builtin_complex; | |
329 | lai->primitive_type_vector [pascal_primitive_type_double_complex] | |
330 | = builtin->builtin_double_complex; | |
331 | ||
332 | lai->bool_type_symbol = "boolean"; | |
333 | lai->bool_type_default = builtin->builtin_bool; | |
334 | } | |
fbfb0a46 AB |
335 | |
336 | /* See language.h. */ | |
337 | ||
338 | void print_type (struct type *type, const char *varstring, | |
339 | struct ui_file *stream, int show, int level, | |
340 | const struct type_print_options *flags) const override | |
341 | { | |
342 | pascal_print_type (type, varstring, stream, show, level, flags); | |
343 | } | |
a1d1fa3e AB |
344 | |
345 | /* See language.h. */ | |
346 | ||
347 | void value_print (struct value *val, struct ui_file *stream, | |
348 | const struct value_print_options *options) const override | |
349 | { | |
350 | return pascal_value_print (val, stream, options); | |
351 | } | |
ebe2334e AB |
352 | |
353 | /* See language.h. */ | |
354 | ||
355 | void value_print_inner | |
356 | (struct value *val, struct ui_file *stream, int recurse, | |
357 | const struct value_print_options *options) const override | |
358 | { | |
359 | return pascal_value_print_inner (val, stream, recurse, options); | |
360 | } | |
87afa652 AB |
361 | |
362 | /* See language.h. */ | |
363 | ||
364 | int parser (struct parser_state *ps) const override | |
365 | { | |
366 | return pascal_parse (ps); | |
367 | } | |
ec8cec5b AB |
368 | |
369 | /* See language.h. */ | |
370 | ||
371 | void emitchar (int ch, struct type *chtype, | |
372 | struct ui_file *stream, int quoter) const override | |
373 | { | |
374 | int in_quotes = 0; | |
375 | ||
376 | pascal_one_char (ch, stream, &in_quotes); | |
377 | if (in_quotes) | |
378 | fputs_filtered ("'", stream); | |
379 | } | |
52b50f2c AB |
380 | |
381 | /* See language.h. */ | |
382 | ||
383 | void printchar (int ch, struct type *chtype, | |
384 | struct ui_file *stream) const override | |
385 | { | |
386 | pascal_printchar (ch, chtype, stream); | |
387 | } | |
388 | ||
d711ee67 AB |
389 | /* See language.h. */ |
390 | ||
391 | void printstr (struct ui_file *stream, struct type *elttype, | |
392 | const gdb_byte *string, unsigned int length, | |
393 | const char *encoding, int force_ellipses, | |
394 | const struct value_print_options *options) const override | |
395 | { | |
396 | enum bfd_endian byte_order = type_byte_order (elttype); | |
397 | unsigned int i; | |
398 | unsigned int things_printed = 0; | |
399 | int in_quotes = 0; | |
400 | int need_comma = 0; | |
401 | int width; | |
402 | ||
403 | /* Preserve ELTTYPE's original type, just set its LENGTH. */ | |
404 | check_typedef (elttype); | |
405 | width = TYPE_LENGTH (elttype); | |
406 | ||
407 | /* If the string was not truncated due to `set print elements', and | |
408 | the last byte of it is a null, we don't print that, in traditional C | |
409 | style. */ | |
410 | if ((!force_ellipses) && length > 0 | |
411 | && extract_unsigned_integer (string + (length - 1) * width, width, | |
412 | byte_order) == 0) | |
413 | length--; | |
414 | ||
415 | if (length == 0) | |
416 | { | |
417 | fputs_filtered ("''", stream); | |
418 | return; | |
419 | } | |
420 | ||
421 | for (i = 0; i < length && things_printed < options->print_max; ++i) | |
422 | { | |
423 | /* Position of the character we are examining | |
424 | to see whether it is repeated. */ | |
425 | unsigned int rep1; | |
426 | /* Number of repetitions we have detected so far. */ | |
427 | unsigned int reps; | |
428 | unsigned long int current_char; | |
429 | ||
430 | QUIT; | |
431 | ||
432 | if (need_comma) | |
433 | { | |
434 | fputs_filtered (", ", stream); | |
435 | need_comma = 0; | |
436 | } | |
437 | ||
438 | current_char = extract_unsigned_integer (string + i * width, width, | |
439 | byte_order); | |
440 | ||
441 | rep1 = i + 1; | |
442 | reps = 1; | |
443 | while (rep1 < length | |
444 | && extract_unsigned_integer (string + rep1 * width, width, | |
445 | byte_order) == current_char) | |
446 | { | |
447 | ++rep1; | |
448 | ++reps; | |
449 | } | |
450 | ||
451 | if (reps > options->repeat_count_threshold) | |
452 | { | |
453 | if (in_quotes) | |
454 | { | |
455 | fputs_filtered ("', ", stream); | |
456 | in_quotes = 0; | |
457 | } | |
458 | pascal_printchar (current_char, elttype, stream); | |
459 | fprintf_filtered (stream, " %p[<repeats %u times>%p]", | |
460 | metadata_style.style ().ptr (), | |
461 | reps, nullptr); | |
462 | i = rep1 - 1; | |
463 | things_printed += options->repeat_count_threshold; | |
464 | need_comma = 1; | |
465 | } | |
466 | else | |
467 | { | |
468 | if ((!in_quotes) && (PRINT_LITERAL_FORM (current_char))) | |
469 | { | |
470 | fputs_filtered ("'", stream); | |
471 | in_quotes = 1; | |
472 | } | |
473 | pascal_one_char (current_char, stream, &in_quotes); | |
474 | ++things_printed; | |
475 | } | |
476 | } | |
477 | ||
478 | /* Terminate the quotes if necessary. */ | |
479 | if (in_quotes) | |
480 | fputs_filtered ("'", stream); | |
481 | ||
482 | if (force_ellipses || i < length) | |
483 | fputs_filtered ("...", stream); | |
484 | } | |
4ffc13fb AB |
485 | |
486 | /* See language.h. */ | |
487 | ||
488 | void print_typedef (struct type *type, struct symbol *new_symbol, | |
489 | struct ui_file *stream) const override | |
490 | { | |
491 | pascal_print_typedef (type, new_symbol, stream); | |
492 | } | |
493 | ||
39e7ecca AB |
494 | /* See language.h. */ |
495 | ||
496 | bool is_string_type_p (struct type *type) const override | |
497 | { | |
498 | return is_pascal_string_type (type, nullptr, nullptr, nullptr, | |
499 | nullptr, nullptr) > 0; | |
500 | } | |
0874fd07 AB |
501 | }; |
502 | ||
503 | /* Single instance of the Pascal language class. */ | |
504 | ||
505 | static pascal_language pascal_language_defn; |