gdb/p-lang.c

   1 /* Pascal language support routines for GDB, the GNU debugger.
   2
   3    Copyright (C) 2000-2020 Free Software Foundation, Inc.
   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
   9    the Free Software Foundation; either version 3 of the License, or
  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
  18    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  19
  20 /* This file is derived from c-lang.c */
  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"
  28 #include "varobj.h"
  29 #include "p-lang.h"
  30 #include "valprint.h"
  31 #include "value.h"
  32 #include <ctype.h>
  33 #include "c-lang.h"
  34 #include "gdbarch.h"
  35 #include "cli/cli-style.h"
  36
  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";
  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,
  56    this should work for all versions posterior to June 2000.  */
  57
  58 const char *
  59 pascal_main_name (void)
  60 {
  61   struct bound_minimal_symbol msym;
  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.  */
  67   if (msym.minsym == NULL)
  68     return NULL;
  69
  70   msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_1, NULL, NULL);
  71   if (msym.minsym != NULL)
  72     {
  73       return GPC_MAIN_PROGRAM_NAME_1;
  74     }
  75
  76   msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_2, NULL, NULL);
  77   if (msym.minsym != NULL)
  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
  87 /* Determines if type TYPE is a pascal string type.
  88    Returns a positive value if the type is a known pascal string type.
  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,
  99                        int *length_size, int *string_pos,
 100                        struct type **char_type,
 101                        const char **arrayname)
 102 {
 103   if (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT)
 104     {
 105       /* Old Borland type pascal strings from Free Pascal Compiler.  */
 106       /* Two fields: length and st.  */
 107       if (TYPE_NFIELDS (type) == 2
 108           && TYPE_FIELD_NAME (type, 0)
 109           && strcmp (TYPE_FIELD_NAME (type, 0), "length") == 0
 110           && TYPE_FIELD_NAME (type, 1)
 111           && strcmp (TYPE_FIELD_NAME (type, 1), "st") == 0)
 112         {
 113           if (length_pos)
 114             *length_pos = TYPE_FIELD_BITPOS (type, 0) / TARGET_CHAR_BIT;
 115           if (length_size)
 116             *length_size = TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
 117           if (string_pos)
 118             *string_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;
 119           if (char_type)
 120             *char_type = TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 1));
 121           if (arrayname)
 122             *arrayname = TYPE_FIELD_NAME (type, 1);
 123          return 2;
 124         };
 125       /* GNU pascal strings.  */
 126       /* Three fields: Capacity, length and schema$ or _p_schema.  */
 127       if (TYPE_NFIELDS (type) == 3
 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)
 132         {
 133           if (length_pos)
 134             *length_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;
 135           if (length_size)
 136             *length_size = TYPE_LENGTH (TYPE_FIELD_TYPE (type, 1));
 137           if (string_pos)
 138             *string_pos = TYPE_FIELD_BITPOS (type, 2) / TARGET_CHAR_BIT;
 139           /* FIXME: how can I detect wide chars in GPC ??  */
 140           if (char_type)
 141             {
 142               *char_type = TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 2));
 143
 144               if (TYPE_CODE (*char_type) == TYPE_CODE_ARRAY)
 145                 *char_type = TYPE_TARGET_TYPE (*char_type);
 146             }
 147           if (arrayname)
 148             *arrayname = TYPE_FIELD_NAME (type, 2);
 149          return 3;
 150         };
 151     }
 152   return 0;
 153 }
 154
 155 /* This is a wrapper around IS_PASCAL_STRING_TYPE that returns true if TYPE
 156    is a string.  */
 157
 158 static bool
 159 pascal_is_string_type_p (struct type *type)
 160 {
 161   return is_pascal_string_type (type, nullptr, nullptr, nullptr,
 162                                 nullptr, nullptr) > 0;
 163 }
 164
 165 static void pascal_one_char (int, struct ui_file *, int *);
 166
 167 /* Print the character C on STREAM as part of the contents of a literal
 168    string.
 169    In_quotes is reset to 0 if a char is written with #4 notation.  */
 170
 171 static void
 172 pascal_one_char (int c, struct ui_file *stream, int *in_quotes)
 173 {
 174   if (c == '\'' || ((unsigned int) c <= 0xff && (PRINT_LITERAL_FORM (c))))
 175     {
 176       if (!(*in_quotes))
 177         fputs_filtered ("'", stream);
 178       *in_quotes = 1;
 179       if (c == '\'')
 180         {
 181           fputs_filtered ("''", stream);
 182         }
 183       else
 184         fprintf_filtered (stream, "%c", c);
 185     }
 186   else
 187     {
 188       if (*in_quotes)
 189         fputs_filtered ("'", stream);
 190       *in_quotes = 0;
 191       fprintf_filtered (stream, "#%d", (unsigned int) c);
 192     }
 193 }
 194
 195 static void pascal_emit_char (int c, struct type *type,
 196                               struct ui_file *stream, int quoter);
 197
 198 /* Print the character C on STREAM as part of the contents of a literal
 199    string whose delimiter is QUOTER.  Note that that format for printing
 200    characters and strings is language specific.  */
 201
 202 static void
 203 pascal_emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
 204 {
 205   int in_quotes = 0;
 206
 207   pascal_one_char (c, stream, &in_quotes);
 208   if (in_quotes)
 209     fputs_filtered ("'", stream);
 210 }
 211
 212 void
 213 pascal_printchar (int c, struct type *type, struct ui_file *stream)
 214 {
 215   int in_quotes = 0;
 216
 217   pascal_one_char (c, stream, &in_quotes);
 218   if (in_quotes)
 219     fputs_filtered ("'", stream);
 220 }
 221
 222 /* Print the character string STRING, printing at most LENGTH characters.
 223    Printing stops early if the number hits print_max; repeat counts
 224    are printed as appropriate.  Print ellipses at the end if we
 225    had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.  */
 226
 227 void
 228 pascal_printstr (struct ui_file *stream, struct type *type,
 229                  const gdb_byte *string, unsigned int length,
 230                  const char *encoding, int force_ellipses,
 231                  const struct value_print_options *options)
 232 {
 233   enum bfd_endian byte_order = type_byte_order (type);
 234   unsigned int i;
 235   unsigned int things_printed = 0;
 236   int in_quotes = 0;
 237   int need_comma = 0;
 238   int width;
 239
 240   /* Preserve TYPE's original type, just set its LENGTH.  */
 241   check_typedef (type);
 242   width = TYPE_LENGTH (type);
 243
 244   /* If the string was not truncated due to `set print elements', and
 245      the last byte of it is a null, we don't print that, in traditional C
 246      style.  */
 247   if ((!force_ellipses) && length > 0
 248         && extract_unsigned_integer (string + (length - 1) * width, width,
 249                                      byte_order) == 0)
 250     length--;
 251
 252   if (length == 0)
 253     {
 254       fputs_filtered ("''", stream);
 255       return;
 256     }
 257
 258   for (i = 0; i < length && things_printed < options->print_max; ++i)
 259     {
 260       /* Position of the character we are examining
 261          to see whether it is repeated.  */
 262       unsigned int rep1;
 263       /* Number of repetitions we have detected so far.  */
 264       unsigned int reps;
 265       unsigned long int current_char;
 266
 267       QUIT;
 268
 269       if (need_comma)
 270         {
 271           fputs_filtered (", ", stream);
 272           need_comma = 0;
 273         }
 274
 275       current_char = extract_unsigned_integer (string + i * width, width,
 276                                                byte_order);
 277
 278       rep1 = i + 1;
 279       reps = 1;
 280       while (rep1 < length
 281              && extract_unsigned_integer (string + rep1 * width, width,
 282                                           byte_order) == current_char)
 283         {
 284           ++rep1;
 285           ++reps;
 286         }
 287
 288       if (reps > options->repeat_count_threshold)
 289         {
 290           if (in_quotes)
 291             {
 292               fputs_filtered ("', ", stream);
 293               in_quotes = 0;
 294             }
 295           pascal_printchar (current_char, type, stream);
 296           fprintf_filtered (stream, " %p[<repeats %u times>%p]",
 297                             metadata_style.style ().ptr (),
 298                             reps, nullptr);
 299           i = rep1 - 1;
 300           things_printed += options->repeat_count_threshold;
 301           need_comma = 1;
 302         }
 303       else
 304         {
 305           if ((!in_quotes) && (PRINT_LITERAL_FORM (current_char)))
 306             {
 307               fputs_filtered ("'", stream);
 308               in_quotes = 1;
 309             }
 310           pascal_one_char (current_char, stream, &in_quotes);
 311           ++things_printed;
 312         }
 313     }
 314
 315   /* Terminate the quotes if necessary.  */
 316   if (in_quotes)
 317     fputs_filtered ("'", stream);
 318
 319   if (force_ellipses || i < length)
 320     fputs_filtered ("...", stream);
 321 }
 322 \f
 323
 324 /* Table mapping opcodes into strings for printing operators
 325    and precedences of the operators.  */
 326
 327 const struct op_print pascal_op_print_tab[] =
 328 {
 329   {",", BINOP_COMMA, PREC_COMMA, 0},
 330   {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
 331   {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
 332   {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
 333   {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
 334   {"=", BINOP_EQUAL, PREC_EQUAL, 0},
 335   {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
 336   {"<=", BINOP_LEQ, PREC_ORDER, 0},
 337   {">=", BINOP_GEQ, PREC_ORDER, 0},
 338   {">", BINOP_GTR, PREC_ORDER, 0},
 339   {"<", BINOP_LESS, PREC_ORDER, 0},
 340   {"shr", BINOP_RSH, PREC_SHIFT, 0},
 341   {"shl", BINOP_LSH, PREC_SHIFT, 0},
 342   {"+", BINOP_ADD, PREC_ADD, 0},
 343   {"-", BINOP_SUB, PREC_ADD, 0},
 344   {"*", BINOP_MUL, PREC_MUL, 0},
 345   {"/", BINOP_DIV, PREC_MUL, 0},
 346   {"div", BINOP_INTDIV, PREC_MUL, 0},
 347   {"mod", BINOP_REM, PREC_MUL, 0},
 348   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
 349   {"-", UNOP_NEG, PREC_PREFIX, 0},
 350   {"not", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
 351   {"^", UNOP_IND, PREC_SUFFIX, 1},
 352   {"@", UNOP_ADDR, PREC_PREFIX, 0},
 353   {"sizeof", UNOP_SIZEOF, PREC_PREFIX, 0},
 354   {NULL, OP_NULL, PREC_PREFIX, 0}
 355 };
 356 \f
 357 enum pascal_primitive_types {
 358   pascal_primitive_type_int,
 359   pascal_primitive_type_long,
 360   pascal_primitive_type_short,
 361   pascal_primitive_type_char,
 362   pascal_primitive_type_float,
 363   pascal_primitive_type_double,
 364   pascal_primitive_type_void,
 365   pascal_primitive_type_long_long,
 366   pascal_primitive_type_signed_char,
 367   pascal_primitive_type_unsigned_char,
 368   pascal_primitive_type_unsigned_short,
 369   pascal_primitive_type_unsigned_int,
 370   pascal_primitive_type_unsigned_long,
 371   pascal_primitive_type_unsigned_long_long,
 372   pascal_primitive_type_long_double,
 373   pascal_primitive_type_complex,
 374   pascal_primitive_type_double_complex,
 375   nr_pascal_primitive_types
 376 };
 377
 378 static void
 379 pascal_language_arch_info (struct gdbarch *gdbarch,
 380                            struct language_arch_info *lai)
 381 {
 382   const struct builtin_type *builtin = builtin_type (gdbarch);
 383
 384   lai->string_char_type = builtin->builtin_char;
 385   lai->primitive_type_vector
 386     = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_pascal_primitive_types + 1,
 387                               struct type *);
 388   lai->primitive_type_vector [pascal_primitive_type_int]
 389     = builtin->builtin_int;
 390   lai->primitive_type_vector [pascal_primitive_type_long]
 391     = builtin->builtin_long;
 392   lai->primitive_type_vector [pascal_primitive_type_short]
 393     = builtin->builtin_short;
 394   lai->primitive_type_vector [pascal_primitive_type_char]
 395     = builtin->builtin_char;
 396   lai->primitive_type_vector [pascal_primitive_type_float]
 397     = builtin->builtin_float;
 398   lai->primitive_type_vector [pascal_primitive_type_double]
 399     = builtin->builtin_double;
 400   lai->primitive_type_vector [pascal_primitive_type_void]
 401     = builtin->builtin_void;
 402   lai->primitive_type_vector [pascal_primitive_type_long_long]
 403     = builtin->builtin_long_long;
 404   lai->primitive_type_vector [pascal_primitive_type_signed_char]
 405     = builtin->builtin_signed_char;
 406   lai->primitive_type_vector [pascal_primitive_type_unsigned_char]
 407     = builtin->builtin_unsigned_char;
 408   lai->primitive_type_vector [pascal_primitive_type_unsigned_short]
 409     = builtin->builtin_unsigned_short;
 410   lai->primitive_type_vector [pascal_primitive_type_unsigned_int]
 411     = builtin->builtin_unsigned_int;
 412   lai->primitive_type_vector [pascal_primitive_type_unsigned_long]
 413     = builtin->builtin_unsigned_long;
 414   lai->primitive_type_vector [pascal_primitive_type_unsigned_long_long]
 415     = builtin->builtin_unsigned_long_long;
 416   lai->primitive_type_vector [pascal_primitive_type_long_double]
 417     = builtin->builtin_long_double;
 418   lai->primitive_type_vector [pascal_primitive_type_complex]
 419     = builtin->builtin_complex;
 420   lai->primitive_type_vector [pascal_primitive_type_double_complex]
 421     = builtin->builtin_double_complex;
 422
 423   lai->bool_type_symbol = "boolean";
 424   lai->bool_type_default = builtin->builtin_bool;
 425 }
 426
 427 static const char *p_extensions[] =
 428 {
 429   ".pas", ".p", ".pp", NULL
 430 };
 431
 432 extern const struct language_defn pascal_language_defn =
 433 {
 434   "pascal",                     /* Language name */
 435   "Pascal",
 436   language_pascal,
 437   range_check_on,
 438   case_sensitive_on,
 439   array_row_major,
 440   macro_expansion_no,
 441   p_extensions,
 442   &exp_descriptor_standard,
 443   pascal_parse,
 444   null_post_parser,
 445   pascal_printchar,             /* Print a character constant */
 446   pascal_printstr,              /* Function to print string constant */
 447   pascal_emit_char,             /* Print a single char */
 448   pascal_print_type,            /* Print a type using appropriate syntax */
 449   pascal_print_typedef,         /* Print a typedef using appropriate syntax */
 450   pascal_val_print,             /* Print a value using appropriate syntax */
 451   pascal_value_print,           /* Print a top-level value */
 452   default_read_var_value,       /* la_read_var_value */
 453   NULL,                         /* Language specific skip_trampoline */
 454   "this",                       /* name_of_this */
 455   false,                        /* la_store_sym_names_in_linkage_form_p */
 456   basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
 457   basic_lookup_transparent_type,/* lookup_transparent_type */
 458   NULL,                         /* Language specific symbol demangler */
 459   NULL,
 460   NULL,                         /* Language specific class_name_from_physname */
 461   pascal_op_print_tab,          /* expression operators for printing */
 462   1,                            /* c-style arrays */
 463   0,                            /* String lower bound */
 464   default_word_break_characters,
 465   default_collect_symbol_completion_matches,
 466   pascal_language_arch_info,
 467   default_print_array_index,
 468   default_pass_by_reference,
 469   c_watch_location_expression,
 470   NULL,                         /* la_compare_symbol_for_completion */
 471   iterate_over_symbols,
 472   default_search_name_hash,
 473   &default_varobj_ops,
 474   NULL,
 475   NULL,
 476   pascal_is_string_type_p,
 477   "{...}"                       /* la_struct_too_deep_ellipsis */
 478 };