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
   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_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               if (TYPE_CODE (*char_type) == TYPE_CODE_ARRAY)
 141                 *char_type = TYPE_TARGET_TYPE (*char_type);
 142             }
 143           if (arrayname)
 144             *arrayname = TYPE_FIELDS (type)[2].name;
 145          return 3;
 146         };
 147     }
 148   return 0;
 149 }
 150
 151 static void pascal_one_char (int, struct ui_file *, int *);
 152
 153 /* Print the character C on STREAM as part of the contents of a literal
 154    string.
 155    In_quotes is reset to 0 if a char is written with #4 notation */
 156
 157 static void
 158 pascal_one_char (int c, struct ui_file *stream, int *in_quotes)
 159 {
 160
 161   c &= 0xFF;                    /* Avoid sign bit follies */
 162
 163   if ((c == '\'') || (PRINT_LITERAL_FORM (c)))
 164     {
 165       if (!(*in_quotes))
 166         fputs_filtered ("'", stream);
 167       *in_quotes = 1;
 168       if (c == '\'')
 169         {
 170           fputs_filtered ("''", stream);
 171         }
 172       else
 173         fprintf_filtered (stream, "%c", c);
 174     }
 175   else
 176     {
 177       if (*in_quotes)
 178         fputs_filtered ("'", stream);
 179       *in_quotes = 0;
 180       fprintf_filtered (stream, "#%d", (unsigned int) c);
 181     }
 182 }
 183
 184 static void pascal_emit_char (int c, struct type *type,
 185                               struct ui_file *stream, int quoter);
 186
 187 /* Print the character C on STREAM as part of the contents of a literal
 188    string whose delimiter is QUOTER.  Note that that format for printing
 189    characters and strings is language specific. */
 190
 191 static void
 192 pascal_emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
 193 {
 194   int in_quotes = 0;
 195   pascal_one_char (c, stream, &in_quotes);
 196   if (in_quotes)
 197     fputs_filtered ("'", stream);
 198 }
 199
 200 void
 201 pascal_printchar (int c, struct type *type, struct ui_file *stream)
 202 {
 203   int in_quotes = 0;
 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                  int force_ellipses,
 218                  const struct value_print_options *options)
 219 {
 220   unsigned int i;
 221   unsigned int things_printed = 0;
 222   int in_quotes = 0;
 223   int need_comma = 0;
 224   int width = TYPE_LENGTH (type);
 225
 226   /* If the string was not truncated due to `set print elements', and
 227      the last byte of it is a null, we don't print that, in traditional C
 228      style.  */
 229   if ((!force_ellipses) && length > 0
 230         && extract_unsigned_integer (string + (length - 1) * width, width) == 0)
 231     length--;
 232
 233   if (length == 0)
 234     {
 235       fputs_filtered ("''", stream);
 236       return;
 237     }
 238
 239   for (i = 0; i < length && things_printed < options->print_max; ++i)
 240     {
 241       /* Position of the character we are examining
 242          to see whether it is repeated.  */
 243       unsigned int rep1;
 244       /* Number of repetitions we have detected so far.  */
 245       unsigned int reps;
 246       unsigned long int current_char;
 247
 248       QUIT;
 249
 250       if (need_comma)
 251         {
 252           fputs_filtered (", ", stream);
 253           need_comma = 0;
 254         }
 255
 256       current_char = extract_unsigned_integer (string + i * width, width);
 257
 258       rep1 = i + 1;
 259       reps = 1;
 260       while (rep1 < length
 261              && extract_unsigned_integer (string + rep1 * width, width)
 262                 == current_char)
 263         {
 264           ++rep1;
 265           ++reps;
 266         }
 267
 268       if (reps > options->repeat_count_threshold)
 269         {
 270           if (in_quotes)
 271             {
 272               if (options->inspect_it)
 273                 fputs_filtered ("\\', ", stream);
 274               else
 275                 fputs_filtered ("', ", stream);
 276               in_quotes = 0;
 277             }
 278           pascal_printchar (current_char, type, stream);
 279           fprintf_filtered (stream, " <repeats %u times>", reps);
 280           i = rep1 - 1;
 281           things_printed += options->repeat_count_threshold;
 282           need_comma = 1;
 283         }
 284       else
 285         {
 286           if ((!in_quotes) && (PRINT_LITERAL_FORM (current_char)))
 287             {
 288               if (options->inspect_it)
 289                 fputs_filtered ("\\'", stream);
 290               else
 291                 fputs_filtered ("'", stream);
 292               in_quotes = 1;
 293             }
 294           pascal_one_char (current_char, stream, &in_quotes);
 295           ++things_printed;
 296         }
 297     }
 298
 299   /* Terminate the quotes if necessary.  */
 300   if (in_quotes)
 301     {
 302       if (options->inspect_it)
 303         fputs_filtered ("\\'", stream);
 304       else
 305         fputs_filtered ("'", stream);
 306     }
 307
 308   if (force_ellipses || i < length)
 309     fputs_filtered ("...", stream);
 310 }
 311 \f
 312
 313 /* Table mapping opcodes into strings for printing operators
 314    and precedences of the operators.  */
 315
 316 const struct op_print pascal_op_print_tab[] =
 317 {
 318   {",", BINOP_COMMA, PREC_COMMA, 0},
 319   {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
 320   {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
 321   {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
 322   {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
 323   {"=", BINOP_EQUAL, PREC_EQUAL, 0},
 324   {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
 325   {"<=", BINOP_LEQ, PREC_ORDER, 0},
 326   {">=", BINOP_GEQ, PREC_ORDER, 0},
 327   {">", BINOP_GTR, PREC_ORDER, 0},
 328   {"<", BINOP_LESS, PREC_ORDER, 0},
 329   {"shr", BINOP_RSH, PREC_SHIFT, 0},
 330   {"shl", BINOP_LSH, PREC_SHIFT, 0},
 331   {"+", BINOP_ADD, PREC_ADD, 0},
 332   {"-", BINOP_SUB, PREC_ADD, 0},
 333   {"*", BINOP_MUL, PREC_MUL, 0},
 334   {"/", BINOP_DIV, PREC_MUL, 0},
 335   {"div", BINOP_INTDIV, PREC_MUL, 0},
 336   {"mod", BINOP_REM, PREC_MUL, 0},
 337   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
 338   {"-", UNOP_NEG, PREC_PREFIX, 0},
 339   {"not", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
 340   {"^", UNOP_IND, PREC_SUFFIX, 1},
 341   {"@", UNOP_ADDR, PREC_PREFIX, 0},
 342   {"sizeof", UNOP_SIZEOF, PREC_PREFIX, 0},
 343   {NULL, 0, 0, 0}
 344 };
 345 \f
 346 enum pascal_primitive_types {
 347   pascal_primitive_type_int,
 348   pascal_primitive_type_long,
 349   pascal_primitive_type_short,
 350   pascal_primitive_type_char,
 351   pascal_primitive_type_float,
 352   pascal_primitive_type_double,
 353   pascal_primitive_type_void,
 354   pascal_primitive_type_long_long,
 355   pascal_primitive_type_signed_char,
 356   pascal_primitive_type_unsigned_char,
 357   pascal_primitive_type_unsigned_short,
 358   pascal_primitive_type_unsigned_int,
 359   pascal_primitive_type_unsigned_long,
 360   pascal_primitive_type_unsigned_long_long,
 361   pascal_primitive_type_long_double,
 362   pascal_primitive_type_complex,
 363   pascal_primitive_type_double_complex,
 364   nr_pascal_primitive_types
 365 };
 366
 367 static void
 368 pascal_language_arch_info (struct gdbarch *gdbarch,
 369                            struct language_arch_info *lai)
 370 {
 371   const struct builtin_type *builtin = builtin_type (gdbarch);
 372   lai->string_char_type = builtin->builtin_char;
 373   lai->primitive_type_vector
 374     = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_pascal_primitive_types + 1,
 375                               struct type *);
 376   lai->primitive_type_vector [pascal_primitive_type_int]
 377     = builtin->builtin_int;
 378   lai->primitive_type_vector [pascal_primitive_type_long]
 379     = builtin->builtin_long;
 380   lai->primitive_type_vector [pascal_primitive_type_short]
 381     = builtin->builtin_short;
 382   lai->primitive_type_vector [pascal_primitive_type_char]
 383     = builtin->builtin_char;
 384   lai->primitive_type_vector [pascal_primitive_type_float]
 385     = builtin->builtin_float;
 386   lai->primitive_type_vector [pascal_primitive_type_double]
 387     = builtin->builtin_double;
 388   lai->primitive_type_vector [pascal_primitive_type_void]
 389     = builtin->builtin_void;
 390   lai->primitive_type_vector [pascal_primitive_type_long_long]
 391     = builtin->builtin_long_long;
 392   lai->primitive_type_vector [pascal_primitive_type_signed_char]
 393     = builtin->builtin_signed_char;
 394   lai->primitive_type_vector [pascal_primitive_type_unsigned_char]
 395     = builtin->builtin_unsigned_char;
 396   lai->primitive_type_vector [pascal_primitive_type_unsigned_short]
 397     = builtin->builtin_unsigned_short;
 398   lai->primitive_type_vector [pascal_primitive_type_unsigned_int]
 399     = builtin->builtin_unsigned_int;
 400   lai->primitive_type_vector [pascal_primitive_type_unsigned_long]
 401     = builtin->builtin_unsigned_long;
 402   lai->primitive_type_vector [pascal_primitive_type_unsigned_long_long]
 403     = builtin->builtin_unsigned_long_long;
 404   lai->primitive_type_vector [pascal_primitive_type_long_double]
 405     = builtin->builtin_long_double;
 406   lai->primitive_type_vector [pascal_primitive_type_complex]
 407     = builtin->builtin_complex;
 408   lai->primitive_type_vector [pascal_primitive_type_double_complex]
 409     = builtin->builtin_double_complex;
 410
 411   lai->bool_type_symbol = "boolean";
 412   lai->bool_type_default = builtin->builtin_bool;
 413 }
 414
 415 const struct language_defn pascal_language_defn =
 416 {
 417   "pascal",                     /* Language name */
 418   language_pascal,
 419   range_check_on,
 420   type_check_on,
 421   case_sensitive_on,
 422   array_row_major,
 423   macro_expansion_no,
 424   &exp_descriptor_standard,
 425   pascal_parse,
 426   pascal_error,
 427   null_post_parser,
 428   pascal_printchar,             /* Print a character constant */
 429   pascal_printstr,              /* Function to print string constant */
 430   pascal_emit_char,             /* Print a single char */
 431   pascal_print_type,            /* Print a type using appropriate syntax */
 432   pascal_print_typedef,         /* Print a typedef using appropriate syntax */
 433   pascal_val_print,             /* Print a value using appropriate syntax */
 434   pascal_value_print,           /* Print a top-level value */
 435   NULL,                         /* Language specific skip_trampoline */
 436   "this",                       /* name_of_this */
 437   basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
 438   basic_lookup_transparent_type,/* lookup_transparent_type */
 439   NULL,                         /* Language specific symbol demangler */
 440   NULL,                         /* Language specific class_name_from_physname */
 441   pascal_op_print_tab,          /* expression operators for printing */
 442   1,                            /* c-style arrays */
 443   0,                            /* String lower bound */
 444   default_word_break_characters,
 445   default_make_symbol_completion_list,
 446   pascal_language_arch_info,
 447   default_print_array_index,
 448   default_pass_by_reference,
 449   default_get_string,
 450   LANG_MAGIC
 451 };
 452
 453 void
 454 _initialize_pascal_language (void)
 455 {
 456   add_language (&pascal_language_defn);
 457 }