aboutsummaryrefslogtreecommitdiff
path: root/gdb/guile/scm-objfile.c
blob: d6c0559afd3cd364bc2d647a0c4def0d015e31f8 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
/* Scheme interface to objfiles.

   Copyright (C) 2008-2024 Free Software Foundation, Inc.

   This file is part of GDB.

   This program is free software; you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 3 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */

/* See README file in this directory for implementation notes, coding
   conventions, et.al.  */

#include "objfiles.h"
#include "language.h"
#include "guile-internal.h"

/* The <gdb:objfile> smob.  */

struct objfile_smob
{
  /* This always appears first.  */
  gdb_smob base;

  /* The corresponding objfile.  */
  struct objfile *objfile;

  /* The pretty-printer list of functions.  */
  SCM pretty_printers;

  /* The <gdb:objfile> object we are contained in, needed to protect/unprotect
     the object since a reference to it comes from non-gc-managed space
     (the objfile).  */
  SCM containing_scm;
};

static const char objfile_smob_name[] = "gdb:objfile";

/* The tag Guile knows the objfile smob by.  */
static scm_t_bits objfile_smob_tag;

/* Objfile registry cleanup handler for when an objfile is deleted.  */
struct ofscm_deleter
{
  void operator() (objfile_smob *o_smob)
  {
    o_smob->objfile = NULL;
    scm_gc_unprotect_object (o_smob->containing_scm);
  }
};

static const registry<objfile>::key<objfile_smob, ofscm_deleter>
     ofscm_objfile_data_key;

/* Return the list of pretty-printers registered with O_SMOB.  */

SCM
ofscm_objfile_smob_pretty_printers (objfile_smob *o_smob)
{
  return o_smob->pretty_printers;
}

/* Administrivia for objfile smobs.  */

/* The smob "print" function for <gdb:objfile>.  */

static int
ofscm_print_objfile_smob (SCM self, SCM port, scm_print_state *pstate)
{
  objfile_smob *o_smob = (objfile_smob *) SCM_SMOB_DATA (self);

  gdbscm_printf (port, "#<%s ", objfile_smob_name);
  gdbscm_printf (port, "%s",
		 o_smob->objfile != NULL
		 ? objfile_name (o_smob->objfile)
		 : "{invalid}");
  scm_puts (">", port);

  scm_remember_upto_here_1 (self);

  /* Non-zero means success.  */
  return 1;
}

/* Low level routine to create a <gdb:objfile> object.
   It's empty in the sense that an OBJFILE still needs to be associated
   with it.  */

static SCM
ofscm_make_objfile_smob (void)
{
  objfile_smob *o_smob = (objfile_smob *)
    scm_gc_malloc (sizeof (objfile_smob), objfile_smob_name);
  SCM o_scm;

  o_smob->objfile = NULL;
  o_smob->pretty_printers = SCM_EOL;
  o_scm = scm_new_smob (objfile_smob_tag, (scm_t_bits) o_smob);
  o_smob->containing_scm = o_scm;
  gdbscm_init_gsmob (&o_smob->base);

  return o_scm;
}

/* Return non-zero if SCM is a <gdb:objfile> object.  */

static int
ofscm_is_objfile (SCM scm)
{
  return SCM_SMOB_PREDICATE (objfile_smob_tag, scm);
}

/* (objfile? object) -> boolean */

static SCM
gdbscm_objfile_p (SCM scm)
{
  return scm_from_bool (ofscm_is_objfile (scm));
}

/* Return a pointer to the objfile_smob that encapsulates OBJFILE,
   creating one if necessary.
   The result is cached so that we have only one copy per objfile.  */

objfile_smob *
ofscm_objfile_smob_from_objfile (struct objfile *objfile)
{
  objfile_smob *o_smob;

  o_smob = ofscm_objfile_data_key.get (objfile);
  if (o_smob == NULL)
    {
      SCM o_scm = ofscm_make_objfile_smob ();

      o_smob = (objfile_smob *) SCM_SMOB_DATA (o_scm);
      o_smob->objfile = objfile;

      ofscm_objfile_data_key.set (objfile, o_smob);
      scm_gc_protect_object (o_smob->containing_scm);
    }

  return o_smob;
}

/* Return the <gdb:objfile> object that encapsulates OBJFILE.  */

SCM
ofscm_scm_from_objfile (struct objfile *objfile)
{
  objfile_smob *o_smob = ofscm_objfile_smob_from_objfile (objfile);

  return o_smob->containing_scm;
}

/* Returns the <gdb:objfile> object in SELF.
   Throws an exception if SELF is not a <gdb:objfile> object.  */

static SCM
ofscm_get_objfile_arg_unsafe (SCM self, int arg_pos, const char *func_name)
{
  SCM_ASSERT_TYPE (ofscm_is_objfile (self), self, arg_pos, func_name,
		   objfile_smob_name);

  return self;
}

/* Returns a pointer to the objfile smob of SELF.
   Throws an exception if SELF is not a <gdb:objfile> object.  */

static objfile_smob *
ofscm_get_objfile_smob_arg_unsafe (SCM self, int arg_pos,
				   const char *func_name)
{
  SCM o_scm = ofscm_get_objfile_arg_unsafe (self, arg_pos, func_name);
  objfile_smob *o_smob = (objfile_smob *) SCM_SMOB_DATA (o_scm);

  return o_smob;
}

/* Return non-zero if objfile O_SMOB is valid.  */

static int
ofscm_is_valid (objfile_smob *o_smob)
{
  return o_smob->objfile != NULL;
}

/* Return the objfile smob in SELF, verifying it's valid.
   Throws an exception if SELF is not a <gdb:objfile> object or is invalid.  */

static objfile_smob *
ofscm_get_valid_objfile_smob_arg_unsafe (SCM self, int arg_pos,
					 const char *func_name)
{
  objfile_smob *o_smob
    = ofscm_get_objfile_smob_arg_unsafe (self, arg_pos, func_name);

  if (!ofscm_is_valid (o_smob))
    {
      gdbscm_invalid_object_error (func_name, arg_pos, self,
				   _("<gdb:objfile>"));
    }

  return o_smob;
}

/* Objfile methods.  */

/* (objfile-valid? <gdb:objfile>) -> boolean
   Returns #t if this object file still exists in GDB.  */

static SCM
gdbscm_objfile_valid_p (SCM self)
{
  objfile_smob *o_smob
    = ofscm_get_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

  return scm_from_bool (o_smob->objfile != NULL);
}

/* (objfile-filename <gdb:objfile>) -> string
   Returns the objfile's file name.
   Throw's an exception if the underlying objfile is invalid.  */

static SCM
gdbscm_objfile_filename (SCM self)
{
  objfile_smob *o_smob
    = ofscm_get_valid_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

  return gdbscm_scm_from_c_string (objfile_name (o_smob->objfile));
}

/* (objfile-progspace <gdb:objfile>) -> <gdb:progspace>
   Returns the objfile's progspace.
   Throw's an exception if the underlying objfile is invalid.  */

static SCM
gdbscm_objfile_progspace (SCM self)
{
  objfile_smob *o_smob
    = ofscm_get_valid_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

  return psscm_scm_from_pspace (o_smob->objfile->pspace ());
}

/* (objfile-pretty-printers <gdb:objfile>) -> list
   Returns the list of pretty-printers for this objfile.  */

static SCM
gdbscm_objfile_pretty_printers (SCM self)
{
  objfile_smob *o_smob
    = ofscm_get_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

  return o_smob->pretty_printers;
}

/* (set-objfile-pretty-printers! <gdb:objfile> list) -> unspecified
   Set the pretty-printers for this objfile.  */

static SCM
gdbscm_set_objfile_pretty_printers_x (SCM self, SCM printers)
{
  objfile_smob *o_smob
    = ofscm_get_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

  SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (printers)), printers,
		   SCM_ARG2, FUNC_NAME, _("list"));

  o_smob->pretty_printers = printers;

  return SCM_UNSPECIFIED;
}

/* The "current" objfile.  This is set when gdb detects that a new
   objfile has been loaded.  It is only set for the duration of a call to
   gdbscm_source_objfile_script and gdbscm_execute_objfile_script; it is NULL
   at other times.  */
static struct objfile *ofscm_current_objfile;

/* Set the current objfile to OBJFILE and then read FILE named FILENAME
   as Guile code.  This does not throw any errors.  If an exception
   occurs Guile will print the backtrace.
   This is the extension_language_script_ops.objfile_script_sourcer
   "method".  */

void
gdbscm_source_objfile_script (const struct extension_language_defn *extlang,
			      struct objfile *objfile, FILE *file,
			      const char *filename)
{
  ofscm_current_objfile = objfile;

  gdb::unique_xmalloc_ptr<char> msg = gdbscm_safe_source_script (filename);
  if (msg != NULL)
    gdb_printf (gdb_stderr, "%s", msg.get ());

  ofscm_current_objfile = NULL;
}

/* Set the current objfile to OBJFILE and then read FILE named FILENAME
   as Guile code.  This does not throw any errors.  If an exception
   occurs Guile will print the backtrace.
   This is the extension_language_script_ops.objfile_script_sourcer
   "method".  */

void
gdbscm_execute_objfile_script (const struct extension_language_defn *extlang,
			       struct objfile *objfile, const char *name,
			       const char *script)
{
  ofscm_current_objfile = objfile;

  gdb::unique_xmalloc_ptr<char> msg
    = gdbscm_safe_eval_string (script, 0 /* display_result */);
  if (msg != NULL)
    gdb_printf (gdb_stderr, "%s", msg.get ());

  ofscm_current_objfile = NULL;
}

/* (current-objfile) -> <gdb:objfile>
   Return the current objfile, or #f if there isn't one.
   Ideally this would be named ofscm_current_objfile, but that name is
   taken by the variable recording the current objfile.  */

static SCM
gdbscm_get_current_objfile (void)
{
  if (ofscm_current_objfile == NULL)
    return SCM_BOOL_F;

  return ofscm_scm_from_objfile (ofscm_current_objfile);
}

/* (objfiles) -> list
   Return a list of all objfiles in the current program space.  */

static SCM
gdbscm_objfiles (void)
{
  SCM result;

  result = SCM_EOL;

  for (objfile *objf : current_program_space->objfiles ())
    {
      SCM item = ofscm_scm_from_objfile (objf);

      result = scm_cons (item, result);
    }

  return scm_reverse_x (result, SCM_EOL);
}

/* Initialize the Scheme objfile support.  */

static const scheme_function objfile_functions[] =
{
  { "objfile?", 1, 0, 0, as_a_scm_t_subr (gdbscm_objfile_p),
    "\
Return #t if the object is a <gdb:objfile> object." },

  { "objfile-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_objfile_valid_p),
    "\
Return #t if the objfile is valid (hasn't been deleted from gdb)." },

  { "objfile-filename", 1, 0, 0, as_a_scm_t_subr (gdbscm_objfile_filename),
    "\
Return the file name of the objfile." },

  { "objfile-progspace", 1, 0, 0, as_a_scm_t_subr (gdbscm_objfile_progspace),
    "\
Return the progspace that the objfile lives in." },

  { "objfile-pretty-printers", 1, 0, 0,
    as_a_scm_t_subr (gdbscm_objfile_pretty_printers),
    "\
Return a list of pretty-printers of the objfile." },

  { "set-objfile-pretty-printers!", 2, 0, 0,
    as_a_scm_t_subr (gdbscm_set_objfile_pretty_printers_x),
    "\
Set the list of pretty-printers of the objfile." },

  { "current-objfile", 0, 0, 0, as_a_scm_t_subr (gdbscm_get_current_objfile),
    "\
Return the current objfile if there is one or #f if there isn't one." },

  { "objfiles", 0, 0, 0, as_a_scm_t_subr (gdbscm_objfiles),
    "\
Return a list of all objfiles in the current program space." },

  END_FUNCTIONS
};

void
gdbscm_initialize_objfiles (void)
{
  objfile_smob_tag
    = gdbscm_make_smob_type (objfile_smob_name, sizeof (objfile_smob));
  scm_set_smob_print (objfile_smob_tag, ofscm_print_objfile_smob);

  gdbscm_define_functions (objfile_functions, 1);
}