gdb/guile/scm-objfile.c

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