1 /* Pascal language support routines for GDB, the GNU debugger.
3 Copyright (C) 2000-2021 Free Software Foundation, Inc.
5 This file is part of GDB.
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
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
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.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
20 /* This file is derived from c-lang.c */
25 #include "expression.h"
26 #include "parser-defs.h"
35 #include "cli/cli-style.h"
37 /* All GPC versions until now (2007-09-27) also define a symbol called
38 '_p_initialize'. Check for the presence of this symbol first. */
39 static const char GPC_P_INITIALIZE
[] = "_p_initialize";
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";
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";
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,
56 this should work for all versions posterior to June 2000. */
59 pascal_main_name (void)
61 struct bound_minimal_symbol msym
;
63 msym
= lookup_minimal_symbol (GPC_P_INITIALIZE
, NULL
, NULL
);
65 /* If '_p_initialize' was not found, the main program is likely not
67 if (msym
.minsym
== NULL
)
70 msym
= lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_1
, NULL
, NULL
);
71 if (msym
.minsym
!= NULL
)
73 return GPC_MAIN_PROGRAM_NAME_1
;
76 msym
= lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_2
, NULL
, NULL
);
77 if (msym
.minsym
!= NULL
)
79 return GPC_MAIN_PROGRAM_NAME_2
;
82 /* No known entry procedure found, the main program is probably
83 not compiled with GPC. */
90 pascal_is_string_type (struct type
*type
,int *length_pos
, int *length_size
,
91 int *string_pos
, struct type
**char_type
,
92 const char **arrayname
)
94 if (type
!= NULL
&& type
->code () == TYPE_CODE_STRUCT
)
96 /* Old Borland type pascal strings from Free Pascal Compiler. */
97 /* Two fields: length and st. */
98 if (type
->num_fields () == 2
99 && TYPE_FIELD_NAME (type
, 0)
100 && strcmp (TYPE_FIELD_NAME (type
, 0), "length") == 0
101 && TYPE_FIELD_NAME (type
, 1)
102 && strcmp (TYPE_FIELD_NAME (type
, 1), "st") == 0)
105 *length_pos
= TYPE_FIELD_BITPOS (type
, 0) / TARGET_CHAR_BIT
;
107 *length_size
= TYPE_LENGTH (type
->field (0).type ());
109 *string_pos
= TYPE_FIELD_BITPOS (type
, 1) / TARGET_CHAR_BIT
;
111 *char_type
= TYPE_TARGET_TYPE (type
->field (1).type ());
113 *arrayname
= TYPE_FIELD_NAME (type
, 1);
116 /* GNU pascal strings. */
117 /* Three fields: Capacity, length and schema$ or _p_schema. */
118 if (type
->num_fields () == 3
119 && TYPE_FIELD_NAME (type
, 0)
120 && strcmp (TYPE_FIELD_NAME (type
, 0), "Capacity") == 0
121 && TYPE_FIELD_NAME (type
, 1)
122 && strcmp (TYPE_FIELD_NAME (type
, 1), "length") == 0)
125 *length_pos
= TYPE_FIELD_BITPOS (type
, 1) / TARGET_CHAR_BIT
;
127 *length_size
= TYPE_LENGTH (type
->field (1).type ());
129 *string_pos
= TYPE_FIELD_BITPOS (type
, 2) / TARGET_CHAR_BIT
;
130 /* FIXME: how can I detect wide chars in GPC ?? */
133 *char_type
= TYPE_TARGET_TYPE (type
->field (2).type ());
135 if ((*char_type
)->code () == TYPE_CODE_ARRAY
)
136 *char_type
= TYPE_TARGET_TYPE (*char_type
);
139 *arrayname
= TYPE_FIELD_NAME (type
, 2);
149 pascal_language::print_one_char (int c
, struct ui_file
*stream
,
150 int *in_quotes
) const
152 if (c
== '\'' || ((unsigned int) c
<= 0xff && (PRINT_LITERAL_FORM (c
))))
155 fputs_filtered ("'", stream
);
159 fputs_filtered ("''", stream
);
162 fprintf_filtered (stream
, "%c", c
);
167 fputs_filtered ("'", stream
);
169 fprintf_filtered (stream
, "#%d", (unsigned int) c
);
173 /* See language.h. */
176 pascal_language::printchar (int c
, struct type
*type
,
177 struct ui_file
*stream
) const
181 print_one_char (c
, stream
, &in_quotes
);
183 fputs_filtered ("'", stream
);
188 /* Table mapping opcodes into strings for printing operators
189 and precedences of the operators. */
191 const struct op_print
pascal_language::op_print_tab
[] =
193 {",", BINOP_COMMA
, PREC_COMMA
, 0},
194 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
195 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
196 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
197 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
198 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
199 {"<>", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
200 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
201 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
202 {">", BINOP_GTR
, PREC_ORDER
, 0},
203 {"<", BINOP_LESS
, PREC_ORDER
, 0},
204 {"shr", BINOP_RSH
, PREC_SHIFT
, 0},
205 {"shl", BINOP_LSH
, PREC_SHIFT
, 0},
206 {"+", BINOP_ADD
, PREC_ADD
, 0},
207 {"-", BINOP_SUB
, PREC_ADD
, 0},
208 {"*", BINOP_MUL
, PREC_MUL
, 0},
209 {"/", BINOP_DIV
, PREC_MUL
, 0},
210 {"div", BINOP_INTDIV
, PREC_MUL
, 0},
211 {"mod", BINOP_REM
, PREC_MUL
, 0},
212 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
213 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
214 {"not", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
215 {"^", UNOP_IND
, PREC_SUFFIX
, 1},
216 {"@", UNOP_ADDR
, PREC_PREFIX
, 0},
217 {"sizeof", UNOP_SIZEOF
, PREC_PREFIX
, 0},
218 {NULL
, OP_NULL
, PREC_PREFIX
, 0}
222 /* See language.h. */
224 void pascal_language::language_arch_info
225 (struct gdbarch
*gdbarch
, struct language_arch_info
*lai
) const
227 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
229 /* Helper function to allow shorter lines below. */
230 auto add
= [&] (struct type
* t
)
232 lai
->add_primitive_type (t
);
235 add (builtin
->builtin_int
);
236 add (builtin
->builtin_long
);
237 add (builtin
->builtin_short
);
238 add (builtin
->builtin_char
);
239 add (builtin
->builtin_float
);
240 add (builtin
->builtin_double
);
241 add (builtin
->builtin_void
);
242 add (builtin
->builtin_long_long
);
243 add (builtin
->builtin_signed_char
);
244 add (builtin
->builtin_unsigned_char
);
245 add (builtin
->builtin_unsigned_short
);
246 add (builtin
->builtin_unsigned_int
);
247 add (builtin
->builtin_unsigned_long
);
248 add (builtin
->builtin_unsigned_long_long
);
249 add (builtin
->builtin_long_double
);
250 add (builtin
->builtin_complex
);
251 add (builtin
->builtin_double_complex
);
253 lai
->set_string_char_type (builtin
->builtin_char
);
254 lai
->set_bool_type (builtin
->builtin_bool
, "boolean");
257 /* See language.h. */
260 pascal_language::printstr (struct ui_file
*stream
, struct type
*elttype
,
261 const gdb_byte
*string
, unsigned int length
,
262 const char *encoding
, int force_ellipses
,
263 const struct value_print_options
*options
) const
265 enum bfd_endian byte_order
= type_byte_order (elttype
);
267 unsigned int things_printed
= 0;
272 /* Preserve ELTTYPE's original type, just set its LENGTH. */
273 check_typedef (elttype
);
274 width
= TYPE_LENGTH (elttype
);
276 /* If the string was not truncated due to `set print elements', and
277 the last byte of it is a null, we don't print that, in traditional C
279 if ((!force_ellipses
) && length
> 0
280 && extract_unsigned_integer (string
+ (length
- 1) * width
, width
,
286 fputs_filtered ("''", stream
);
290 for (i
= 0; i
< length
&& things_printed
< options
->print_max
; ++i
)
292 /* Position of the character we are examining
293 to see whether it is repeated. */
295 /* Number of repetitions we have detected so far. */
297 unsigned long int current_char
;
303 fputs_filtered (", ", stream
);
307 current_char
= extract_unsigned_integer (string
+ i
* width
, width
,
313 && extract_unsigned_integer (string
+ rep1
* width
, width
,
314 byte_order
) == current_char
)
320 if (reps
> options
->repeat_count_threshold
)
324 fputs_filtered ("', ", stream
);
327 printchar (current_char
, elttype
, stream
);
328 fprintf_filtered (stream
, " %p[<repeats %u times>%p]",
329 metadata_style
.style ().ptr (),
332 things_printed
+= options
->repeat_count_threshold
;
337 if ((!in_quotes
) && (PRINT_LITERAL_FORM (current_char
)))
339 fputs_filtered ("'", stream
);
342 print_one_char (current_char
, stream
, &in_quotes
);
347 /* Terminate the quotes if necessary. */
349 fputs_filtered ("'", stream
);
351 if (force_ellipses
|| i
< length
)
352 fputs_filtered ("...", stream
);
355 /* Single instance of the Pascal language class. */
357 static pascal_language pascal_language_defn
;