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