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 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.
 159    In_quotes is reset to 0 if a char is written with #4 notation.  */
 160
 161 static void
 162 pascal_one_char (int c, struct ui_file *stream, int *in_quotes)
 163 {
 164   if (c == '\'' || ((unsigned int) c <= 0xff && (PRINT_LITERAL_FORM (c))))
 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
 185 void
 186 pascal_printchar (int c, struct type *type, struct ui_file *stream)
 187 {
 188   int in_quotes = 0;
 189
 190   pascal_one_char (c, stream, &in_quotes);
 191   if (in_quotes)
 192     fputs_filtered ("'", stream);
 193 }
 194
 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},
 227   {NULL, OP_NULL, PREC_PREFIX, 0}
 228 };
 229 \f
 230
 231 /* Class representing the Pascal language.  */
 232
 233 class pascal_language : public language_defn
 234 {
 235 public:
 236   pascal_language ()
 237     : language_defn (language_pascal)
 238   { /* Nothing.  */ }
 239
 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
 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   }
 258
 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
 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");
 291   }
 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   }
 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   }
 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   }
 318
 319   /* See language.h.  */
 320
 321   int parser (struct parser_state *ps) const override
 322   {
 323     return pascal_parse (ps);
 324   }
 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   }
 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
 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   }
 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
 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   }
 458
 459   /* See language.h.  */
 460
 461   const char *name_of_this () const override
 462   { return "this"; }
 463
 464   /* See language.h.  */
 465
 466   bool range_checking_on_by_default () const override
 467   { return true; }
 468
 469   /* See language.h.  */
 470
 471   const struct op_print *opcode_print_table () const override
 472   { return pascal_op_print_tab; }
 473 };
 474
 475 /* Single instance of the Pascal language class.  */
 476
 477 static pascal_language pascal_language_defn;