gdb/guile/scm-objfile.c

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