gdb/guile/scm-lazy-string.c

   1 /* Scheme interface to lazy strings.
   2
   3    Copyright (C) 2010-2023 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 /* See README file in this directory for implementation notes, coding
  21    conventions, et.al.  */
  22
  23 #include "defs.h"
  24 #include "charset.h"
  25 #include "value.h"
  26 #include "valprint.h"
  27 #include "language.h"
  28 #include "guile-internal.h"
  29
  30 /* The <gdb:lazy-string> smob.  */
  31
  32 struct lazy_string_smob
  33 {
  34   /* This always appears first.  */
  35   gdb_smob base;
  36
  37   /*  Holds the address of the lazy string.  */
  38   CORE_ADDR address;
  39
  40   /*  Holds the encoding that will be applied to the string when the string
  41       is printed by GDB.  If the encoding is set to NULL then GDB will select
  42       the most appropriate encoding when the sting is printed.
  43       Space for this is malloc'd and will be freed when the object is
  44       freed.  */
  45   char *encoding;
  46
  47   /* If TYPE is an array: If the length is known, then this value is the
  48      array's length, otherwise it is -1.
  49      If TYPE is not an array: Then this value represents the string's length.
  50      In either case, if the value is -1 then the string will be fetched and
  51      encoded up to the first null of appropriate width.  */
  52   int length;
  53
  54   /* The type of the string.
  55      For example if the lazy string was created from a C "char*" then TYPE
  56      represents a C "char*".  To get the type of the character in the string
  57      call lsscm_elt_type which handles the different kinds of values for TYPE.
  58      This is recorded as an SCM object so that we take advantage of support for
  59      preserving the type should its owning objfile go away.  */
  60   SCM type;
  61 };
  62
  63 static const char lazy_string_smob_name[] = "gdb:lazy-string";
  64
  65 /* The tag Guile knows the lazy string smob by.  */
  66 static scm_t_bits lazy_string_smob_tag;
  67 \f
  68 /* Administrivia for lazy string smobs.  */
  69
  70 /* The smob "free" function for <gdb:lazy-string>.  */
  71
  72 static size_t
  73 lsscm_free_lazy_string_smob (SCM self)
  74 {
  75   lazy_string_smob *v_smob = (lazy_string_smob *) SCM_SMOB_DATA (self);
  76
  77   xfree (v_smob->encoding);
  78
  79   return 0;
  80 }
  81
  82 /* The smob "print" function for <gdb:lazy-string>.  */
  83
  84 static int
  85 lsscm_print_lazy_string_smob (SCM self, SCM port, scm_print_state *pstate)
  86 {
  87   lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (self);
  88
  89   gdbscm_printf (port, "#<%s", lazy_string_smob_name);
  90   gdbscm_printf (port, " @%s", hex_string (ls_smob->address));
  91   if (ls_smob->length >= 0)
  92     gdbscm_printf (port, " length %d", ls_smob->length);
  93   if (ls_smob->encoding != NULL)
  94     gdbscm_printf (port, " encoding %s", ls_smob->encoding);
  95   scm_puts (">", port);
  96
  97   scm_remember_upto_here_1 (self);
  98
  99   /* Non-zero means success.  */
 100   return 1;
 101 }
 102
 103 /* Low level routine to create a <gdb:lazy-string> object.
 104    The caller must verify:
 105    - length >= -1
 106    - !(address == 0 && length != 0)
 107    - type != NULL */
 108
 109 static SCM
 110 lsscm_make_lazy_string_smob (CORE_ADDR address, int length,
 111                              const char *encoding, struct type *type)
 112 {
 113   lazy_string_smob *ls_smob = (lazy_string_smob *)
 114     scm_gc_malloc (sizeof (lazy_string_smob), lazy_string_smob_name);
 115   SCM ls_scm;
 116
 117   gdb_assert (length >= -1);
 118   gdb_assert (!(address == 0 && length != 0));
 119   gdb_assert (type != NULL);
 120
 121   ls_smob->address = address;
 122   ls_smob->length = length;
 123   if (encoding == NULL || strcmp (encoding, "") == 0)
 124     ls_smob->encoding = NULL;
 125   else
 126     ls_smob->encoding = xstrdup (encoding);
 127   ls_smob->type = tyscm_scm_from_type (type);
 128
 129   ls_scm = scm_new_smob (lazy_string_smob_tag, (scm_t_bits) ls_smob);
 130   gdbscm_init_gsmob (&ls_smob->base);
 131
 132   return ls_scm;
 133 }
 134
 135 /* Return non-zero if SCM is a <gdb:lazy-string> object.  */
 136
 137 int
 138 lsscm_is_lazy_string (SCM scm)
 139 {
 140   return SCM_SMOB_PREDICATE (lazy_string_smob_tag, scm);
 141 }
 142
 143 /* (lazy-string? object) -> boolean */
 144
 145 static SCM
 146 gdbscm_lazy_string_p (SCM scm)
 147 {
 148   return scm_from_bool (lsscm_is_lazy_string (scm));
 149 }
 150
 151 /* Main entry point to create a <gdb:lazy-string> object.
 152    If there's an error a <gdb:exception> object is returned.  */
 153
 154 SCM
 155 lsscm_make_lazy_string (CORE_ADDR address, int length,
 156                         const char *encoding, struct type *type)
 157 {
 158   if (length < -1)
 159     {
 160       return gdbscm_make_out_of_range_error (NULL, 0,
 161                                              scm_from_int (length),
 162                                              _("invalid length"));
 163     }
 164
 165   if (address == 0 && length != 0)
 166     {
 167       return gdbscm_make_out_of_range_error
 168         (NULL, 0, scm_from_int (length),
 169          _("cannot create a lazy string with address 0x0,"
 170            " and a non-zero length"));
 171     }
 172
 173   if (type == NULL)
 174     {
 175       return gdbscm_make_out_of_range_error
 176         (NULL, 0, scm_from_int (0), _("a lazy string's type cannot be NULL"));
 177     }
 178
 179   return lsscm_make_lazy_string_smob (address, length, encoding, type);
 180 }
 181
 182 /* Returns the <gdb:lazy-string> smob in SELF.
 183    Throws an exception if SELF is not a <gdb:lazy-string> object.  */
 184
 185 static SCM
 186 lsscm_get_lazy_string_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 187 {
 188   SCM_ASSERT_TYPE (lsscm_is_lazy_string (self), self, arg_pos, func_name,
 189                    lazy_string_smob_name);
 190
 191   return self;
 192 }
 193
 194 /* Return the type of a character in lazy string LS_SMOB.  */
 195
 196 static struct type *
 197 lsscm_elt_type (lazy_string_smob *ls_smob)
 198 {
 199   struct type *type = tyscm_scm_to_type (ls_smob->type);
 200   struct type *realtype;
 201
 202   realtype = check_typedef (type);
 203
 204   switch (realtype->code ())
 205     {
 206     case TYPE_CODE_PTR:
 207     case TYPE_CODE_ARRAY:
 208       return realtype->target_type ();
 209     default:
 210       /* This is done to preserve existing behaviour.  PR 20769.
 211          E.g., gdb.parse_and_eval("my_int_variable").lazy_string().type.  */
 212       return realtype;
 213     }
 214 }
 215 \f
 216 /* Lazy string methods.  */
 217
 218 /* (lazy-string-address <gdb:lazy-string>) -> address */
 219
 220 static SCM
 221 gdbscm_lazy_string_address (SCM self)
 222 {
 223   SCM ls_scm = lsscm_get_lazy_string_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 224   lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (ls_scm);
 225
 226   return gdbscm_scm_from_ulongest (ls_smob->address);
 227 }
 228
 229 /* (lazy-string-length <gdb:lazy-string>) -> integer */
 230
 231 static SCM
 232 gdbscm_lazy_string_length (SCM self)
 233 {
 234   SCM ls_scm = lsscm_get_lazy_string_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 235   lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (ls_scm);
 236
 237   return scm_from_int (ls_smob->length);
 238 }
 239
 240 /* (lazy-string-encoding <gdb:lazy-string>) -> string */
 241
 242 static SCM
 243 gdbscm_lazy_string_encoding (SCM self)
 244 {
 245   SCM ls_scm = lsscm_get_lazy_string_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 246   lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (ls_scm);
 247
 248   /* An encoding can be set to NULL by the user, so check first.
 249      If NULL return #f.  */
 250   if (ls_smob != NULL)
 251     return gdbscm_scm_from_c_string (ls_smob->encoding);
 252   return SCM_BOOL_F;
 253 }
 254
 255 /* (lazy-string-type <gdb:lazy-string>) -> <gdb:type> */
 256
 257 static SCM
 258 gdbscm_lazy_string_type (SCM self)
 259 {
 260   SCM ls_scm = lsscm_get_lazy_string_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 261   lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (ls_scm);
 262
 263   return ls_smob->type;
 264 }
 265
 266 /* (lazy-string->value <gdb:lazy-string>) -> <gdb:value> */
 267
 268 static SCM
 269 gdbscm_lazy_string_to_value (SCM self)
 270 {
 271   SCM ls_scm = lsscm_get_lazy_string_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 272   SCM except_scm;
 273   struct value *value;
 274
 275   value = lsscm_safe_lazy_string_to_value (ls_scm, SCM_ARG1, FUNC_NAME,
 276                                            &except_scm);
 277   if (value == NULL)
 278     gdbscm_throw (except_scm);
 279   return vlscm_scm_from_value (value);
 280 }
 281
 282 /* A "safe" version of gdbscm_lazy_string_to_value for use by
 283    vlscm_convert_typed_value_from_scheme.
 284    The result, upon success, is the value of <gdb:lazy-string> STRING.
 285    ARG_POS is the argument position of STRING in the original Scheme
 286    function call, used in exception text.
 287    If there's an error, NULL is returned and a <gdb:exception> object
 288    is stored in *except_scmp.
 289
 290    Note: The result is still "lazy".  The caller must call value_fetch_lazy
 291    to actually fetch the value.  */
 292
 293 struct value *
 294 lsscm_safe_lazy_string_to_value (SCM string, int arg_pos,
 295                                  const char *func_name, SCM *except_scmp)
 296 {
 297   lazy_string_smob *ls_smob;
 298   struct value *value = NULL;
 299
 300   gdb_assert (lsscm_is_lazy_string (string));
 301
 302   ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (string);
 303
 304   if (ls_smob->address == 0)
 305     {
 306       *except_scmp
 307         = gdbscm_make_out_of_range_error (func_name, arg_pos, string,
 308                                          _("cannot create a value from NULL"));
 309       return NULL;
 310     }
 311
 312   try
 313     {
 314       struct type *type = tyscm_scm_to_type (ls_smob->type);
 315       struct type *realtype = check_typedef (type);
 316
 317       switch (realtype->code ())
 318         {
 319         case TYPE_CODE_PTR:
 320           /* If a length is specified we need to convert this to an array
 321              of the specified size.  */
 322           if (ls_smob->length != -1)
 323             {
 324               /* PR 20786: There's no way to specify an array of length zero.
 325                  Record a length of [0,-1] which is how Ada does it.  Anything
 326                  we do is broken, but this one possible solution.  */
 327               type = lookup_array_range_type (realtype->target_type (),
 328                                               0, ls_smob->length - 1);
 329               value = value_at_lazy (type, ls_smob->address);
 330             }
 331           else
 332             value = value_from_pointer (type, ls_smob->address);
 333           break;
 334         default:
 335           value = value_at_lazy (type, ls_smob->address);
 336           break;
 337         }
 338     }
 339   catch (const gdb_exception &except)
 340     {
 341       *except_scmp = gdbscm_scm_from_gdb_exception (unpack (except));
 342       return NULL;
 343     }
 344
 345   return value;
 346 }
 347
 348 /* Print a lazy string to STREAM using val_print_string.
 349    STRING must be a <gdb:lazy-string> object.  */
 350
 351 void
 352 lsscm_val_print_lazy_string (SCM string, struct ui_file *stream,
 353                              const struct value_print_options *options)
 354 {
 355   lazy_string_smob *ls_smob;
 356   struct type *elt_type;
 357
 358   gdb_assert (lsscm_is_lazy_string (string));
 359
 360   ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (string);
 361   elt_type = lsscm_elt_type (ls_smob);
 362
 363   val_print_string (elt_type, ls_smob->encoding,
 364                     ls_smob->address, ls_smob->length,
 365                     stream, options);
 366 }
 367 \f
 368 /* Initialize the Scheme lazy-strings code.  */
 369
 370 static const scheme_function lazy_string_functions[] =
 371 {
 372   { "lazy-string?", 1, 0, 0, as_a_scm_t_subr (gdbscm_lazy_string_p),
 373     "\
 374 Return #t if the object is a <gdb:lazy-string> object." },
 375
 376   { "lazy-string-address", 1, 0, 0,
 377     as_a_scm_t_subr (gdbscm_lazy_string_address),
 378     "\
 379 Return the address of the lazy-string." },
 380
 381   { "lazy-string-length", 1, 0, 0, as_a_scm_t_subr (gdbscm_lazy_string_length),
 382     "\
 383 Return the length of the lazy-string.\n\
 384 If the length is -1 then the length is determined by the first null\n\
 385 of appropriate width." },
 386
 387   { "lazy-string-encoding", 1, 0, 0,
 388     as_a_scm_t_subr (gdbscm_lazy_string_encoding),
 389     "\
 390 Return the encoding of the lazy-string." },
 391
 392   { "lazy-string-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_lazy_string_type),
 393     "\
 394 Return the <gdb:type> of the lazy-string." },
 395
 396   { "lazy-string->value", 1, 0, 0,
 397     as_a_scm_t_subr (gdbscm_lazy_string_to_value),
 398     "\
 399 Return the <gdb:value> representation of the lazy-string." },
 400
 401   END_FUNCTIONS
 402 };
 403
 404 void
 405 gdbscm_initialize_lazy_strings (void)
 406 {
 407   lazy_string_smob_tag = gdbscm_make_smob_type (lazy_string_smob_name,
 408                                                 sizeof (lazy_string_smob));
 409   scm_set_smob_free (lazy_string_smob_tag, lsscm_free_lazy_string_smob);
 410   scm_set_smob_print (lazy_string_smob_tag, lsscm_print_lazy_string_smob);
 411
 412   gdbscm_define_functions (lazy_string_functions, 1);
 413 }