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