gdb/p-lang.c

   1 /* Pascal language support routines for GDB, the GNU debugger.
   2
   3    Copyright (C) 2000, 2002, 2003, 2004, 2005, 2007, 2008, 2009
   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 /* All GPC versions until now (2007-09-27) also define a symbol called
  39    '_p_initialize'. Check for the presence of this symbol first.  */
  40 static const char GPC_P_INITIALIZE[] = "_p_initialize";
  41
  42 /* The name of the symbol that GPC uses as the name of the main
  43    procedure (since version 20050212).  */
  44 static const char GPC_MAIN_PROGRAM_NAME_1[] = "_p__M0_main_program";
  45
  46 /* Older versions of GPC (versions older than 20050212) were using
  47    a different name for the main procedure.  */
  48 static const char GPC_MAIN_PROGRAM_NAME_2[] = "pascal_main_program";
  49
  50 /* Function returning the special symbol name used
  51    by GPC for the main procedure in the main program
  52    if it is found in minimal symbol list.
  53    This function tries to find minimal symbols generated by GPC
  54    so that it finds the even if the program was compiled
  55    without debugging information.
  56    According to information supplied by Waldeck Hebisch,
  57    this should work for all versions posterior to June 2000. */
  58
  59 const char *
  60 pascal_main_name (void)
  61 {
  62   struct minimal_symbol *msym;
  63
  64   msym = lookup_minimal_symbol (GPC_P_INITIALIZE, NULL, NULL);
  65
  66   /*  If '_p_initialize' was not found, the main program is likely not
  67      written in Pascal.  */
  68   if (msym == NULL)
  69     return NULL;
  70
  71   msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_1, NULL, NULL);
  72   if (msym != NULL)
  73     {
  74       return GPC_MAIN_PROGRAM_NAME_1;
  75     }
  76
  77   msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_2, NULL, NULL);
  78   if (msym != NULL)
  79     {
  80       return GPC_MAIN_PROGRAM_NAME_2;
  81     }
  82
  83   /*  No known entry procedure found, the main program is probably
  84       not compiled with GPC.  */
  85   return NULL;
  86 }
  87
  88 /* Determines if type TYPE is a pascal string type.
  89    Returns 1 if the type is a known pascal type
  90    This function is used by p-valprint.c code to allow better string display.
  91    If it is a pascal string type, then it also sets info needed
  92    to get the length and the data of the string
  93    length_pos, length_size and string_pos are given in bytes.
  94    char_size gives the element size in bytes.
  95    FIXME: if the position or the size of these fields
  96    are not multiple of TARGET_CHAR_BIT then the results are wrong
  97    but this does not happen for Free Pascal nor for GPC.  */
  98 int
  99 is_pascal_string_type (struct type *type,int *length_pos,
 100                        int *length_size, int *string_pos, int *char_size,
 101                        char **arrayname)
 102 {
 103   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
 104     {
 105       /* Old Borland type pascal strings from Free Pascal Compiler.  */
 106       /* Two fields: length and st.  */
 107       if (TYPE_NFIELDS (type) == 2
 108           && strcmp (TYPE_FIELDS (type)[0].name, "length") == 0
 109           && strcmp (TYPE_FIELDS (type)[1].name, "st") == 0)
 110         {
 111           if (length_pos)
 112             *length_pos = TYPE_FIELD_BITPOS (type, 0) / TARGET_CHAR_BIT;
 113           if (length_size)
 114             *length_size = TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
 115           if (string_pos)
 116             *string_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;
 117           if (char_size)
 118             *char_size = 1;
 119           if (arrayname)
 120             *arrayname = TYPE_FIELDS (type)[1].name;
 121          return 2;
 122         };
 123       /* GNU pascal strings.  */
 124       /* Three fields: Capacity, length and schema$ or _p_schema.  */
 125       if (TYPE_NFIELDS (type) == 3
 126           && strcmp (TYPE_FIELDS (type)[0].name, "Capacity") == 0
 127           && strcmp (TYPE_FIELDS (type)[1].name, "length") == 0)
 128         {
 129           if (length_pos)
 130             *length_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;
 131           if (length_size)
 132             *length_size = TYPE_LENGTH (TYPE_FIELD_TYPE (type, 1));
 133           if (string_pos)
 134             *string_pos = TYPE_FIELD_BITPOS (type, 2) / TARGET_CHAR_BIT;
 135           /* FIXME: how can I detect wide chars in GPC ?? */
 136           if (char_size)
 137             *char_size = 1;
 138           if (arrayname)
 139             *arrayname = TYPE_FIELDS (type)[2].name;
 140          return 3;
 141         };
 142     }
 143   return 0;
 144 }
 145
 146 static void pascal_one_char (int, struct ui_file *, int *);
 147
 148 /* Print the character C on STREAM as part of the contents of a literal
 149    string.
 150    In_quotes is reset to 0 if a char is written with #4 notation */
 151
 152 static void
 153 pascal_one_char (int c, struct ui_file *stream, int *in_quotes)
 154 {
 155
 156   c &= 0xFF;                    /* Avoid sign bit follies */
 157
 158   if ((c == '\'') || (PRINT_LITERAL_FORM (c)))
 159     {
 160       if (!(*in_quotes))
 161         fputs_filtered ("'", stream);
 162       *in_quotes = 1;
 163       if (c == '\'')
 164         {
 165           fputs_filtered ("''", stream);
 166         }
 167       else
 168         fprintf_filtered (stream, "%c", c);
 169     }
 170   else
 171     {
 172       if (*in_quotes)
 173         fputs_filtered ("'", stream);
 174       *in_quotes = 0;
 175       fprintf_filtered (stream, "#%d", (unsigned int) c);
 176     }
 177 }
 178
 179 static void pascal_emit_char (int c, struct ui_file *stream, int quoter);
 180
 181 /* Print the character C on STREAM as part of the contents of a literal
 182    string whose delimiter is QUOTER.  Note that that format for printing
 183    characters and strings is language specific. */
 184
 185 static void
 186 pascal_emit_char (int c, struct ui_file *stream, int quoter)
 187 {
 188   int in_quotes = 0;
 189   pascal_one_char (c, stream, &in_quotes);
 190   if (in_quotes)
 191     fputs_filtered ("'", stream);
 192 }
 193
 194 void
 195 pascal_printchar (int c, struct ui_file *stream)
 196 {
 197   int in_quotes = 0;
 198   pascal_one_char (c, stream, &in_quotes);
 199   if (in_quotes)
 200     fputs_filtered ("'", stream);
 201 }
 202
 203 /* Print the character string STRING, printing at most LENGTH characters.
 204    Printing stops early if the number hits print_max; repeat counts
 205    are printed as appropriate.  Print ellipses at the end if we
 206    had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.  */
 207
 208 void
 209 pascal_printstr (struct ui_file *stream, const gdb_byte *string,
 210                  unsigned int length, int width, int force_ellipses,
 211                  const struct value_print_options *options)
 212 {
 213   unsigned int i;
 214   unsigned int things_printed = 0;
 215   int in_quotes = 0;
 216   int need_comma = 0;
 217
 218   /* If the string was not truncated due to `set print elements', and
 219      the last byte of it is a null, we don't print that, in traditional C
 220      style.  */
 221   if ((!force_ellipses) && length > 0 && string[length - 1] == '\0')
 222     length--;
 223
 224   if (length == 0)
 225     {
 226       fputs_filtered ("''", stream);
 227       return;
 228     }
 229
 230   for (i = 0; i < length && things_printed < options->print_max; ++i)
 231     {
 232       /* Position of the character we are examining
 233          to see whether it is repeated.  */
 234       unsigned int rep1;
 235       /* Number of repetitions we have detected so far.  */
 236       unsigned int reps;
 237
 238       QUIT;
 239
 240       if (need_comma)
 241         {
 242           fputs_filtered (", ", stream);
 243           need_comma = 0;
 244         }
 245
 246       rep1 = i + 1;
 247       reps = 1;
 248       while (rep1 < length && string[rep1] == string[i])
 249         {
 250           ++rep1;
 251           ++reps;
 252         }
 253
 254       if (reps > options->repeat_count_threshold)
 255         {
 256           if (in_quotes)
 257             {
 258               if (options->inspect_it)
 259                 fputs_filtered ("\\', ", stream);
 260               else
 261                 fputs_filtered ("', ", stream);
 262               in_quotes = 0;
 263             }
 264           pascal_printchar (string[i], stream);
 265           fprintf_filtered (stream, " <repeats %u times>", reps);
 266           i = rep1 - 1;
 267           things_printed += options->repeat_count_threshold;
 268           need_comma = 1;
 269         }
 270       else
 271         {
 272           int c = string[i];
 273           if ((!in_quotes) && (PRINT_LITERAL_FORM (c)))
 274             {
 275               if (options->inspect_it)
 276                 fputs_filtered ("\\'", stream);
 277               else
 278                 fputs_filtered ("'", stream);
 279               in_quotes = 1;
 280             }
 281           pascal_one_char (c, stream, &in_quotes);
 282           ++things_printed;
 283         }
 284     }
 285
 286   /* Terminate the quotes if necessary.  */
 287   if (in_quotes)
 288     {
 289       if (options->inspect_it)
 290         fputs_filtered ("\\'", stream);
 291       else
 292         fputs_filtered ("'", stream);
 293     }
 294
 295   if (force_ellipses || i < length)
 296     fputs_filtered ("...", stream);
 297 }
 298 \f
 299
 300 /* Table mapping opcodes into strings for printing operators
 301    and precedences of the operators.  */
 302
 303 const struct op_print pascal_op_print_tab[] =
 304 {
 305   {",", BINOP_COMMA, PREC_COMMA, 0},
 306   {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
 307   {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
 308   {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
 309   {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
 310   {"=", BINOP_EQUAL, PREC_EQUAL, 0},
 311   {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
 312   {"<=", BINOP_LEQ, PREC_ORDER, 0},
 313   {">=", BINOP_GEQ, PREC_ORDER, 0},
 314   {">", BINOP_GTR, PREC_ORDER, 0},
 315   {"<", BINOP_LESS, PREC_ORDER, 0},
 316   {"shr", BINOP_RSH, PREC_SHIFT, 0},
 317   {"shl", BINOP_LSH, PREC_SHIFT, 0},
 318   {"+", BINOP_ADD, PREC_ADD, 0},
 319   {"-", BINOP_SUB, PREC_ADD, 0},
 320   {"*", BINOP_MUL, PREC_MUL, 0},
 321   {"/", BINOP_DIV, PREC_MUL, 0},
 322   {"div", BINOP_INTDIV, PREC_MUL, 0},
 323   {"mod", BINOP_REM, PREC_MUL, 0},
 324   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
 325   {"-", UNOP_NEG, PREC_PREFIX, 0},
 326   {"not", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
 327   {"^", UNOP_IND, PREC_SUFFIX, 1},
 328   {"@", UNOP_ADDR, PREC_PREFIX, 0},
 329   {"sizeof", UNOP_SIZEOF, PREC_PREFIX, 0},
 330   {NULL, 0, 0, 0}
 331 };
 332 \f
 333 enum pascal_primitive_types {
 334   pascal_primitive_type_int,
 335   pascal_primitive_type_long,
 336   pascal_primitive_type_short,
 337   pascal_primitive_type_char,
 338   pascal_primitive_type_float,
 339   pascal_primitive_type_double,
 340   pascal_primitive_type_void,
 341   pascal_primitive_type_long_long,
 342   pascal_primitive_type_signed_char,
 343   pascal_primitive_type_unsigned_char,
 344   pascal_primitive_type_unsigned_short,
 345   pascal_primitive_type_unsigned_int,
 346   pascal_primitive_type_unsigned_long,
 347   pascal_primitive_type_unsigned_long_long,
 348   pascal_primitive_type_long_double,
 349   pascal_primitive_type_complex,
 350   pascal_primitive_type_double_complex,
 351   nr_pascal_primitive_types
 352 };
 353
 354 static void
 355 pascal_language_arch_info (struct gdbarch *gdbarch,
 356                            struct language_arch_info *lai)
 357 {
 358   const struct builtin_type *builtin = builtin_type (gdbarch);
 359   lai->string_char_type = builtin->builtin_char;
 360   lai->primitive_type_vector
 361     = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_pascal_primitive_types + 1,
 362                               struct type *);
 363   lai->primitive_type_vector [pascal_primitive_type_int]
 364     = builtin->builtin_int;
 365   lai->primitive_type_vector [pascal_primitive_type_long]
 366     = builtin->builtin_long;
 367   lai->primitive_type_vector [pascal_primitive_type_short]
 368     = builtin->builtin_short;
 369   lai->primitive_type_vector [pascal_primitive_type_char]
 370     = builtin->builtin_char;
 371   lai->primitive_type_vector [pascal_primitive_type_float]
 372     = builtin->builtin_float;
 373   lai->primitive_type_vector [pascal_primitive_type_double]
 374     = builtin->builtin_double;
 375   lai->primitive_type_vector [pascal_primitive_type_void]
 376     = builtin->builtin_void;
 377   lai->primitive_type_vector [pascal_primitive_type_long_long]
 378     = builtin->builtin_long_long;
 379   lai->primitive_type_vector [pascal_primitive_type_signed_char]
 380     = builtin->builtin_signed_char;
 381   lai->primitive_type_vector [pascal_primitive_type_unsigned_char]
 382     = builtin->builtin_unsigned_char;
 383   lai->primitive_type_vector [pascal_primitive_type_unsigned_short]
 384     = builtin->builtin_unsigned_short;
 385   lai->primitive_type_vector [pascal_primitive_type_unsigned_int]
 386     = builtin->builtin_unsigned_int;
 387   lai->primitive_type_vector [pascal_primitive_type_unsigned_long]
 388     = builtin->builtin_unsigned_long;
 389   lai->primitive_type_vector [pascal_primitive_type_unsigned_long_long]
 390     = builtin->builtin_unsigned_long_long;
 391   lai->primitive_type_vector [pascal_primitive_type_long_double]
 392     = builtin->builtin_long_double;
 393   lai->primitive_type_vector [pascal_primitive_type_complex]
 394     = builtin->builtin_complex;
 395   lai->primitive_type_vector [pascal_primitive_type_double_complex]
 396     = builtin->builtin_double_complex;
 397
 398   lai->bool_type_symbol = "boolean";
 399   lai->bool_type_default = builtin->builtin_bool;
 400 }
 401
 402 const struct language_defn pascal_language_defn =
 403 {
 404   "pascal",                     /* Language name */
 405   language_pascal,
 406   range_check_on,
 407   type_check_on,
 408   case_sensitive_on,
 409   array_row_major,
 410   macro_expansion_no,
 411   &exp_descriptor_standard,
 412   pascal_parse,
 413   pascal_error,
 414   null_post_parser,
 415   pascal_printchar,             /* Print a character constant */
 416   pascal_printstr,              /* Function to print string constant */
 417   pascal_emit_char,             /* Print a single char */
 418   pascal_print_type,            /* Print a type using appropriate syntax */
 419   pascal_print_typedef,         /* Print a typedef using appropriate syntax */
 420   pascal_val_print,             /* Print a value using appropriate syntax */
 421   pascal_value_print,           /* Print a top-level value */
 422   NULL,                         /* Language specific skip_trampoline */
 423   "this",                       /* name_of_this */
 424   basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
 425   basic_lookup_transparent_type,/* lookup_transparent_type */
 426   NULL,                         /* Language specific symbol demangler */
 427   NULL,                         /* Language specific class_name_from_physname */
 428   pascal_op_print_tab,          /* expression operators for printing */
 429   1,                            /* c-style arrays */
 430   0,                            /* String lower bound */
 431   default_word_break_characters,
 432   default_make_symbol_completion_list,
 433   pascal_language_arch_info,
 434   default_print_array_index,
 435   default_pass_by_reference,
 436   default_get_string,
 437   LANG_MAGIC
 438 };
 439
 440 void
 441 _initialize_pascal_language (void)
 442 {
 443   add_language (&pascal_language_defn);
 444 }