gdb/p-lang.c

   1 /* Pascal language support routines for GDB, the GNU debugger.
   2
   3    Copyright (C) 2000, 2002, 2003, 2004, 2005, 2007
   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 /* Determines if type TYPE is a pascal string type.
  39    Returns 1 if the type is a known pascal type
  40    This function is used by p-valprint.c code to allow better string display.
  41    If it is a pascal string type, then it also sets info needed
  42    to get the length and the data of the string
  43    length_pos, length_size and string_pos are given in bytes.
  44    char_size gives the element size in bytes.
  45    FIXME: if the position or the size of these fields
  46    are not multiple of TARGET_CHAR_BIT then the results are wrong
  47    but this does not happen for Free Pascal nor for GPC.  */
  48 int
  49 is_pascal_string_type (struct type *type,int *length_pos,
  50                        int *length_size, int *string_pos, int *char_size,
  51                        char **arrayname)
  52 {
  53   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
  54     {
  55       /* Old Borland type pascal strings from Free Pascal Compiler.  */
  56       /* Two fields: length and st.  */
  57       if (TYPE_NFIELDS (type) == 2
  58           && strcmp (TYPE_FIELDS (type)[0].name, "length") == 0
  59           && strcmp (TYPE_FIELDS (type)[1].name, "st") == 0)
  60         {
  61           if (length_pos)
  62             *length_pos = TYPE_FIELD_BITPOS (type, 0) / TARGET_CHAR_BIT;
  63           if (length_size)
  64             *length_size = TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
  65           if (string_pos)
  66             *string_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;
  67           if (char_size)
  68             *char_size = 1;
  69           if (arrayname)
  70             *arrayname = TYPE_FIELDS (type)[1].name;
  71          return 2;
  72         };
  73       /* GNU pascal strings.  */
  74       /* Three fields: Capacity, length and schema$ or _p_schema.  */
  75       if (TYPE_NFIELDS (type) == 3
  76           && strcmp (TYPE_FIELDS (type)[0].name, "Capacity") == 0
  77           && strcmp (TYPE_FIELDS (type)[1].name, "length") == 0)
  78         {
  79           if (length_pos)
  80             *length_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;
  81           if (length_size)
  82             *length_size = TYPE_LENGTH (TYPE_FIELD_TYPE (type, 1));
  83           if (string_pos)
  84             *string_pos = TYPE_FIELD_BITPOS (type, 2) / TARGET_CHAR_BIT;
  85           /* FIXME: how can I detect wide chars in GPC ?? */
  86           if (char_size)
  87             *char_size = 1;
  88           if (arrayname)
  89             *arrayname = TYPE_FIELDS (type)[2].name;
  90          return 3;
  91         };
  92     }
  93   return 0;
  94 }
  95
  96 static void pascal_one_char (int, struct ui_file *, int *);
  97
  98 /* Print the character C on STREAM as part of the contents of a literal
  99    string.
 100    In_quotes is reset to 0 if a char is written with #4 notation */
 101
 102 static void
 103 pascal_one_char (int c, struct ui_file *stream, int *in_quotes)
 104 {
 105
 106   c &= 0xFF;                    /* Avoid sign bit follies */
 107
 108   if ((c == '\'') || (PRINT_LITERAL_FORM (c)))
 109     {
 110       if (!(*in_quotes))
 111         fputs_filtered ("'", stream);
 112       *in_quotes = 1;
 113       if (c == '\'')
 114         {
 115           fputs_filtered ("''", stream);
 116         }
 117       else
 118         fprintf_filtered (stream, "%c", c);
 119     }
 120   else
 121     {
 122       if (*in_quotes)
 123         fputs_filtered ("'", stream);
 124       *in_quotes = 0;
 125       fprintf_filtered (stream, "#%d", (unsigned int) c);
 126     }
 127 }
 128
 129 static void pascal_emit_char (int c, struct ui_file *stream, int quoter);
 130
 131 /* Print the character C on STREAM as part of the contents of a literal
 132    string whose delimiter is QUOTER.  Note that that format for printing
 133    characters and strings is language specific. */
 134
 135 static void
 136 pascal_emit_char (int c, struct ui_file *stream, int quoter)
 137 {
 138   int in_quotes = 0;
 139   pascal_one_char (c, stream, &in_quotes);
 140   if (in_quotes)
 141     fputs_filtered ("'", stream);
 142 }
 143
 144 void
 145 pascal_printchar (int c, struct ui_file *stream)
 146 {
 147   int in_quotes = 0;
 148   pascal_one_char (c, stream, &in_quotes);
 149   if (in_quotes)
 150     fputs_filtered ("'", stream);
 151 }
 152
 153 /* Print the character string STRING, printing at most LENGTH characters.
 154    Printing stops early if the number hits print_max; repeat counts
 155    are printed as appropriate.  Print ellipses at the end if we
 156    had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.  */
 157
 158 void
 159 pascal_printstr (struct ui_file *stream, const gdb_byte *string,
 160                  unsigned int length, int width, int force_ellipses)
 161 {
 162   unsigned int i;
 163   unsigned int things_printed = 0;
 164   int in_quotes = 0;
 165   int need_comma = 0;
 166
 167   /* If the string was not truncated due to `set print elements', and
 168      the last byte of it is a null, we don't print that, in traditional C
 169      style.  */
 170   if ((!force_ellipses) && length > 0 && string[length - 1] == '\0')
 171     length--;
 172
 173   if (length == 0)
 174     {
 175       fputs_filtered ("''", stream);
 176       return;
 177     }
 178
 179   for (i = 0; i < length && things_printed < print_max; ++i)
 180     {
 181       /* Position of the character we are examining
 182          to see whether it is repeated.  */
 183       unsigned int rep1;
 184       /* Number of repetitions we have detected so far.  */
 185       unsigned int reps;
 186
 187       QUIT;
 188
 189       if (need_comma)
 190         {
 191           fputs_filtered (", ", stream);
 192           need_comma = 0;
 193         }
 194
 195       rep1 = i + 1;
 196       reps = 1;
 197       while (rep1 < length && string[rep1] == string[i])
 198         {
 199           ++rep1;
 200           ++reps;
 201         }
 202
 203       if (reps > repeat_count_threshold)
 204         {
 205           if (in_quotes)
 206             {
 207               if (inspect_it)
 208                 fputs_filtered ("\\', ", stream);
 209               else
 210                 fputs_filtered ("', ", stream);
 211               in_quotes = 0;
 212             }
 213           pascal_printchar (string[i], stream);
 214           fprintf_filtered (stream, " <repeats %u times>", reps);
 215           i = rep1 - 1;
 216           things_printed += repeat_count_threshold;
 217           need_comma = 1;
 218         }
 219       else
 220         {
 221           int c = string[i];
 222           if ((!in_quotes) && (PRINT_LITERAL_FORM (c)))
 223             {
 224               if (inspect_it)
 225                 fputs_filtered ("\\'", stream);
 226               else
 227                 fputs_filtered ("'", stream);
 228               in_quotes = 1;
 229             }
 230           pascal_one_char (c, stream, &in_quotes);
 231           ++things_printed;
 232         }
 233     }
 234
 235   /* Terminate the quotes if necessary.  */
 236   if (in_quotes)
 237     {
 238       if (inspect_it)
 239         fputs_filtered ("\\'", stream);
 240       else
 241         fputs_filtered ("'", stream);
 242     }
 243
 244   if (force_ellipses || i < length)
 245     fputs_filtered ("...", stream);
 246 }
 247
 248 /* Create a fundamental Pascal type using default reasonable for the current
 249    target machine.
 250
 251    Some object/debugging file formats (DWARF version 1, COFF, etc) do not
 252    define fundamental types such as "int" or "double".  Others (stabs or
 253    DWARF version 2, etc) do define fundamental types.  For the formats which
 254    don't provide fundamental types, gdb can create such types using this
 255    function.
 256
 257    FIXME:  Some compilers distinguish explicitly signed integral types
 258    (signed short, signed int, signed long) from "regular" integral types
 259    (short, int, long) in the debugging information.  There is some dis-
 260    agreement as to how useful this feature is.  In particular, gcc does
 261    not support this.  Also, only some debugging formats allow the
 262    distinction to be passed on to a debugger.  For now, we always just
 263    use "short", "int", or "long" as the type name, for both the implicit
 264    and explicitly signed types.  This also makes life easier for the
 265    gdb test suite since we don't have to account for the differences
 266    in output depending upon what the compiler and debugging format
 267    support.  We will probably have to re-examine the issue when gdb
 268    starts taking it's fundamental type information directly from the
 269    debugging information supplied by the compiler.  fnf@cygnus.com */
 270
 271 /* Note there might be some discussion about the choosen correspondance
 272    because it mainly reflects Free Pascal Compiler setup for now PM */
 273
 274
 275 struct type *
 276 pascal_create_fundamental_type (struct objfile *objfile, int typeid)
 277 {
 278   struct type *type = NULL;
 279
 280   switch (typeid)
 281     {
 282     default:
 283       /* FIXME:  For now, if we are asked to produce a type not in this
 284          language, create the equivalent of a C integer type with the
 285          name "<?type?>".  When all the dust settles from the type
 286          reconstruction work, this should probably become an error. */
 287       type = init_type (TYPE_CODE_INT,
 288                         gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
 289                         0, "<?type?>", objfile);
 290       warning (_("internal error: no Pascal fundamental type %d"), typeid);
 291       break;
 292     case FT_VOID:
 293       type = init_type (TYPE_CODE_VOID,
 294                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
 295                         0, "void", objfile);
 296       break;
 297     case FT_CHAR:
 298       type = init_type (TYPE_CODE_CHAR,
 299                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
 300                         0, "char", objfile);
 301       break;
 302     case FT_SIGNED_CHAR:
 303       type = init_type (TYPE_CODE_INT,
 304                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
 305                         0, "shortint", objfile);
 306       break;
 307     case FT_UNSIGNED_CHAR:
 308       type = init_type (TYPE_CODE_INT,
 309                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
 310                         TYPE_FLAG_UNSIGNED, "byte", objfile);
 311       break;
 312     case FT_SHORT:
 313       type = init_type (TYPE_CODE_INT,
 314                         gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
 315                         0, "integer", objfile);
 316       break;
 317     case FT_SIGNED_SHORT:
 318       type = init_type (TYPE_CODE_INT,
 319                         gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
 320                         0, "integer", objfile);         /* FIXME-fnf */
 321       break;
 322     case FT_UNSIGNED_SHORT:
 323       type = init_type (TYPE_CODE_INT,
 324                         gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
 325                         TYPE_FLAG_UNSIGNED, "word", objfile);
 326       break;
 327     case FT_INTEGER:
 328       type = init_type (TYPE_CODE_INT,
 329                         gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
 330                         0, "longint", objfile);
 331       break;
 332     case FT_SIGNED_INTEGER:
 333       type = init_type (TYPE_CODE_INT,
 334                         gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
 335                         0, "longint", objfile);         /* FIXME -fnf */
 336       break;
 337     case FT_UNSIGNED_INTEGER:
 338       type = init_type (TYPE_CODE_INT,
 339                         gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
 340                         TYPE_FLAG_UNSIGNED, "cardinal", objfile);
 341       break;
 342     case FT_LONG:
 343       type = init_type (TYPE_CODE_INT,
 344                         gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
 345                         0, "long", objfile);
 346       break;
 347     case FT_SIGNED_LONG:
 348       type = init_type (TYPE_CODE_INT,
 349                         gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
 350                         0, "long", objfile);    /* FIXME -fnf */
 351       break;
 352     case FT_UNSIGNED_LONG:
 353       type = init_type (TYPE_CODE_INT,
 354                         gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
 355                         TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
 356       break;
 357     case FT_LONG_LONG:
 358       type = init_type (TYPE_CODE_INT,
 359                         gdbarch_long_long_bit
 360                           (current_gdbarch) / TARGET_CHAR_BIT,
 361                         0, "long long", objfile);
 362       break;
 363     case FT_SIGNED_LONG_LONG:
 364       type = init_type (TYPE_CODE_INT,
 365                         gdbarch_long_long_bit
 366                           (current_gdbarch) / TARGET_CHAR_BIT,
 367                         0, "signed long long", objfile);
 368       break;
 369     case FT_UNSIGNED_LONG_LONG:
 370       type = init_type (TYPE_CODE_INT,
 371                         gdbarch_long_long_bit
 372                           (current_gdbarch) / TARGET_CHAR_BIT,
 373                         TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
 374       break;
 375     case FT_FLOAT:
 376       type = init_type (TYPE_CODE_FLT,
 377                         gdbarch_float_bit (current_gdbarch) / TARGET_CHAR_BIT,
 378                         0, "float", objfile);
 379       break;
 380     case FT_DBL_PREC_FLOAT:
 381       type = init_type (TYPE_CODE_FLT,
 382                         gdbarch_double_bit (current_gdbarch) / TARGET_CHAR_BIT,
 383                         0, "double", objfile);
 384       break;
 385     case FT_EXT_PREC_FLOAT:
 386       type = init_type (TYPE_CODE_FLT,
 387                         gdbarch_long_double_bit (current_gdbarch)
 388                           / TARGET_CHAR_BIT,
 389                         0, "extended", objfile);
 390       break;
 391     }
 392   return (type);
 393 }
 394 \f
 395
 396 /* Table mapping opcodes into strings for printing operators
 397    and precedences of the operators.  */
 398
 399 const struct op_print pascal_op_print_tab[] =
 400 {
 401   {",", BINOP_COMMA, PREC_COMMA, 0},
 402   {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
 403   {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
 404   {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
 405   {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
 406   {"=", BINOP_EQUAL, PREC_EQUAL, 0},
 407   {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
 408   {"<=", BINOP_LEQ, PREC_ORDER, 0},
 409   {">=", BINOP_GEQ, PREC_ORDER, 0},
 410   {">", BINOP_GTR, PREC_ORDER, 0},
 411   {"<", BINOP_LESS, PREC_ORDER, 0},
 412   {"shr", BINOP_RSH, PREC_SHIFT, 0},
 413   {"shl", BINOP_LSH, PREC_SHIFT, 0},
 414   {"+", BINOP_ADD, PREC_ADD, 0},
 415   {"-", BINOP_SUB, PREC_ADD, 0},
 416   {"*", BINOP_MUL, PREC_MUL, 0},
 417   {"/", BINOP_DIV, PREC_MUL, 0},
 418   {"div", BINOP_INTDIV, PREC_MUL, 0},
 419   {"mod", BINOP_REM, PREC_MUL, 0},
 420   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
 421   {"-", UNOP_NEG, PREC_PREFIX, 0},
 422   {"not", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
 423   {"^", UNOP_IND, PREC_SUFFIX, 1},
 424   {"@", UNOP_ADDR, PREC_PREFIX, 0},
 425   {"sizeof", UNOP_SIZEOF, PREC_PREFIX, 0},
 426   {NULL, 0, 0, 0}
 427 };
 428 \f
 429 enum pascal_primitive_types {
 430   pascal_primitive_type_int,
 431   pascal_primitive_type_long,
 432   pascal_primitive_type_short,
 433   pascal_primitive_type_char,
 434   pascal_primitive_type_float,
 435   pascal_primitive_type_double,
 436   pascal_primitive_type_void,
 437   pascal_primitive_type_long_long,
 438   pascal_primitive_type_signed_char,
 439   pascal_primitive_type_unsigned_char,
 440   pascal_primitive_type_unsigned_short,
 441   pascal_primitive_type_unsigned_int,
 442   pascal_primitive_type_unsigned_long,
 443   pascal_primitive_type_unsigned_long_long,
 444   pascal_primitive_type_long_double,
 445   pascal_primitive_type_complex,
 446   pascal_primitive_type_double_complex,
 447   nr_pascal_primitive_types
 448 };
 449
 450 static void
 451 pascal_language_arch_info (struct gdbarch *gdbarch,
 452                            struct language_arch_info *lai)
 453 {
 454   const struct builtin_type *builtin = builtin_type (gdbarch);
 455   lai->string_char_type = builtin->builtin_char;
 456   lai->primitive_type_vector
 457     = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_pascal_primitive_types + 1,
 458                               struct type *);
 459   lai->primitive_type_vector [pascal_primitive_type_int]
 460     = builtin->builtin_int;
 461   lai->primitive_type_vector [pascal_primitive_type_long]
 462     = builtin->builtin_long;
 463   lai->primitive_type_vector [pascal_primitive_type_short]
 464     = builtin->builtin_short;
 465   lai->primitive_type_vector [pascal_primitive_type_char]
 466     = builtin->builtin_char;
 467   lai->primitive_type_vector [pascal_primitive_type_float]
 468     = builtin->builtin_float;
 469   lai->primitive_type_vector [pascal_primitive_type_double]
 470     = builtin->builtin_double;
 471   lai->primitive_type_vector [pascal_primitive_type_void]
 472     = builtin->builtin_void;
 473   lai->primitive_type_vector [pascal_primitive_type_long_long]
 474     = builtin->builtin_long_long;
 475   lai->primitive_type_vector [pascal_primitive_type_signed_char]
 476     = builtin->builtin_signed_char;
 477   lai->primitive_type_vector [pascal_primitive_type_unsigned_char]
 478     = builtin->builtin_unsigned_char;
 479   lai->primitive_type_vector [pascal_primitive_type_unsigned_short]
 480     = builtin->builtin_unsigned_short;
 481   lai->primitive_type_vector [pascal_primitive_type_unsigned_int]
 482     = builtin->builtin_unsigned_int;
 483   lai->primitive_type_vector [pascal_primitive_type_unsigned_long]
 484     = builtin->builtin_unsigned_long;
 485   lai->primitive_type_vector [pascal_primitive_type_unsigned_long_long]
 486     = builtin->builtin_unsigned_long_long;
 487   lai->primitive_type_vector [pascal_primitive_type_long_double]
 488     = builtin->builtin_long_double;
 489   lai->primitive_type_vector [pascal_primitive_type_complex]
 490     = builtin->builtin_complex;
 491   lai->primitive_type_vector [pascal_primitive_type_double_complex]
 492     = builtin->builtin_double_complex;
 493 }
 494
 495 const struct language_defn pascal_language_defn =
 496 {
 497   "pascal",                     /* Language name */
 498   language_pascal,
 499   NULL,
 500   range_check_on,
 501   type_check_on,
 502   case_sensitive_on,
 503   array_row_major,
 504   &exp_descriptor_standard,
 505   pascal_parse,
 506   pascal_error,
 507   null_post_parser,
 508   pascal_printchar,             /* Print a character constant */
 509   pascal_printstr,              /* Function to print string constant */
 510   pascal_emit_char,             /* Print a single char */
 511   pascal_create_fundamental_type,       /* Create fundamental type in this language */
 512   pascal_print_type,            /* Print a type using appropriate syntax */
 513   pascal_val_print,             /* Print a value using appropriate syntax */
 514   pascal_value_print,           /* Print a top-level value */
 515   NULL,                         /* Language specific skip_trampoline */
 516   value_of_this,                /* value_of_this */
 517   basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
 518   basic_lookup_transparent_type,/* lookup_transparent_type */
 519   NULL,                         /* Language specific symbol demangler */
 520   NULL,                         /* Language specific class_name_from_physname */
 521   pascal_op_print_tab,          /* expression operators for printing */
 522   1,                            /* c-style arrays */
 523   0,                            /* String lower bound */
 524   NULL,
 525   default_word_break_characters,
 526   pascal_language_arch_info,
 527   default_print_array_index,
 528   LANG_MAGIC
 529 };
 530
 531 void
 532 _initialize_pascal_language (void)
 533 {
 534   add_language (&pascal_language_defn);
 535 }