libgeda/src/scheme_smob.c

   1 /* gEDA - GPL Electronic Design Automation
   2  * libgeda - gEDA's library - Scheme API
   3  * Copyright (C) 2010-2013 Peter Brett <peter@peter-b.co.uk>
   4  *
   5  * This program is free software; you can redistribute it and/or modify
   6  * it under the terms of the GNU General Public License as published by
   7  * the Free Software Foundation; either version 2 of the License, or
   8  * (at your option) any later version.
   9  *
  10  * This program is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  * GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with this program; if not, write to the Free Software
  17  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
  18  */
  19
  20 /*!
  21  * \file scheme_smob.c
  22  * \brief Scheme representations of gEDA C structures
  23  *
  24  * In order for Scheme code to be able to manipulate libgeda data
  25  * structures, it is convenient for it to be able to get handles to
  26  * several of the different C structures that libgeda uses, in
  27  * particular #TOPLEVEL, #PAGE and #OBJECT.
  28  *
  29  * A particular issue is that, in principle, Guile can stash a
  30  * variable somewhere and only try and access it much later, possibly
  31  * after the underlying C structure has already been freed.
  32  *
  33  * In order to avoid this situation causing a segmentation fault, weak
  34  * references are used. In the case of #PAGE and #TOPLEVEL handles,
  35  * the usage is quite straightforward; Scheme code can never create or
  36  * destroy a #TOPLEVEL; and although a #PAGE can be created by Scheme
  37  * code, it must explicitly be destroyed if the Scheme code doesn't
  38  * want the #PAGE to hang around after it returns.
  39  *
  40  * #OBJECT handles are a more complex case. It's possible that Scheme
  41  * code may legitimately want to create an #OBJECT and do something
  42  * with it (or, similarly, pull an #OBJECT out of a #PAGE), without
  43  * needing to carefully keep track of the #OBJECT to avoid dropping it
  44  * on the floor. In that case, users should be able to rely on the
  45  * garbage collector.
  46  *
  47  * For that reason, an #OBJECT is marked to be destroyed by
  48  * garbage-collection in two cases:
  49  *
  50  * -# If they have been created by Scheme code, but not yet added to a
  51  *    PAGE.
  52  * -# If they have been removed from a #PAGE by Scheme code, but not
  53  *    yet re-added to a #PAGE.
  54  *
  55  * \sa weakref.c
  56  *
  57  * This file also provides support for a variety of GObject-based gEDA
  58  * types, including EdaConfig instances.
  59  */
  60
  61 #include <config.h>
  62
  63 #include "libgeda_priv.h"
  64 #include "libgedaguile_priv.h"
  65
  66 scm_t_bits geda_smob_tag;
  67
  68 /*! \brief Weak reference notify function for gEDA smobs.
  69  * \par Function Description
  70  * Clears a gEDA smob's pointer when the target object is destroyed.
  71  */
  72 static void
  73 smob_weakref_notify (void *target, void *smob) {
  74   SCM s = SCM_PACK ((scm_t_bits) smob);
  75   SCM_SET_SMOB_DATA (s, NULL);
  76 }
  77
  78 /*! \brief Weak reference notify function for double-length gEDA smobs.
  79  * \par Function Description
  80  * Clears a gEDA smob's second pointer when the target object is
  81  * destroyed.
  82  *
  83  * \see edascm_from_object().
  84  */
  85 static void
  86 smob_weakref2_notify (void *target, void *smob) {
  87   SCM s = SCM_PACK ((scm_t_bits) smob);
  88   SCM_SET_SMOB_DATA_2 (s, NULL);
  89 }
  90
  91 /*! \brief Free a gEDA smob.
  92  * \par Function Description
  93  * Finalizes a gEDA smob for deletion, removing the weak reference.
  94  *
  95  * Used internally to Guile.
  96  */
  97 static size_t
  98 smob_free (SCM smob)
  99 {
 100   void *data;
 101
 102   /* If the weak reference has already been cleared, do nothing */
 103   if (!EDASCM_SMOB_VALIDP(smob)) return 0;
 104
 105   data = (void *) SCM_SMOB_DATA (smob);
 106
 107   /* Otherwise, clear the weak reference */
 108   switch (EDASCM_SMOB_TYPE (smob)) {
 109   case GEDA_SMOB_TOPLEVEL:
 110     s_toplevel_weak_unref ((TOPLEVEL *) data, smob_weakref_notify, (void *) SCM_UNPACK (smob));
 111     break;
 112   case GEDA_SMOB_PAGE:
 113     s_page_weak_unref ((PAGE *) data, smob_weakref_notify, (void *) SCM_UNPACK (smob));
 114     break;
 115   case GEDA_SMOB_OBJECT:
 116     /* See edascm_from_object() for an explanation of why OBJECT
 117      * smobs store a TOPLEVEL in the second data word */
 118     s_object_weak_unref ((OBJECT *) data, smob_weakref_notify, (void *) SCM_UNPACK (smob));
 119     s_toplevel_weak_unref ((TOPLEVEL *) SCM_SMOB_DATA_2 (smob),
 120                            smob_weakref2_notify, (void *) SCM_UNPACK (smob));
 121     break;
 122   case GEDA_SMOB_CONFIG:
 123     g_object_unref (G_OBJECT (data));
 124     break;
 125   case GEDA_SMOB_CLOSURE:
 126     break;
 127   default:
 128     /* This should REALLY definitely never be run */
 129     g_critical ("%s: received bad smob flags.", __FUNCTION__);
 130   }
 131
 132   /* If the smob is marked as garbage-collectable, destroy its
 133    * contents.
 134    *
 135    * Because PAGEs and TOPLEVELs should never be garbage collected,
 136    * emit critical warnings if the GC tries to free them.
 137    */
 138   if (EDASCM_SMOB_GCP (smob)) {
 139     switch (EDASCM_SMOB_TYPE (smob)) {
 140     case GEDA_SMOB_TOPLEVEL:
 141       g_critical ("%s: Blocked garbage-collection of TOPLEVEL %p",
 142                  __FUNCTION__, data);
 143       break;
 144     case GEDA_SMOB_PAGE:
 145       g_critical ("%s: Blocked garbage-collection of PAGE %p",
 146                  __FUNCTION__, data);
 147       break;
 148     case GEDA_SMOB_OBJECT:
 149       /* See edascm_from_object() for an explanation of why OBJECT
 150        * smobs store a TOPLEVEL in the second data word */
 151       s_delete_object ((TOPLEVEL *) SCM_SMOB_DATA_2 (smob), (OBJECT *) data);
 152       break;
 153     case GEDA_SMOB_CONFIG:
 154       /* These are reference counted, so the structure will have
 155        * already been destroyed above if appropriate. */
 156       break;
 157     case GEDA_SMOB_CLOSURE:
 158       break;
 159     default:
 160       /* This should REALLY definitely never be run */
 161       g_critical ("%s: received bad smob flags.", __FUNCTION__);
 162     }
 163   }
 164   return 0;
 165 }
 166
 167 /*! \brief Print a representation of a gEDA smob.
 168  * \par Function Description
 169  * Outputs a string representing the gEDA \a smob to a Scheme output
 170  * \a port. The format used is "#<geda-TYPE b7ef65d0>", where TYPE is
 171  * a string describing the C structure represented by the gEDA smob.
 172  *
 173  * Used internally to Guile.
 174  */
 175 static int
 176 smob_print (SCM smob, SCM port, scm_print_state *pstate)
 177 {
 178   gchar *hexstring;
 179
 180   scm_puts ("#<geda-", port);
 181
 182   switch (EDASCM_SMOB_TYPE (smob)) {
 183   case GEDA_SMOB_TOPLEVEL:
 184     scm_puts ("toplevel", port);
 185     break;
 186   case GEDA_SMOB_PAGE:
 187     scm_puts ("page", port);
 188     break;
 189   case GEDA_SMOB_OBJECT:
 190     scm_puts ("object", port);
 191     break;
 192   case GEDA_SMOB_CONFIG:
 193     scm_puts ("config", port);
 194     break;
 195   case GEDA_SMOB_CLOSURE:
 196     scm_puts ("closure", port);
 197     break;
 198   default:
 199     g_critical ("%s: received bad smob flags.", __FUNCTION__);
 200     scm_puts ("unknown", port);
 201   }
 202
 203   if (SCM_SMOB_DATA (smob) != 0) {
 204     scm_dynwind_begin (0);
 205     hexstring = g_strdup_printf (" %p", (void *) SCM_SMOB_DATA (smob));
 206     scm_dynwind_unwind_handler (g_free, hexstring, SCM_F_WIND_EXPLICITLY);
 207     scm_puts (hexstring, port);
 208     scm_dynwind_end ();
 209   } else {
 210     scm_puts (" (null)", port);
 211   }
 212
 213   scm_puts (">", port);
 214
 215   /* Non-zero means success */
 216   return 1;
 217 }
 218
 219 /*! \brief Check gEDA smobs for equality.
 220  * \par Function description
 221  * Returns SCM_BOOL_T if \a obj1 represents the same gEDA structure as
 222  * \a obj2 does. Otherwise, returns SCM_BOOL_F.
 223  *
 224  * Used internally to Guile.
 225  */
 226 static SCM
 227 smob_equalp (SCM obj1, SCM obj2)
 228 {
 229   EDASCM_ASSERT_SMOB_VALID (obj1);
 230   EDASCM_ASSERT_SMOB_VALID (obj2);
 231
 232   if (SCM_SMOB_DATA (obj1) == SCM_SMOB_DATA (obj2)) {
 233     return SCM_BOOL_T;
 234   } else {
 235     return SCM_BOOL_F;
 236   }
 237 }
 238
 239 /*! \brief Get the smob for a TOPLEVEL.
 240  * \ingroup guile_c_iface
 241  * \par Function Description
 242  * Create a new smob representing \a toplevel.
 243  *
 244  * \param toplevel #TOPLEVEL to create a smob for.
 245  * \return a smob representing \a toplevel.
 246  */
 247 SCM
 248 edascm_from_toplevel (TOPLEVEL *toplevel)
 249 {
 250   SCM smob;
 251
 252   SCM_NEWSMOB (smob, geda_smob_tag, toplevel);
 253   SCM_SET_SMOB_FLAGS (smob, GEDA_SMOB_TOPLEVEL);
 254
 255   /* Set weak reference */
 256   s_toplevel_weak_ref (toplevel, smob_weakref_notify, (void *) SCM_UNPACK (smob));
 257
 258   return smob;
 259 }
 260
 261 /*! \brief Get a smob for a page.
 262  * \ingroup guile_c_iface
 263  * \par Function Description
 264  * Create a new smob representing \a page.
 265  *
 266  * \param page #PAGE to create a smob for.
 267  * \return a smob representing \a page.
 268  */
 269 SCM
 270 edascm_from_page (PAGE *page)
 271 {
 272   SCM smob;
 273
 274   SCM_NEWSMOB (smob, geda_smob_tag, page);
 275   SCM_SET_SMOB_FLAGS (smob, GEDA_SMOB_PAGE);
 276
 277   /* Set weak reference */
 278   s_page_weak_ref (page, smob_weakref_notify, (void *) SCM_UNPACK (smob));
 279
 280   return smob;
 281 }
 282
 283 /*! \brief Get a page from a smob.
 284  * \ingroup guile_c_iface
 285  * \par Function Description
 286  * Return the #PAGE represented by \a smob.
 287  *
 288  * \param [in] smob Guile value to retrieve #PAGE from.
 289  * \return the #PAGE represented by \a smob.
 290  */
 291 PAGE *
 292 edascm_to_page (SCM smob)
 293 {
 294 #ifndef NDEBUG
 295   SCM_ASSERT (EDASCM_PAGEP (smob), smob,
 296               SCM_ARG1, "edascm_to_page");
 297 #endif
 298   EDASCM_ASSERT_SMOB_VALID (smob);
 299
 300   return (PAGE *) SCM_SMOB_DATA (smob);
 301 }
 302
 303 /*! \brief Get a smob for a schematic object.
 304  * \ingroup guile_c_iface
 305  * \par Function Description
 306  * Create a new smob representing \a object.
 307  *
 308  * \warning The returned smob is initially marked as owned by the C
 309  *   code. If it should be permitted to be garbage-collected, you
 310  *   should set the garbage-collectable flag by calling:
 311  *
 312  * \code
 313  *   SCM x = edascm_from_object (object);
 314  *   edascm_c_set_gc (x, 1);
 315  * \endcode
 316  *
 317  * \note We currently have to bake a TOPLEVEL pointer into the smob,
 318  * so that if the object becomes garbage-collectable we can obtain a
 319  * TOPLEVEL to use for deleting the smob without accessing the
 320  * TOPLEVEL fluid and potentially causing a race condition (see bug
 321  * 909358).
 322  *
 323  * \param object #OBJECT to create a smob for.
 324  * \return a smob representing \a object.
 325  */
 326 SCM
 327 edascm_from_object (OBJECT *object)
 328 {
 329   SCM smob;
 330   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
 331
 332   SCM_NEWSMOB2 (smob, geda_smob_tag, object, toplevel);
 333   SCM_SET_SMOB_FLAGS (smob, GEDA_SMOB_OBJECT);
 334
 335   /* Set weak references */
 336   s_object_weak_ref (object, smob_weakref_notify, (void *) SCM_UNPACK (smob));
 337   s_toplevel_weak_ref (toplevel, smob_weakref2_notify, (void *) SCM_UNPACK (smob));
 338
 339   return smob;
 340 }
 341
 342 /*! \brief Get a schematic object from a smob.
 343  * \ingroup guile_c_iface
 344  * \par Function Description
 345  * Return the #OBJECT represented by \a smob.
 346  *
 347  * \param [in] smob Guile value to retrieve #OBJECT from.
 348  * \return the #OBJECT represented by \a smob.
 349  */
 350 OBJECT *
 351 edascm_to_object (SCM smob)
 352 {
 353 #ifndef NDEBUG
 354   SCM_ASSERT (EDASCM_OBJECTP (smob), smob,
 355               SCM_ARG1, "edascm_to_object");
 356 #endif
 357   EDASCM_ASSERT_SMOB_VALID (smob);
 358
 359   return (OBJECT *) SCM_SMOB_DATA (smob);
 360 }
 361
 362 /*! \brief Get a smob for a configuration context.
 363  * \ingroup guile_c_iface
 364  * \par Function Description
 365  * Create a new smob representing \a cfg.
 366  *
 367  * \param cfg Configuration context to create a smob for.
 368  * \return a smob representing \a cfg.
 369  */
 370 SCM
 371 edascm_from_config (EdaConfig *cfg)
 372 {
 373   SCM smob;
 374   SCM_NEWSMOB (smob, geda_smob_tag, g_object_ref (cfg));
 375   SCM_SET_SMOB_FLAGS (smob, GEDA_SMOB_CONFIG);
 376   return smob;
 377 }
 378
 379 /*! \brief Get a configuration context from a smob.
 380  * \ingroup guile_c_iface
 381  * \par Function Description
 382  * Return the #EdaConfig represented by \a smob.
 383  *
 384  * \param [in] smob Guile value to retrieve #EdaConfig from.
 385  * \return the #EdaConfig represented by \a smob.
 386  */
 387 EdaConfig *
 388 edascm_to_config (SCM smob)
 389 {
 390 #ifndef NDEBUG
 391   SCM_ASSERT (EDASCM_CONFIGP (smob), smob,
 392               SCM_ARG1, "edascm_to_object");
 393 #endif
 394   EDASCM_ASSERT_SMOB_VALID (smob);
 395
 396   return EDA_CONFIG (SCM_SMOB_DATA (smob));
 397 }
 398
 399 /*! \brief Get a smob for a C closure.
 400  * \par Function Description
 401  * Create a new smob representing a C closure.
 402  *
 403  * \warning Do not call this function from user code; use
 404  * edascm_c_make_closure() instead.
 405  *
 406  * \param func C function to make closure around.
 407  * \param user_data User data for function.
 408  * \return a C closure smob.
 409  */
 410 SCM
 411 edascm_from_closure (SCM (*func)(SCM, gpointer), gpointer user_data)
 412 {
 413   SCM smob;
 414   SCM_NEWSMOB2 (smob, geda_smob_tag, func, user_data);
 415   SCM_SET_SMOB_FLAGS (smob, GEDA_SMOB_CLOSURE);
 416   return smob;
 417 }
 418
 419 /*! \brief Set whether a gEDA object may be garbage collected.
 420  * \ingroup guile_c_iface
 421  * \par Function Description
 422  * If \a gc is non-zero, allow the structure represented by \a smob to
 423  * be destroyed when \a smob is garbage-collected.
 424  *
 425  * \param [in,out] smob Smob for which to set garbage-collection
 426  *                      permission.
 427  * \param [in]     gc    If non-zero, permit garbage collection.
 428  */
 429 void
 430 edascm_c_set_gc (SCM smob, int gc)
 431 {
 432   EDASCM_ASSERT_SMOB_VALID (smob);
 433   EDASCM_SMOB_SET_GC (smob, gc);
 434 }
 435
 436 /*! \brief Test whether a smob is a #OBJECT instance
 437  * \ingroup guile_c_iface
 438  * \par Function Description
 439  * If \a smob is a #OBJECT instance, returns non-zero. Otherwise,
 440  * returns zero.
 441  *
 442  * \param [in] smob Guile value to test.
 443  *
 444  * \return non-zero iff \a smob is a #OBJECT instance.
 445  */
 446 int
 447 edascm_is_object (SCM smob)
 448 {
 449   return EDASCM_OBJECTP (smob);
 450 }
 451
 452 /*! \brief Test whether a smob is a #PAGE instance
 453  * \ingroup guile_c_iface
 454  * \par Function Description
 455  * If \a smob is a #PAGE instance, returns non-zero. Otherwise,
 456  * returns zero.
 457  *
 458  * \param [in] smob Guile value to test.
 459  *
 460  * \return non-zero iff \a smob is a #PAGE instance.
 461  */
 462 int
 463 edascm_is_page (SCM smob)
 464 {
 465   return EDASCM_PAGEP (smob);
 466 }
 467
 468 /*! \brief Test whether a smob is an #EdaConfig instance.
 469  * \ingroup guile_c_iface
 470  * \par Function Description
 471  * If \a smob is a configuration context, returns non-zero. Otherwise,
 472  * returns zero.
 473  *
 474  * \param [in] smob Guile value to test.
 475  * \return non-zero iff \a smob is an #EdaConfig instance.
 476  */
 477 int
 478 edascm_is_config (SCM smob)
 479 {
 480   return EDASCM_CONFIGP (smob);
 481 }
 482
 483 /*! \brief Test whether a smob is a #PAGE instance.
 484  * \par Function Description
 485  * If \a page_smob is a #PAGE instance, returns \b SCM_BOOL_T;
 486  * otherwise returns \b SCM_BOOL_F.
 487  *
 488  * \note Scheme API: Implements the %page? procedure in the (geda
 489  * core smob) module.
 490  *
 491  * \param [in] page_smob Guile value to test.
 492  *
 493  * \return SCM_BOOL_T iff \a page_smob is a #PAGE instance.
 494  */
 495 SCM_DEFINE (page_p, "%page?", 1, 0, 0,
 496             (SCM page_smob),
 497             "Test whether the value is a gEDA PAGE instance.")
 498 {
 499   return (EDASCM_PAGEP (page_smob) ? SCM_BOOL_T : SCM_BOOL_F);
 500 }
 501
 502 /*! \brief Test whether a smob is an #OBJECT instance.
 503  * \par Function Description
 504  * If \a object_smob is an #OBJECT instance, returns \b SCM_BOOL_T;
 505  * otherwise returns \b SCM_BOOL_F.
 506  *
 507  * \note Scheme API: Implements the %object? procedure in the (geda
 508  * core smob) module.
 509  *
 510  * \param [in] object_smob Guile value to test.
 511  *
 512  * \return SCM_BOOL_T iff \a object_smob is an #OBJECT instance.
 513  */
 514 SCM_DEFINE (object_p, "%object?", 1, 0, 0,
 515             (SCM object_smob),
 516             "Test whether the value is a gEDA OBJECT instance.")
 517 {
 518   return (EDASCM_OBJECTP (object_smob) ? SCM_BOOL_T : SCM_BOOL_F);
 519 }
 520
 521 /*! \brief Test whether a smob is an #EdaConfig instance.
 522  * \par Function Description
 523  * If \a config_smob is a configuration context, returns \b
 524  * SCM_BOOL_T; otherwise returns \b SCM_BOOL_F.
 525  *
 526  * \note Scheme API: Implements the %config? procedure in the (geda
 527  * core smob) module.
 528  *
 529  * \param [in] config_smob Guile value to test.
 530  *
 531  * \return SCM_BOOL_T iff \a config_smob is an #EdaConfig instance.
 532  */
 533 SCM_DEFINE (config_p, "%config?", 1, 0, 0,
 534             (SCM config_smob),
 535             "Test whether the value is a gEDA configuration context.")
 536 {
 537   return (EDASCM_CONFIGP (config_smob) ? SCM_BOOL_T : SCM_BOOL_F);
 538 }
 539
 540 /*!
 541  * \brief Create the (geda core smob) Scheme module.
 542  * \par Function Description
 543  * Defines procedures in the (geda core smob) module. The module can
 544  * be accessed using (use-modules (geda core smob)).
 545  */
 546 static void
 547 init_module_geda_core_smob ()
 548 {
 549   /* Register the functions. */
 550   #include "scheme_smob.x"
 551
 552   /* Add them to the module's public definitions. */
 553   scm_c_export (s_page_p, s_object_p, s_config_p, NULL);
 554 }
 555
 556 /*!
 557  * \brief Initialise the basic gEDA smob types.
 558  * \par Function Description
 559  * Registers the gEDA core smob types and some procedures acting on
 560  * them.  gEDA only uses a single Guile smob, and uses the flags field
 561  * to multiplex the several different underlying C structures that may
 562  * be represented by that smob. Should only be called by
 563  * edascm_init().
 564  */
 565 void
 566 edascm_init_smob ()
 567 {
 568   /* Register gEDA smob type */
 569   geda_smob_tag = scm_make_smob_type ("geda", 0);
 570   scm_set_smob_free (geda_smob_tag, smob_free);
 571   scm_set_smob_print (geda_smob_tag, smob_print);
 572   scm_set_smob_equalp (geda_smob_tag, smob_equalp);
 573
 574   /* Define the (geda core smob) module */
 575   scm_c_define_module ("geda core smob",
 576                        init_module_geda_core_smob,
 577                        NULL);
 578 }