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