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 = 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_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-pretty-printers <gdb:objfile>) -> list
 256    Returns the list of pretty-printers for this objfile.  */
 257
 258 static SCM
 259 gdbscm_objfile_pretty_printers (SCM self)
 260 {
 261   objfile_smob *o_smob
 262     = ofscm_get_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 263
 264   return o_smob->pretty_printers;
 265 }
 266
 267 /* (set-objfile-pretty-printers! <gdb:objfile> list) -> unspecified
 268    Set the pretty-printers for this objfile.  */
 269
 270 static SCM
 271 gdbscm_set_objfile_pretty_printers_x (SCM self, SCM printers)
 272 {
 273   objfile_smob *o_smob
 274     = ofscm_get_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 275
 276   SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (printers)), printers,
 277                    SCM_ARG2, FUNC_NAME, _("list"));
 278
 279   o_smob->pretty_printers = printers;
 280
 281   return SCM_UNSPECIFIED;
 282 }
 283 \f
 284 /* The "current" objfile.  This is set when gdb detects that a new
 285    objfile has been loaded.  It is only set for the duration of a call to
 286    gdbscm_source_objfile_script and gdbscm_execute_objfile_script; it is NULL
 287    at other times.  */
 288 static struct objfile *ofscm_current_objfile;
 289
 290 /* Set the current objfile to OBJFILE and then read FILE named FILENAME
 291    as Guile code.  This does not throw any errors.  If an exception
 292    occurs Guile will print the backtrace.
 293    This is the extension_language_script_ops.objfile_script_sourcer
 294    "method".  */
 295
 296 void
 297 gdbscm_source_objfile_script (const struct extension_language_defn *extlang,
 298                               struct objfile *objfile, FILE *file,
 299                               const char *filename)
 300 {
 301   char *msg;
 302
 303   ofscm_current_objfile = objfile;
 304
 305   msg = gdbscm_safe_source_script (filename);
 306   if (msg != NULL)
 307     {
 308       fprintf_filtered (gdb_stderr, "%s", msg);
 309       xfree (msg);
 310     }
 311
 312   ofscm_current_objfile = NULL;
 313 }
 314
 315 /* Set the current objfile to OBJFILE and then read FILE named FILENAME
 316    as Guile code.  This does not throw any errors.  If an exception
 317    occurs Guile will print the backtrace.
 318    This is the extension_language_script_ops.objfile_script_sourcer
 319    "method".  */
 320
 321 void
 322 gdbscm_execute_objfile_script (const struct extension_language_defn *extlang,
 323                                struct objfile *objfile, const char *name,
 324                                const char *script)
 325 {
 326   char *msg;
 327
 328   ofscm_current_objfile = objfile;
 329
 330   msg = gdbscm_safe_eval_string (script, 0 /* display_result */);
 331   if (msg != NULL)
 332     {
 333       fprintf_filtered (gdb_stderr, "%s", msg);
 334       xfree (msg);
 335     }
 336
 337   ofscm_current_objfile = NULL;
 338 }
 339
 340 /* (current-objfile) -> <gdb:obfjile>
 341    Return the current objfile, or #f if there isn't one.
 342    Ideally this would be named ofscm_current_objfile, but that name is
 343    taken by the variable recording the current objfile.  */
 344
 345 static SCM
 346 gdbscm_get_current_objfile (void)
 347 {
 348   if (ofscm_current_objfile == NULL)
 349     return SCM_BOOL_F;
 350
 351   return ofscm_scm_from_objfile (ofscm_current_objfile);
 352 }
 353
 354 /* (objfiles) -> list
 355    Return a list of all objfiles in the current program space.  */
 356
 357 static SCM
 358 gdbscm_objfiles (void)
 359 {
 360   struct objfile *objf;
 361   SCM result;
 362
 363   result = SCM_EOL;
 364
 365   ALL_OBJFILES (objf)
 366   {
 367     SCM item = ofscm_scm_from_objfile (objf);
 368
 369     result = scm_cons (item, result);
 370   }
 371
 372   return scm_reverse_x (result, SCM_EOL);
 373 }
 374 \f
 375 /* Initialize the Scheme objfile support.  */
 376
 377 static const scheme_function objfile_functions[] =
 378 {
 379   { "objfile?", 1, 0, 0, gdbscm_objfile_p,
 380     "\
 381 Return #t if the object is a <gdb:objfile> object." },
 382
 383   { "objfile-valid?", 1, 0, 0, gdbscm_objfile_valid_p,
 384     "\
 385 Return #t if the objfile is valid (hasn't been deleted from gdb)." },
 386
 387   { "objfile-filename", 1, 0, 0, gdbscm_objfile_filename,
 388     "\
 389 Return the file name of the objfile." },
 390
 391   { "objfile-pretty-printers", 1, 0, 0, gdbscm_objfile_pretty_printers,
 392     "\
 393 Return a list of pretty-printers of the objfile." },
 394
 395   { "set-objfile-pretty-printers!", 2, 0, 0,
 396     gdbscm_set_objfile_pretty_printers_x,
 397     "\
 398 Set the list of pretty-printers of the objfile." },
 399
 400   { "current-objfile", 0, 0, 0, gdbscm_get_current_objfile,
 401     "\
 402 Return the current objfile if there is one or #f if there isn't one." },
 403
 404   { "objfiles", 0, 0, 0, gdbscm_objfiles,
 405     "\
 406 Return a list of all objfiles in the current program space." },
 407
 408   END_FUNCTIONS
 409 };
 410
 411 void
 412 gdbscm_initialize_objfiles (void)
 413 {
 414   objfile_smob_tag
 415     = gdbscm_make_smob_type (objfile_smob_name, sizeof (objfile_smob));
 416   scm_set_smob_print (objfile_smob_tag, ofscm_print_objfile_smob);
 417
 418   gdbscm_define_functions (objfile_functions, 1);
 419
 420   ofscm_objfile_data_key
 421     = register_objfile_data_with_cleanup (NULL, ofscm_handle_objfile_deleted);
 422 }