gdb/guile/scm-objfile.c

   1 /* Scheme interface to objfiles.
   2
   3    Copyright (C) 2008-2022 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 "objfiles.h"
  25 #include "language.h"
  26 #include "guile-internal.h"
  27
  28 /* The <gdb:objfile> smob.  */
  29
  30 struct objfile_smob
  31 {
  32   /* This always appears first.  */
  33   gdb_smob base;
  34
  35   /* The corresponding objfile.  */
  36   struct objfile *objfile;
  37
  38   /* The pretty-printer list of functions.  */
  39   SCM pretty_printers;
  40
  41   /* The <gdb:objfile> object we are contained in, needed to protect/unprotect
  42      the object since a reference to it comes from non-gc-managed space
  43      (the objfile).  */
  44   SCM containing_scm;
  45 };
  46
  47 static const char objfile_smob_name[] = "gdb:objfile";
  48
  49 /* The tag Guile knows the objfile smob by.  */
  50 static scm_t_bits objfile_smob_tag;
  51
  52 /* Objfile registry cleanup handler for when an objfile is deleted.  */
  53 struct ofscm_deleter
  54 {
  55   void operator() (objfile_smob *o_smob)
  56   {
  57     o_smob->objfile = NULL;
  58     scm_gc_unprotect_object (o_smob->containing_scm);
  59   }
  60 };
  61
  62 static const registry<objfile>::key<objfile_smob, ofscm_deleter>
  63      ofscm_objfile_data_key;
  64
  65 /* Return the list of pretty-printers registered with O_SMOB.  */
  66
  67 SCM
  68 ofscm_objfile_smob_pretty_printers (objfile_smob *o_smob)
  69 {
  70   return o_smob->pretty_printers;
  71 }
  72 \f
  73 /* Administrivia for objfile smobs.  */
  74
  75 /* The smob "print" function for <gdb:objfile>.  */
  76
  77 static int
  78 ofscm_print_objfile_smob (SCM self, SCM port, scm_print_state *pstate)
  79 {
  80   objfile_smob *o_smob = (objfile_smob *) SCM_SMOB_DATA (self);
  81
  82   gdbscm_printf (port, "#<%s ", objfile_smob_name);
  83   gdbscm_printf (port, "%s",
  84                  o_smob->objfile != NULL
  85                  ? objfile_name (o_smob->objfile)
  86                  : "{invalid}");
  87   scm_puts (">", port);
  88
  89   scm_remember_upto_here_1 (self);
  90
  91   /* Non-zero means success.  */
  92   return 1;
  93 }
  94
  95 /* Low level routine to create a <gdb:objfile> object.
  96    It's empty in the sense that an OBJFILE still needs to be associated
  97    with it.  */
  98
  99 static SCM
 100 ofscm_make_objfile_smob (void)
 101 {
 102   objfile_smob *o_smob = (objfile_smob *)
 103     scm_gc_malloc (sizeof (objfile_smob), objfile_smob_name);
 104   SCM o_scm;
 105
 106   o_smob->objfile = NULL;
 107   o_smob->pretty_printers = SCM_EOL;
 108   o_scm = scm_new_smob (objfile_smob_tag, (scm_t_bits) o_smob);
 109   o_smob->containing_scm = o_scm;
 110   gdbscm_init_gsmob (&o_smob->base);
 111
 112   return o_scm;
 113 }
 114
 115 /* Return non-zero if SCM is a <gdb:objfile> object.  */
 116
 117 static int
 118 ofscm_is_objfile (SCM scm)
 119 {
 120   return SCM_SMOB_PREDICATE (objfile_smob_tag, scm);
 121 }
 122
 123 /* (objfile? object) -> boolean */
 124
 125 static SCM
 126 gdbscm_objfile_p (SCM scm)
 127 {
 128   return scm_from_bool (ofscm_is_objfile (scm));
 129 }
 130
 131 /* Return a pointer to the objfile_smob that encapsulates OBJFILE,
 132    creating one if necessary.
 133    The result is cached so that we have only one copy per objfile.  */
 134
 135 objfile_smob *
 136 ofscm_objfile_smob_from_objfile (struct objfile *objfile)
 137 {
 138   objfile_smob *o_smob;
 139
 140   o_smob = ofscm_objfile_data_key.get (objfile);
 141   if (o_smob == NULL)
 142     {
 143       SCM o_scm = ofscm_make_objfile_smob ();
 144
 145       o_smob = (objfile_smob *) SCM_SMOB_DATA (o_scm);
 146       o_smob->objfile = objfile;
 147
 148       ofscm_objfile_data_key.set (objfile, o_smob);
 149       scm_gc_protect_object (o_smob->containing_scm);
 150     }
 151
 152   return o_smob;
 153 }
 154
 155 /* Return the <gdb:objfile> object that encapsulates OBJFILE.  */
 156
 157 SCM
 158 ofscm_scm_from_objfile (struct objfile *objfile)
 159 {
 160   objfile_smob *o_smob = ofscm_objfile_smob_from_objfile (objfile);
 161
 162   return o_smob->containing_scm;
 163 }
 164
 165 /* Returns the <gdb:objfile> object in SELF.
 166    Throws an exception if SELF is not a <gdb:objfile> object.  */
 167
 168 static SCM
 169 ofscm_get_objfile_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 170 {
 171   SCM_ASSERT_TYPE (ofscm_is_objfile (self), self, arg_pos, func_name,
 172                    objfile_smob_name);
 173
 174   return self;
 175 }
 176
 177 /* Returns a pointer to the objfile smob of SELF.
 178    Throws an exception if SELF is not a <gdb:objfile> object.  */
 179
 180 static objfile_smob *
 181 ofscm_get_objfile_smob_arg_unsafe (SCM self, int arg_pos,
 182                                    const char *func_name)
 183 {
 184   SCM o_scm = ofscm_get_objfile_arg_unsafe (self, arg_pos, func_name);
 185   objfile_smob *o_smob = (objfile_smob *) SCM_SMOB_DATA (o_scm);
 186
 187   return o_smob;
 188 }
 189
 190 /* Return non-zero if objfile O_SMOB is valid.  */
 191
 192 static int
 193 ofscm_is_valid (objfile_smob *o_smob)
 194 {
 195   return o_smob->objfile != NULL;
 196 }
 197
 198 /* Return the objfile smob in SELF, verifying it's valid.
 199    Throws an exception if SELF is not a <gdb:objfile> object or is invalid.  */
 200
 201 static objfile_smob *
 202 ofscm_get_valid_objfile_smob_arg_unsafe (SCM self, int arg_pos,
 203                                          const char *func_name)
 204 {
 205   objfile_smob *o_smob
 206     = ofscm_get_objfile_smob_arg_unsafe (self, arg_pos, func_name);
 207
 208   if (!ofscm_is_valid (o_smob))
 209     {
 210       gdbscm_invalid_object_error (func_name, arg_pos, self,
 211                                    _("<gdb:objfile>"));
 212     }
 213
 214   return o_smob;
 215 }
 216 \f
 217 /* Objfile methods.  */
 218
 219 /* (objfile-valid? <gdb:objfile>) -> boolean
 220    Returns #t if this object file still exists in GDB.  */
 221
 222 static SCM
 223 gdbscm_objfile_valid_p (SCM self)
 224 {
 225   objfile_smob *o_smob
 226     = ofscm_get_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 227
 228   return scm_from_bool (o_smob->objfile != NULL);
 229 }
 230
 231 /* (objfile-filename <gdb:objfile>) -> string
 232    Returns the objfile's file name.
 233    Throw's an exception if the underlying objfile is invalid.  */
 234
 235 static SCM
 236 gdbscm_objfile_filename (SCM self)
 237 {
 238   objfile_smob *o_smob
 239     = ofscm_get_valid_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 240
 241   return gdbscm_scm_from_c_string (objfile_name (o_smob->objfile));
 242 }
 243
 244 /* (objfile-progspace <gdb:objfile>) -> <gdb:progspace>
 245    Returns the objfile's progspace.
 246    Throw's an exception if the underlying objfile is invalid.  */
 247
 248 static SCM
 249 gdbscm_objfile_progspace (SCM self)
 250 {
 251   objfile_smob *o_smob
 252     = ofscm_get_valid_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 253
 254   return psscm_scm_from_pspace (o_smob->objfile->pspace);
 255 }
 256
 257 /* (objfile-pretty-printers <gdb:objfile>) -> list
 258    Returns the list of pretty-printers for this objfile.  */
 259
 260 static SCM
 261 gdbscm_objfile_pretty_printers (SCM self)
 262 {
 263   objfile_smob *o_smob
 264     = ofscm_get_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 265
 266   return o_smob->pretty_printers;
 267 }
 268
 269 /* (set-objfile-pretty-printers! <gdb:objfile> list) -> unspecified
 270    Set the pretty-printers for this objfile.  */
 271
 272 static SCM
 273 gdbscm_set_objfile_pretty_printers_x (SCM self, SCM printers)
 274 {
 275   objfile_smob *o_smob
 276     = ofscm_get_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 277
 278   SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (printers)), printers,
 279                    SCM_ARG2, FUNC_NAME, _("list"));
 280
 281   o_smob->pretty_printers = printers;
 282
 283   return SCM_UNSPECIFIED;
 284 }
 285 \f
 286 /* The "current" objfile.  This is set when gdb detects that a new
 287    objfile has been loaded.  It is only set for the duration of a call to
 288    gdbscm_source_objfile_script and gdbscm_execute_objfile_script; it is NULL
 289    at other times.  */
 290 static struct objfile *ofscm_current_objfile;
 291
 292 /* Set the current objfile to OBJFILE and then read FILE named FILENAME
 293    as Guile code.  This does not throw any errors.  If an exception
 294    occurs Guile will print the backtrace.
 295    This is the extension_language_script_ops.objfile_script_sourcer
 296    "method".  */
 297
 298 void
 299 gdbscm_source_objfile_script (const struct extension_language_defn *extlang,
 300                               struct objfile *objfile, FILE *file,
 301                               const char *filename)
 302 {
 303   ofscm_current_objfile = objfile;
 304
 305   gdb::unique_xmalloc_ptr<char> msg = gdbscm_safe_source_script (filename);
 306   if (msg != NULL)
 307     gdb_printf (gdb_stderr, "%s", msg.get ());
 308
 309   ofscm_current_objfile = NULL;
 310 }
 311
 312 /* Set the current objfile to OBJFILE and then read FILE named FILENAME
 313    as Guile code.  This does not throw any errors.  If an exception
 314    occurs Guile will print the backtrace.
 315    This is the extension_language_script_ops.objfile_script_sourcer
 316    "method".  */
 317
 318 void
 319 gdbscm_execute_objfile_script (const struct extension_language_defn *extlang,
 320                                struct objfile *objfile, const char *name,
 321                                const char *script)
 322 {
 323   ofscm_current_objfile = objfile;
 324
 325   gdb::unique_xmalloc_ptr<char> msg
 326     = gdbscm_safe_eval_string (script, 0 /* display_result */);
 327   if (msg != NULL)
 328     gdb_printf (gdb_stderr, "%s", msg.get ());
 329
 330   ofscm_current_objfile = NULL;
 331 }
 332
 333 /* (current-objfile) -> <gdb:objfile>
 334    Return the current objfile, or #f if there isn't one.
 335    Ideally this would be named ofscm_current_objfile, but that name is
 336    taken by the variable recording the current objfile.  */
 337
 338 static SCM
 339 gdbscm_get_current_objfile (void)
 340 {
 341   if (ofscm_current_objfile == NULL)
 342     return SCM_BOOL_F;
 343
 344   return ofscm_scm_from_objfile (ofscm_current_objfile);
 345 }
 346
 347 /* (objfiles) -> list
 348    Return a list of all objfiles in the current program space.  */
 349
 350 static SCM
 351 gdbscm_objfiles (void)
 352 {
 353   SCM result;
 354
 355   result = SCM_EOL;
 356
 357   for (objfile *objf : current_program_space->objfiles ())
 358     {
 359       SCM item = ofscm_scm_from_objfile (objf);
 360
 361       result = scm_cons (item, result);
 362     }
 363
 364   return scm_reverse_x (result, SCM_EOL);
 365 }
 366 \f
 367 /* Initialize the Scheme objfile support.  */
 368
 369 static const scheme_function objfile_functions[] =
 370 {
 371   { "objfile?", 1, 0, 0, as_a_scm_t_subr (gdbscm_objfile_p),
 372     "\
 373 Return #t if the object is a <gdb:objfile> object." },
 374
 375   { "objfile-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_objfile_valid_p),
 376     "\
 377 Return #t if the objfile is valid (hasn't been deleted from gdb)." },
 378
 379   { "objfile-filename", 1, 0, 0, as_a_scm_t_subr (gdbscm_objfile_filename),
 380     "\
 381 Return the file name of the objfile." },
 382
 383   { "objfile-progspace", 1, 0, 0, as_a_scm_t_subr (gdbscm_objfile_progspace),
 384     "\
 385 Return the progspace that the objfile lives in." },
 386
 387   { "objfile-pretty-printers", 1, 0, 0,
 388     as_a_scm_t_subr (gdbscm_objfile_pretty_printers),
 389     "\
 390 Return a list of pretty-printers of the objfile." },
 391
 392   { "set-objfile-pretty-printers!", 2, 0, 0,
 393     as_a_scm_t_subr (gdbscm_set_objfile_pretty_printers_x),
 394     "\
 395 Set the list of pretty-printers of the objfile." },
 396
 397   { "current-objfile", 0, 0, 0, as_a_scm_t_subr (gdbscm_get_current_objfile),
 398     "\
 399 Return the current objfile if there is one or #f if there isn't one." },
 400
 401   { "objfiles", 0, 0, 0, as_a_scm_t_subr (gdbscm_objfiles),
 402     "\
 403 Return a list of all objfiles in the current program space." },
 404
 405   END_FUNCTIONS
 406 };
 407
 408 void
 409 gdbscm_initialize_objfiles (void)
 410 {
 411   objfile_smob_tag
 412     = gdbscm_make_smob_type (objfile_smob_name, sizeof (objfile_smob));
 413   scm_set_smob_print (objfile_smob_tag, ofscm_print_objfile_smob);
 414
 415   gdbscm_define_functions (objfile_functions, 1);
 416 }