gdb/p-lang.c

   1 /* Pascal language support routines for GDB, the GNU debugger.
   2
   3    Copyright (C) 2000-2024 Free Software Foundation, Inc.
   4
   5    This file is part of GDB.
   6
   7    This program is free software; you can redistribute it and/or modify
   8    it under the terms of the GNU General Public License as published by
   9    the Free Software Foundation; either version 3 of the License, or
  10    (at your option) any later version.
  11
  12    This program is distributed in the hope that it will be useful,
  13    but WITHOUT ANY WARRANTY; without even the implied warranty of
  14    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15    GNU General Public License for more details.
  16
  17    You should have received a copy of the GNU General Public License
  18    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  19
  20 /* This file is derived from c-lang.c */
  21
  22 #include "symtab.h"
  23 #include "gdbtypes.h"
  24 #include "expression.h"
  25 #include "parser-defs.h"
  26 #include "language.h"
  27 #include "varobj.h"
  28 #include "p-lang.h"
  29 #include "valprint.h"
  30 #include "value.h"
  31 #include <ctype.h>
  32 #include "c-lang.h"
  33 #include "gdbarch.h"
  34 #include "cli/cli-style.h"
  35
  36 /* All GPC versions until now (2007-09-27) also define a symbol called
  37    '_p_initialize'.  Check for the presence of this symbol first.  */
  38 static const char GPC_P_INITIALIZE[] = "_p_initialize";
  39
  40 /* The name of the symbol that GPC uses as the name of the main
  41    procedure (since version 20050212).  */
  42 static const char GPC_MAIN_PROGRAM_NAME_1[] = "_p__M0_main_program";
  43
  44 /* Older versions of GPC (versions older than 20050212) were using
  45    a different name for the main procedure.  */
  46 static const char GPC_MAIN_PROGRAM_NAME_2[] = "pascal_main_program";
  47
  48 /* Function returning the special symbol name used
  49    by GPC for the main procedure in the main program
  50    if it is found in minimal symbol list.
  51    This function tries to find minimal symbols generated by GPC
  52    so that it finds the even if the program was compiled
  53    without debugging information.
  54    According to information supplied by Waldeck Hebisch,
  55    this should work for all versions posterior to June 2000.  */
  56
  57 const char *
  58 pascal_main_name (void)
  59 {
  60   struct bound_minimal_symbol msym;
  61
  62   msym = lookup_minimal_symbol (GPC_P_INITIALIZE, NULL, NULL);
  63
  64   /*  If '_p_initialize' was not found, the main program is likely not
  65      written in Pascal.  */
  66   if (msym.minsym == NULL)
  67     return NULL;
  68
  69   msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_1, NULL, NULL);
  70   if (msym.minsym != NULL)
  71     {
  72       return GPC_MAIN_PROGRAM_NAME_1;
  73     }
  74
  75   msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_2, NULL, NULL);
  76   if (msym.minsym != NULL)
  77     {
  78       return GPC_MAIN_PROGRAM_NAME_2;
  79     }
  80
  81   /*  No known entry procedure found, the main program is probably
  82       not compiled with GPC.  */
  83   return NULL;
  84 }
  85
  86 /* See p-lang.h.  */
  87
  88 int
  89 pascal_is_string_type (struct type *type,int *length_pos, int *length_size,
  90                        int *string_pos, struct type **char_type,
  91                        const char **arrayname)
  92 {
  93   if (type != NULL && type->code () == TYPE_CODE_STRUCT)
  94     {
  95       /* Old Borland type pascal strings from Free Pascal Compiler.  */
  96       /* Two fields: length and st.  */
  97       if (type->num_fields () == 2
  98           && type->field (0).name ()
  99           && strcmp (type->field (0).name (), "length") == 0
 100           && type->field (1).name ()
 101           && strcmp (type->field (1).name (), "st") == 0)
 102         {
 103           if (length_pos)
 104             *length_pos = type->field (0).loc_bitpos () / TARGET_CHAR_BIT;
 105           if (length_size)
 106             *length_size = type->field (0).type ()->length ();
 107           if (string_pos)
 108             *string_pos = type->field (1).loc_bitpos () / TARGET_CHAR_BIT;
 109           if (char_type)
 110             *char_type = type->field (1).type ()->target_type ();
 111           if (arrayname)
 112             *arrayname = type->field (1).name ();
 113          return 2;
 114         };
 115       /* GNU pascal strings.  */
 116       /* Three fields: Capacity, length and schema$ or _p_schema.  */
 117       if (type->num_fields () == 3
 118           && type->field (0).name ()
 119           && strcmp (type->field (0).name (), "Capacity") == 0
 120           && type->field (1).name ()
 121           && strcmp (type->field (1).name (), "length") == 0)
 122         {
 123           if (length_pos)
 124             *length_pos = type->field (1).loc_bitpos () / TARGET_CHAR_BIT;
 125           if (length_size)
 126             *length_size = type->field (1).type ()->length ();
 127           if (string_pos)
 128             *string_pos = type->field (2).loc_bitpos () / TARGET_CHAR_BIT;
 129           /* FIXME: how can I detect wide chars in GPC ??  */
 130           if (char_type)
 131             {
 132               *char_type = type->field (2).type ()->target_type ();
 133
 134               if ((*char_type)->code () == TYPE_CODE_ARRAY)
 135                 *char_type = (*char_type)->target_type ();
 136             }
 137           if (arrayname)
 138             *arrayname = type->field (2).name ();
 139          return 3;
 140         };
 141     }
 142   return 0;
 143 }
 144
 145 /* See p-lang.h.  */
 146
 147 void
 148 pascal_language::print_one_char (int c, struct ui_file *stream,
 149                                  int *in_quotes) const
 150 {
 151   if (c == '\'' || ((unsigned int) c <= 0xff && (PRINT_LITERAL_FORM (c))))
 152     {
 153       if (!(*in_quotes))
 154         gdb_puts ("'", stream);
 155       *in_quotes = 1;
 156       if (c == '\'')
 157         {
 158           gdb_puts ("''", stream);
 159         }
 160       else
 161         gdb_printf (stream, "%c", c);
 162     }
 163   else
 164     {
 165       if (*in_quotes)
 166         gdb_puts ("'", stream);
 167       *in_quotes = 0;
 168       gdb_printf (stream, "#%d", (unsigned int) c);
 169     }
 170 }
 171
 172 /* See language.h.  */
 173
 174 void
 175 pascal_language::printchar (int c, struct type *type,
 176                             struct ui_file *stream) const
 177 {
 178   int in_quotes = 0;
 179
 180   print_one_char (c, stream, &in_quotes);
 181   if (in_quotes)
 182     gdb_puts ("'", stream);
 183 }
 184
 185 \f
 186
 187 /* See language.h.  */
 188
 189 void pascal_language::language_arch_info
 190         (struct gdbarch *gdbarch, struct language_arch_info *lai) const
 191 {
 192   const struct builtin_type *builtin = builtin_type (gdbarch);
 193
 194   /* Helper function to allow shorter lines below.  */
 195   auto add  = [&] (struct type * t)
 196   {
 197     lai->add_primitive_type (t);
 198   };
 199
 200   add (builtin->builtin_int);
 201   add (builtin->builtin_long);
 202   add (builtin->builtin_short);
 203   add (builtin->builtin_char);
 204   add (builtin->builtin_float);
 205   add (builtin->builtin_double);
 206   add (builtin->builtin_void);
 207   add (builtin->builtin_long_long);
 208   add (builtin->builtin_signed_char);
 209   add (builtin->builtin_unsigned_char);
 210   add (builtin->builtin_unsigned_short);
 211   add (builtin->builtin_unsigned_int);
 212   add (builtin->builtin_unsigned_long);
 213   add (builtin->builtin_unsigned_long_long);
 214   add (builtin->builtin_long_double);
 215   add (builtin->builtin_complex);
 216   add (builtin->builtin_double_complex);
 217
 218   lai->set_string_char_type (builtin->builtin_char);
 219   lai->set_bool_type (builtin->builtin_bool, "boolean");
 220 }
 221
 222 /* See language.h.  */
 223
 224 void
 225 pascal_language::printstr (struct ui_file *stream, struct type *elttype,
 226                            const gdb_byte *string, unsigned int length,
 227                            const char *encoding, int force_ellipses,
 228                            const struct value_print_options *options) const
 229 {
 230   enum bfd_endian byte_order = type_byte_order (elttype);
 231   unsigned int i;
 232   unsigned int things_printed = 0;
 233   int in_quotes = 0;
 234   int need_comma = 0;
 235   int width;
 236
 237   /* Preserve ELTTYPE's original type, just set its LENGTH.  */
 238   check_typedef (elttype);
 239   width = elttype->length ();
 240
 241   /* If the string was not truncated due to `set print elements', and
 242      the last byte of it is a null, we don't print that, in traditional C
 243      style.  */
 244   if ((!force_ellipses) && length > 0
 245       && extract_unsigned_integer (string + (length - 1) * width, width,
 246                                    byte_order) == 0)
 247     length--;
 248
 249   if (length == 0)
 250     {
 251       gdb_puts ("''", stream);
 252       return;
 253     }
 254
 255   unsigned int print_max_chars = get_print_max_chars (options);
 256   for (i = 0; i < length && things_printed < print_max_chars; ++i)
 257     {
 258       /* Position of the character we are examining
 259          to see whether it is repeated.  */
 260       unsigned int rep1;
 261       /* Number of repetitions we have detected so far.  */
 262       unsigned int reps;
 263       unsigned long int current_char;
 264
 265       QUIT;
 266
 267       if (need_comma)
 268         {
 269           gdb_puts (", ", stream);
 270           need_comma = 0;
 271         }
 272
 273       current_char = extract_unsigned_integer (string + i * width, width,
 274                                                byte_order);
 275
 276       rep1 = i + 1;
 277       reps = 1;
 278       while (rep1 < length
 279              && extract_unsigned_integer (string + rep1 * width, width,
 280                                           byte_order) == current_char)
 281         {
 282           ++rep1;
 283           ++reps;
 284         }
 285
 286       if (reps > options->repeat_count_threshold)
 287         {
 288           if (in_quotes)
 289             {
 290               gdb_puts ("', ", stream);
 291               in_quotes = 0;
 292             }
 293           printchar (current_char, elttype, stream);
 294           gdb_printf (stream, " %p[<repeats %u times>%p]",
 295                       metadata_style.style ().ptr (),
 296                       reps, nullptr);
 297           i = rep1 - 1;
 298           things_printed += options->repeat_count_threshold;
 299           need_comma = 1;
 300         }
 301       else
 302         {
 303           if ((!in_quotes) && (PRINT_LITERAL_FORM (current_char)))
 304             {
 305               gdb_puts ("'", stream);
 306               in_quotes = 1;
 307             }
 308           print_one_char (current_char, stream, &in_quotes);
 309           ++things_printed;
 310         }
 311     }
 312
 313   /* Terminate the quotes if necessary.  */
 314   if (in_quotes)
 315     gdb_puts ("'", stream);
 316
 317   if (force_ellipses || i < length)
 318     gdb_puts ("...", stream);
 319 }
 320
 321 /* Single instance of the Pascal language class.  */
 322
 323 static pascal_language pascal_language_defn;