gdb/guile/scm-objfile.c

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