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 "event-top.h"
  23 #include "extract-store-integer.h"
  24 #include "symtab.h"
  25 #include "gdbtypes.h"
  26 #include "expression.h"
  27 #include "parser-defs.h"
  28 #include "language.h"
  29 #include "varobj.h"
  30 #include "p-lang.h"
  31 #include "valprint.h"
  32 #include "value.h"
  33 #include <ctype.h>
  34 #include "c-lang.h"
  35 #include "gdbarch.h"
  36 #include "cli/cli-style.h"
  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   bound_minimal_symbol msym
  63     = lookup_minimal_symbol (current_program_space, GPC_P_INITIALIZE);
  64
  65   /*  If '_p_initialize' was not found, the main program is likely not
  66      written in Pascal.  */
  67   if (msym.minsym == NULL)
  68     return NULL;
  69
  70   msym
  71     = lookup_minimal_symbol (current_program_space, GPC_MAIN_PROGRAM_NAME_1);
  72   if (msym.minsym != NULL)
  73     {
  74       return GPC_MAIN_PROGRAM_NAME_1;
  75     }
  76
  77   msym
  78     = lookup_minimal_symbol (current_program_space, GPC_MAIN_PROGRAM_NAME_2);
  79   if (msym.minsym != NULL)
  80     {
  81       return GPC_MAIN_PROGRAM_NAME_2;
  82     }
  83
  84   /*  No known entry procedure found, the main program is probably
  85       not compiled with GPC.  */
  86   return NULL;
  87 }
  88
  89 /* See p-lang.h.  */
  90
  91 int
  92 pascal_is_string_type (struct type *type,int *length_pos, int *length_size,
  93                        int *string_pos, struct type **char_type,
  94                        const char **arrayname)
  95 {
  96   if (type != NULL && type->code () == TYPE_CODE_STRUCT)
  97     {
  98       /* Old Borland type pascal strings from Free Pascal Compiler.  */
  99       /* Two fields: length and st.  */
 100       if (type->num_fields () == 2
 101           && type->field (0).name ()
 102           && strcmp (type->field (0).name (), "length") == 0
 103           && type->field (1).name ()
 104           && strcmp (type->field (1).name (), "st") == 0)
 105         {
 106           if (length_pos)
 107             *length_pos = type->field (0).loc_bitpos () / TARGET_CHAR_BIT;
 108           if (length_size)
 109             *length_size = type->field (0).type ()->length ();
 110           if (string_pos)
 111             *string_pos = type->field (1).loc_bitpos () / TARGET_CHAR_BIT;
 112           if (char_type)
 113             *char_type = type->field (1).type ()->target_type ();
 114           if (arrayname)
 115             *arrayname = type->field (1).name ();
 116          return 2;
 117         };
 118       /* GNU pascal strings.  */
 119       /* Three fields: Capacity, length and schema$ or _p_schema.  */
 120       if (type->num_fields () == 3
 121           && type->field (0).name ()
 122           && strcmp (type->field (0).name (), "Capacity") == 0
 123           && type->field (1).name ()
 124           && strcmp (type->field (1).name (), "length") == 0)
 125         {
 126           if (length_pos)
 127             *length_pos = type->field (1).loc_bitpos () / TARGET_CHAR_BIT;
 128           if (length_size)
 129             *length_size = type->field (1).type ()->length ();
 130           if (string_pos)
 131             *string_pos = type->field (2).loc_bitpos () / TARGET_CHAR_BIT;
 132           /* FIXME: how can I detect wide chars in GPC ??  */
 133           if (char_type)
 134             {
 135               *char_type = type->field (2).type ()->target_type ();
 136
 137               if ((*char_type)->code () == TYPE_CODE_ARRAY)
 138                 *char_type = (*char_type)->target_type ();
 139             }
 140           if (arrayname)
 141             *arrayname = type->field (2).name ();
 142          return 3;
 143         };
 144     }
 145   return 0;
 146 }
 147
 148 /* See p-lang.h.  */
 149
 150 void
 151 pascal_language::print_one_char (int c, struct ui_file *stream,
 152                                  int *in_quotes) const
 153 {
 154   if (c == '\'' || ((unsigned int) c <= 0xff && (PRINT_LITERAL_FORM (c))))
 155     {
 156       if (!(*in_quotes))
 157         gdb_puts ("'", stream);
 158       *in_quotes = 1;
 159       if (c == '\'')
 160         {
 161           gdb_puts ("''", stream);
 162         }
 163       else
 164         gdb_printf (stream, "%c", c);
 165     }
 166   else
 167     {
 168       if (*in_quotes)
 169         gdb_puts ("'", stream);
 170       *in_quotes = 0;
 171       gdb_printf (stream, "#%d", (unsigned int) c);
 172     }
 173 }
 174
 175 /* See language.h.  */
 176
 177 void
 178 pascal_language::printchar (int c, struct type *type,
 179                             struct ui_file *stream) const
 180 {
 181   int in_quotes = 0;
 182
 183   print_one_char (c, stream, &in_quotes);
 184   if (in_quotes)
 185     gdb_puts ("'", stream);
 186 }
 187
 188 \f
 189
 190 /* See language.h.  */
 191
 192 void pascal_language::language_arch_info
 193         (struct gdbarch *gdbarch, struct language_arch_info *lai) const
 194 {
 195   const struct builtin_type *builtin = builtin_type (gdbarch);
 196
 197   /* Helper function to allow shorter lines below.  */
 198   auto add  = [&] (struct type * t)
 199   {
 200     lai->add_primitive_type (t);
 201   };
 202
 203   add (builtin->builtin_int);
 204   add (builtin->builtin_long);
 205   add (builtin->builtin_short);
 206   add (builtin->builtin_char);
 207   add (builtin->builtin_float);
 208   add (builtin->builtin_double);
 209   add (builtin->builtin_void);
 210   add (builtin->builtin_long_long);
 211   add (builtin->builtin_signed_char);
 212   add (builtin->builtin_unsigned_char);
 213   add (builtin->builtin_unsigned_short);
 214   add (builtin->builtin_unsigned_int);
 215   add (builtin->builtin_unsigned_long);
 216   add (builtin->builtin_unsigned_long_long);
 217   add (builtin->builtin_long_double);
 218   add (builtin->builtin_complex);
 219   add (builtin->builtin_double_complex);
 220
 221   lai->set_string_char_type (builtin->builtin_char);
 222   lai->set_bool_type (builtin->builtin_bool, "boolean");
 223 }
 224
 225 /* See language.h.  */
 226
 227 void
 228 pascal_language::printstr (struct ui_file *stream, struct type *elttype,
 229                            const gdb_byte *string, unsigned int length,
 230                            const char *encoding, int force_ellipses,
 231                            const struct value_print_options *options) const
 232 {
 233   enum bfd_endian byte_order = type_byte_order (elttype);
 234   unsigned int i;
 235   unsigned int things_printed = 0;
 236   int in_quotes = 0;
 237   int need_comma = 0;
 238   int width;
 239
 240   /* Preserve ELTTYPE's original type, just set its LENGTH.  */
 241   check_typedef (elttype);
 242   width = elttype->length ();
 243
 244   /* If the string was not truncated due to `set print elements', and
 245      the last byte of it is a null, we don't print that, in traditional C
 246      style.  */
 247   if ((!force_ellipses) && length > 0
 248       && extract_unsigned_integer (string + (length - 1) * width, width,
 249                                    byte_order) == 0)
 250     length--;
 251
 252   if (length == 0)
 253     {
 254       gdb_puts ("''", stream);
 255       return;
 256     }
 257
 258   unsigned int print_max_chars = get_print_max_chars (options);
 259   for (i = 0; i < length && things_printed < print_max_chars; ++i)
 260     {
 261       /* Position of the character we are examining
 262          to see whether it is repeated.  */
 263       unsigned int rep1;
 264       /* Number of repetitions we have detected so far.  */
 265       unsigned int reps;
 266       unsigned long int current_char;
 267
 268       QUIT;
 269
 270       if (need_comma)
 271         {
 272           gdb_puts (", ", stream);
 273           need_comma = 0;
 274         }
 275
 276       current_char = extract_unsigned_integer (string + i * width, width,
 277                                                byte_order);
 278
 279       rep1 = i + 1;
 280       reps = 1;
 281       while (rep1 < length
 282              && extract_unsigned_integer (string + rep1 * width, width,
 283                                           byte_order) == current_char)
 284         {
 285           ++rep1;
 286           ++reps;
 287         }
 288
 289       if (reps > options->repeat_count_threshold)
 290         {
 291           if (in_quotes)
 292             {
 293               gdb_puts ("', ", stream);
 294               in_quotes = 0;
 295             }
 296           printchar (current_char, elttype, stream);
 297           gdb_printf (stream, " %p[<repeats %u times>%p]",
 298                       metadata_style.style ().ptr (),
 299                       reps, nullptr);
 300           i = rep1 - 1;
 301           things_printed += options->repeat_count_threshold;
 302           need_comma = 1;
 303         }
 304       else
 305         {
 306           if ((!in_quotes) && (PRINT_LITERAL_FORM (current_char)))
 307             {
 308               gdb_puts ("'", stream);
 309               in_quotes = 1;
 310             }
 311           print_one_char (current_char, stream, &in_quotes);
 312           ++things_printed;
 313         }
 314     }
 315
 316   /* Terminate the quotes if necessary.  */
 317   if (in_quotes)
 318     gdb_puts ("'", stream);
 319
 320   if (force_ellipses || i < length)
 321     gdb_puts ("...", stream);
 322 }
 323
 324 /* Single instance of the Pascal language class.  */
 325
 326 static pascal_language pascal_language_defn;