Support default return value in o_complex_get_refdes.

[geda-gaf/berndj.git] / libgeda / src / g_smob.c

/* gEDA - GPL Electronic Design Automation
 * libgeda - gEDA's library
 * Copyright (C) 1998-2007 Ales Hvezda
 * Copyright (C) 1998-2007 gEDA Contributors (see ChangeLog for details)
 *
 * 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 <math.h>
#include <stdio.h>
#ifdef HAVE_STDLIB_H
#include <stdlib.h>
#endif
#ifdef HAVE_STRING_H
#include <string.h>
#endif

#include "libgeda_priv.h"

#ifdef HAVE_LIBDMALLOC
#include <dmalloc.h>
#endif

struct st_object_smob {
  TOPLEVEL *world;   /* We need this when updating schematic */
  OBJECT   *object;
};

struct st_page_smob {
  TOPLEVEL *world;   /* We need this when updating schematic */
  PAGE   *page;
};

struct st_toplevel_smob {
  TOPLEVEL *toplevel;
};

static long attrib_smob_tag; /*! Attribute SMOB tag */
static long object_smob_tag; /*! Object SMOB tag */
static long page_smob_tag;   /*! Page SMOB tag */
static long toplevel_smob_tag; /*! Toplevel SMOB tag */

/* Private function declarations */
static SCM g_set_attrib_value_internal(SCM attrib_smob,
                                       SCM scm_value,
                                       OBJECT **o_attrib,
                                       char *new_string[]);
static void
custom_world_get_single_object_bounds(OBJECT *o_current,
                                      int *left, int *top, 
                                      int *right, int *bottom,
                                      GList *exclude_attrib_list,
                                      GList *exclude_obj_type_list);

static void
custom_world_get_object_list_bounds(OBJECT *o_current,
                                    int *left, int *top, 
                                    int *right, int *bottom,
                                    GList *exclude_attrib_list,
                                    GList *exclude_obj_type_list);

static SCM g_hierarchy_traversepages(SCM toplevel_smob, SCM flags);

/*! \brief Free attribute smob memory.
 *  \par Function Description
 *  Free the memory allocated by the attribute smob and return its size.
 *
 *  \param [in] attrib_smob  The attribute smob to free.
 *  \return Size of attribute smob.
 */
static scm_sizet g_free_attrib_smob(SCM attrib_smob)
{
  struct st_attrib_smob *attribute = 
    (struct st_attrib_smob *) SCM_SMOB_DATA (attrib_smob);

  scm_gc_free(attribute, sizeof (*attribute), "attribute");
  return 0;
}

/*! \brief Prints attribute smob to port.
 *  \par Function Description
 *  This function prints the given attribute smob to the port.
 *  It just prints a string showing it is an attribute and its string.
 *
 *  \param [in] attrib_smob  The attribute smob.
 *  \param [in] port         The port to print to.
 *  \param [in] pstate       Unused.
 *  \return non-zero means success.
 */
static int g_print_attrib_smob(SCM attrib_smob, SCM port,
                               scm_print_state *pstate G_GNUC_UNUSED)
{
  struct st_attrib_smob *attribute = 
    (struct st_attrib_smob *) SCM_SMOB_DATA (attrib_smob);

  if (attribute) {
    char const *representation = o_text_get_string(attribute->attribute);
    scm_simple_format(port, scm_from_locale_string("#<attribute ~a>"),
                      scm_list_1(scm_from_locale_string(representation)));
  }
        
  /* non-zero means success */
  return 1;
}


/*! \brief Creates a name-value smob
 *  \par Function Description
 *  This function Creates and returns a new attribute smob,
 *  based on the given TOPLEVEL curr_w and attribute curr_attr.
 *
 *  \param [in] curr_attr  The current attribute.
 *  \return SCM
 */
SCM g_make_attrib_smob(OBJECT *curr_attr)
{
  struct st_attrib_smob *smob_attribute;

  smob_attribute = scm_gc_malloc(sizeof(struct st_attrib_smob), "attribute");

  smob_attribute->attribute = curr_attr;

  /* Assumes Guile version >= 1.3.2 */
  SCM_RETURN_NEWSMOB(attrib_smob_tag, smob_attribute);
}

/*! \todo Finish function documentation!!!
 *  \brief
 *  \par Function Description
 *
 */
/* Makes a list of all attributes currently connected to object. *
 * Principle stolen from o_attrib_return_attribs */
SCM g_make_attrib_smob_list(OBJECT *object)
{
  OBJECT *a_current;
  GList *a_iter;
  SCM smob_list = SCM_EOL;

  if (!object) {
    return(SCM_EOL);
  }

  if (!object->attribs) {
    return(SCM_EOL);
  }

  /* go through attribs */
  a_iter = object->attribs;
  while(a_iter != NULL) {
    a_current = a_iter->data;
    if (a_current->type == OBJ_TEXT) {
      if (o_text_get_string(a_current)) {
        smob_list = scm_cons(g_make_attrib_smob(a_current), smob_list);
      }
    }
    a_iter = g_list_next (a_iter);
  }

  return smob_list;
}

/*! \brief Get name and value of attribute.
 *  \par Function Description
 *  Returns a list with the name and value of the given attribute smob
 *  
 *  \param [in] attrib_smob  The attribute smob to get name and value from.
 *  \return A list containing the name and value of the attribute.
 */
SCM g_get_attrib_name_value(SCM attrib_smob)
{
  struct st_attrib_smob *attribute;
  char *name = NULL;
  char *value = NULL;
  char const *attrib_chars = NULL;
  SCM returned = SCM_EOL;

  SCM_ASSERT ( SCM_NIMP(attrib_smob) && 
               ((long) SCM_CAR(attrib_smob) == attrib_smob_tag),
               attrib_smob, SCM_ARG1, "get-attribute-name-value");

  attribute = (struct st_attrib_smob *) SCM_SMOB_DATA (attrib_smob);

  if (attribute && attribute->attribute) {
    attrib_chars = o_text_get_string(attribute->attribute);
  }

  if (attrib_chars) {
    o_attrib_get_name_value(attrib_chars, &name, &value );
    returned = scm_cons(scm_from_locale_string(name),
                        scm_from_locale_string(value));
    g_free(name);
    g_free(value);
  }

  return returned;
}

/*! \brief Set the attribute value.
 *  \par Function Description
 *  This function puts the attribute smob name into a new_string and
 *  the new scm_value (attribute=value format). It also returns the
 *  TOPLEVEL and OBJECT pointers.
 *
 *  \param [in]     attrib_smob  The attribute to update.
 *  \param [in]     scm_value    The new value of the attribute.
 *  \param [in,out] o_attrib     Pointer to the updated attribute smob.
 *  \param [in]     new_string   Returns the attribute=value format string for the
 *                               updated attribute.
 *  \return Always SCM_UNDEFINED
 */
static SCM g_set_attrib_value_internal(SCM attrib_smob, SCM scm_value,
                                       OBJECT **o_attrib,
                                       char *new_string[])
{
  struct st_attrib_smob *attribute;
  char *name = NULL;
  char *value = NULL;
  char const *attrib_chars = NULL;

  SCM_ASSERT ( SCM_NIMP(attrib_smob) && 
               ((long) SCM_CAR(attrib_smob) == attrib_smob_tag),
               attrib_smob, SCM_ARG1, "set-attribute-value!");
  SCM_ASSERT (scm_is_string(scm_value), scm_value, SCM_ARG2, 
              "set-attribute-value!");

  scm_dynwind_begin(0);
  attribute = (struct st_attrib_smob *) SCM_SMOB_DATA (attrib_smob);
  value = scm_to_locale_string(scm_value);
  scm_dynwind_free(value);

  if (attribute && attribute->attribute) {
    attrib_chars = o_text_get_string(attribute->attribute);
  }

  if (attrib_chars) {
    o_attrib_get_name_value(attrib_chars, &name, NULL);

    *new_string = g_strconcat (name, "=", value, NULL);
                
    *o_attrib = attribute->attribute;

    g_free(name);
  }

  scm_dynwind_end();
  return SCM_UNDEFINED;
}

/*! \brief Calculate the attribute bounds as it has the given properties.
 *  \par Function Description
 *  Given an attribute, and a new angle, position and alignment, 
 *  this function calculates the bounds of the attribute with the new properties,
 *  but without modifying the attribute.
 *
 *  \param [in]     attrib_smob     The attribute.
 *  \param [in]     scm_alignment   The new alignment of the attribute.
 *     String with the alignment of the text. Possible values are:
 *       ""           : Keep the previous alignment.
 *       "Lower Left"
 *       "Middle Left"
 *       "Upper Left"
 *       "Lower Middle"
 *       "Middle Middle"
 *       "Upper Middle"
 *       "Lower Right"
 *       "Middle Right"
 *       "Upper Right"
 *  \param [in]     angle_scm       The new angle of the attribute,
 *                                  or -1 to keep the previous angle.
 *  \param [in]     x_scm           The new x position of the attribute
 *                                  or -1 to keep the previous value.
 *  \param [in]     y_scm           The new y position of the attribute
 *                                  or -1 to keep the previous value.
 *  \return A list of the form ( (x1 x2) (y1 y2) ) with:
 *       (x1, y1): bottom left corner.
 *       (x2, y2): upper right corner.
 */
SCM g_calculate_new_attrib_bounds(SCM attrib_smob, SCM scm_alignment,
                                  SCM angle_scm, SCM x_scm, SCM y_scm)
{
  OBJECT *object = NULL;
  struct st_attrib_smob *attribute;
  char *alignment_string;
  int alignment = -2;
  int angle = 0;
  int x = -1, y = -1;
  int old_angle, old_x, old_y, old_alignment;
  int left=0, right=0, top=0, bottom=0;
  SCM vertical = SCM_EOL;
  SCM horizontal = SCM_EOL;
  SCM returned = SCM_EOL;

  SCM_ASSERT (scm_is_string(scm_alignment), scm_alignment,
              SCM_ARG2, "calculate-new-attrib-bounds");
  SCM_ASSERT(scm_is_integer(angle_scm),
             angle_scm, SCM_ARG3, "calculate-new-attrib-bounds");
  SCM_ASSERT(scm_is_integer(x_scm),
             x_scm, SCM_ARG4, "calculate-new-attrib-bounds");
  SCM_ASSERT(scm_is_integer(y_scm),
             y_scm, SCM_ARG5, "calculate-new-attrib-bounds");

  angle = scm_to_int(angle_scm);
  x = scm_to_int(x_scm);
  y = scm_to_int(y_scm);
  
  alignment_string = scm_to_locale_string(scm_alignment);

  if (strlen(alignment_string) == 0) {
    alignment = -1;
  }
  if (strcmp(alignment_string, "Lower Left") == 0) {
    alignment = 0;
  }
  if (strcmp(alignment_string, "Middle Left") == 0) {
    alignment = 1;
  }
  if (strcmp(alignment_string, "Upper Left") == 0) {
    alignment = 2;
  }
  if (strcmp(alignment_string, "Lower Middle") == 0) {
    alignment = 3;
  }
  if (strcmp(alignment_string, "Middle Middle") == 0) {
    alignment = 4;
  }
  if (strcmp(alignment_string, "Upper Middle") == 0) {
    alignment = 5;
  }
  if (strcmp(alignment_string, "Lower Right") == 0) {
    alignment = 6;
  }
  if (strcmp(alignment_string, "Middle Right") == 0) {
    alignment = 7;
  }
  if (strcmp(alignment_string, "Upper Right") == 0) {
    alignment = 8;
  }

  free(alignment_string);

  if (alignment == -2) {
    /* Bad specified */
    SCM_ASSERT (scm_is_string(scm_alignment), scm_alignment,
                SCM_ARG2, "calculate-new-attrib-bounds");
  }

  attribute = (struct st_attrib_smob *) SCM_SMOB_DATA (attrib_smob);
  
  SCM_ASSERT ( attribute &&
               attribute->attribute &&
               attribute->attribute->type == OBJ_TEXT,
               attrib_smob, SCM_ARG1, "calculate-new-attrib-bounds");

  object = attribute->attribute;
  
  /* Store the previous values */
  old_alignment = object->text->alignment;
  old_angle = object->text->angle;
  old_x = object->text->x;
  old_y = object->text->y;
  
  /* Set the new ones */
  if (alignment != -1) 
    object->text->alignment = alignment;
  if (angle != -1)
    object->text->angle = angle;
  if (x != -1)
    object->text->x = x;
  if (y != -1)
        object->text->y = y;
  
  o_text_recreate(object);

  /* Get the new bounds */
  world_get_text_bounds(object, &left, &top, &right, &bottom);
  
  /* Restore the original attributes */
  object->text->alignment = old_alignment;
  object->text->angle = old_angle;
  object->text->x = old_x;
  object->text->y = old_y;
  
  o_text_recreate(object);

  /* Construct the return value */
  horizontal = scm_cons (scm_from_int(left), scm_from_int(right));
  vertical = scm_cons (scm_from_int(top), scm_from_int(bottom));
  returned = scm_cons (horizontal, vertical);

  return returned;
}

/*! \brief Initialize the framework to support an attribute smob.
 *  \par Function Description
 *  Initialize the framework to support an attribute smob.
 *
 */
void g_init_attrib_smob(void)
{

  attrib_smob_tag = scm_make_smob_type("attribute",
                                       sizeof (struct st_attrib_smob));
  scm_set_smob_mark(attrib_smob_tag, 0);
  scm_set_smob_free(attrib_smob_tag, g_free_attrib_smob);
  scm_set_smob_print(attrib_smob_tag, g_print_attrib_smob);

  scm_c_define_gsubr("get-attribute-name-value", 1, 0, 0,
                     g_get_attrib_name_value);

  scm_c_define_gsubr ("get-attribute-bounds", 1, 0, 0, g_get_attrib_bounds);
  scm_c_define_gsubr ("get-attribute-angle", 1, 0, 0, g_get_attrib_angle);
  scm_c_define_gsubr("calculate-new-attrib-bounds", 5, 0, 0,
                     g_calculate_new_attrib_bounds);
  /* Keep the misnamed interface around in case someone uses it. */
  scm_c_define_gsubr("calcule-new-attrib-bounds", 5, 0, 0,
                     g_calculate_new_attrib_bounds);

  return;
}

/*! \brief Get the bounds of an attribute.
 *  \par Function Description
 *  Get the bounds of an attribute.
 *  WARNING: top and bottom are mis-named in world-coords,
 *  top is the smallest "y" value, and bottom is the largest.
 *  Be careful! This doesn't correspond to what you'd expect,
 *  nor to the coordinate system whose origin is the bottom, left of the page.
 *  \param[in] attrib_smob the attribute.
 *  \return a list of the bounds of the <B>attrib smob</B>. 
 *  The list has the format: ( (left right) (top bottom) )
 */
SCM g_get_attrib_bounds(SCM attrib_smob)
{
  struct st_attrib_smob *attribute;
  SCM vertical = SCM_EOL;
  SCM horizontal = SCM_EOL;
  int left=0, right=0, bottom=0, top=0; 
  SCM returned = SCM_EOL;

  SCM_ASSERT ( SCM_NIMP(attrib_smob) && 
               ((long) SCM_CAR(attrib_smob) == attrib_smob_tag),
               attrib_smob, SCM_ARG1, "get-attribute-bounds");
  
  attribute = (struct st_attrib_smob *) SCM_SMOB_DATA (attrib_smob);

  if (attribute &&
      attribute->attribute &&
      attribute->attribute->type == OBJ_TEXT) {
    world_get_text_bounds(attribute->attribute, &left, &top, &right, &bottom);

    horizontal = scm_cons (scm_from_int(left), scm_from_int(right));
    vertical = scm_cons (scm_from_int(top), scm_from_int(bottom));
    returned = scm_cons (horizontal, vertical);
  }

  return returned;
}

/*! \brief Get the angle of an attribute.
 *  \par Function Description
 *  Get the angle of an attribute.
 *  \param[in] attrib_smob the attribute.
 *  \return the angle of the <B>attrib smob</B>. 
 */
SCM g_get_attrib_angle(SCM attrib_smob)
{
  struct st_attrib_smob *attribute;

  SCM_ASSERT ( SCM_NIMP(attrib_smob) && 
               ((long) SCM_CAR(attrib_smob) == attrib_smob_tag),
               attrib_smob, SCM_ARG1, "get-attribute-angle");
  
  attribute = (struct st_attrib_smob *) SCM_SMOB_DATA (attrib_smob);

  SCM_ASSERT ( attribute && 
               attribute->attribute &&
               attribute->attribute->text,
               attrib_smob, SCM_ARG1, "get-attribute-angle");

  return scm_from_int(attribute->attribute->text->angle);
}

/*! \brief Free object smob memory.
 *  \par Function Description
 *  Free the memory allocated by the object smob and return its size.
 *
 *  \param [in] object_smob  The object smob to free.
 *  \return Size of object smob.
 */
static scm_sizet g_free_object_smob(SCM object_smob)
{
  struct st_object_smob *object =
    (struct st_object_smob *) SCM_SMOB_DATA(object_smob);

  scm_gc_free(object, sizeof (*object), "object");
  return 0;
}

/*! \brief Prints object smob to port.
 *  \par Function Description
 *  This function prints the given object smob to the port.
 *  It just prints a string showing it is an object and the object name.
 *
 *  \param [in] object_smob  The object smob.
 *  \param [in] port         The port to print to.
 *  \param [in] pstate       Unused.
 *  \return non-zero means success.
 */
static int g_print_object_smob(SCM object_smob, SCM port,
                               scm_print_state *pstate G_GNUC_UNUSED)
{
  struct st_object_smob *object =
    (struct st_object_smob *) SCM_SMOB_DATA(object_smob);

  if (object &&
      object->object &&
      object->object->name) {
    char const *representation = object->object->name;
    scm_simple_format(port, scm_from_locale_string("#<object ~a>"),
                      scm_list_1(scm_from_locale_string(representation)));
  }
        
  /* non-zero means success */
  return 1;
}

/*! \brief Creates a object smob
 *  \par Function Description
 *  This function creates and returns a new object smob,
 *  from the given TOPLEVEL curr_w and object pointers.
 *
 *  \param [in] curr_w  The current TOPLEVEL object.
 *  \param [in] object  The current object.
 *  \return SCM
 */
SCM g_make_object_smob(TOPLEVEL *curr_w, OBJECT *object)
{
  struct st_object_smob *smob_object;

  g_assert(object);

  smob_object = scm_gc_malloc(sizeof(struct st_object_smob), "object");

  smob_object->world  = curr_w;
  smob_object->object = object;

  /* Assumes Guile version >= 1.3.2 */
  SCM_RETURN_NEWSMOB(object_smob_tag, smob_object);
}

/*! \brief Get all object attributes in a list.
 *  \par Function Description
 *  This function returns a list with all the attributes of a given object smob.
 *
 *  \param [in] object_smob  The object smob to get attributes from.
 *  \return A list of attributes associated with this object smob.
 */
SCM g_get_object_attributes(SCM object_smob)
{
  struct st_object_smob *object;
  SCM returned = SCM_EOL;
  GList *a_iter;
  OBJECT *a_current;

  SCM_ASSERT ( SCM_NIMP(object_smob) && 
               ((long) SCM_CAR(object_smob) == object_smob_tag),
               object_smob, SCM_ARG1, "get-object-attributes");

  object = (struct st_object_smob *) SCM_SMOB_DATA(object_smob);

  if (object &&
      object->object) {

    a_iter = object->object->attribs;
    while (a_iter != NULL) {
      a_current = a_iter->data;
      if (a_current && a_current->text) {
        returned = scm_cons(g_make_attrib_smob(a_current), returned);
      }
      a_iter = g_list_next (a_iter);
    }
  }

  return returned;
}

/*! \brief Get the value(s) of the attributes with the given name in the 
 *  given object.
 *  \par Function Description
 *  This function returns a list with all the attribute values, providing that
 *  its attribute name is the given name, in a given object smob.
 *
 *  \param [in] object_smob  The object smob to get attributes from.
 *  \param [in] scm_attrib_name  The name of the attribute you want the value.
 *  \return A list of attribute values.
 */
SCM g_get_attrib_value_by_attrib_name(SCM object_smob, SCM scm_attrib_name)
{
  struct st_object_smob *object;
  gchar *attrib_name=NULL;
  SCM returned = SCM_EOL;
  gchar *name=NULL, *value=NULL;
  GList *a_iter;
  OBJECT *a_current;

  SCM_ASSERT ( SCM_NIMP(object_smob) && 
               ((long) SCM_CAR(object_smob) == object_smob_tag),
               object_smob, SCM_ARG1, "get-attrib-value-by-attrib-name");

  SCM_ASSERT (scm_is_string(scm_attrib_name), scm_attrib_name,
              SCM_ARG2, "get-attrib-value-by-attrib-name");

  scm_dynwind_begin(0);

  /* Get parameters */
  object = (struct st_object_smob *) SCM_SMOB_DATA(object_smob);
  attrib_name = scm_to_locale_string(scm_attrib_name);
  scm_dynwind_free(attrib_name);

  if (object && object->object) {
    a_iter = object->object->attribs;
    while (a_iter != NULL) {
      a_current = a_iter->data;
      if (a_current) {
        o_attrib_get_name_value(o_text_get_string(a_current), &name, &value );
        if (strcmp(name, attrib_name) == 0) {
          returned = scm_cons(scm_from_locale_string(value), returned);
        }
      }
      a_iter = g_list_next (a_iter);
    }
  }

  scm_dynwind_end();
  return returned;
}

/*! \todo Finish function documentation!!!
 *  \brief
 *  \par Function Description
 *
 */
SCM g_set_attrib_value_x(SCM attrib_smob, SCM scm_value)
{
  SCM returned;
  OBJECT *o_attrib;
  char *new_string = NULL;

  returned = g_set_attrib_value_internal(attrib_smob, scm_value,
                                         &o_attrib, &new_string);

  if (new_string) {
    o_text_change(o_attrib, new_string,
                  o_attrib->visibility, o_attrib->show_name_value);
    g_free(new_string);
  }

  return returned;
}

/*! \brief Get the object type.
 *  \par Function Description
 *  This function returns a string with the type of a given object smob.
 *
 *  \param [in] object_smob  The object smob to get the type from.
 *  \return A string with the type of the given object. 
 *   Actually it is the object->type character converted into a string.
 */
SCM g_get_object_type(SCM object_smob)
{
  struct st_object_smob *object_struct;
  OBJECT *object;
  SCM returned = SCM_EOL;

  SCM_ASSERT ( SCM_NIMP(object_smob) && 
               ((long) SCM_CAR(object_smob) == object_smob_tag),
               object_smob, SCM_ARG1, "get-object-type");

  object_struct = (struct st_object_smob *) SCM_SMOB_DATA(object_smob);

  g_assert(object_struct);
  g_assert(object_struct->object);
  
  object = object_struct->object;
  
  returned = SCM_MAKE_CHAR((unsigned char) object->type);

  return returned;
}

/*
 * Returns a list with coords of the ends of  the given pin <B>object</B>.
The list is ( (x0 y0) (x1 y1) ), where the beginning is at (x0,y0) and the end at (x1,y1).
The active connection end of the pin is the beginning, so this function cares about the whichend property of the pin object. If whichend is 1, then it has to reverse the ends.
 */
SCM g_get_pin_ends(SCM object)
{
  OBJECT *o_current;
  SCM coord1 = SCM_EOL;
  SCM coord2 = SCM_EOL;
  SCM coords = SCM_EOL;
  int x1, y1, x2, y2;

  /* Get toplevel and o_current */
  SCM_ASSERT(g_get_data_from_object_smob(object, NULL, &o_current),
             object, SCM_ARG1, "get-pin-ends");

  /* Check that it is a pin object */
  SCM_ASSERT (o_current != NULL,
              object, SCM_ARG1, "get-pin-ends");
  SCM_ASSERT (o_current->type == OBJ_PIN,
              object, SCM_ARG1, "get-pin-ends");
  SCM_ASSERT (o_current->line != NULL,
              object, SCM_ARG1, "get-pin-ends");

  s_basic_get_grip(o_current, GRIP_1, &x1, &y1);
  s_basic_get_grip(o_current, GRIP_2, &x2, &y2);

  coord1 = scm_cons(scm_from_int(x1), scm_from_int(y1));
  coord2 = scm_cons(scm_from_int(x2), scm_from_int(y2));
  if (o_current->whichend == 0) {
    coords = scm_cons(coord1, scm_list(coord2));
  } else {
    coords = scm_cons(coord2, scm_list(coord1));
  }

  return coords;
}

SCM g_swap_pins(SCM component, SCM n1, SCM n2)
{
  OBJECT *owner, *attrib;
  char *packagepins, *vpads, *pin1, *pin2;
  char *pad1 = NULL, *pad2 = NULL;

  SCM_ASSERT(g_get_data_from_object_smob(component, NULL, &owner),
             component, SCM_ARG1, "swap-pins");
  SCM_ASSERT(scm_is_string(n1), n1, SCM_ARG2, "swap-pins");
  SCM_ASSERT(scm_is_string(n2), n2, SCM_ARG3, "swap-pins");

  scm_dynwind_begin(0);

  pin1 = scm_to_locale_string(n1);
  scm_dynwind_free(pin1);
  pin2 = scm_to_locale_string(n2);
  scm_dynwind_free(pin2);

  /* First find which pads correspond to the pins. */
  packagepins = o_attrib_search_name_single(owner, "packagepins", &attrib);
  if (packagepins) {
    char *pair, *s;
    gboolean shorted_pads = FALSE;

    for (s = packagepins; s != NULL; ) {
      char *equals;
      char *pad, *pin;
      char **ppin, **ppad;
      int i;

      pair = u_basic_split(&s, ',');
      equals = strchr(pair, '=');

      if (!equals) {
        /* I think this should be bad, but for now just assume identity. */
        g_free(pair);
        continue;
      }

      *equals = 0;
      pad = pair;
      pin = equals + 1;

      /* If this entry assigns one of the pins, remember the pad. */
      for (i = 0, ppad = &pad1, ppin = &pin1; i < 2;
           i++, ppad = &pad2, ppin = &pin2) {
        if (strcmp(pin, *ppin) == 0) {
          if (*ppad) {
            /* An earlier entry already used the pad. */
            shorted_pads = TRUE;
            g_free(*ppad);
          }
          *ppad = g_strdup(pad);
        }
      }

      g_free(pair);
    }

    if (shorted_pads) {
      char *refdes = o_complex_get_refdes(owner, _("(unknown part)"));

      g_warning(_("Component %s #<object %s> has shorted pads\n"),
                refdes, owner->name);
      g_free(refdes);
    }
  }
  g_free(packagepins);

  /* If there is no package map, assume an identity map. */
  if (!pad1) {
    pad1 = g_strdup(pin1);
  }
  if (!pad2) {
    pad2 = g_strdup(pin2);
  }

  vpads = o_attrib_search_name_single(owner, "vpads", &attrib);
  if (vpads) {
    char *pair, *s;
    GString *newmap;
    int pad1_seen = 0, pad2_seen = 0;

    newmap = g_string_sized_new(0);

    for (s = vpads; s != NULL; ) {
      char *equals;
      char *vpad, *pad;

      pair = u_basic_split(&s, ',');
      equals = strchr(pair, '=');

      *equals = 0;
      vpad = pair;
      pad = equals + 1;

      /* Do the swap. */
      if (strcmp(pad, pad1) == 0) {
        g_string_append_printf(newmap, ",%s=%s", vpad, pad2);
        pad1_seen++;
      } else if (strcmp(pad, pad2) == 0) {
        g_string_append_printf(newmap, ",%s=%s", vpad, pad1);
        pad2_seen++;
      } else {
        g_string_append_printf(newmap, ",%s=%s", vpad, pad);
      }
    }

    /* Build the new attribute, skipping the leading comma. */
    g_free(vpads);
    vpads = g_strdup_printf("vpads=%s", newmap->len ? newmap->str + 1 : "");
    g_string_free(newmap, TRUE);

    if (pad1_seen != 1 || pad2_seen != 1) {
      /* Component doesn't have exactly one of each of the named pads. */
      char *refdes = o_complex_get_refdes(owner, _("(unknown part)"));

      scm_dynwind_unwind_handler(g_free, refdes, SCM_F_WIND_EXPLICITLY);
      g_warning(_("Component %s #<object %s> has broken vpads attribute\n"),
                refdes, owner->name);
      g_free(vpads);
      scm_dynwind_end();

      return SCM_BOOL_F;
    }

    /* Signal handler will update OBJECT::pad_to_pin. */
    o_text_change(attrib, vpads, attrib->visibility, attrib->show_name_value);
  } else {
    /* Component doesn't support pin swapping at all. */
    char *refdes = o_complex_get_refdes(owner, _("(unknown part)"));

    scm_dynwind_unwind_handler(g_free, refdes, SCM_F_WIND_EXPLICITLY);
    g_warning(_("Component %s #<object %s> does not support pin swapping\n"),
              refdes, owner->name);
    scm_dynwind_end();

    return SCM_BOOL_F;
  }

  g_free(vpads);
  scm_dynwind_end();

  return SCM_BOOL_T;
}

/*! \brief Get the object bounds of the given object, excluding the object
 *  types given as parameters.
 *  \par Function Description
 *  Get the object bounds without considering the attributes in
 *  exclude_attrib_list, neither the object types included in
 *  exclude_obj_type_list
 *  \param [in] o_current The object we want to know the bounds of.
 *  \param [in] exclude_attrib_list A list with the attribute names we don't
 *  want to include when calculating the bounds.
 *  \param [in] exclude_obj_type_list A list with the object types we don't
 *  want to include when calculating the bounds.
 *  The object types are those used in (OBJECT *)->type converted into strings.
 *  \param [out] left Left bound of the object.
 *  \param [out] top  Top bound of the object.
 *  \param [out] right Right bound of the object.
 *  \param [out] bottom  Bottom bound of the object.
 *
 */
static void
custom_world_get_single_object_bounds(OBJECT *o_current,
                                      int *left, int *top,
                                      int *right, int *bottom,
                                      GList *exclude_attrib_list,
                                      GList *exclude_obj_type_list) {
  OBJECT *a_current;
  GList *a_iter;
  int rleft, rright, rbottom, rtop;
  const gchar *text_value;
  char *name_ptr, aux_ptr[2];
  gboolean include_text;

  rleft = *left;
  rright = *right;
  rtop = *top;
  rbottom = *bottom;

  sprintf(aux_ptr, "%c", o_current->type);
  include_text = TRUE;
  if (!g_list_find_custom(exclude_obj_type_list, aux_ptr,
                          (GCompareFunc) &strcmp)) {
    switch (o_current->type) {
    case (OBJ_PIN):
      world_get_single_object_bounds(o_current,
                                      &rleft, &rtop, &rright, &rbottom);
      break;
    case (OBJ_TEXT):
      text_value = o_text_get_string(o_current);
      if (text_value) {
        if (o_attrib_get_name_value(text_value, &name_ptr, NULL) &&
            g_list_find_custom(exclude_attrib_list, name_ptr, (GCompareFunc) &strcmp)) {
          include_text = FALSE;
        }
        if (g_list_find_custom(exclude_attrib_list, "all",
                               (GCompareFunc) &strcmp)) {
          include_text = FALSE;
        }
        if (include_text) {
          world_get_single_object_bounds(o_current,
                                          &rleft, &rtop, &rright, &rbottom);
        }
        g_free(name_ptr);
      }
      break;
    case (OBJ_COMPLEX):
    case (OBJ_PLACEHOLDER):
      custom_world_get_object_list_bounds(o_current->complex->prim_objs,
                                          left, top, right, bottom,
                                          exclude_attrib_list,
                                          exclude_obj_type_list);
      break;

    default:
      world_get_single_object_bounds(o_current,
                                      &rleft, &rtop, &rright, &rbottom);
      break;
    }

    if (rleft < *left) *left = rleft;
    if (rtop < *top) *top = rtop;
    if (rright > *right) *right = rright;
    if (rbottom > *bottom) *bottom = rbottom;

    /* If it's a pin object, check the pin attributes */
    if (o_current->type == OBJ_PIN) {
      a_iter = o_current->attribs;
      while (a_iter != NULL) {
        a_current = a_iter->data;

        if (a_current->type == OBJ_TEXT) {
          custom_world_get_single_object_bounds(a_current,
                                                &rleft, &rtop,
                                                &rright, &rbottom,
                                                exclude_attrib_list,
                                                exclude_obj_type_list);
          if (rleft < *left) *left = rleft;
          if (rtop < *top) *top = rtop;
          if (rright > *right) *right = rright;
          if (rbottom > *bottom) *bottom = rbottom;
        }

        a_iter = g_list_next (a_iter);
      }
    }
  }
}

static void
custom_world_get_object_list_bounds(OBJECT *o_current,
                                    int *left, int *top,
                                    int *right, int *bottom,
                                    GList *exclude_attrib_list,
                                    GList *exclude_obj_type_list) {
  int rleft, rtop, rright, rbottom;

  rleft = *left;
  rtop = *top;
  rright = *right;
  rbottom = *bottom;

  while (o_current != NULL) {
    custom_world_get_single_object_bounds(o_current, &rleft, &rtop,
                                          &rright, &rbottom,
                                          exclude_attrib_list,
                                          exclude_obj_type_list);
    if (rleft < *left) *left = rleft;
    if (rtop < *top) *top = rtop;
    if (rright > *right) *right = rright;
    if (rbottom > *bottom) *bottom = rbottom;

    o_current = o_current->next;
  }
}

/*! \brief Get the object bounds of the given object, excluding the object
 *  types or the attributes given as parameters.
 *  \par Function Description
 *  Get the object bounds without considering the attributes in
 *  scm_exclude_attribs, neither the object types included in
 *  scm_exclude_object_type
 *  \param [in] object_smob              Get this object's bounds
 *  \param [in] scm_exclude_attribs      Ignore attributes with these names.
 *  \param [in] scm_exclude_object_type  Ignore objects of these types.
 *  The object types are those used in (OBJECT *)->type converted into strings.
 *  \return a list of the bounds of the <B>object smob</B>.
 *  The list has the format: ( (left right) (top bottom) )
 *  WARNING: top and bottom are mis-named in world-coords,
 *  top is the smallest "y" value, and bottom is the largest.
 *  Be careful! This doesn't correspond to what you'd expect,
 *  nor to the coordinate system whose origin is the bottom, left of the page.
 */
SCM g_get_object_bounds (SCM object_smob, SCM scm_exclude_attribs, SCM scm_exclude_object_type)
{
  OBJECT *object=NULL;
  int left=G_MAXINT, right=0, bottom=0, top=G_MAXINT;
  SCM returned = SCM_EOL;
  SCM vertical = SCM_EOL;
  SCM horizontal = SCM_EOL;
  GList *exclude_attrib_list = NULL, *exclude_obj_type_list = NULL;
  SCM rest;

  SCM_ASSERT (scm_list_p(scm_exclude_attribs), scm_exclude_attribs,
              SCM_ARG2, "get-object-bounds");
  SCM_ASSERT (scm_list_p(scm_exclude_object_type), scm_exclude_object_type,
              SCM_ARG3, "get-object-bounds");

  scm_dynwind_begin(0);

  /* Build the exclude attrib list */
  for (rest = scm_exclude_attribs; !scm_is_null(rest); rest = SCM_CDR(rest)) {
    char *attrib_name;

    SCM_ASSERT(scm_is_string(SCM_CAR(rest)), SCM_CAR(rest), SCM_ARG2,
               "get-object-bounds");

    attrib_name = scm_to_locale_string(SCM_CAR(rest));
    scm_dynwind_free(attrib_name);

    exclude_attrib_list = g_list_prepend(exclude_attrib_list, attrib_name);
  }

  /* Build the exclude object type list */
  for (rest = scm_exclude_object_type;
       !scm_is_null(rest);
       rest = SCM_CDR(rest)) {
    char *object_type;

    SCM_ASSERT(scm_is_string(SCM_CAR(rest)), SCM_CAR(rest), SCM_ARG3,
               "get-object-bounds");

    object_type = scm_to_locale_string(SCM_CAR(rest));
    scm_dynwind_free(object_type);

    exclude_obj_type_list = g_list_prepend(exclude_obj_type_list, object_type);
  }

  /* Get toplevel and o_current. */
  g_get_data_from_object_smob(object_smob, NULL, &object);

  SCM_ASSERT(object, object_smob, SCM_ARG1, "get-object-bounds");

  custom_world_get_single_object_bounds(object, &left, &top, &right, &bottom,
                                        exclude_attrib_list,
                                        exclude_obj_type_list);

  g_list_free(exclude_attrib_list);
  g_list_free(exclude_obj_type_list);
  scm_dynwind_end();

  horizontal = scm_cons (scm_from_int(left), scm_from_int(right));
  vertical = scm_cons (scm_from_int(top), scm_from_int(bottom));
  returned = scm_cons (horizontal, vertical);

  return (returned);
}

/*! \todo Finish function documentation!!!
 *  \brief
 *  \par Function Description
 *
 */
/*
 *Returns a list of the pins of the <B>object smob</B>.
 */
SCM g_get_object_pins (SCM object_smob)
{
  TOPLEVEL *toplevel=NULL;
  OBJECT *object=NULL;
  OBJECT *prim_obj;
  SCM returned=SCM_EOL;

  /* Get toplevel and o_current */
  SCM_ASSERT (g_get_data_from_object_smob (object_smob, &toplevel, &object),
              object_smob, SCM_ARG1, "get-object-pins");

  if (!object) {
    return (returned);
  }
  if (object->complex && object->complex->prim_objs) {
    prim_obj = object->complex->prim_objs;
    while (prim_obj != NULL) {
      if (prim_obj->type == OBJ_PIN) {
        returned = scm_cons (g_make_object_smob(toplevel, prim_obj),returned);
      }
      prim_obj = prim_obj->next;
    }
  }

  return (returned);
}

/*! \brief Get the line width used to draw an object.
 *  \par Function Description
 *  This function returns the line width used to draw an object.
 *
 *  \param [in] object_smob  The object smob to get the line width.
 *  \return The line width. 
 *   Actually it is the object->line_width.
 */
SCM g_get_line_width(SCM object_smob)
{
  struct st_object_smob *object_struct;
  OBJECT *object;
  SCM returned = SCM_EOL;

  SCM_ASSERT ( SCM_NIMP(object_smob) && 
               ((long) SCM_CAR(object_smob) == object_smob_tag),
               object_smob, SCM_ARG1, "get-line-width");

  object_struct = (struct st_object_smob *) SCM_SMOB_DATA(object_smob);

  g_assert (object_struct && object_struct->object);
  
  object = object_struct->object;
  
  returned = scm_from_int(object->line_width);

  return returned;
}

struct get_slots_context {
  TOPLEVEL *toplevel;
  SCM retval;
};

static void get_slots_visitor(OBJECT *o, void *context)
{
  struct get_slots_context *ctx = context;
  SCM slot_smob;

  if (o->type != OBJ_SLOT) {
    return;
  }

  slot_smob = g_make_object_smob(ctx->toplevel, o);

  ctx->retval = scm_cons(slot_smob, ctx->retval);
}

/*! \brief Get all slots in a list.
 *  \par Function Description
 *  This function returns a list with all the slots in an object.
 *
 *  \param [in] object_smob  The object smob to get slots from.
 *  \return A list of slots belonging to \a object_smob.
 */
SCM g_get_object_slots(SCM object_smob)
{
  struct st_object_smob *object;
  SCM returned = SCM_EOL;

  SCM_ASSERT ( SCM_NIMP(object_smob) && 
               ((long) SCM_CAR(object_smob) == object_smob_tag),
               object_smob, SCM_ARG1, "get-object-slots");

  object = (struct st_object_smob *) SCM_SMOB_DATA(object_smob);

  if (object->object->type != OBJ_COMPLEX) {
    g_warning(_("g_get_object_attributes: object is not a component\n"));
    return SCM_BOOL_F;
  }

  if (object && object->object) {
    TOPLEVEL *toplevel;
    struct get_slots_context ctx;

    toplevel = object->world;

    ctx.toplevel = toplevel;
    ctx.retval = returned;

    s_visit(object->object, &get_slots_visitor, &ctx, VISIT_UNORDERED, 2);

    returned = ctx.retval;
  }

  return returned;
}

/*! \brief Get the occupant of a slot object
 *  \par Function Description
 *  This function returns the abstract symbol occupying a slot
 *
 *  \param [in] object_smob  The object smob of a slot object
 *  \return The abstract symbol object
 */
SCM g_get_slot_occupant(SCM object_smob)
{
  struct st_object_smob *object_struct;
  TOPLEVEL *toplevel;
  OBJECT *object;
  SCM returned = SCM_EOL;

  SCM_ASSERT ( SCM_NIMP(object_smob) && 
               ((long) SCM_CAR(object_smob) == object_smob_tag),
               object_smob, SCM_ARG1, "get-slot-occupant");

  object_struct = (struct st_object_smob *) SCM_SMOB_DATA(object_smob);

  g_assert (object_struct && object_struct->object);
  
  toplevel = object_struct->world;
  object = object_struct->object;
  
  if (object->type != OBJ_SLOT) {
    g_warning(_("g_get_slot_occupant: object is not a slot\n"));
    return SCM_BOOL_F;
  }

  if (object->slot->symbol) {
    OBJECT *occupant;

    occupant = s_slot_get_occupant(object);
    returned = g_make_object_smob(toplevel, occupant);
  }

  return returned;
}

/*! \brief Determine if an object is compatible with a slot
 *  \par Function Description
 *
 *  \param [in] object_smob  An object to put in a slot
 *  \param [in] slot_smob    A slot object
 *  \return True if \a object_smob is compatible with \a slot_smob.
 */
SCM g_object_compatiblep(SCM object_smob, SCM slot_smob)
{
  struct st_object_smob *object_data;
  struct st_object_smob *slot_data;
  SCM retval = SCM_BOOL_F;

  SCM_ASSERT ( SCM_NIMP(object_smob) && 
               ((long) SCM_CAR(object_smob) == object_smob_tag),
               object_smob, SCM_ARG1, "object-compatible?");
  SCM_ASSERT ( SCM_NIMP(slot_smob) && 
               ((long) SCM_CAR(slot_smob) == object_smob_tag),
               slot_smob, SCM_ARG2, "object-compatible?");

  object_data = (struct st_object_smob *) SCM_SMOB_DATA(object_smob);
  slot_data = (struct st_object_smob *) SCM_SMOB_DATA(slot_smob);

  g_assert (object_data && object_data->object);
  g_assert (slot_data && slot_data->object);

  if (slot_data->object->type != OBJ_SLOT) {
    g_warning(_("g_object_compatiblep: object is not a slot\n"));
    return SCM_BOOL_F;
  }

  if (s_slot_compatible(object_data->object, slot_data->object)) {
    retval = SCM_BOOL_T;
  }

  return retval;
}

/*! \brief Put a component into a slot
 *  \par Function Description
 *
 *  \param [in] object_smob  An object to put in a slot
 *  \param [in] symbol_smob  A slot object
 *  \return True iff the slot-link succeeded.
 */
SCM g_slot_link(SCM object_smob, SCM symbol_smob)
{
  struct st_object_smob *object_data;
  struct st_object_smob *symbol_data;
  TOPLEVEL *toplevel;
  OBJECT *object, *symbol;
  SCM retval = SCM_BOOL_F;

  SCM_ASSERT ( SCM_NIMP(object_smob) && 
               ((long) SCM_CAR(object_smob) == object_smob_tag),
               object_smob, SCM_ARG1, "slot-link");
  SCM_ASSERT ( SCM_NIMP(symbol_smob) &&
               ((long) SCM_CAR(symbol_smob) == object_smob_tag),
               symbol_smob, SCM_ARG2, "slot-link");

  object_data = (struct st_object_smob *) SCM_SMOB_DATA(object_smob);
  symbol_data = (struct st_object_smob *) SCM_SMOB_DATA(symbol_smob);

  g_assert (object_data && object_data->object);
  g_assert (symbol_data && symbol_data->object);

  /* FIXME: Don't infer toplevel. */
  toplevel = object_data->world;
  object = object_data->object;
  symbol = symbol_data->object;

  if (s_slot_link(toplevel, object, symbol) == 0) {
    retval = SCM_BOOL_T;
  }

  return retval;
}

/*! \brief Remove a component from its slot
 *  \par Function Description
 *
 *  \param [in] object_smob  An object to remove from its slot
 *  \return True iff the slot-link succeeded.
 */
SCM g_slot_unlink(SCM object_smob)
{
  struct st_object_smob *object_data;
  OBJECT *object, *old_slot;
  TOPLEVEL *toplevel;
  SCM retval = SCM_BOOL_F;

  SCM_ASSERT ( SCM_NIMP(object_smob) && 
               ((long) SCM_CAR(object_smob) == object_smob_tag),
               object_smob, SCM_ARG1, "slot-unlink");

  object_data = (struct st_object_smob *) SCM_SMOB_DATA(object_smob);

  g_assert (object_data && object_data->object);

  toplevel = object_data->world;
  object = object_data->object;

  old_slot = s_slot_unlink(object);
  s_slot_reset_attribs(object);
  if (old_slot) {
    retval = g_make_object_smob(toplevel, old_slot);
  }

  return retval;
}

/*! \brief Initialize the framework to support an object smob.
 *  \par Function Description
 *  Initialize the framework to support an object smob.
 *
 */
void g_init_object_smob(void)
{

  object_smob_tag = scm_make_smob_type("object", sizeof (struct st_object_smob));
  scm_set_smob_mark(object_smob_tag, 0);
  scm_set_smob_free(object_smob_tag, g_free_object_smob);
  scm_set_smob_print(object_smob_tag, g_print_object_smob);

  scm_c_define_gsubr("get-attrib-value-by-attrib-name", 2, 0, 0, 
                     g_get_attrib_value_by_attrib_name);
  scm_c_define_gsubr("get-object-type", 1, 0, 0, g_get_object_type);
  scm_c_define_gsubr("get-line-width", 1, 0, 0, g_get_line_width);

  scm_c_define_gsubr("get-object-slots", 1, 0, 0, g_get_object_slots);
  scm_c_define_gsubr("get-slot-occupant", 1, 0, 0, g_get_slot_occupant);
  scm_c_define_gsubr("object-compatible?", 2, 0, 0, g_object_compatiblep);
  scm_c_define_gsubr("slot-link", 2, 0, 0, g_slot_link);
  scm_c_define_gsubr("slot-unlink", 1, 0, 0, g_slot_unlink);

  return;
}


/*! \brief Get the TOPLEVEL and OBJECT data from an object smob.
 *  \par Function Description
 *  Get the TOPLEVEL and OBJECT data from an object smob.
 *
 *  \param [in]  object_smob  The object smob to get data from.
 *  \param [out] toplevel     The TOPLEVEL to write data to.
 *  \param [out] object       The OBJECT to write data to.
 *  \return TRUE on success, FALSE otherwise
 */
gboolean g_get_data_from_object_smob(SCM object_smob, TOPLEVEL **toplevel, 
                                     OBJECT **object)
{
  
  if ( (!SCM_NIMP(object_smob)) || 
       ((long) SCM_CAR(object_smob) != object_smob_tag) ) {
    return(FALSE);
  }
  if (toplevel != NULL) {
    *toplevel = (TOPLEVEL *) 
    (((struct st_object_smob *) SCM_SMOB_DATA(object_smob))->world);
  }
  if (object != NULL) {
    *object = (((struct st_object_smob *) SCM_SMOB_DATA(object_smob))->object);
  }
  return (TRUE);
}

/*! \brief Free page smob memory.
 *  \par Function Description
 *  Free the memory allocated by the page smob and return its size.
 *
 *  \param [in] page_smob  The page smob to free.
 *  \return Size of page smob.
 */
static scm_sizet g_free_page_smob(SCM page_smob)
{
  struct st_page_smob *page = 
  (struct st_page_smob *) SCM_SMOB_DATA(page_smob);

  scm_gc_free(page, sizeof (*page), "page");
  return 0;
}

/*! \brief Prints page smob to port.
 *  \par Function Description
 *  This function prints the given page smob to the port.
 *  It just prints a string showing it is a page and the page name.
 *
 *  \param [in] page_smob    The page smob.
 *  \param [in] port         The port to print to.
 *  \param [in] pstate       Unused.
 *  \return non-zero means success.
 */
static int g_print_page_smob(SCM page_smob, SCM port,
                             scm_print_state *pstate G_GNUC_UNUSED)
{
  struct st_page_smob *page =
    (struct st_page_smob *) SCM_SMOB_DATA(page_smob);

  if (page &&
      page->page &&
      page->page->page_filename) {
    char const *representation = page->page->page_filename;
    scm_simple_format(port, scm_from_locale_string("#<page ~a>"),
                      scm_list_1(scm_from_locale_string(representation)));
  }
        
  /* non-zero means success */
  return 1;
}

/*! \brief Initialize the framework to support a page smob.
 *  \par Function Description
 *  Initialize the framework to support a page smob.
 *
 */
void g_init_page_smob(void)
{

  page_smob_tag = scm_make_smob_type("page",
                                       sizeof (struct st_page_smob));
  scm_set_smob_mark(page_smob_tag, 0);
  scm_set_smob_free(page_smob_tag, g_free_page_smob);
  scm_set_smob_print(page_smob_tag, g_print_page_smob);

  scm_c_define_gsubr ("get-page-filename", 1, 0, 0, g_get_page_filename);

  return;
}

/*! \brief Creates a page smob
 *  \par Function Description
 *  This function creates and returns a new page smob,
 *  from the given TOPLEVEL curr_w and page pointers.
 *
 *  \param [in] curr_w  The current TOPLEVEL object.
 *  \param [in] page    The page object.
 *  \return SCM         The new page smob
 */
SCM g_make_page_smob(TOPLEVEL *curr_w, PAGE *page)
{
  struct st_page_smob *smob_page;

  smob_page = scm_gc_malloc(sizeof(struct st_page_smob), "page");

  smob_page->world  = curr_w;
  smob_page->page = page;

  /* Assumes Guile version >= 1.3.2 */
  SCM_RETURN_NEWSMOB(page_smob_tag, smob_page);
}

/*! \brief Get the TOPLEVEL and PAGE data from a page smob.
 *  \par Function Description
 *  Get the TOPLEVEL and OBJECT data from a page smob.
 *
 *  \param [in]  page_smob    The page smob to get data from.
 *  \param [out] toplevel     The TOPLEVEL to write data to.
 *  \param [out] page         The PAGE to write data to.
 *  \return TRUE on success, FALSE otherwise
 */
gboolean g_get_data_from_page_smob(SCM page_smob, TOPLEVEL **toplevel, 
                                   PAGE **page)
{
  
  if ( (!SCM_NIMP(page_smob)) || 
       ((long) SCM_CAR(page_smob) != page_smob_tag) ) {
    return(FALSE);
  }
  if (toplevel != NULL) {
    *toplevel = (TOPLEVEL *) 
    (((struct st_page_smob *) SCM_SMOB_DATA (page_smob))->world);
  }
  if (page != NULL) {
    *page = (PAGE *) 
    (((struct st_page_smob *) SCM_SMOB_DATA (page_smob))->page);
  }
  return (TRUE);
}

/*! \brief Get the page filename from a page smob.
 *  \par Function Description
 *  Get the page filename from a page smob.
 *
 *  \param [in]  page_smob    The page smob to get the filename from.
 *  \return the page filename or SCM_EOL if there was some error.
 */
SCM g_get_page_filename(SCM page_smob)
{
  SCM returned = SCM_EOL;
  PAGE *page;

  SCM_ASSERT ( SCM_NIMP(page_smob) &&
               ((long) SCM_CAR(page_smob) == page_smob_tag),
               page_smob, SCM_ARG1, "get-page-filename");

  page = (PAGE *) 
    (((struct st_page_smob *) SCM_SMOB_DATA (page_smob))->page);

  if (page->page_filename) {
    returned = scm_from_locale_string(page->page_filename);
  }

  return (returned);
}

/*! \brief Add a component to the page.
 *  \par Function Description
 *  Adds a component <B>comp_name_scm</B> to the schematic, at
 *  position (<B>x_scm</B>, <B>y_scm</B>), with some properties set by
 *  the parameters:
 *  \param [in] x_scm          Coordinate X of the symbol.
 *  \param [in] y_scm          Coordinate Y of the symbol.
 *  \param [in] angle_scm      Angle of rotation of the symbol.
 *  \param [in] selectable_scm True if the symbol is selectable, false otherwise.
 *  \param [in] mirror_scm     True if the symbol is mirrored, false otherwise.
 *  If comp_name_scm is a scheme empty list, SCM_BOOL_F, or an empty
 *  string (""), then g_add_component returns SCM_BOOL_F without writing
 *  to the log.
 *  \return TRUE if the component was added, FALSE otherwise.
 *
 */
SCM g_add_component(SCM page_smob, SCM comp_name_scm, SCM x_scm, SCM y_scm,
                    SCM angle_scm, SCM selectable_scm, SCM mirror_scm)
{
  TOPLEVEL *toplevel;
  PAGE *page;
  gboolean selectable, mirror;
  gchar *comp_name;
  int x, y, angle;
  OBJECT *new_obj;
  const CLibSymbol *clib;

  /* Return if comp_name_scm is NULL (an empty list) or scheme's FALSE */
  if (SCM_NULLP(comp_name_scm) ||
      (SCM_BOOLP(comp_name_scm) && !(SCM_NFALSEP(comp_name_scm))) ) {
    return SCM_BOOL_F;
  }

  /* Get toplevel and the page */
  SCM_ASSERT (g_get_data_from_page_smob (page_smob, &toplevel, &page),
              page_smob, SCM_ARG1, "add-component-at-xy");
  /* Check the arguments */
  SCM_ASSERT(scm_is_string(comp_name_scm), comp_name_scm,
             SCM_ARG2, "add-component-at-xy");
  SCM_ASSERT(scm_is_integer(x_scm), x_scm,
             SCM_ARG3, "add-component-at-xy");
  SCM_ASSERT(scm_is_integer(y_scm), y_scm,
             SCM_ARG4, "add-component-at-xy");
  SCM_ASSERT(scm_is_integer(angle_scm), angle_scm,
             SCM_ARG5, "add-component-at-xy");
  SCM_ASSERT(scm_boolean_p(selectable_scm), selectable_scm,
             SCM_ARG6, "add-component-at-xy");
  SCM_ASSERT(scm_boolean_p(mirror_scm), mirror_scm,
             SCM_ARG7, "add-component-at-xy");

  scm_dynwind_begin(0);

  /* Get the parameters */
  comp_name = scm_to_locale_string(comp_name_scm);
  scm_dynwind_free(comp_name);
  x = scm_to_int(x_scm);
  y = scm_to_int(y_scm);
  angle = scm_to_int(angle_scm);
  selectable = SCM_NFALSEP(selectable_scm);
  mirror = SCM_NFALSEP(mirror_scm);

  SCM_ASSERT(comp_name, comp_name_scm, SCM_ARG2, "add-component-at-xy");

  if (strcmp(comp_name, "") == 0) {
    scm_dynwind_end();
    return SCM_BOOL_F;
  }

  clib = s_clib_get_symbol_by_name (comp_name);

  new_obj = o_complex_new (toplevel, 'C', WHITE, x, y, angle, mirror,
                           clib, comp_name, selectable);
  s_page_append(page, new_obj);
  o_complex_promote_attribs(toplevel, page, new_obj);
  o_attrib_fix_uuid(new_obj);
  s_toplevel_register_object(toplevel, new_obj);

  /*
   * For now, do not redraw the newly added complex, since this might cause
   * flicker if you are zoom/panning right after this function executes
   */
#if 0
  /* Now the new component should be added to the object's list and
     drawn in the screen */
  o_redraw_single(toplevel, new_object);
#endif

  scm_dynwind_end();
  return SCM_BOOL_T;
}

/*! \brief Return the objects in a page.
 *  \par Function Description
 *  Returns an object smob list with all the objects in the given page.
 *  \param [in] page_smob Page to look at.
 *  \return the object smob list with the objects in the page.
 *
 */
SCM g_get_objects_in_page(SCM page_smob) {
  TOPLEVEL *toplevel;
  PAGE *page;
  OBJECT *object;
  SCM return_list=SCM_EOL;

  /* Get toplevel and the page */
  SCM_ASSERT (g_get_data_from_page_smob (page_smob, &toplevel, &page),
              page_smob, SCM_ARG1, "get-objects-in-page");

  if (page && page->object_head && page->object_head->next) {
    object = page->object_head->next;
    while (object) {
      return_list = scm_cons (g_make_object_smob(toplevel, object),
                              return_list);
      object = object->next;
    }
  }

  return return_list;
}

/*! \brief Free toplevel smob memory.
 *  \par Function Description
 *  Free the memory allocated by the toplevel smob and return its size.
 *
 *  \param [in] toplevel_smob  The toplevel smob to free.
 *  \return Size of toplevel smob.
 */
static scm_sizet g_free_toplevel_smob(SCM toplevel_smob)
{
  struct st_toplevel_smob *toplevel =
    (struct st_toplevel_smob *) SCM_SMOB_DATA(toplevel_smob);

  scm_gc_free(toplevel, sizeof (*toplevel), "geda-toplevel");
  return 0;
}

/*! \brief Initialize the framework to support a toplevel smob.
 *  \par Function Description
 *  Initialize the framework to support a toplevel smob.
 *
 */
void g_init_toplevel_smob(void)
{

  toplevel_smob_tag = scm_make_smob_type("geda-toplevel",
                                         sizeof (struct st_toplevel_smob));
  scm_set_smob_mark(toplevel_smob_tag, 0);
  scm_set_smob_free(toplevel_smob_tag, g_free_toplevel_smob);

  scm_c_define_gsubr("get-toplevel-from", 1, 0, 0, g_get_toplevel_from);
  scm_c_define_gsubr("get-toplevel-pages", 1, 0, 0, g_get_toplevel_pages);
  scm_c_define_gsubr("hierarchy-traverse-pages", 2, 0, 0,
                     &g_hierarchy_traversepages);

  return;
}

/*! \brief Creates a toplevel smob
 *  \par Function Description
 *  This function creates and returns a new toplevel smob,
 *  from the given TOPLEVEL toplevel pointer.
 *
 *  \param [in] toplevel  The current TOPLEVEL object.
 *  \return SCM           The new toplevel smob
 */
SCM g_make_toplevel_smob(TOPLEVEL *toplevel)
{
  struct st_toplevel_smob *smob_toplevel;

  smob_toplevel = scm_gc_malloc(sizeof(struct st_toplevel_smob), "geda-toplevel");

  smob_toplevel->toplevel  = toplevel;

  /* Assumes Guile version >= 1.3.2 */
  SCM_RETURN_NEWSMOB(toplevel_smob_tag, smob_toplevel);
}

/*! \brief Get the TOPLEVEL in which another smob exists.
 *  \par Function Description
 *  This function returns a TOPLEVEL in which a PAGE or OBJECT exist.
 *
 *  \param [in] smob  The PAGE or OBJECT smob to get TOPLEVEL from.
 *  \return A TOPLEVEL smob.
 */
SCM g_get_toplevel_from(SCM smob)
{
  SCM returned = SCM_BOOL_F;
  TOPLEVEL *toplevel = NULL;

  SCM_ASSERT(SCM_NIMP(smob), smob, SCM_ARG1, "get-toplevel-from");

  if ((long) SCM_CAR(smob) == object_smob_tag) {
    struct st_object_smob *object =
      (struct st_object_smob *) SCM_SMOB_DATA(smob);
    toplevel = object->world;
  } else if ((long) SCM_CAR(smob) == page_smob_tag) {
    struct st_page_smob *page =
      (struct st_page_smob *) SCM_SMOB_DATA(smob);
    toplevel = page->world;
  } else {
    SCM_ASSERT(0, smob, SCM_ARG1, "get-toplevel-from");
  }

  returned = g_make_toplevel_smob(toplevel);

  return returned;
}

/*! \brief Get all pages in a list.
 *  \par Function Description
 *  This function returns a list with all the pages of a given toplevel smob.
 *
 *  \param [in] toplevel_smob  The toplevel smob to get pages from.
 *  \return A list of pages associated with this toplevel smob.
 */
SCM g_get_toplevel_pages(SCM toplevel_smob)
{
  struct st_toplevel_smob *toplevel;
  SCM returned = SCM_EOL;

  SCM_ASSERT ( SCM_NIMP(toplevel_smob) && 
               ((long) SCM_CAR(toplevel_smob) == toplevel_smob_tag),
               toplevel_smob, SCM_ARG1, "get-toplevel-pages");

  toplevel = (struct st_toplevel_smob *) SCM_SMOB_DATA(toplevel_smob);

  if (toplevel && toplevel->toplevel) {
    const GList *iter;

    for (iter = geda_list_get_glist(toplevel->toplevel->pages);
         iter != NULL;
         iter = g_list_next(iter)) {
      PAGE *page = iter->data;
      returned = scm_cons(g_make_page_smob(toplevel->toplevel, page),
                          returned);
    }
  }

  return returned;
}

/*! \brief Find a component from the global UUID map.
 *  \par Function Description
 *  Look up a UUID in the TOPLEVEL uuidmap and return the object found.
 *
 *  \param [in] toplevel_smob  The TOPLEVEL smob containing the map.
 *  \param [in] uuid_smob      The UUID of the desired object.
 *
 *  \return OBJECT smob for the found object, or #f if not found.
 */
SCM g_lookup_uuid(SCM toplevel_smob, SCM uuid_smob)
{
  OBJECT *component;
  struct st_toplevel_smob *metatoplevel;
  TOPLEVEL *toplevel;
  char *uuid;
  SCM retval = SCM_BOOL_F;

  SCM_ASSERT(SCM_NIMP(toplevel_smob) &&
             ((long) SCM_CAR(toplevel_smob) == toplevel_smob_tag),
             toplevel_smob, SCM_ARG1, "lookup-uuid");
  SCM_ASSERT(scm_is_string(uuid_smob), uuid_smob, SCM_ARG2, "lookup-uuid");
  metatoplevel = (struct st_toplevel_smob *) SCM_SMOB_DATA(toplevel_smob);
  SCM_ASSERT(metatoplevel && metatoplevel->toplevel,
             toplevel_smob, SCM_ARG1, "lookup-uuid");
  toplevel = metatoplevel->toplevel;

  uuid = scm_to_locale_string(uuid_smob);
  component = g_hash_table_lookup(toplevel->uuidmap, uuid);
  free(uuid);

  if (component) {
    retval = g_make_object_smob(toplevel, component);
  }

  return retval;
}

/*! \brief Get a list of pages rooted at the current page.
 */
static SCM g_hierarchy_traversepages(SCM toplevel_smob, SCM flags)
{
  struct st_toplevel_smob *toplevel;
  SCM retval = SCM_EOL;
  const GList *iter;
  GList *pages;

  SCM_ASSERT(SCM_NIMP(toplevel_smob) &&
             ((long) SCM_CAR(toplevel_smob) == toplevel_smob_tag),
             toplevel_smob, SCM_ARG1, "hierarchy-traverse-pages");
  toplevel = (struct st_toplevel_smob *) SCM_SMOB_DATA(toplevel_smob);
  SCM_ASSERT(toplevel && toplevel->toplevel, toplevel_smob, SCM_ARG1,
             "hierarchy-traverse-pages");

  SCM_ASSERT(scm_is_integer(flags), flags, SCM_ARG2,
             "hierarchy-traverse-pages");

  pages = s_hierarchy_traversepages(toplevel->toplevel,
                                    toplevel->toplevel->page_current,
                                    scm_to_int(flags));

  /* Consing up the scheme list reverses the order. */
  pages = g_list_reverse(pages);

  for (iter = pages; iter; iter = iter->next) {
    SCM page = g_make_page_smob(toplevel->toplevel, iter->data);
    retval = scm_cons(page, retval);
  }

  return retval;
}