scheme_smob.c

Go to the documentation of this file.

/* gEDA - GPL Electronic Design Automation
 * libgeda - gEDA's library - Scheme API
 * Copyright (C) 2010-2012 Peter Brett <peter@peter-b.co.uk>
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
 */

#include <config.h>

#include "libgeda_priv.h"
#include "libgedaguile_priv.h"

scm_t_bits geda_smob_tag;

static void
smob_weakref_notify (void *target, void *smob) {
  SCM s = (SCM) smob;
  SCM_SET_SMOB_DATA (s, NULL);
}

static void
smob_weakref2_notify (void *target, void *smob) {
  SCM s = (SCM) smob;
  SCM_SET_SMOB_DATA_2 (s, NULL);
}

static size_t
smob_free (SCM smob)
{
  void *data;

  /* If the weak reference has already been cleared, do nothing */
  if (!EDASCM_SMOB_VALIDP(smob)) return 0;

  data = (void *) SCM_SMOB_DATA (smob);

  /* Otherwise, clear the weak reference */
  switch (EDASCM_SMOB_TYPE (smob)) {
  case GEDA_SMOB_TOPLEVEL:
    s_toplevel_weak_unref ((TOPLEVEL *) data, smob_weakref_notify, smob);
    break;
  case GEDA_SMOB_PAGE:
    s_page_weak_unref ((PAGE *) data, smob_weakref_notify, smob);
    break;
  case GEDA_SMOB_OBJECT:
    /* See edascm_from_object() for an explanation of why OBJECT
     * smobs store a TOPLEVEL in the second data word */
    s_object_weak_unref ((OBJECT *) data, smob_weakref_notify, smob);
    s_toplevel_weak_unref ((TOPLEVEL *) SCM_SMOB_DATA_2 (smob),
                           smob_weakref2_notify, smob);
    break;
  default:
    /* This should REALLY definitely never be run */
    g_critical ("%s: received bad smob flags.", __FUNCTION__);
  }

  /* If the smob is marked as garbage-collectable, destroy its
   * contents.
   *
   * Because PAGEs and TOPLEVELs should never be garbage collected,
   * emit critical warnings if the GC tries to free them.
   */
  if (EDASCM_SMOB_GCP (smob)) {
    switch (EDASCM_SMOB_TYPE (smob)) {
    case GEDA_SMOB_TOPLEVEL:
      g_critical ("%s: Blocked garbage-collection of TOPLEVEL %p",
                 __FUNCTION__, data);
      break;
    case GEDA_SMOB_PAGE:
      g_critical ("%s: Blocked garbage-collection of PAGE %p",
                 __FUNCTION__, data);
      break;
    case GEDA_SMOB_OBJECT:
      /* See edascm_from_object() for an explanation of why OBJECT
       * smobs store a TOPLEVEL in the second data word */
      s_delete_object ((TOPLEVEL *) SCM_SMOB_DATA_2 (smob), (OBJECT *) data);
      break;
    default:
      /* This should REALLY definitely never be run */
      g_critical ("%s: received bad smob flags.", __FUNCTION__);
    }
  }
  return 0;
}

static int
smob_print (SCM smob, SCM port, scm_print_state *pstate)
{
  gchar *hexstring;

  scm_puts ("#<geda-", port);

  switch (EDASCM_SMOB_TYPE (smob)) {
  case GEDA_SMOB_TOPLEVEL:
    scm_puts ("toplevel", port);
    break;
  case GEDA_SMOB_PAGE:
    scm_puts ("page", port);
    break;
  case GEDA_SMOB_OBJECT:
    scm_puts ("object", port);
    break;
  default:
    g_critical ("%s: received bad smob flags.", __FUNCTION__);
    scm_puts ("unknown", port);
  }

  if (SCM_SMOB_DATA (smob) != 0) {
    scm_dynwind_begin (0);
    hexstring = g_strdup_printf (" %p", (void *) SCM_SMOB_DATA (smob));
    scm_dynwind_unwind_handler (g_free, hexstring, SCM_F_WIND_EXPLICITLY);
    scm_puts (hexstring, port);
    scm_dynwind_end ();
  } else {
    scm_puts (" (null)", port);
  }

  scm_puts (">", port);

  /* Non-zero means success */
  return 1;
}

static SCM
smob_equalp (SCM obj1, SCM obj2)
{
  EDASCM_ASSERT_SMOB_VALID (obj1);
  EDASCM_ASSERT_SMOB_VALID (obj2);

  if (SCM_SMOB_DATA (obj1) == SCM_SMOB_DATA (obj2)) {
    return SCM_BOOL_T;
  } else {
    return SCM_BOOL_F;
  }
}

SCM
edascm_from_toplevel (TOPLEVEL *toplevel)
{
  SCM smob;

  SCM_NEWSMOB (smob, geda_smob_tag, toplevel);
  SCM_SET_SMOB_FLAGS (smob, GEDA_SMOB_TOPLEVEL);

  /* Set weak reference */
  s_toplevel_weak_ref (toplevel, smob_weakref_notify, smob);

  return smob;
}

SCM
edascm_from_page (PAGE *page)
{
  SCM smob;

  SCM_NEWSMOB (smob, geda_smob_tag, page);
  SCM_SET_SMOB_FLAGS (smob, GEDA_SMOB_PAGE);

  /* Set weak reference */
  s_page_weak_ref (page, smob_weakref_notify, smob);

  return smob;
}

PAGE *
edascm_to_page (SCM smob)
{
#ifndef NDEBUG
  SCM_ASSERT (EDASCM_PAGEP (smob), smob,
              SCM_ARG1, "edascm_to_page");
#endif
  EDASCM_ASSERT_SMOB_VALID (smob);

  return (PAGE *) SCM_SMOB_DATA (smob);
}

SCM
edascm_from_object (OBJECT *object)
{
  SCM smob;
  TOPLEVEL *toplevel = edascm_c_current_toplevel ();

  SCM_NEWSMOB2 (smob, geda_smob_tag, object, toplevel);
  SCM_SET_SMOB_FLAGS (smob, GEDA_SMOB_OBJECT);

  /* Set weak references */
  s_object_weak_ref (object, smob_weakref_notify, smob);
  s_toplevel_weak_ref (toplevel, smob_weakref2_notify, smob);

  return smob;
}

OBJECT *
edascm_to_object (SCM smob)
{
#ifndef NDEBUG
  SCM_ASSERT (EDASCM_OBJECTP (smob), smob,
              SCM_ARG1, "edascm_to_object");
#endif
  EDASCM_ASSERT_SMOB_VALID (smob);

  return (OBJECT *) SCM_SMOB_DATA (smob);
}

void
edascm_c_set_gc (SCM smob, int gc)
{
  EDASCM_ASSERT_SMOB_VALID (smob);
  EDASCM_SMOB_SET_GC (smob, gc);
}

int
edascm_is_object (SCM smob)
{
  return EDASCM_OBJECTP (smob);
}

int
edascm_is_page (SCM smob)
{
  return EDASCM_PAGEP (smob);
}

SCM_DEFINE (page_p, "%page?", 1, 0, 0,
            (SCM page_smob),
            "Test whether the value is a gEDA PAGE instance.")
{
  return (EDASCM_PAGEP (page_smob) ? SCM_BOOL_T : SCM_BOOL_F);
}

SCM_DEFINE (object_p, "%object?", 1, 0, 0,
            (SCM object_smob),
            "Test whether the value is a gEDA OBJECT instance.")
{
  return (EDASCM_OBJECTP (object_smob) ? SCM_BOOL_T : SCM_BOOL_F);
}

static void
init_module_geda_core_smob ()
{
  /* Register the functions. */
  #include "scheme_smob.x"

  /* Add them to the module's public definitions. */ 
  scm_c_export (s_page_p, s_object_p, NULL);
}

void
edascm_init_smob ()
{
  /* Register gEDA smob type */
  geda_smob_tag = scm_make_smob_type ("geda", 0);
  scm_set_smob_free (geda_smob_tag, smob_free);
  scm_set_smob_print (geda_smob_tag, smob_print);
  scm_set_smob_equalp (geda_smob_tag, smob_equalp);

  /* Define the (geda core smob) module */
  scm_c_define_module ("geda core smob",
                       init_module_geda_core_smob,
                       NULL);
}