gdb/p-lang.c

   1 /* Pascal language support routines for GDB, the GNU debugger.
   2
   3    Copyright (C) 2000, 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010
   4    Free Software Foundation, Inc.
   5
   6    This file is part of GDB.
   7
   8    This program is free software; you can redistribute it and/or modify
   9    it under the terms of the GNU General Public License as published by
  10    the Free Software Foundation; either version 3 of the License, or
  11    (at your option) any later version.
  12
  13    This program is distributed in the hope that it will be useful,
  14    but WITHOUT ANY WARRANTY; without even the implied warranty of
  15    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16    GNU General Public License for more details.
  17
  18    You should have received a copy of the GNU General Public License
  19    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  20
  21 /* This file is derived from c-lang.c */
  22
  23 #include "defs.h"
  24 #include "gdb_string.h"
  25 #include "symtab.h"
  26 #include "gdbtypes.h"
  27 #include "expression.h"
  28 #include "parser-defs.h"
  29 #include "language.h"
  30 #include "p-lang.h"
  31 #include "valprint.h"
  32 #include "value.h"
  33 #include <ctype.h>
  34
  35 extern void _initialize_pascal_language (void);
  36
  37
  38 /* All GPC versions until now (2007-09-27) also define a symbol called
  39    '_p_initialize'. Check for the presence of this symbol first.  */
  40 static const char GPC_P_INITIALIZE[] = "_p_initialize";
  41
  42 /* The name of the symbol that GPC uses as the name of the main
  43    procedure (since version 20050212).  */
  44 static const char GPC_MAIN_PROGRAM_NAME_1[] = "_p__M0_main_program";
  45
  46 /* Older versions of GPC (versions older than 20050212) were using
  47    a different name for the main procedure.  */
  48 static const char GPC_MAIN_PROGRAM_NAME_2[] = "pascal_main_program";
  49
  50 /* Function returning the special symbol name used
  51    by GPC for the main procedure in the main program
  52    if it is found in minimal symbol list.
  53    This function tries to find minimal symbols generated by GPC
  54    so that it finds the even if the program was compiled
  55    without debugging information.
  56    According to information supplied by Waldeck Hebisch,
  57    this should work for all versions posterior to June 2000. */
  58
  59 const char *
  60 pascal_main_name (void)
  61 {
  62   struct minimal_symbol *msym;
  63
  64   msym = lookup_minimal_symbol (GPC_P_INITIALIZE, NULL, NULL);
  65
  66   /*  If '_p_initialize' was not found, the main program is likely not
  67      written in Pascal.  */
  68   if (msym == NULL)
  69     return NULL;
  70
  71   msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_1, NULL, NULL);
  72   if (msym != NULL)
  73     {
  74       return GPC_MAIN_PROGRAM_NAME_1;
  75     }
  76
  77   msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_2, NULL, NULL);
  78   if (msym != NULL)
  79     {
  80       return GPC_MAIN_PROGRAM_NAME_2;
  81     }
  82
  83   /*  No known entry procedure found, the main program is probably
  84       not compiled with GPC.  */
  85   return NULL;
  86 }
  87
  88 /* Determines if type TYPE is a pascal string type.
  89    Returns a positive value if the type is a known pascal string type.
  90    This function is used by p-valprint.c code to allow better string display.
  91    If it is a pascal string type, then it also sets info needed
  92    to get the length and the data of the string
  93    length_pos, length_size and string_pos are given in bytes.
  94    char_size gives the element size in bytes.
  95    FIXME: if the position or the size of these fields
  96    are not multiple of TARGET_CHAR_BIT then the results are wrong
  97    but this does not happen for Free Pascal nor for GPC.  */
  98 int
  99 is_pascal_string_type (struct type *type,int *length_pos,
 100                        int *length_size, int *string_pos,
 101                        struct type **char_type,
 102                        char **arrayname)
 103 {
 104   if (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT)
 105     {
 106       /* Old Borland type pascal strings from Free Pascal Compiler.  */
 107       /* Two fields: length and st.  */
 108       if (TYPE_NFIELDS (type) == 2
 109           && strcmp (TYPE_FIELDS (type)[0].name, "length") == 0
 110           && strcmp (TYPE_FIELDS (type)[1].name, "st") == 0)
 111         {
 112           if (length_pos)
 113             *length_pos = TYPE_FIELD_BITPOS (type, 0) / TARGET_CHAR_BIT;
 114           if (length_size)
 115             *length_size = TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
 116           if (string_pos)
 117             *string_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;
 118           if (char_type)
 119             *char_type = TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 1));
 120           if (arrayname)
 121             *arrayname = TYPE_FIELDS (type)[1].name;
 122          return 2;
 123         };
 124       /* GNU pascal strings.  */
 125       /* Three fields: Capacity, length and schema$ or _p_schema.  */
 126       if (TYPE_NFIELDS (type) == 3
 127           && strcmp (TYPE_FIELDS (type)[0].name, "Capacity") == 0
 128           && strcmp (TYPE_FIELDS (type)[1].name, "length") == 0)
 129         {
 130           if (length_pos)
 131             *length_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;
 132           if (length_size)
 133             *length_size = TYPE_LENGTH (TYPE_FIELD_TYPE (type, 1));
 134           if (string_pos)
 135             *string_pos = TYPE_FIELD_BITPOS (type, 2) / TARGET_CHAR_BIT;
 136           /* FIXME: how can I detect wide chars in GPC ?? */
 137           if (char_type)
 138             {
 139               *char_type = TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 2));
 140
 141               if (TYPE_CODE (*char_type) == TYPE_CODE_ARRAY)
 142                 *char_type = TYPE_TARGET_TYPE (*char_type);
 143             }
 144           if (arrayname)
 145             *arrayname = TYPE_FIELDS (type)[2].name;
 146          return 3;
 147         };
 148     }
 149   return 0;
 150 }
 151
 152 static void pascal_one_char (int, struct ui_file *, int *);
 153
 154 /* Print the character C on STREAM as part of the contents of a literal
 155    string.
 156    In_quotes is reset to 0 if a char is written with #4 notation */
 157
 158 static void
 159 pascal_one_char (int c, struct ui_file *stream, int *in_quotes)
 160 {
 161   if (c == '\'' || ((unsigned int) c <= 0xff && (PRINT_LITERAL_FORM (c))))
 162     {
 163       if (!(*in_quotes))
 164         fputs_filtered ("'", stream);
 165       *in_quotes = 1;
 166       if (c == '\'')
 167         {
 168           fputs_filtered ("''", stream);
 169         }
 170       else
 171         fprintf_filtered (stream, "%c", c);
 172     }
 173   else
 174     {
 175       if (*in_quotes)
 176         fputs_filtered ("'", stream);
 177       *in_quotes = 0;
 178       fprintf_filtered (stream, "#%d", (unsigned int) c);
 179     }
 180 }
 181
 182 static void pascal_emit_char (int c, struct type *type,
 183                               struct ui_file *stream, int quoter);
 184
 185 /* Print the character C on STREAM as part of the contents of a literal
 186    string whose delimiter is QUOTER.  Note that that format for printing
 187    characters and strings is language specific. */
 188
 189 static void
 190 pascal_emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
 191 {
 192   int in_quotes = 0;
 193
 194   pascal_one_char (c, stream, &in_quotes);
 195   if (in_quotes)
 196     fputs_filtered ("'", stream);
 197 }
 198
 199 void
 200 pascal_printchar (int c, struct type *type, struct ui_file *stream)
 201 {
 202   int in_quotes = 0;
 203
 204   pascal_one_char (c, stream, &in_quotes);
 205   if (in_quotes)
 206     fputs_filtered ("'", stream);
 207 }
 208
 209 /* Print the character string STRING, printing at most LENGTH characters.
 210    Printing stops early if the number hits print_max; repeat counts
 211    are printed as appropriate.  Print ellipses at the end if we
 212    had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.  */
 213
 214 void
 215 pascal_printstr (struct ui_file *stream, struct type *type,
 216                  const gdb_byte *string, unsigned int length,
 217                  const char *encoding, int force_ellipses,
 218                  const struct value_print_options *options)
 219 {
 220   enum bfd_endian byte_order = gdbarch_byte_order (get_type_arch (type));
 221   unsigned int i;
 222   unsigned int things_printed = 0;
 223   int in_quotes = 0;
 224   int need_comma = 0;
 225   int 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               if (options->inspect_it)
 276                 fputs_filtered ("\\', ", stream);
 277               else
 278                 fputs_filtered ("', ", stream);
 279               in_quotes = 0;
 280             }
 281           pascal_printchar (current_char, type, stream);
 282           fprintf_filtered (stream, " <repeats %u times>", reps);
 283           i = rep1 - 1;
 284           things_printed += options->repeat_count_threshold;
 285           need_comma = 1;
 286         }
 287       else
 288         {
 289           if ((!in_quotes) && (PRINT_LITERAL_FORM (current_char)))
 290             {
 291               if (options->inspect_it)
 292                 fputs_filtered ("\\'", stream);
 293               else
 294                 fputs_filtered ("'", stream);
 295               in_quotes = 1;
 296             }
 297           pascal_one_char (current_char, stream, &in_quotes);
 298           ++things_printed;
 299         }
 300     }
 301
 302   /* Terminate the quotes if necessary.  */
 303   if (in_quotes)
 304     {
 305       if (options->inspect_it)
 306         fputs_filtered ("\\'", stream);
 307       else
 308         fputs_filtered ("'", stream);
 309     }
 310
 311   if (force_ellipses || i < length)
 312     fputs_filtered ("...", stream);
 313 }
 314 \f
 315
 316 /* Table mapping opcodes into strings for printing operators
 317    and precedences of the operators.  */
 318
 319 const struct op_print pascal_op_print_tab[] =
 320 {
 321   {",", BINOP_COMMA, PREC_COMMA, 0},
 322   {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
 323   {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
 324   {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
 325   {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
 326   {"=", BINOP_EQUAL, PREC_EQUAL, 0},
 327   {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
 328   {"<=", BINOP_LEQ, PREC_ORDER, 0},
 329   {">=", BINOP_GEQ, PREC_ORDER, 0},
 330   {">", BINOP_GTR, PREC_ORDER, 0},
 331   {"<", BINOP_LESS, PREC_ORDER, 0},
 332   {"shr", BINOP_RSH, PREC_SHIFT, 0},
 333   {"shl", BINOP_LSH, PREC_SHIFT, 0},
 334   {"+", BINOP_ADD, PREC_ADD, 0},
 335   {"-", BINOP_SUB, PREC_ADD, 0},
 336   {"*", BINOP_MUL, PREC_MUL, 0},
 337   {"/", BINOP_DIV, PREC_MUL, 0},
 338   {"div", BINOP_INTDIV, PREC_MUL, 0},
 339   {"mod", BINOP_REM, PREC_MUL, 0},
 340   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
 341   {"-", UNOP_NEG, PREC_PREFIX, 0},
 342   {"not", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
 343   {"^", UNOP_IND, PREC_SUFFIX, 1},
 344   {"@", UNOP_ADDR, PREC_PREFIX, 0},
 345   {"sizeof", UNOP_SIZEOF, PREC_PREFIX, 0},
 346   {NULL, 0, 0, 0}
 347 };
 348 \f
 349 enum pascal_primitive_types {
 350   pascal_primitive_type_int,
 351   pascal_primitive_type_long,
 352   pascal_primitive_type_short,
 353   pascal_primitive_type_char,
 354   pascal_primitive_type_float,
 355   pascal_primitive_type_double,
 356   pascal_primitive_type_void,
 357   pascal_primitive_type_long_long,
 358   pascal_primitive_type_signed_char,
 359   pascal_primitive_type_unsigned_char,
 360   pascal_primitive_type_unsigned_short,
 361   pascal_primitive_type_unsigned_int,
 362   pascal_primitive_type_unsigned_long,
 363   pascal_primitive_type_unsigned_long_long,
 364   pascal_primitive_type_long_double,
 365   pascal_primitive_type_complex,
 366   pascal_primitive_type_double_complex,
 367   nr_pascal_primitive_types
 368 };
 369
 370 static void
 371 pascal_language_arch_info (struct gdbarch *gdbarch,
 372                            struct language_arch_info *lai)
 373 {
 374   const struct builtin_type *builtin = builtin_type (gdbarch);
 375
 376   lai->string_char_type = builtin->builtin_char;
 377   lai->primitive_type_vector
 378     = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_pascal_primitive_types + 1,
 379                               struct type *);
 380   lai->primitive_type_vector [pascal_primitive_type_int]
 381     = builtin->builtin_int;
 382   lai->primitive_type_vector [pascal_primitive_type_long]
 383     = builtin->builtin_long;
 384   lai->primitive_type_vector [pascal_primitive_type_short]
 385     = builtin->builtin_short;
 386   lai->primitive_type_vector [pascal_primitive_type_char]
 387     = builtin->builtin_char;
 388   lai->primitive_type_vector [pascal_primitive_type_float]
 389     = builtin->builtin_float;
 390   lai->primitive_type_vector [pascal_primitive_type_double]
 391     = builtin->builtin_double;
 392   lai->primitive_type_vector [pascal_primitive_type_void]
 393     = builtin->builtin_void;
 394   lai->primitive_type_vector [pascal_primitive_type_long_long]
 395     = builtin->builtin_long_long;
 396   lai->primitive_type_vector [pascal_primitive_type_signed_char]
 397     = builtin->builtin_signed_char;
 398   lai->primitive_type_vector [pascal_primitive_type_unsigned_char]
 399     = builtin->builtin_unsigned_char;
 400   lai->primitive_type_vector [pascal_primitive_type_unsigned_short]
 401     = builtin->builtin_unsigned_short;
 402   lai->primitive_type_vector [pascal_primitive_type_unsigned_int]
 403     = builtin->builtin_unsigned_int;
 404   lai->primitive_type_vector [pascal_primitive_type_unsigned_long]
 405     = builtin->builtin_unsigned_long;
 406   lai->primitive_type_vector [pascal_primitive_type_unsigned_long_long]
 407     = builtin->builtin_unsigned_long_long;
 408   lai->primitive_type_vector [pascal_primitive_type_long_double]
 409     = builtin->builtin_long_double;
 410   lai->primitive_type_vector [pascal_primitive_type_complex]
 411     = builtin->builtin_complex;
 412   lai->primitive_type_vector [pascal_primitive_type_double_complex]
 413     = builtin->builtin_double_complex;
 414
 415   lai->bool_type_symbol = "boolean";
 416   lai->bool_type_default = builtin->builtin_bool;
 417 }
 418
 419 const struct language_defn pascal_language_defn =
 420 {
 421   "pascal",                     /* Language name */
 422   language_pascal,
 423   range_check_on,
 424   type_check_on,
 425   case_sensitive_on,
 426   array_row_major,
 427   macro_expansion_no,
 428   &exp_descriptor_standard,
 429   pascal_parse,
 430   pascal_error,
 431   null_post_parser,
 432   pascal_printchar,             /* Print a character constant */
 433   pascal_printstr,              /* Function to print string constant */
 434   pascal_emit_char,             /* Print a single char */
 435   pascal_print_type,            /* Print a type using appropriate syntax */
 436   pascal_print_typedef,         /* Print a typedef using appropriate syntax */
 437   pascal_val_print,             /* Print a value using appropriate syntax */
 438   pascal_value_print,           /* Print a top-level value */
 439   NULL,                         /* Language specific skip_trampoline */
 440   "this",                       /* name_of_this */
 441   basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
 442   basic_lookup_transparent_type,/* lookup_transparent_type */
 443   NULL,                         /* Language specific symbol demangler */
 444   NULL,                         /* Language specific class_name_from_physname */
 445   pascal_op_print_tab,          /* expression operators for printing */
 446   1,                            /* c-style arrays */
 447   0,                            /* String lower bound */
 448   default_word_break_characters,
 449   default_make_symbol_completion_list,
 450   pascal_language_arch_info,
 451   default_print_array_index,
 452   default_pass_by_reference,
 453   default_get_string,
 454   LANG_MAGIC
 455 };
 456
 457 void
 458 _initialize_pascal_language (void)
 459 {
 460   add_language (&pascal_language_defn);
 461 }