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 | |
373a8247 | 230 | |
0874fd07 AB |
231 | /* Class representing the Pascal language. */ |
232 | ||
233 | class pascal_language : public language_defn | |
234 | { | |
235 | public: | |
236 | pascal_language () | |
0e25e767 | 237 | : language_defn (language_pascal) |
0874fd07 | 238 | { /* Nothing. */ } |
1fb314aa | 239 | |
6f7664a9 AB |
240 | /* See language.h. */ |
241 | ||
242 | const char *name () const override | |
243 | { return "pascal"; } | |
244 | ||
245 | /* See language.h. */ | |
246 | ||
247 | const char *natural_name () const override | |
248 | { return "Pascal"; } | |
249 | ||
e171d6f1 AB |
250 | /* See language.h. */ |
251 | ||
252 | const std::vector<const char *> &filename_extensions () const override | |
253 | { | |
254 | static const std::vector<const char *> extensions | |
255 | = { ".pas", ".p", ".pp" }; | |
256 | return extensions; | |
257 | } | |
6f7664a9 | 258 | |
1fb314aa AB |
259 | /* See language.h. */ |
260 | void language_arch_info (struct gdbarch *gdbarch, | |
261 | struct language_arch_info *lai) const override | |
262 | { | |
263 | const struct builtin_type *builtin = builtin_type (gdbarch); | |
264 | ||
7bea47f0 AB |
265 | /* Helper function to allow shorter lines below. */ |
266 | auto add = [&] (struct type * t) | |
267 | { | |
268 | lai->add_primitive_type (t); | |
269 | }; | |
270 | ||
271 | add (builtin->builtin_int); | |
272 | add (builtin->builtin_long); | |
273 | add (builtin->builtin_short); | |
274 | add (builtin->builtin_char); | |
275 | add (builtin->builtin_float); | |
276 | add (builtin->builtin_double); | |
277 | add (builtin->builtin_void); | |
278 | add (builtin->builtin_long_long); | |
279 | add (builtin->builtin_signed_char); | |
280 | add (builtin->builtin_unsigned_char); | |
281 | add (builtin->builtin_unsigned_short); | |
282 | add (builtin->builtin_unsigned_int); | |
283 | add (builtin->builtin_unsigned_long); | |
284 | add (builtin->builtin_unsigned_long_long); | |
285 | add (builtin->builtin_long_double); | |
286 | add (builtin->builtin_complex); | |
287 | add (builtin->builtin_double_complex); | |
288 | ||
289 | lai->set_string_char_type (builtin->builtin_char); | |
290 | lai->set_bool_type (builtin->builtin_bool, "boolean"); | |
1fb314aa | 291 | } |
fbfb0a46 AB |
292 | |
293 | /* See language.h. */ | |
294 | ||
295 | void print_type (struct type *type, const char *varstring, | |
296 | struct ui_file *stream, int show, int level, | |
297 | const struct type_print_options *flags) const override | |
298 | { | |
299 | pascal_print_type (type, varstring, stream, show, level, flags); | |
300 | } | |
a1d1fa3e AB |
301 | |
302 | /* See language.h. */ | |
303 | ||
304 | void value_print (struct value *val, struct ui_file *stream, | |
305 | const struct value_print_options *options) const override | |
306 | { | |
307 | return pascal_value_print (val, stream, options); | |
308 | } | |
ebe2334e AB |
309 | |
310 | /* See language.h. */ | |
311 | ||
312 | void value_print_inner | |
313 | (struct value *val, struct ui_file *stream, int recurse, | |
314 | const struct value_print_options *options) const override | |
315 | { | |
316 | return pascal_value_print_inner (val, stream, recurse, options); | |
317 | } | |
87afa652 AB |
318 | |
319 | /* See language.h. */ | |
320 | ||
321 | int parser (struct parser_state *ps) const override | |
322 | { | |
323 | return pascal_parse (ps); | |
324 | } | |
ec8cec5b AB |
325 | |
326 | /* See language.h. */ | |
327 | ||
328 | void emitchar (int ch, struct type *chtype, | |
329 | struct ui_file *stream, int quoter) const override | |
330 | { | |
331 | int in_quotes = 0; | |
332 | ||
333 | pascal_one_char (ch, stream, &in_quotes); | |
334 | if (in_quotes) | |
335 | fputs_filtered ("'", stream); | |
336 | } | |
52b50f2c AB |
337 | |
338 | /* See language.h. */ | |
339 | ||
340 | void printchar (int ch, struct type *chtype, | |
341 | struct ui_file *stream) const override | |
342 | { | |
343 | pascal_printchar (ch, chtype, stream); | |
344 | } | |
345 | ||
d711ee67 AB |
346 | /* See language.h. */ |
347 | ||
348 | void printstr (struct ui_file *stream, struct type *elttype, | |
349 | const gdb_byte *string, unsigned int length, | |
350 | const char *encoding, int force_ellipses, | |
351 | const struct value_print_options *options) const override | |
352 | { | |
353 | enum bfd_endian byte_order = type_byte_order (elttype); | |
354 | unsigned int i; | |
355 | unsigned int things_printed = 0; | |
356 | int in_quotes = 0; | |
357 | int need_comma = 0; | |
358 | int width; | |
359 | ||
360 | /* Preserve ELTTYPE's original type, just set its LENGTH. */ | |
361 | check_typedef (elttype); | |
362 | width = TYPE_LENGTH (elttype); | |
363 | ||
364 | /* If the string was not truncated due to `set print elements', and | |
365 | the last byte of it is a null, we don't print that, in traditional C | |
366 | style. */ | |
367 | if ((!force_ellipses) && length > 0 | |
368 | && extract_unsigned_integer (string + (length - 1) * width, width, | |
369 | byte_order) == 0) | |
370 | length--; | |
371 | ||
372 | if (length == 0) | |
373 | { | |
374 | fputs_filtered ("''", stream); | |
375 | return; | |
376 | } | |
377 | ||
378 | for (i = 0; i < length && things_printed < options->print_max; ++i) | |
379 | { | |
380 | /* Position of the character we are examining | |
381 | to see whether it is repeated. */ | |
382 | unsigned int rep1; | |
383 | /* Number of repetitions we have detected so far. */ | |
384 | unsigned int reps; | |
385 | unsigned long int current_char; | |
386 | ||
387 | QUIT; | |
388 | ||
389 | if (need_comma) | |
390 | { | |
391 | fputs_filtered (", ", stream); | |
392 | need_comma = 0; | |
393 | } | |
394 | ||
395 | current_char = extract_unsigned_integer (string + i * width, width, | |
396 | byte_order); | |
397 | ||
398 | rep1 = i + 1; | |
399 | reps = 1; | |
400 | while (rep1 < length | |
401 | && extract_unsigned_integer (string + rep1 * width, width, | |
402 | byte_order) == current_char) | |
403 | { | |
404 | ++rep1; | |
405 | ++reps; | |
406 | } | |
407 | ||
408 | if (reps > options->repeat_count_threshold) | |
409 | { | |
410 | if (in_quotes) | |
411 | { | |
412 | fputs_filtered ("', ", stream); | |
413 | in_quotes = 0; | |
414 | } | |
415 | pascal_printchar (current_char, elttype, stream); | |
416 | fprintf_filtered (stream, " %p[<repeats %u times>%p]", | |
417 | metadata_style.style ().ptr (), | |
418 | reps, nullptr); | |
419 | i = rep1 - 1; | |
420 | things_printed += options->repeat_count_threshold; | |
421 | need_comma = 1; | |
422 | } | |
423 | else | |
424 | { | |
425 | if ((!in_quotes) && (PRINT_LITERAL_FORM (current_char))) | |
426 | { | |
427 | fputs_filtered ("'", stream); | |
428 | in_quotes = 1; | |
429 | } | |
430 | pascal_one_char (current_char, stream, &in_quotes); | |
431 | ++things_printed; | |
432 | } | |
433 | } | |
434 | ||
435 | /* Terminate the quotes if necessary. */ | |
436 | if (in_quotes) | |
437 | fputs_filtered ("'", stream); | |
438 | ||
439 | if (force_ellipses || i < length) | |
440 | fputs_filtered ("...", stream); | |
441 | } | |
4ffc13fb AB |
442 | |
443 | /* See language.h. */ | |
444 | ||
445 | void print_typedef (struct type *type, struct symbol *new_symbol, | |
446 | struct ui_file *stream) const override | |
447 | { | |
448 | pascal_print_typedef (type, new_symbol, stream); | |
449 | } | |
450 | ||
39e7ecca AB |
451 | /* See language.h. */ |
452 | ||
453 | bool is_string_type_p (struct type *type) const override | |
454 | { | |
455 | return is_pascal_string_type (type, nullptr, nullptr, nullptr, | |
456 | nullptr, nullptr) > 0; | |
457 | } | |
5bae7c4e AB |
458 | |
459 | /* See language.h. */ | |
460 | ||
461 | const char *name_of_this () const override | |
462 | { return "this"; } | |
efdf6a73 AB |
463 | |
464 | /* See language.h. */ | |
465 | ||
466 | bool range_checking_on_by_default () const override | |
467 | { return true; } | |
b7c6e27d AB |
468 | |
469 | /* See language.h. */ | |
470 | ||
471 | const struct op_print *opcode_print_table () const override | |
472 | { return pascal_op_print_tab; } | |
0874fd07 AB |
473 | }; |
474 | ||
475 | /* Single instance of the Pascal language class. */ | |
476 | ||
477 | static pascal_language pascal_language_defn; |