gdb/guile/scm-lazy-string.c

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