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, | |
dda83cd7 | 99 | int *length_size, int *string_pos, |
6c7a06a3 | 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) | |
dda83cd7 SM |
112 | { |
113 | if (length_pos) | |
e2625b33 | 114 | *length_pos = TYPE_FIELD_BITPOS (type, 0) / TARGET_CHAR_BIT; |
dda83cd7 | 115 | if (length_size) |
940da03e | 116 | *length_size = TYPE_LENGTH (type->field (0).type ()); |
dda83cd7 | 117 | if (string_pos) |
e2625b33 | 118 | *string_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT; |
dda83cd7 | 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); |
dda83cd7 SM |
123 | return 2; |
124 | }; | |
5598ce11 PM |
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) | |
dda83cd7 | 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; |
dda83cd7 SM |
139 | /* FIXME: how can I detect wide chars in GPC ?? */ |
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); |
dda83cd7 SM |
149 | return 3; |
150 | }; | |
5598ce11 PM |
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 | ||
0874fd07 AB |
251 | /* Class representing the Pascal language. */ |
252 | ||
253 | class pascal_language : public language_defn | |
254 | { | |
255 | public: | |
256 | pascal_language () | |
0e25e767 | 257 | : language_defn (language_pascal) |
0874fd07 | 258 | { /* Nothing. */ } |
1fb314aa | 259 | |
6f7664a9 AB |
260 | /* See language.h. */ |
261 | ||
262 | const char *name () const override | |
263 | { return "pascal"; } | |
264 | ||
265 | /* See language.h. */ | |
266 | ||
267 | const char *natural_name () const override | |
268 | { return "Pascal"; } | |
269 | ||
e171d6f1 AB |
270 | /* See language.h. */ |
271 | ||
272 | const std::vector<const char *> &filename_extensions () const override | |
273 | { | |
274 | static const std::vector<const char *> extensions | |
275 | = { ".pas", ".p", ".pp" }; | |
276 | return extensions; | |
277 | } | |
6f7664a9 | 278 | |
1fb314aa AB |
279 | /* See language.h. */ |
280 | void language_arch_info (struct gdbarch *gdbarch, | |
281 | struct language_arch_info *lai) const override | |
282 | { | |
283 | const struct builtin_type *builtin = builtin_type (gdbarch); | |
284 | ||
285 | lai->string_char_type = builtin->builtin_char; | |
286 | lai->primitive_type_vector | |
287 | = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_pascal_primitive_types + 1, | |
dda83cd7 | 288 | struct type *); |
1fb314aa AB |
289 | lai->primitive_type_vector [pascal_primitive_type_int] |
290 | = builtin->builtin_int; | |
291 | lai->primitive_type_vector [pascal_primitive_type_long] | |
292 | = builtin->builtin_long; | |
293 | lai->primitive_type_vector [pascal_primitive_type_short] | |
294 | = builtin->builtin_short; | |
295 | lai->primitive_type_vector [pascal_primitive_type_char] | |
296 | = builtin->builtin_char; | |
297 | lai->primitive_type_vector [pascal_primitive_type_float] | |
298 | = builtin->builtin_float; | |
299 | lai->primitive_type_vector [pascal_primitive_type_double] | |
300 | = builtin->builtin_double; | |
301 | lai->primitive_type_vector [pascal_primitive_type_void] | |
302 | = builtin->builtin_void; | |
303 | lai->primitive_type_vector [pascal_primitive_type_long_long] | |
304 | = builtin->builtin_long_long; | |
305 | lai->primitive_type_vector [pascal_primitive_type_signed_char] | |
306 | = builtin->builtin_signed_char; | |
307 | lai->primitive_type_vector [pascal_primitive_type_unsigned_char] | |
308 | = builtin->builtin_unsigned_char; | |
309 | lai->primitive_type_vector [pascal_primitive_type_unsigned_short] | |
310 | = builtin->builtin_unsigned_short; | |
311 | lai->primitive_type_vector [pascal_primitive_type_unsigned_int] | |
312 | = builtin->builtin_unsigned_int; | |
313 | lai->primitive_type_vector [pascal_primitive_type_unsigned_long] | |
314 | = builtin->builtin_unsigned_long; | |
315 | lai->primitive_type_vector [pascal_primitive_type_unsigned_long_long] | |
316 | = builtin->builtin_unsigned_long_long; | |
317 | lai->primitive_type_vector [pascal_primitive_type_long_double] | |
318 | = builtin->builtin_long_double; | |
319 | lai->primitive_type_vector [pascal_primitive_type_complex] | |
320 | = builtin->builtin_complex; | |
321 | lai->primitive_type_vector [pascal_primitive_type_double_complex] | |
322 | = builtin->builtin_double_complex; | |
323 | ||
324 | lai->bool_type_symbol = "boolean"; | |
325 | lai->bool_type_default = builtin->builtin_bool; | |
326 | } | |
fbfb0a46 AB |
327 | |
328 | /* See language.h. */ | |
329 | ||
330 | void print_type (struct type *type, const char *varstring, | |
331 | struct ui_file *stream, int show, int level, | |
332 | const struct type_print_options *flags) const override | |
333 | { | |
334 | pascal_print_type (type, varstring, stream, show, level, flags); | |
335 | } | |
a1d1fa3e AB |
336 | |
337 | /* See language.h. */ | |
338 | ||
339 | void value_print (struct value *val, struct ui_file *stream, | |
340 | const struct value_print_options *options) const override | |
341 | { | |
342 | return pascal_value_print (val, stream, options); | |
343 | } | |
ebe2334e AB |
344 | |
345 | /* See language.h. */ | |
346 | ||
347 | void value_print_inner | |
348 | (struct value *val, struct ui_file *stream, int recurse, | |
349 | const struct value_print_options *options) const override | |
350 | { | |
351 | return pascal_value_print_inner (val, stream, recurse, options); | |
352 | } | |
87afa652 AB |
353 | |
354 | /* See language.h. */ | |
355 | ||
356 | int parser (struct parser_state *ps) const override | |
357 | { | |
358 | return pascal_parse (ps); | |
359 | } | |
ec8cec5b AB |
360 | |
361 | /* See language.h. */ | |
362 | ||
363 | void emitchar (int ch, struct type *chtype, | |
364 | struct ui_file *stream, int quoter) const override | |
365 | { | |
366 | int in_quotes = 0; | |
367 | ||
368 | pascal_one_char (ch, stream, &in_quotes); | |
369 | if (in_quotes) | |
370 | fputs_filtered ("'", stream); | |
371 | } | |
52b50f2c AB |
372 | |
373 | /* See language.h. */ | |
374 | ||
375 | void printchar (int ch, struct type *chtype, | |
376 | struct ui_file *stream) const override | |
377 | { | |
378 | pascal_printchar (ch, chtype, stream); | |
379 | } | |
380 | ||
d711ee67 AB |
381 | /* See language.h. */ |
382 | ||
383 | void printstr (struct ui_file *stream, struct type *elttype, | |
384 | const gdb_byte *string, unsigned int length, | |
385 | const char *encoding, int force_ellipses, | |
386 | const struct value_print_options *options) const override | |
387 | { | |
388 | enum bfd_endian byte_order = type_byte_order (elttype); | |
389 | unsigned int i; | |
390 | unsigned int things_printed = 0; | |
391 | int in_quotes = 0; | |
392 | int need_comma = 0; | |
393 | int width; | |
394 | ||
395 | /* Preserve ELTTYPE's original type, just set its LENGTH. */ | |
396 | check_typedef (elttype); | |
397 | width = TYPE_LENGTH (elttype); | |
398 | ||
399 | /* If the string was not truncated due to `set print elements', and | |
400 | the last byte of it is a null, we don't print that, in traditional C | |
401 | style. */ | |
402 | if ((!force_ellipses) && length > 0 | |
403 | && extract_unsigned_integer (string + (length - 1) * width, width, | |
404 | byte_order) == 0) | |
405 | length--; | |
406 | ||
407 | if (length == 0) | |
408 | { | |
409 | fputs_filtered ("''", stream); | |
410 | return; | |
411 | } | |
412 | ||
413 | for (i = 0; i < length && things_printed < options->print_max; ++i) | |
414 | { | |
415 | /* Position of the character we are examining | |
416 | to see whether it is repeated. */ | |
417 | unsigned int rep1; | |
418 | /* Number of repetitions we have detected so far. */ | |
419 | unsigned int reps; | |
420 | unsigned long int current_char; | |
421 | ||
422 | QUIT; | |
423 | ||
424 | if (need_comma) | |
425 | { | |
426 | fputs_filtered (", ", stream); | |
427 | need_comma = 0; | |
428 | } | |
429 | ||
430 | current_char = extract_unsigned_integer (string + i * width, width, | |
431 | byte_order); | |
432 | ||
433 | rep1 = i + 1; | |
434 | reps = 1; | |
435 | while (rep1 < length | |
436 | && extract_unsigned_integer (string + rep1 * width, width, | |
437 | byte_order) == current_char) | |
438 | { | |
439 | ++rep1; | |
440 | ++reps; | |
441 | } | |
442 | ||
443 | if (reps > options->repeat_count_threshold) | |
444 | { | |
445 | if (in_quotes) | |
446 | { | |
447 | fputs_filtered ("', ", stream); | |
448 | in_quotes = 0; | |
449 | } | |
450 | pascal_printchar (current_char, elttype, stream); | |
451 | fprintf_filtered (stream, " %p[<repeats %u times>%p]", | |
452 | metadata_style.style ().ptr (), | |
453 | reps, nullptr); | |
454 | i = rep1 - 1; | |
455 | things_printed += options->repeat_count_threshold; | |
456 | need_comma = 1; | |
457 | } | |
458 | else | |
459 | { | |
460 | if ((!in_quotes) && (PRINT_LITERAL_FORM (current_char))) | |
461 | { | |
462 | fputs_filtered ("'", stream); | |
463 | in_quotes = 1; | |
464 | } | |
465 | pascal_one_char (current_char, stream, &in_quotes); | |
466 | ++things_printed; | |
467 | } | |
468 | } | |
469 | ||
470 | /* Terminate the quotes if necessary. */ | |
471 | if (in_quotes) | |
472 | fputs_filtered ("'", stream); | |
473 | ||
474 | if (force_ellipses || i < length) | |
475 | fputs_filtered ("...", stream); | |
476 | } | |
4ffc13fb AB |
477 | |
478 | /* See language.h. */ | |
479 | ||
480 | void print_typedef (struct type *type, struct symbol *new_symbol, | |
481 | struct ui_file *stream) const override | |
482 | { | |
483 | pascal_print_typedef (type, new_symbol, stream); | |
484 | } | |
485 | ||
39e7ecca AB |
486 | /* See language.h. */ |
487 | ||
488 | bool is_string_type_p (struct type *type) const override | |
489 | { | |
490 | return is_pascal_string_type (type, nullptr, nullptr, nullptr, | |
491 | nullptr, nullptr) > 0; | |
492 | } | |
5bae7c4e AB |
493 | |
494 | /* See language.h. */ | |
495 | ||
496 | const char *name_of_this () const override | |
497 | { return "this"; } | |
efdf6a73 AB |
498 | |
499 | /* See language.h. */ | |
500 | ||
501 | bool range_checking_on_by_default () const override | |
502 | { return true; } | |
b7c6e27d AB |
503 | |
504 | /* See language.h. */ | |
505 | ||
506 | const struct op_print *opcode_print_table () const override | |
507 | { return pascal_op_print_tab; } | |
0874fd07 AB |
508 | }; |
509 | ||
510 | /* Single instance of the Pascal language class. */ | |
511 | ||
512 | static pascal_language pascal_language_defn; |