1/* Scheme interface to lazy strings.
2
3   Copyright (C) 2010-2020 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
32typedef struct
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} lazy_string_smob;
62
63static const char lazy_string_smob_name[] = "gdb:lazy-string";
64
65/* The tag Guile knows the lazy string smob by.  */
66static scm_t_bits lazy_string_smob_tag;
67
68/* Administrivia for lazy string smobs.  */
69
70/* The smob "free" function for <gdb:lazy-string>.  */
71
72static size_t
73lsscm_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
84static int
85lsscm_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
109static SCM
110lsscm_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
137int
138lsscm_is_lazy_string (SCM scm)
139{
140  return SCM_SMOB_PREDICATE (lazy_string_smob_tag, scm);
141}
142
143/* (lazy-string? object) -> boolean */
144
145static SCM
146gdbscm_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
154SCM
155lsscm_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
185static SCM
186lsscm_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
196static struct type *
197lsscm_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 TYPE_TARGET_TYPE (realtype);
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
216/* Lazy string methods.  */
217
218/* (lazy-string-address <gdb:lazy-string>) -> address */
219
220static SCM
221gdbscm_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
231static SCM
232gdbscm_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
242static SCM
243gdbscm_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
257static SCM
258gdbscm_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
268static SCM
269gdbscm_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
293struct value *
294lsscm_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 (TYPE_TARGET_TYPE (realtype),
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
351void
352lsscm_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
368/* Initialize the Scheme lazy-strings code.  */
369
370static const scheme_function lazy_string_functions[] =
371{
372  { "lazy-string?", 1, 0, 0, as_a_scm_t_subr (gdbscm_lazy_string_p),
373    "\
374Return #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    "\
379Return the address of the lazy-string." },
380
381  { "lazy-string-length", 1, 0, 0, as_a_scm_t_subr (gdbscm_lazy_string_length),
382    "\
383Return the length of the lazy-string.\n\
384If the length is -1 then the length is determined by the first null\n\
385of appropriate width." },
386
387  { "lazy-string-encoding", 1, 0, 0,
388    as_a_scm_t_subr (gdbscm_lazy_string_encoding),
389    "\
390Return the encoding of the lazy-string." },
391
392  { "lazy-string-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_lazy_string_type),
393    "\
394Return 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    "\
399Return the <gdb:value> representation of the lazy-string." },
400
401  END_FUNCTIONS
402};
403
404void
405gdbscm_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}
414