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