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