gdb/p-lang.c

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