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