contrib/gdb-6.2.1/gdb/p-lang.c

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