gdb/p-lang.c

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