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_CODE_STRUCT)
 104     {
 105       /* Old Borland type pascal strings from Free Pascal Compiler.  */
 106       /* Two fields: length and st.  */
 107       if (type->num_fields () == 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 (0).type ());
 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 (1).type ());
 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->num_fields () == 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 (1).type ());
 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 (2).type ());
 143
 144               if ((*char_type)->code () == 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 void
 196 pascal_printchar (int c, struct type *type, struct ui_file *stream)
 197 {
 198   int in_quotes = 0;
 199
 200   pascal_one_char (c, stream, &in_quotes);
 201   if (in_quotes)
 202     fputs_filtered ("'", stream);
 203 }
 204
 205 /* Print the character string STRING, printing at most LENGTH characters.
 206    Printing stops early if the number hits print_max; repeat counts
 207    are printed as appropriate.  Print ellipses at the end if we
 208    had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.  */
 209
 210 void
 211 pascal_printstr (struct ui_file *stream, struct type *type,
 212                  const gdb_byte *string, unsigned int length,
 213                  const char *encoding, int force_ellipses,
 214                  const struct value_print_options *options)
 215 {
 216   enum bfd_endian byte_order = type_byte_order (type);
 217   unsigned int i;
 218   unsigned int things_printed = 0;
 219   int in_quotes = 0;
 220   int need_comma = 0;
 221   int width;
 222
 223   /* Preserve TYPE's original type, just set its LENGTH.  */
 224   check_typedef (type);
 225   width = TYPE_LENGTH (type);
 226
 227   /* If the string was not truncated due to `set print elements', and
 228      the last byte of it is a null, we don't print that, in traditional C
 229      style.  */
 230   if ((!force_ellipses) && length > 0
 231         && extract_unsigned_integer (string + (length - 1) * width, width,
 232                                      byte_order) == 0)
 233     length--;
 234
 235   if (length == 0)
 236     {
 237       fputs_filtered ("''", stream);
 238       return;
 239     }
 240
 241   for (i = 0; i < length && things_printed < options->print_max; ++i)
 242     {
 243       /* Position of the character we are examining
 244          to see whether it is repeated.  */
 245       unsigned int rep1;
 246       /* Number of repetitions we have detected so far.  */
 247       unsigned int reps;
 248       unsigned long int current_char;
 249
 250       QUIT;
 251
 252       if (need_comma)
 253         {
 254           fputs_filtered (", ", stream);
 255           need_comma = 0;
 256         }
 257
 258       current_char = extract_unsigned_integer (string + i * width, width,
 259                                                byte_order);
 260
 261       rep1 = i + 1;
 262       reps = 1;
 263       while (rep1 < length
 264              && extract_unsigned_integer (string + rep1 * width, width,
 265                                           byte_order) == current_char)
 266         {
 267           ++rep1;
 268           ++reps;
 269         }
 270
 271       if (reps > options->repeat_count_threshold)
 272         {
 273           if (in_quotes)
 274             {
 275               fputs_filtered ("', ", stream);
 276               in_quotes = 0;
 277             }
 278           pascal_printchar (current_char, type, stream);
 279           fprintf_filtered (stream, " %p[<repeats %u times>%p]",
 280                             metadata_style.style ().ptr (),
 281                             reps, nullptr);
 282           i = rep1 - 1;
 283           things_printed += options->repeat_count_threshold;
 284           need_comma = 1;
 285         }
 286       else
 287         {
 288           if ((!in_quotes) && (PRINT_LITERAL_FORM (current_char)))
 289             {
 290               fputs_filtered ("'", stream);
 291               in_quotes = 1;
 292             }
 293           pascal_one_char (current_char, stream, &in_quotes);
 294           ++things_printed;
 295         }
 296     }
 297
 298   /* Terminate the quotes if necessary.  */
 299   if (in_quotes)
 300     fputs_filtered ("'", stream);
 301
 302   if (force_ellipses || i < length)
 303     fputs_filtered ("...", stream);
 304 }
 305 \f
 306
 307 /* Table mapping opcodes into strings for printing operators
 308    and precedences of the operators.  */
 309
 310 const struct op_print pascal_op_print_tab[] =
 311 {
 312   {",", BINOP_COMMA, PREC_COMMA, 0},
 313   {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
 314   {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
 315   {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
 316   {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
 317   {"=", BINOP_EQUAL, PREC_EQUAL, 0},
 318   {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
 319   {"<=", BINOP_LEQ, PREC_ORDER, 0},
 320   {">=", BINOP_GEQ, PREC_ORDER, 0},
 321   {">", BINOP_GTR, PREC_ORDER, 0},
 322   {"<", BINOP_LESS, PREC_ORDER, 0},
 323   {"shr", BINOP_RSH, PREC_SHIFT, 0},
 324   {"shl", BINOP_LSH, PREC_SHIFT, 0},
 325   {"+", BINOP_ADD, PREC_ADD, 0},
 326   {"-", BINOP_SUB, PREC_ADD, 0},
 327   {"*", BINOP_MUL, PREC_MUL, 0},
 328   {"/", BINOP_DIV, PREC_MUL, 0},
 329   {"div", BINOP_INTDIV, PREC_MUL, 0},
 330   {"mod", BINOP_REM, PREC_MUL, 0},
 331   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
 332   {"-", UNOP_NEG, PREC_PREFIX, 0},
 333   {"not", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
 334   {"^", UNOP_IND, PREC_SUFFIX, 1},
 335   {"@", UNOP_ADDR, PREC_PREFIX, 0},
 336   {"sizeof", UNOP_SIZEOF, PREC_PREFIX, 0},
 337   {NULL, OP_NULL, PREC_PREFIX, 0}
 338 };
 339 \f
 340 enum pascal_primitive_types {
 341   pascal_primitive_type_int,
 342   pascal_primitive_type_long,
 343   pascal_primitive_type_short,
 344   pascal_primitive_type_char,
 345   pascal_primitive_type_float,
 346   pascal_primitive_type_double,
 347   pascal_primitive_type_void,
 348   pascal_primitive_type_long_long,
 349   pascal_primitive_type_signed_char,
 350   pascal_primitive_type_unsigned_char,
 351   pascal_primitive_type_unsigned_short,
 352   pascal_primitive_type_unsigned_int,
 353   pascal_primitive_type_unsigned_long,
 354   pascal_primitive_type_unsigned_long_long,
 355   pascal_primitive_type_long_double,
 356   pascal_primitive_type_complex,
 357   pascal_primitive_type_double_complex,
 358   nr_pascal_primitive_types
 359 };
 360
 361 static const char *p_extensions[] =
 362 {
 363   ".pas", ".p", ".pp", NULL
 364 };
 365
 366 /* Constant data representing the Pascal language.  */
 367
 368 extern const struct language_data pascal_language_data =
 369 {
 370   "pascal",                     /* Language name */
 371   "Pascal",
 372   language_pascal,
 373   range_check_on,
 374   case_sensitive_on,
 375   array_row_major,
 376   macro_expansion_no,
 377   p_extensions,
 378   &exp_descriptor_standard,
 379   pascal_printstr,              /* Function to print string constant */
 380   pascal_print_typedef,         /* Print a typedef using appropriate syntax */
 381   "this",                       /* name_of_this */
 382   false,                        /* la_store_sym_names_in_linkage_form_p */
 383   pascal_op_print_tab,          /* expression operators for printing */
 384   1,                            /* c-style arrays */
 385   0,                            /* String lower bound */
 386   &default_varobj_ops,
 387   pascal_is_string_type_p,
 388   "{...}"                       /* la_struct_too_deep_ellipsis */
 389 };
 390
 391 /* Class representing the Pascal language.  */
 392
 393 class pascal_language : public language_defn
 394 {
 395 public:
 396   pascal_language ()
 397     : language_defn (language_pascal, pascal_language_data)
 398   { /* Nothing.  */ }
 399
 400   /* See language.h.  */
 401   void language_arch_info (struct gdbarch *gdbarch,
 402                            struct language_arch_info *lai) const override
 403   {
 404     const struct builtin_type *builtin = builtin_type (gdbarch);
 405
 406     lai->string_char_type = builtin->builtin_char;
 407     lai->primitive_type_vector
 408       = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_pascal_primitive_types + 1,
 409                               struct type *);
 410     lai->primitive_type_vector [pascal_primitive_type_int]
 411       = builtin->builtin_int;
 412     lai->primitive_type_vector [pascal_primitive_type_long]
 413       = builtin->builtin_long;
 414     lai->primitive_type_vector [pascal_primitive_type_short]
 415       = builtin->builtin_short;
 416     lai->primitive_type_vector [pascal_primitive_type_char]
 417       = builtin->builtin_char;
 418     lai->primitive_type_vector [pascal_primitive_type_float]
 419       = builtin->builtin_float;
 420     lai->primitive_type_vector [pascal_primitive_type_double]
 421       = builtin->builtin_double;
 422     lai->primitive_type_vector [pascal_primitive_type_void]
 423       = builtin->builtin_void;
 424     lai->primitive_type_vector [pascal_primitive_type_long_long]
 425       = builtin->builtin_long_long;
 426     lai->primitive_type_vector [pascal_primitive_type_signed_char]
 427       = builtin->builtin_signed_char;
 428     lai->primitive_type_vector [pascal_primitive_type_unsigned_char]
 429       = builtin->builtin_unsigned_char;
 430     lai->primitive_type_vector [pascal_primitive_type_unsigned_short]
 431       = builtin->builtin_unsigned_short;
 432     lai->primitive_type_vector [pascal_primitive_type_unsigned_int]
 433       = builtin->builtin_unsigned_int;
 434     lai->primitive_type_vector [pascal_primitive_type_unsigned_long]
 435       = builtin->builtin_unsigned_long;
 436     lai->primitive_type_vector [pascal_primitive_type_unsigned_long_long]
 437       = builtin->builtin_unsigned_long_long;
 438     lai->primitive_type_vector [pascal_primitive_type_long_double]
 439       = builtin->builtin_long_double;
 440     lai->primitive_type_vector [pascal_primitive_type_complex]
 441       = builtin->builtin_complex;
 442     lai->primitive_type_vector [pascal_primitive_type_double_complex]
 443       = builtin->builtin_double_complex;
 444
 445     lai->bool_type_symbol = "boolean";
 446     lai->bool_type_default = builtin->builtin_bool;
 447   }
 448
 449   /* See language.h.  */
 450
 451   void print_type (struct type *type, const char *varstring,
 452                    struct ui_file *stream, int show, int level,
 453                    const struct type_print_options *flags) const override
 454   {
 455     pascal_print_type (type, varstring, stream, show, level, flags);
 456   }
 457
 458   /* See language.h.  */
 459
 460   void value_print (struct value *val, struct ui_file *stream,
 461                     const struct value_print_options *options) const override
 462   {
 463     return pascal_value_print (val, stream, options);
 464   }
 465
 466   /* See language.h.  */
 467
 468   void value_print_inner
 469         (struct value *val, struct ui_file *stream, int recurse,
 470          const struct value_print_options *options) const override
 471   {
 472     return pascal_value_print_inner (val, stream, recurse, options);
 473   }
 474
 475   /* See language.h.  */
 476
 477   int parser (struct parser_state *ps) const override
 478   {
 479     return pascal_parse (ps);
 480   }
 481
 482   /* See language.h.  */
 483
 484   void emitchar (int ch, struct type *chtype,
 485                  struct ui_file *stream, int quoter) const override
 486   {
 487     int in_quotes = 0;
 488
 489     pascal_one_char (ch, stream, &in_quotes);
 490     if (in_quotes)
 491       fputs_filtered ("'", stream);
 492   }
 493
 494   /* See language.h.  */
 495
 496   void printchar (int ch, struct type *chtype,
 497                   struct ui_file *stream) const override
 498   {
 499     pascal_printchar (ch, chtype, stream);
 500   }
 501
 502 };
 503
 504 /* Single instance of the Pascal language class.  */
 505
 506 static pascal_language pascal_language_defn;