/* Guile bindings for Mutt
   Copyright (C) 2003  Ludovic Courtès

   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., 675 Mass Ave, Cambridge, MA 02139, USA.  */

#include "mutt.h"

#include <libguile.h>

#include <errno.h>
#include <assert.h>

/* Define this to have some more debugging information */
#undef DEBUG_GUILE

#ifdef DEBUG_GUILE
# ifndef __GNU_LIBRARY__
#  error mcheck () is only available in the GNU C library.
# else
#  include <mcheck.h>
# endif
#endif

#ifndef STRINGIFY
# define _STRINGIFY(_y) #_y
# define STRINGIFY(_x)  _STRINGIFY (_x)
#endif


/* Warning: Most of this glue code is written in capital letters, because it
   mostly uses hairy macros...  */

/* Smob types tags.
   A note about Scheme smob types names: type names from the C code
   base are unchanged (but lower-cased) except for `HEADER' which we
   call `message' here and `CONTEXT' which we call `mailbox' here for
   clarity.  */
static scm_t_bits smutt_mailbox_tag, smutt_alias_tag, smutt_address_tag,
  smutt_message_tag, smutt_envelope_tag, smutt_body_tag,
  smutt_content_tag, smutt_pattern_tag, smutt_menu_tag,
  smutt_score_tag, smutt_buffy_tag;


/* Data structure representing a Mutt SMOB (sort of a proxy object).
   Only one such object should be allocated per underlying C object.
   Specific smob types have a corresponding proxy data type that
   inherits from this one.  */
typedef struct _smutt_object
{
  /* Size of this object (>= sizeof (smutt_object_t)) */
  size_t    self_size;
  
  /* The C object represented by this SMOB and its size */
  void     *object;
  size_t    object_size;

  /* Pointer to OBJECT's `extdata' pointer */
  struct _smutt_object **object_extdata;

  /* Method that should free C object OBJECT and all its associated
     resources, *except* those bound to other smobs.  For instance,
     strings should be freed here, but a pointer-to-envelope which is
     bound to a smob must *not* be freed.  This method should return
     the amount of freed space.  */
  size_t (* free_object) (void *object);

  /* Tells whether OBJECT should be destroyed when this SMOB gets
     garbage collected.  The same effect could be obtained by setting
     the initial reference count to 1, but then we would never free
     `smutt_object_t' objects.  */
  unsigned int destroy:1;

  /* The SMOB itself */
  SCM  smob;
  
} smutt_object_t;

/* Below are type-specific typedefs inheriting from smutt_object_t.
   Those typedefs should only contain a number of fields representing
   smobs that may potentially be referenced by the smob they
   represent.  For instance, a `message' smob may potentially reference
   an `envelope' smob because messages aggregate envelopes.
   For things to work properly, the name of the SCM fields below have
   to be the same as those of the original C type (several macros
   rely on it).  */

typedef smutt_object_t  smutt_mailbox_t;

typedef struct
{
  /* Inherit from smutt_object_t */
  smutt_object_t smutt_object;

  /* List of aggregated SMOBs (may be equal to SCM_UNDEFINED) */
  SCM  addr;
} smutt_alias_t;

typedef struct
{
  smutt_object_t smutt_object;

  SCM  next;
} smutt_address_t;

typedef struct
{
  smutt_object_t smutt_object;

  SCM  env;
  SCM  content;
} smutt_message_t;

typedef struct
{
  smutt_object_t smutt_object;

  SCM  to;
  SCM  from;
  SCM  return_path;
} smutt_envelope_t;

typedef struct
{
  smutt_object_t smutt_object;

  SCM content;
  SCM parts;
  SCM next;
} smutt_body_t;

typedef smutt_object_t  smutt_content_t;
typedef smutt_object_t  smutt_pattern_t;
typedef smutt_object_t  smutt_menu_t;
typedef smutt_object_t  smutt_score_t;
typedef smutt_object_t  smutt_buffy_t;


/* Mark _C_OBJECT as undestroyable (i.e. it is now referenced by C
   code and should *not* be garbage collected).  */
#define MARK_AS_UNDESTROYABLE(_c_object)			\
{								\
  smutt_object_t *smutt_object;					\
  smutt_object = (smutt_object_t *)(_c_object)->extdata;	\
  if (smutt_object)						\
    smutt_object->destroy = 0;					\
}

/* Mark _C_OBJECT as destroyable (i.e. it is not referenced anymore
   by C code and may be garbage collected eventually).  */
#define MARK_AS_DESTROYABLE(_c_object)				\
{								\
  smutt_object_t *smutt_object;					\
  smutt_object = (smutt_object_t *)(_c_object)->extdata;	\
  if (smutt_object)						\
    smutt_object->destroy = 1;					\
}

/* Return non-zero if _C_OBJECT is destroyable (i.e. not referenced
   by C code).  */
#define DESTROYABLE(_c_object) \
  (((smutt_object_t *)(_c_object)->extdata)->destroy)


/* A generic marking function for the smobs we create.  This function
   is called by the garbage collector to mark objects which are still
   referenced by some other objects.  */
static SCM
smutt_mark_object (SCM object)
{
  smutt_object_t *smutt_object;
  unsigned int elements, i;
  SCM *smob;

  smutt_object = (smutt_object_t *) SCM_SMOB_DATA (object);
  assert (smutt_object);

  assert (smutt_object->self_size >= sizeof (smutt_object_t));
  elements = smutt_object->self_size - sizeof (smutt_object_t);

  /* Make sure the remaining size divides by sizeof (SCM).  Here we
     assume that sizeof (SCM) is a power of 2, which should be the
     case since SCM is a pointer type.  */
  assert ((elements & (sizeof (SCM) - 1)) == 0);
  elements = elements / sizeof (SCM);

  if (elements == 0)
    return SCM_BOOL_F;
  
  /* Now, we consider that there is an array of ELEMENTS smobs
     starting from the end of the SMUTT_OBJECT structure.  So we just
     traverse this array in order to mark each of these smobs.
     WARNING:  This means that typedefs such as `smutt_message_t'
     should contain *only* smobs!  */
  smob = (SCM *) (smutt_object + 1);
  for (i = 0; i < elements - 1; i++)
    {
      if (smob[i] != (SCM)0)
	scm_gc_mark (smob[i]);
    }

  if (smob[elements - 1] != (SCM)0)
    /* In order to minimize recursion, Guile allows to return the next
       object to be marked.  */
    return smob[elements - 1];

  return SCM_BOOL_F;
}

#if 0
static SCM
smutt_mark_message (SCM message)
{
  smutt_message_t *smutt_message;

  smutt_message = (smutt_message_t *) SCM_SMOB_DATA (message);

  if (smutt_message->env != (SCM)0)
    scm_gc_mark (smutt_message->env);
  if (smutt_message->content != (SCM)0)
    return smutt_message->content;

  return SCM_BOOL_F;
}

static SCM
smutt_mark_nothing (SCM object)
{
  return SCM_BOOL_F;
}
#endif


/* Hooks that are called anytime a C object is being deleted by
   C code.  */


#if 0
/* A generic object destruction hook to avoid code duplication.
   It can be called by type-specific destruction hook anytime the
   C object to which SMUTT_OBJECT is attached is about to be destroyed
   by C code.  */
static INLINE void
free_object_hook (smutt_object_t *smutt_object)
{
  unsigned int bytes;
  SCM *smob;

  assert (smutt_object->self_size >= sizeof (smutt_object_t));
  bytes = smutt_object->self_size - sizeof (smutt_object_t);

  /* Make sure the remaining size divides by sizeof (SCM).  Here we
     assume that sizeof (SCM) is a power of 2, which should be the
     case since SCM is a pointer type.  */
  assert ((bytes & (sizeof (SCM) - 1)) == 0);

  if (bytes == 0)
    return;
  
  /* Now, we consider that there is an array of ELEMENTS smobs
     starting from the end of the SMUTT_OBJECT structure.
     WARNING:  This means that typedefs such as `smutt_message_t'
     should contain *only* smobs!  */
  smob = (SCM *) ((char *)smutt_object + sizeof (smutt_object_t));
  bzero (smob, bytes);

  smutt_object->object = NULL;
  smutt_object->object_extdata = NULL;
  smutt_object->smob = (SCM)0;
}
#endif

/* These hooks will not actually delete the object they are passed but
   rather mark them as `destroyable' so that their deletion is delayed
   until the next GC sweep phase if they are not needed anymore by
   Scheme code.  In other words, any C object that Scheme code is
   aware of is ultimately destroyed by smutt_free_smob (), unless
   marked `undestroyable' (i.e. owned by C code).  */

static void
free_body_hook (BODY *body)
{
  assert (body->extdata);
  /* free_object_hook ((smutt_object_t *)body->extdata); */
  MARK_AS_DESTROYABLE (body);
}

static void
free_message_hook (HEADER *message)
{
  assert (message->extdata);
  MARK_AS_DESTROYABLE (message);
}

static void
free_envelope_hook (ENVELOPE *envelope)
{
  assert (envelope->extdata);
  MARK_AS_DESTROYABLE (envelope);
}

static void
free_alias_hook (ALIAS *alias)
{
  assert (alias->extdata);
  MARK_AS_DESTROYABLE (alias);
}

static void
free_address_hook (ADDRESS *address)
{
  assert (address->extdata);
  MARK_AS_DESTROYABLE (address);
}


/* Type-specific deallocation methods that may be stored in the
   `free_object' field of smutt_object_t items and called by
   `smutt_free_smob ()' for objects owned by Scheme code
   (i.e. `destroyable' objects).

   Note that before calling the original Mutt destructors, these
   functions have to clear any field containing a pointer to a C
   object for which there exist a smob.  Otherwise, this C object
   would be freed before the corresponding smob actually needs to be
   freed.  The free hooks will not be called because at the time our
   free_* functions are called, the `extdata' field of the object they
   are passed is NULL.

   Also, since some of these objects may be allocated by C code, we
   never call scm_must_malloc () or scm_done_malloc () when allocating
   such objects, even if they are allocated by Scheme code.
   Consequently, these functions should not tell Guile how much data
   has been freed, so they always return zero.  */


/* Mark aggregated object _OBJECT as NULL if there exist a live smob
   representing it, so that it doesn't get destroyed right now.  */
#define CLEAR_OBJECT(_object)			\
do						\
  {						\
    if ((_object))				\
      if ((_object)->extdata)			\
	/* Delay object deletion */		\
	(_object) = NULL;			\
  }						\
while (0)

static size_t
free_alias (ALIAS *alias)
{
  assert (alias->extdata == NULL);
  
  CLEAR_OBJECT (alias->addr);
  mutt_free_alias (&alias);

  return 0;
}

static size_t
free_envelope (ENVELOPE *envelope)
{
  assert (envelope->extdata == NULL);
  
  CLEAR_OBJECT (envelope->to);
  CLEAR_OBJECT (envelope->from);
  CLEAR_OBJECT (envelope->return_path);

  mutt_free_envelope (&envelope);
  
  return 0;
}

static size_t
free_address (ADDRESS *address)
{
  assert (address->extdata == NULL);
  
  CLEAR_OBJECT (address->next); /* FIXME: Really? */
  rfc822_free_address (&address);
  
  return 0;
}

static size_t
free_body (BODY *body)
{
  assert (body->extdata == NULL);
  
  CLEAR_OBJECT (body->content);
  mutt_free_body (&body);

  return 0;
}

#define free_mailbox  NULL
#define free_message  NULL
#define free_content  NULL
#define free_pattern  NULL
#define free_menu     NULL
#define free_score    NULL
#define free_buffy    NULL



/* Validate the type of a `smutt' (stands for "Schemey Mutt") object.  */
#define SCM_VALIDATE_MUTT_TYPE(_type, _pos, _sym) \
  SCM_ASSERT (SCM_SMOB_PREDICATE (smutt_ ## _type ## _tag, (_sym)), \
	      (_sym), (_pos), __FUNCTION__);

/* Make sure _SYM is a string list.  */
#define SCM_VALIDATE_STRING_LIST(_pos, _sym)		\
{							\
  SCM _list = (_sym);					\
							\
  SCM_VALIDATE_LIST ((_pos), _list);			\
  while (_list != SCM_EOL)				\
    {							\
      SCM_VALIDATE_STRING ((_pos), SCM_CAR (_list));	\
      _list = SCM_CDR (_list);				\
    }							\
}

/* Make sure _SYM is a string pair.  */
#define SCM_VALIDATE_STRING_PAIR(_pos, _sym)		\
{							\
  /* SCM_VALIDATE_PAIR   ((_pos), (_sym)); */		\
  SCM_VALIDATE_STRING ((_pos), SCM_CAR ((_sym)));	\
  SCM_VALIDATE_STRING ((_pos), SCM_CDR ((_sym)));	\
}

/* Make sure _SYM is an association list made of string pairs.  */
#define SCM_VALIDATE_STRING_ALIST(_pos, _sym)			\
{								\
  SCM _list = (_sym);						\
								\
  SCM_VALIDATE_LIST ((_pos), _list);				\
  while (_list != SCM_EOL)					\
    {								\
      SCM_VALIDATE_STRING_PAIR ((_pos), SCM_CAR (_list));	\
      _list = SCM_CDR (_list);					\
    }								\
}

/* Set _C_STRING to a copy of Scheme string _S_STRING.  */
#define SCM_STRING_DUP(_c_string, _s_string)			\
{								\
  (_c_string) = safe_strdup (SCM_STRING_CHARS (_s_string));	\
}

/* Turn _S_LIST into a Scheme list of strings, based on C string list
   _C_LIST.  */
#define SCM_MAKE_STRING_LIST(_s_list, _c_list)				\
do									\
{									\
  LIST *_c_element = (_c_list);						\
									\
  (_s_list) = SCM_EOL;							\
  for (_c_element = (_c_list);						\
       _c_element;							\
       _c_element = _c_element->next)					\
    {									\
      if (_c_element->data)						\
	{								\
	  SCM _s_element;						\
	  _s_element = scm_makfrom0str (_c_element->data);		\
	  (_s_list) = scm_append (SCM_LIST2 ((_s_list),			\
					     SCM_LIST1 (_s_element)));	\
	}								\
    }									\
}									\
while (0)

/* Turn _S_LIST into a list of pairs (an association list)
   representing the attribute-value pairs of the _PARAMETER list.
   _C_TYPE is the alist C type (which should contain a `next' field);
   _CAR_FIELD is the field whose value will be assigned to pairs' car;
   _CDR_FIELD is the field whose value will be assigned to pairs'
   cdr.  */
#define MAKE_STRING_ALIST(_s_list, _parameter, _c_type, _car_field, _cdr_field) \
{								\
  _c_type *_param;						\
								\
  for (_param = (_parameter), (_s_list) = SCM_EOL;		\
       _param != NULL;						\
       _param = _param->next)					\
    {								\
      if (_param-> _car_field && _param-> _cdr_field)		\
	scm_assq_set_x ((_s_list),				\
			scm_makfrom0str (_param-> _car_field),	\
			scm_makfrom0str (_param-> _cdr_field));	\
    }								\
}


/* Turn _S_LIST into an alist where each key is a string and each
   value is a smob of type _CDR_STYPE.  */
#define MAKE_STRING_OBJECT_ALIST(_s_list, _parameter, _c_type,			\
				 _car_field, _cdr_field, _cdr_stype)		\
{										\
  _c_type *_param;								\
										\
  for (_param = (_parameter), (_s_list) = SCM_EOL;				\
       _param != NULL;								\
       _param = _param->next)							\
    {										\
      SCM smob;									\
      if (_param-> _car_field && _param-> _cdr_field)				\
	{									\
	  MAKE_SMOB (smob, _cdr_stype, _param-> _cdr_field, 1);			\
 	  scm_assq_set_x ((_s_list),						\
			  scm_makfrom0str (_param-> _car_field),		\
			  smob);						\
	}									\
    }										\
}


/* Assigns _C_RESULT, which is a pointer to type _C_TYPE, the C equivalent
   of _SMOB.  */
#define TRANSLATE_SMOB(_c_result, _smob, _c_type)				\
  do										\
  {										\
    smutt_object_t *smutt_object = (smutt_object_t *) SCM_SMOB_DATA (_smob);	\
    assert (smutt_object);							\
    assert (smutt_object->object);						\
    assert (smutt_object->smob == (_smob));					\
    assert (((_c_type *)smutt_object->object)->extdata == smutt_object);	\
    										\
    (_c_result) = (_c_type *) smutt_object->object;				\
  }										\
  while (0)

/* Turn _SMUTT_SMOB into a SMOB representing C object _C_OBJECT whose
   scheme type is _S_TYPE.  _DESTROY is an integer specifying whether
   _C_OBJECT should be freed when _SMUTT_SMOB is garbage collected.  */
#define MAKE_SMOB(_smutt_smob, _s_type, _c_object, _destroy)			\
  do										\
  {										\
    if (! (_c_object))								\
      _smutt_smob = SCM_UNDEFINED;						\
    else									\
    {										\
      smutt_object_t *_smutt_object;						\
      _smutt_object = (smutt_object_t *)(_c_object)->extdata;			\
      if (!_smutt_object)							\
      {										\
        _smutt_object =								\
	  scm_must_malloc (sizeof (smutt_ ## _s_type ## _t),			\
			   "smutt-" STRINGIFY (_s_type));			\
        if (!_smutt_object)							\
        {									\
          (_smutt_smob) = SCM_UNDEFINED;					\
          break;								\
        }									\
        bzero (_smutt_object, sizeof (smutt_ ## _s_type ## _t));		\
        _smutt_object->self_size = sizeof (smutt_ ## _s_type ## _t);		\
        _smutt_object->object = (_c_object);					\
        _smutt_object->object_size = sizeof (*(_c_object));			\
        _smutt_object->free_object = (size_t (*)(void *)) free_ ## _s_type;	\
        _smutt_object->destroy = (_destroy);					\
        _smutt_object->object_extdata =						\
          (smutt_object_t **) &(_c_object)->extdata;				\
        (_c_object)->extdata = _smutt_object;					\
        SCM_NEWSMOB ((_smutt_smob), smutt_ ## _s_type ## _tag, _smutt_object);	\
        _smutt_object->smob = (_smutt_smob);					\
      }										\
      else									\
      {										\
        /* Try to reuse the same smob as before */				\
        assert (_smutt_object->smob != (SCM)0);					\
        assert (_smutt_object->object == (_c_object));				\
        assert ((void *)SCM_SMOB_DATA (_smutt_object->smob) == _smutt_object);	\
        (_smutt_smob) = _smutt_object->smob;					\
      }										\
    }										\
  }										\
  while (0)

/* Create a SMOB of type _S_TYPE for internal Mutt object (i.e. data
   which should NOT be garbage collected) _C_OBJECT.  */
#define MAKE_MUTT_SMOB(_smutt_smob, _s_type, _c_object) \
  MAKE_SMOB (_smutt_smob, _s_type, _c_object, 0)

/* Magic macro that produces the body of an accessor function for
   type TYPE (eg. `symbol'), with argument ARG, accessing field named FIELD
   which is of type FIELDTYPE, and using RETURN_EXPR upon return.  */
#define GETTER_FUNCTION_BODY(ctype, stype, arg, field, fieldtype, return_expr) \
{						\
  ctype *object;				\
  fieldtype field;				\
						\
  SCM_VALIDATE_MUTT_TYPE (stype, 0, arg);	\
  TRANSLATE_SMOB (object, arg, ctype);          \
  field =  object-> field;	                \
						\
  return (return_expr);				\
}

/* Same as above except that ARG is considered as an optional argument whose
   default C value is ARG_DFLT.  */
#define GETTER_FUNCTION_BODY_OPT(ctype, stype, arg, arg_dflt, field, fieldtype, return_expr) \
{						\
  ctype *object = arg_dflt;			\
  fieldtype field;				\
						\
  if (arg != SCM_UNDEFINED)			\
    {						\
      SCM_VALIDATE_MUTT_TYPE (stype, 0, arg);	\
      TRANSLATE_SMOB (object, arg, ctype);	\
    }						\
  						\
  if (!object)					\
    return SCM_BOOL_F;				\
   						\
  field = object-> field;			\
						\
  return (return_expr);				\
}

/* Body of a getter which accesses field FIELD of smob ARG and return
   a string list.  */
#define STRING_LIST_GETTER_FUNCTION_BODY(arg, stype, ctype, field)	\
{									\
  ctype *c_object;							\
  SCM    s_string_list;							\
									\
  SCM_VALIDATE_MUTT_TYPE (stype, 0, arg);				\
  TRANSLATE_SMOB (c_object, arg, ctype);				\
  SCM_MAKE_STRING_LIST (s_string_list, c_object-> field);		\
									\
  return s_string_list;							\
}

/* Body of a getter returning a parameter list in the form of a string
   association list.  */
#define STRING_ALIST_GETTER_FUNCTION_BODY(arg, stype, ctype, field)	\
{									\
  ctype *c_object;							\
  SCM    s_alist;							\
									\
  SCM_VALIDATE_MUTT_TYPE (stype, 0, arg);				\
  TRANSLATE_SMOB (c_object, arg, ctype);				\
  MAKE_STRING_ALIST (s_alist, c_object-> field, PARAMETER,		\
		     attribute, value);					\
									\
  return s_alist;							\
}

/* Body of functions accessing objects.  Note that we must ensure that the
   accessed object (the parent) retains a reference to its field (the child)
   so that the child C object cannot be deleted until its parent is freed.
   
   XXX: We can't use the GETTER_FUNCTION_BODY macro because we are not
   supposed to use GCC's macros returning values. :(  */
#define OBJECT_GETTER_FUNCTION_BODY(ctype, stype, arg,			\
				    field,				\
				    fieldctype, fieldstype)		\
{									\
  ctype *object;							\
  fieldctype field;							\
  SCM ret;								\
									\
  SCM_VALIDATE_MUTT_TYPE (stype, 0, arg);				\
  TRANSLATE_SMOB (object, arg, ctype);					\
  field = object-> field;						\
									\
  if (!field)								\
    ret = SCM_BOOL_F;							\
  else									\
  {									\
    smutt_ ## stype ## _t *smutt_object;				\
    smutt_object = (smutt_ ## stype ## _t *) SCM_SMOB_DATA (arg);	\
    MAKE_MUTT_SMOB (ret, fieldstype, field);				\
    /* Keep the field smob so that it can be marked */			\
    smutt_object-> field = ret;						\
  }									\
									\
  return ret;								\
}

/* Body of a setter function, i.e. a function that does something equivalent
   to S_PARENT->FIELD = S_CHILD.  The `smutt object' representing S_PARENT
   must record the smob that we are assigning to FIELD so that is can
   be marked later.  The previous smob for FIELD will be forgotten and
   therefore may be left unmaked after the next mark phase of the GC
   in which case it will be garbage collected.  */
#define OBJECT_SETTER_FUNCTION_BODY(s_parent, parent_stype, parent_ctype,  \
				    s_child, child_stype, child_ctype,	   \
				    field)                                 \
{								\
  parent_ctype *c_parent;					\
  child_ctype  *c_child;					\
  smutt_ ## parent_stype ## _t *smutt_parent_obj;		\
								\
  SCM_VALIDATE_MUTT_TYPE (parent_stype, 0, s_parent);		\
  SCM_VALIDATE_MUTT_TYPE (child_stype,  1, s_child);		\
  TRANSLATE_SMOB (c_parent, s_parent, parent_ctype);		\
  TRANSLATE_SMOB (c_child,  s_child,  child_ctype);		\
								\
  /* Keep the `child' smob so that it can be marked later on */	\
  smutt_parent_obj =						\
    (smutt_ ## parent_stype ## _t *) SCM_SMOB_DATA (s_parent);	\
  assert (smutt_parent_obj);					\
  smutt_parent_obj-> field = s_child;				\
  c_parent-> field = c_child;					\
								\
  return SCM_UNSPECIFIED;					\
}

/* Body of a setter function that sets field FIELD of smob S_OBJECT to
   a copy of S_STRING.  */
#define STRING_SETTER_FUNCTION_BODY(s_object, object_stype, object_ctype,	\
				    s_string,					\
				    field)					\
{										\
  object_ctype *c_object;							\
										\
  SCM_VALIDATE_MUTT_TYPE (object_stype, 0, s_object);				\
  SCM_VALIDATE_STRING (1, s_string);						\
  TRANSLATE_SMOB (c_object, s_object, object_ctype);				\
										\
  if (c_object-> field)								\
    free (c_object-> field);							\
  										\
  SCM_STRING_DUP (c_object-> field, s_string);					\
  if (!c_object-> field)							\
    return SCM_BOOL_F;								\
										\
  return SCM_UNDEFINED;								\
}

/* Body of a string list setter function.
   XXX: We don't use scm_done_free () and such here because some lists
   may have been allocated by internal C code which didn't call
   scm_done_malloc ().  */
#define STRING_LIST_SETTER_FUNCTION_BODY(s_object, object_stype, object_ctype,	\
					 s_string_list, field)			\
{										\
  object_ctype *c_object;							\
										\
  SCM_VALIDATE_MUTT_TYPE (object_stype, 0, s_object);				\
  SCM_VALIDATE_STRING_LIST (1, s_string_list);					\
  TRANSLATE_SMOB (c_object, s_object, object_ctype);				\
 										\
  TRANSLATE_STRING_LIST (&c_object-> field, s_string_list);			\
										\
  return SCM_UNSPECIFIED;							\
}

/* Body of a string association list setter.  */
#define STRING_ALIST_SETTER_FUNCTION_BODY(s_object, object_stype, object_ctype,	\
					  s_alist, field)			\
{										\
  object_ctype *c_object;							\
										\
  SCM_VALIDATE_MUTT_TYPE (object_stype, 0, s_object);				\
  SCM_VALIDATE_STRING_ALIST (1, s_alist);					\
  TRANSLATE_SMOB (c_object, s_object, object_ctype);				\
										\
  TRANSLATE_STRING_ALIST (&c_object-> field, s_alist);				\
										\
  return SCM_UNSPECIFIED;							\
}


/* Translate _S_STRING_LIST, a Scheme list of string elements, into
   a C list of strings pointed to by _C_LIST_P.
   Warning: It does not check the type of the Scheme list elements and
   its modifies the value of the variable underlying _S_STRING_LIST.  */
#define TRANSLATE_STRING_LIST(_c_list_p, _s_string_list)		\
{									\
  LIST *c_element;							\
									\
  if (! *(_c_list_p))							\
    *(_c_list_p) = safe_calloc (1, sizeof (LIST));			\
									\
  for (c_element = *(_c_list_p);					\
       (c_element != NULL) && ((_s_string_list) != SCM_EOL);		\
       (_s_string_list) = SCM_CDR ((_s_string_list)))			\
    {									\
      SCM s_string;							\
      s_string = SCM_CAR ((_s_string_list));				\
      if (c_element->data)						\
	free (c_element->data);						\
									\
      /* Don't call scm_done_malloc () here!  */			\
      c_element->data = safe_strdup (SCM_STRING_CHARS (s_string));	\
      if (!c_element->data)						\
	break;								\
									\
      if (SCM_CDR ((_s_string_list)) != SCM_EOL)			\
	{								\
	  /* Do we need to allocate a new element? */			\
	  if (!c_element->next)						\
	    c_element->next = safe_calloc (1, sizeof (LIST));		\
									\
	  c_element = c_element->next;					\
	}								\
    }									\
}

/* Translate _S_LIST, a Scheme association list, into *_PARAMETER_P,
   a C parameter list.  */
#define TRANSLATE_STRING_ALIST(_parameter_p, _s_list)			\
{									\
  PARAMETER *c_element;							\
									\
  if (! *(_parameter_p))						\
    *(_parameter_p) = safe_calloc (1, sizeof (PARAMETER));		\
									\
   for (c_element = *(_parameter_p);					\
       (c_element != NULL) && ((_s_list) != SCM_EOL);			\
       (_s_list) = SCM_CDR ((_s_list)))					\
    {									\
      SCM s_pair, s_attr, s_val;					\
									\
      s_pair = SCM_CAR ((_s_list));					\
      s_attr = SCM_CAR (s_pair);					\
      s_val  = SCM_CDR (s_pair);					\
      if (c_element->attribute)						\
	free (c_element->attribute);					\
      if (c_element->value)						\
	free (c_element->value);					\
									\
      /* Don't call scm_done_malloc () here!  */			\
      c_element->attribute = safe_strdup (SCM_STRING_CHARS (s_attr));	\
      c_element->value = safe_strdup (SCM_STRING_CHARS (s_val));	\
      if ((!c_element->attribute) || (!c_element->value))		\
	break;								\
									\
      if (SCM_CDR ((_s_list)) != SCM_EOL)				\
	{								\
	  /* Do we need to allocate a new element? */			\
	  if (!c_element->next)						\
	    c_element->next = safe_calloc (1, sizeof (PARAMETER));	\
									\
	  c_element = c_element->next;					\
	}								\
    }									\
}

/* Produce the body of a message flag setter function.  _FLAG_NAME has to be
   both the flag name in the HEADER struct and the function boolean parameter
   name, while _FLAG_VALUE is the value that should be passed to
   mutt_set_flags () (on of M_TAG, M_DELETED, etc.).  */
#define MESSAGE_FLAG_SETTER_BODY(_message, _flag_name, _mailbox, _flag_value) \
{								\
  int c_set_flag = 1;						\
  HEADER  *c_message;						\
  CONTEXT *c_mailbox = Context;					\
								\
  SCM_VALIDATE_MUTT_TYPE (_message, 0, message);		\
  if (_flag_name != SCM_UNDEFINED)				\
  {								\
    SCM_VALIDATE_BOOL (1, _flag_name);				\
    c_set_flag = (_flag_name == SCM_BOOL_T);			\
  }								\
  if (_mailbox != SCM_UNDEFINED)				\
  {								\
    SCM_VALIDATE_MUTT_TYPE (mailbox, 2, _mailbox);		\
    TRANSLATE_SMOB (c_mailbox, _mailbox, CONTEXT);		\
  }								\
  TRANSLATE_SMOB (c_message, _message, HEADER);			\
  mutt_set_flag (c_mailbox, c_message, _flag_value, c_set_flag);\
								\
  return SCM_UNSPECIFIED;					\
}

/* Construction function body for smob type S_TYPE which corresponds
   to C type C_TYPE.  */
#define OBJECT_CONSTRUCTOR_FUNCTION_BODY(s_type, c_type)	\
{								\
  SCM s_object;							\
  c_type *c_object;						\
								\
  c_object = calloc (1, sizeof (c_type));			\
  if (!c_object)						\
    return SCM_BOOL_F;						\
								\
  /* Return a destroyable object */				\
  MAKE_SMOB (s_object, s_type, c_object, 1);			\
								\
  return s_object;						\
}

/* Convert Scheme file port _S_PORT into C file handle _C_FILE.  */
#define MAKE_FILE_FROM_PORT(_c_file, _s_port)				\
{									\
  scm_force_output ((_s_port));						\
  (_c_file) = fdopen (SCM_NUM2INT (0, scm_fileno ((_s_port))), "w");	\
}

/* The last error message returned by a command.  */
static char last_error_message[ERRMSG_SIZE_MAX] = { '\0' };


/* Accessor functions, ie. functions that makes it possible to access fields
   of SMOB objects.  */

SCM_DEFINE (smutt_mailbox_path, "mailbox-path", 0, 1, 0,
	    (SCM mailbox),
	    "Return @var{mailbox}'s mailbox path (or URL).")
#define FUNC_NAME s_smutt_mailbox_path
GETTER_FUNCTION_BODY_OPT (CONTEXT, mailbox, mailbox, Context,
			  path, char *,
			  path ? scm_makfrom0str (path) : SCM_BOOL_F)
#undef FUNC_NAME

/* Note: `mutt.scm' should define a procedure with setter called
   `mailbox-limit-pattern'.  */
SCM_DEFINE (smutt_mailbox_limit_pattern_ref,
	    "mailbox-limit-pattern-ref", 0, 1, 0,
	    (SCM mailbox),
	    "Return @var{mailbox}'s current limit pattern (a string).")
#define FUNC_NAME s_smutt_mailbox_limit_pattern_ref
GETTER_FUNCTION_BODY_OPT (CONTEXT, mailbox, mailbox, Context,
			  pattern, char *,
			  pattern ? scm_makfrom0str (pattern) : SCM_BOOL_F)
#undef FUNC_NAME

SCM_DEFINE (smutt_mailbox_limit_pattern_set,
	    "mailbox-limit-pattern-set!", 2, 0, 0,
	    (SCM mailbox, SCM pattern),
	    "Set @var{mailbox}'s limit pattern.")
#define FUNC_NAME s_smutt_mailbox_limit_pattern_set
{
  int err;
  CONTEXT *c_mailbox;
  pattern_t *c_pattern;

  SCM_VALIDATE_MUTT_TYPE (mailbox, 0, mailbox);
  SCM_VALIDATE_STRING (1, pattern);

  TRANSLATE_SMOB (c_mailbox, mailbox, CONTEXT);

  err = builtin_compile_pattern (&c_pattern, SCM_STRING_CHARS (pattern),
				 M_FULL_MSG, last_error_message);
  if (err)
    return SCM_BOOL_F;

  if (c_mailbox->pattern)
    free (c_mailbox->pattern);
  if (c_mailbox->limit_pattern)
    free (c_mailbox->limit_pattern);

  /* XXX: The index is *not* refreshed!  */
  SCM_STRING_DUP (c_mailbox->pattern, pattern);
  c_mailbox->limit_pattern = c_pattern;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_mailbox_messages, "mailbox-messages", 0, 1, 0,
	    (SCM mailbox),
	    "Returns the number of message for @var{mailbox}.")
#define FUNC_NAME smutt_mailbox_messages
GETTER_FUNCTION_BODY_OPT (CONTEXT, mailbox, mailbox, Context,
			  msgcount, int,
			  scm_int2num (msgcount))
#undef FUNC_NAME

SCM_DEFINE (smutt_mailbox_tagged_messages,
	    "mailbox-tagged-messages", 0, 1, 0,
	    (SCM mailbox),
	    "Returns the number of tagged messages for @var{mailbox}.")
#define FUNC_NAME s_smutt_mailbox_tagged_messages
GETTER_FUNCTION_BODY_OPT (CONTEXT, mailbox, mailbox, Context,
			  tagged, int,
			  scm_int2num (tagged))
#undef FUNC_NAME

SCM_DEFINE (smutt_mailbox_new_messages,
	    "mailbox-new-messages", 0, 1, 0,
	    (SCM mailbox),
	    "Returns the number of new messages for @var{mailbox}.")
#define FUNC_NAME s_smutt_mailbox_new_messages
GETTER_FUNCTION_BODY_OPT (CONTEXT, mailbox, mailbox, Context,
			  new, int,
			  scm_int2num (new))
#undef FUNC_NAME

SCM_DEFINE (smutt_mailbox_unread_messages,
	    "mailbox-unread-messages", 0, 1, 0,
	    (SCM mailbox),
	    "Returns the number of unread messages for @var{mailbox}.")
#define FUNC_NAME s_smutt_mailbox_unread_messages
GETTER_FUNCTION_BODY_OPT (CONTEXT, mailbox, mailbox, Context,
			  unread, int,
			  scm_int2num (unread))
#undef FUNC_NAME

SCM_DEFINE (smutt_mailbox_deleted_messages,
	    "mailbox-deleted-messages", 0, 1, 0,
	    (SCM mailbox),
	    "Returns the number of deleted messages for @var{mailbox}.")
#define FUNC_NAME s_smutt_mailbox_deleted_messages
GETTER_FUNCTION_BODY_OPT (CONTEXT, mailbox, mailbox, Context,
			  deleted, int,
			  scm_int2num (deleted))
#undef FUNC_NAME

SCM_DEFINE (smutt_mailbox_flagged_messages,
	    "mailbox-flagged-messages", 0, 1, 0,
	    (SCM mailbox),
	    "Returns the number of flagged messages for @var{mailbox}.")
#define FUNC_NAME s_smutt_mailbox_flagged_messages
GETTER_FUNCTION_BODY_OPT (CONTEXT, mailbox, mailbox, Context,
			  flagged, int,
			  scm_int2num (flagged))
#undef FUNC_NAME

SCM_DEFINE (smutt_mailbox_select_messages,
	    "mailbox-select-messages", 1, 1, 0,
	    (SCM proc, SCM mailbox),
	    "Return the list of messages for which @var{proc} returned true. "
	    "@var{proc} has to be a one-argument procedure.")
#define FUNC_NAME s_smutt_mailbox_select_messages
{
  int i;
  SCM result_list;
  HEADER  *c_message;
  CONTEXT *c_mailbox = Context;

  SCM_VALIDATE_PROC (0, proc);
  if (mailbox != SCM_UNDEFINED)
  {
    SCM_VALIDATE_MUTT_TYPE (mailbox, 1, mailbox);
    TRANSLATE_SMOB (c_mailbox, mailbox, CONTEXT);
  }

  result_list = SCM_EOL;
  if (!c_mailbox)
    return result_list;

  for (i = 0, c_message = c_mailbox->hdrs[0];
       i < c_mailbox->msgcount;
       i++, c_message = c_mailbox->hdrs[i])
  {
    SCM message, result;

    MAKE_MUTT_SMOB (message, message, c_message);
    result = scm_call_1 (proc, message);

    if (!SCM_FALSEP (result))
      /* Append the result to the list */
      result_list = scm_append (SCM_LIST2 (result_list, SCM_LIST1 (message)));
  }

  return result_list;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_mailbox_locked_p, "mailbox-locked?", 0, 1, 0,
	    (SCM mailbox),
	    "Returns true if @var{mailbox} is locked.")
#define FUNC_NAME s_smutt_mailbox_locked_p
GETTER_FUNCTION_BODY_OPT (CONTEXT, mailbox, mailbox, Context,
			  locked, int,
			  scm_int2num (locked))
#undef FUNC_NAME

SCM_DEFINE (smutt_mailbox_changed_p, "mailbox-changed?", 0, 1, 0,
	    (SCM mailbox),
	    "Returns true if @var{mailbox} is changed.")
#define FUNC_NAME s_smutt_mailbox_changed_p
GETTER_FUNCTION_BODY_OPT (CONTEXT, mailbox, mailbox, Context,
			  changed, int,
			  scm_int2num (changed))
#undef FUNC_NAME

SCM_DEFINE (smutt_mailbox_readonly_p, "mailbox-readonly?", 0, 1, 0,
	    (SCM mailbox),
	    "Returns true if @var{mailbox} is read-only.")
#define FUNC_NAME s_smutt_mailbox_readonly_p
GETTER_FUNCTION_BODY_OPT (CONTEXT, mailbox, mailbox, Context,
			  readonly, int,
			  scm_int2num (readonly))
#undef FUNC_NAME

SCM_DEFINE (smutt_mailbox_dontwrite_p, "mailbox-dontwrite?", 0, 1, 0,
	    (SCM mailbox),
	    "Returns true if @var{mailbox}'s mailbox will not be written.")
#define FUNC_NAME s_smutt_mailbox_dontwrite_p
GETTER_FUNCTION_BODY_OPT (CONTEXT, mailbox, mailbox, Context,
			  dontwrite, int,
			  scm_int2num (dontwrite))
#undef FUNC_NAME

SCM_DEFINE (smutt_mailbox_append_p, "mailbox-append?", 0, 1, 0,
	    (SCM mailbox),
	    "Returns true if the mailbox is opened in append mode.")
#define FUNC_NAME s_smutt_mailbox_append_p
GETTER_FUNCTION_BODY_OPT (CONTEXT, mailbox, mailbox, Context,
			  append, int,
			  scm_int2num (append))
#undef FUNC_NAME

SCM_DEFINE (smutt_mailbox_collapsed_p, "mailbox-collapsed?", 0, 1, 0,
	    (SCM mailbox),
	    "Returns true if @var{mailbox}'s threads are collapsed.")
#define FUNC_NAME s_smutt_mailbox_collapsed_p
GETTER_FUNCTION_BODY_OPT (CONTEXT, mailbox, mailbox, Context,
			  collapsed, int,
			  scm_int2num (collapsed))
#undef FUNC_NAME

SCM_DEFINE (smutt_address_personal_ref, "address-personal-ref", 1, 0, 0,
	    (SCM address),
	    "Returns the personal information for @var{address}.")
#define FUNC_NAME s_smutt_address_personal_ref
GETTER_FUNCTION_BODY (ADDRESS, address, address,
		      personal, char *,
		      personal ? scm_makfrom0str (personal) : SCM_BOOL_F)
#undef FUNC_NAME

SCM_DEFINE (smutt_address_personal_set, "address-personal-set!", 2, 0, 0,
	    (SCM address, SCM personal),
	    "Sets @var{address}'s personal field.")
#define FUNC_NAME s_smutt_address_personal_set
STRING_SETTER_FUNCTION_BODY (address, address, ADDRESS,
			     personal, personal)
#undef FUNC_NAME

SCM_DEFINE (smutt_address_mailbox_ref, "address-mailbox-ref", 1, 0, 0,
	    (SCM address),
	    "Returns the mailbox information for @var{address}.")
#define FUNC_NAME s_smutt_address_mailbox_ref
GETTER_FUNCTION_BODY (ADDRESS, address, address,
		      mailbox, char *,
		      mailbox ? scm_makfrom0str (mailbox) : SCM_BOOL_F)
#undef FUNC_NAME

SCM_DEFINE (smutt_address_mailbox_set, "address-mailbox-set!", 2, 0, 0,
	    (SCM address, SCM mailbox),
	    "Set @var{address}'s mailbox to @var{mailbox}, a string.")
#define FUNC_NAME s_smutt_address_mailbox_set
STRING_SETTER_FUNCTION_BODY (address, address, ADDRESS,
			     mailbox, mailbox)
#undef FUNC_NAME

SCM_DEFINE (smutt_address_group_ref, "address-group?-ref", 1, 0, 0,
	    (SCM address),
	    "Return true if @var{address} is a group address.")
#define FUNC_NAME s_smutt_address_group_ref
GETTER_FUNCTION_BODY (ADDRESS, address, address,
		      group, int,
		      group ? SCM_BOOL_T : SCM_BOOL_F)
#undef FUNC_NAME

SCM_DEFINE (smutt_address_group_set, "address-group?-set!", 2, 0, 0,
	    (SCM address, SCM group),
	    "Tell whether @var{address} is a group address.")
#define FUNC_NAME s_smutt_address_group_set
{
  ADDRESS *c_address;

  SCM_VALIDATE_MUTT_TYPE (address, 0, address);

  TRANSLATE_SMOB (c_address, address, ADDRESS);
  c_address->group = (group == SCM_BOOL_T) ? 1 : 0;
  
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_address_next, "address-next", 1, 0, 0,
	    (SCM address),
	    "If @var{address} contains several addresses, return the next "
	    "one; return false otherwise.")
#define FUNC_NAME s_smutt_address_next
OBJECT_GETTER_FUNCTION_BODY (ADDRESS, address, address,
			     next, ADDRESS *, address)
#undef FUNC_NAME

SCM_DEFINE (smutt_alias_name, "alias-name", 1, 0, 0,
	    (SCM alias),
	    "Returns @var{alias}' name.")
#define FUNC_NAME s_smutt_alias_name
GETTER_FUNCTION_BODY (ALIAS, alias, alias,
		      name, char *,
		      name ? scm_makfrom0str (name) : SCM_BOOL_F)
#undef FUNC_NAME

SCM_DEFINE (smutt_alias_address, "alias-address", 1, 0, 0,
	    (SCM alias),
	    "Returns @var{alias}' address object.")
#define FUNC_NAME s_smutt_alias_address
OBJECT_GETTER_FUNCTION_BODY (ALIAS, alias, alias,
			     addr, ADDRESS *, address)
#undef FUNC_NAME

/* Note: `mutt.scm' should define a procedure with setter called
   `message-score'.  */
SCM_DEFINE (smutt_message_score_ref, "message-score-ref", 1, 0, 0,
	    (SCM message),
	    "Return the score of @var{message}.")
#define FUNC_NAME s_smutt_message_score_ref
GETTER_FUNCTION_BODY (HEADER, message, message,
		      score, int,
		      scm_int2num (score))
#undef FUNC_NAME

SCM_DEFINE (smutt_message_score_set, "message-score-set!", 2, 0, 0,
	    (SCM message, SCM score),
	    "Set the score of @var{message}.")
#define FUNC_NAME s_smutt_message_score_set
{
  HEADER *c_message;
  int c_score;

  SCM_VALIDATE_MUTT_TYPE (message, 0, message);
  SCM_VALIDATE_NUMBER (1, score);

  TRANSLATE_SMOB (c_message, message, HEADER);
  c_score = SCM_NUM2INT (1, score);
  c_message->score = c_score;

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_message_date_sent_ref, "message-date-sent-ref", 1, 0, 0,
	    (SCM message),
	    "Return the date when @var{message} was sent, an integer "
	    "(Epoch, UTC).")
#define FUNC_NAME s_smutt_message_date_sent_ref
GETTER_FUNCTION_BODY (HEADER, message, message,
		      date_sent, time_t,
		      scm_uint2num (date_sent))
#undef FUNC_NAME

SCM_DEFINE (smutt_message_date_sent_set, "message-date-sent-set!", 2, 0, 0,
	    (SCM message, SCM date),
	    "Change the date at which @var{message} was sent to @var{date}.")
#define FUNC_NAME s_smutt_message_date_sent_set
{
  HEADER *c_message;
  time_t  c_date;

  SCM_VALIDATE_MUTT_TYPE (message, 0, message);
  SCM_VALIDATE_NUMBER (1, date);

  TRANSLATE_SMOB (c_message, message, HEADER);
  c_date = SCM_NUM2UINT (1, date);
  c_message->date_sent = c_date;

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME 

SCM_DEFINE (smutt_message_date_received_ref, "message-date-received-ref", 1, 0, 0,
	    (SCM message),
	    "Return the date when @var{message} was sent, an integer "
	    "(Epoch, UTC).")
#define FUNC_NAME s_smutt_message_date_received_ref
GETTER_FUNCTION_BODY (HEADER, message, message,
		      received, time_t,
		      scm_uint2num (received))
#undef FUNC_NAME

SCM_DEFINE (smutt_message_date_received_set, "message-date-received-set!", 2, 0, 0,
	    (SCM message, SCM date),
	    "Change the date at which @var{message} was sent to @var{date}.")
#define FUNC_NAME s_smutt_message_date_received_set
{
  HEADER *c_message;
  time_t  c_date;

  SCM_VALIDATE_MUTT_TYPE (message, 0, message);
  SCM_VALIDATE_NUMBER (1, date);

  TRANSLATE_SMOB (c_message, message, HEADER);
  c_date = SCM_NUM2UINT (1, date);
  c_message->received = c_date;

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME 

SCM_DEFINE (smutt_message_number, "message-number", 1, 0, 0,
	    (SCM message),
	    "Get @var{message}'s index number.")
#define FUNC_NAME s_smutt_message_number
GETTER_FUNCTION_BODY (HEADER, message, message,
		      msgno, int,
		      scm_int2num (msgno))
#undef FUNC_NAME
     
SCM_DEFINE (smutt_message_flagged_p, "message-flagged?", 1, 0, 0,
	    (SCM message),
	    "Returns true if @var{message} is flagged.")
#define FUNC_NAME smutt_message_flagged_p
GETTER_FUNCTION_BODY (HEADER, message, message,
		      flagged, int,
		      flagged ? SCM_BOOL_T : SCM_BOOL_F)
#undef FUNC_NAME

SCM_DEFINE (smutt_message_tagged_p, "message-tagged?", 1, 0, 0,
	    (SCM message),
	    "Returns true if @var{message} is tagged.")
#define FUNC_NAME smutt_message_tagged_p
GETTER_FUNCTION_BODY (HEADER, message, message,
		      tagged, int,
		      tagged ? SCM_BOOL_T : SCM_BOOL_F)
#undef FUNC_NAME

SCM_DEFINE (smutt_message_deleted_p, "message-deleted?", 1, 0, 0,
	    (SCM message),
	    "Returns true if @var{message} is deleted.")
#define FUNC_NAME smutt_message_deleted_p
GETTER_FUNCTION_BODY (HEADER, message, message,
		      deleted, int,
		      deleted ? SCM_BOOL_T : SCM_BOOL_F)
#undef FUNC_NAME

SCM_DEFINE (smutt_message_changed_p, "message-changed?", 1, 0, 0,
	    (SCM message),
	    "Returns true if @var{message} is changed.")
#define FUNC_NAME smutt_message_changed_p
GETTER_FUNCTION_BODY (HEADER, message, message,
		      changed, int,
		      changed ? SCM_BOOL_T : SCM_BOOL_F)
#undef FUNC_NAME

SCM_DEFINE (smutt_message_read_p, "message-read?", 1, 0, 0,
	    (SCM message),
	    "Returns true if @var{message} is read.")
#define FUNC_NAME smutt_message_read_p
GETTER_FUNCTION_BODY (HEADER, message, message,
		      read, int,
		      read ? SCM_BOOL_T : SCM_BOOL_F)
#undef FUNC_NAME

SCM_DEFINE (smutt_message_replied_p, "message-replied?", 1, 0, 0,
	    (SCM message),
	    "Returns true if @var{message} is replied.")
#define FUNC_NAME smutt_message_replied_p
GETTER_FUNCTION_BODY (HEADER, message, message,
		      replied, int,
		      replied ? SCM_BOOL_T : SCM_BOOL_F)
#undef FUNC_NAME

SCM_DEFINE (smutt_message_flag_x, "message-flag!", 1, 2, 0,
	    (SCM message, SCM flagged, SCM mailbox),
	    "If @var{flagged} (default) is true, mark @var{message} as flagged.")
#define FUNC_NAME s_smutt_message_flag_x
MESSAGE_FLAG_SETTER_BODY (message, flagged, mailbox, M_FLAG)
#undef FUNC_NAME

SCM_DEFINE (smutt_message_tag_x, "message-tag!", 1, 2, 0,
	    (SCM message, SCM tagged, SCM mailbox),
	    "If @var{tagged} (default) is true, mark @var{message} as tagged.")
#define FUNC_NAME s_smutt_message_tag_x
MESSAGE_FLAG_SETTER_BODY (message, tagged, mailbox, M_TAG)
#undef FUNC_NAME

SCM_DEFINE (smutt_message_delete_x, "message-delete!", 1, 2, 0,
	    (SCM message, SCM deleted, SCM mailbox),
	    "If @var{deleted} (default) is true, mark @var{message} as deleted.")
#define FUNC_NAME s_smutt_message_delete_x
MESSAGE_FLAG_SETTER_BODY (message, deleted, mailbox, M_DELETE)
#undef FUNC_NAME

SCM_DEFINE (smutt_message_read_x, "message-read!", 1, 2, 0,
	    (SCM message, SCM read, SCM mailbox),
	    "If @var{read} (default) is true, mark @var{message} as read.")
#define FUNC_NAME s_smutt_message_read_x
MESSAGE_FLAG_SETTER_BODY (message, read, mailbox, M_READ)
#undef FUNC_NAME

SCM_DEFINE (smutt_message_reply_x, "message-reply!", 1, 2, 0,
	    (SCM message, SCM replied, SCM mailbox),
	    "If @var{replied} (default) is true, mark @var{message} as replied.")
#define FUNC_NAME s_smutt_message_reply_x
MESSAGE_FLAG_SETTER_BODY (message, replied, mailbox, M_REPLIED)
#undef FUNC_NAME

SCM_DEFINE (smutt_message_envelope, "message-envelope-ref", 1, 0, 0,
	    (SCM message),
	    "Returns @var{message}'s envelope object.")
#define FUNC_NAME s_smutt_message_envelope
OBJECT_GETTER_FUNCTION_BODY (HEADER, message, message,
			     env, ENVELOPE *, envelope)
#undef FUNC_NAME

SCM_DEFINE (smutt_message_envelope_set, "message-envelope-set!", 2, 0, 0,
	    (SCM message, SCM envelope),
	    "Sets @var{message}'s envelope to @var{envelope}.")
#define FUNC_NAME s_smutt_message_envelope_set
OBJECT_SETTER_FUNCTION_BODY (message,   message,   HEADER,
			     envelope, envelope, ENVELOPE,
			     env)
#undef FUNC_NAME

SCM_DEFINE (smutt_envelope_return_path, "envelope-return-path", 1, 0, 0,
	    (SCM envelope),
	    "Return @var{envelope}'s return path (an address object).")
#define FUNC_NAME s_smutt_envelope_return_path
OBJECT_GETTER_FUNCTION_BODY (ENVELOPE, envelope, envelope,
			     return_path, ADDRESS *, address)
#undef FUNC_NAME

SCM_DEFINE (smutt_envelope_from, "envelope-from-ref", 1, 0, 0,
	    (SCM envelope),
	    "Return @var{envelope}'s from (an address object).")
#define FUNC_NAME s_smutt_envelope_from
OBJECT_GETTER_FUNCTION_BODY (ENVELOPE, envelope, envelope,
			     from, ADDRESS *, address)
#undef FUNC_NAME

SCM_DEFINE (smutt_envelope_to, "envelope-to-ref", 1, 0, 0,
	    (SCM envelope),
	    "Return @var{envelope}'s to (an address object).")
#define FUNC_NAME s_smutt_envelope_to
OBJECT_GETTER_FUNCTION_BODY (ENVELOPE, envelope, envelope,
			     to, ADDRESS *, address)
#undef FUNC_NAME

SCM_DEFINE (smutt_envelope_real_subject, "envelope-real-subject", 1, 0, 0,
	    (SCM envelope),
	    "Return @var{envelope}'s real subject (i.e. without the `Re:').")
#define FUNC_NAME s_mutt_envelope_real_subject
GETTER_FUNCTION_BODY (ENVELOPE, envelope, envelope,
		      real_subj, char *,
		      real_subj ? scm_makfrom0str (real_subj) : SCM_BOOL_F)
#undef FUNC_NAME

/* Note: `mutt.scm' should define a procedure with setter called
   `envelope-subject'.  */
SCM_DEFINE (smutt_envelope_subject_ref, "envelope-subject-ref", 1, 0, 0,
	    (SCM envelope),
	    "Return @var{envelope}'s subject.")
#define FUNC_NAME s_mutt_envelope_subject_ref
GETTER_FUNCTION_BODY (ENVELOPE, envelope, envelope,
		      subject, char *,
		      subject ? scm_makfrom0str (subject) : SCM_BOOL_F)
#undef FUNC_NAME

SCM_DEFINE (smutt_envelope_subject_set, "envelope-subject-set!", 2, 0, 0,
	    (SCM envelope, SCM subject),
	    "Set @var{envelope}'s subject to @var{subject}.")
#define FUNC_NAME s_smutt_envelope_subject_set
STRING_SETTER_FUNCTION_BODY (envelope, envelope, ENVELOPE,
			     subject, subject)
#undef FUNC_NAME

SCM_DEFINE (smutt_envelope_message_id_ref, "envelope-message-id-ref", 1, 0, 0,
	    (SCM envelope),
	    "Get @var{envelope}'s message id.")
#define FUNC_NAME s_smutt_envelope_message_id_ref
GETTER_FUNCTION_BODY (ENVELOPE, envelope, envelope,
		      message_id, char *,
		      message_id ? scm_makfrom0str (message_id) : SCM_BOOL_F)
#undef FUNC_NAME

SCM_DEFINE (smutt_envelope_message_id_set, "envelope-message-id-set!", 2, 0, 0,
	    (SCM envelope, SCM messageid),
	    "Set @var{envelope}'s message-id to @var{messageid}, a string.")
#define FUNC_NAME s_smutt_envelope_message_id_set
STRING_SETTER_FUNCTION_BODY (envelope, envelope, ENVELOPE,
			     messageid, message_id)
#undef FUNC_NAME

SCM_DEFINE (smutt_envelope_references_ref, "envelope-references-ref", 1, 0, 0,
	    (SCM envelope),
	    "Get @var{envelope}'s references, a list of strings.")
#define FUNC_NAME s_smutt_envelope_references_ref
STRING_LIST_GETTER_FUNCTION_BODY (envelope, envelope, ENVELOPE,
				  references)
#undef FUNC_NAME

SCM_DEFINE (smutt_envelope_references_set, "envelope-references-set!", 2, 0, 0,
	    (SCM envelope, SCM reference_list),
	    "Set @var{envelope}'s references to @var{string_list}.")
#define FUNC_NAME s_smutt_envelope_references_set
STRING_LIST_SETTER_FUNCTION_BODY (envelope, envelope, ENVELOPE,
				  reference_list, references)
#undef FUNC_NAME

SCM_DEFINE (smutt_envelope_from_set, "envelope-from-set!", 2, 0, 0,
	    (SCM envelope, SCM from),
	    "Set @var{envelope}'s from address to @var{from}.")
#define FUNC_NAME s_smutt_envelope_from_set
OBJECT_SETTER_FUNCTION_BODY (envelope, envelope, ENVELOPE,
			     from,     address,  ADDRESS,
			     from)
#undef FUNC_NAME

SCM_DEFINE (smutt_envelope_to_set, "envelope-to-set!", 2, 0, 0,
	    (SCM envelope, SCM to),
	    "Set @var{envelope}'s to address to @var{to}.")
#define FUNC_NAME s_smutt_envelope_to_set
OBJECT_SETTER_FUNCTION_BODY (envelope, envelope, ENVELOPE,
			     to,       address,  ADDRESS,
			     to)
#undef FUNC_NAME

SCM_DEFINE (smutt_envelope_date, "envelope-date", 1, 0, 0,
	    (SCM envelope),
	    "Return @var{envelope}'s date (a string).")
#define FUNC_NAME s_mutt_envelope_date
GETTER_FUNCTION_BODY (ENVELOPE, envelope, envelope,
		      date, char *,
		      date ? scm_makfrom0str (date) : SCM_BOOL_F)
#undef FUNC_NAME

/* Note: `mutt.scm' should define a procedure with setter.  */
SCM_DEFINE (smutt_body_content, "body-content-ref", 1, 0, 0,
	    (SCM body),
	    "Returns @var{body}'s content object.")
#define FUNC_NAME s_smutt_body_content
OBJECT_GETTER_FUNCTION_BODY (BODY, body, body,
			     content, CONTENT *, content)
#undef FUNC_NAME

SCM_DEFINE (smutt_body_next_ref, "body-next-ref", 1, 0, 0,
	    (SCM body),
	    "Return the next attachment of @var{body}.")
#define FUNC_NAME s_smutt_body_next_ref
OBJECT_GETTER_FUNCTION_BODY (BODY, body, body,
			     next, BODY *, body)
#undef FUNC_NAME

SCM_DEFINE (smutt_body_next_set, "body-next-set!", 2, 0, 0,
	    (SCM body, SCM next),
	    "Set @var{body}'s next attachment to @var{next}, a body.")
#define FUNC_NAME s_smutt_body_next_set
OBJECT_SETTER_FUNCTION_BODY (body, body, BODY,
			     next, body, BODY,
			     next)
#undef FUNC_NAME

SCM_DEFINE (smutt_body_parts_ref, "body-parts-ref", 1, 0, 0,
	    (SCM body),
	    "Return the parts of multipart message @var{body}.")
#define FUNC_NAME s_smutt_body_parts_ref
OBJECT_GETTER_FUNCTION_BODY (BODY, body, body,
			     parts, BODY *, body)
#undef FUNC_NAME

SCM_DEFINE (smutt_body_parts_set, "body-parts-set!", 2, 0, 0,
	    (SCM body, SCM parts),
	    "Set @var{body}'s parts to @var{parts}, a body.")
#define FUNC_NAME s_smutt_body_next_set
OBJECT_SETTER_FUNCTION_BODY (body,  body, BODY,
			     parts, body, BODY,
			     parts)
#undef FUNC_NAME

SCM_DEFINE (smutt_body_filename, "body-filename-ref", 1, 0, 0,
	    (SCM body),
	    "Return @var{body}'s content filename.")
#define FUNC_NAME s_smutt_body_filename
GETTER_FUNCTION_BODY (BODY, body, body,
		      filename, char *,
		      filename ? scm_makfrom0str (filename) : SCM_BOOL_F)
#undef FUNC_NAME

SCM_DEFINE (smutt_body_filename_set, "body-filename-set!", 2, 0, 0,
	    (SCM body, SCM filename),
	    "Set @var{body}'s content filename to @var{filename}.")
#define FUNC_NAME s_smutt_body_filename_set
STRING_SETTER_FUNCTION_BODY (body, body, BODY,
			     filename, filename)
#undef FUNC_NAME

SCM_DEFINE (smutt_body_content_type_ref, "body-content-type-ref", 1, 0, 0,
	    (SCM body),
	    "Return a pair whose car is the content xtype (e.g. \"text\") "
	    "and whose cdr is the content subtype (e.g. \"plain\").")
#define FUNC_NAME s_smutt_body_content_type_ref
{
  SCM s_pair, s_xtype, s_subtype;
  BODY *c_body;

  SCM_VALIDATE_MUTT_TYPE (body, 0, body);
  TRANSLATE_SMOB (c_body, body, BODY);
  
  if (c_body->xtype)
    s_xtype = scm_makfrom0str (c_body->xtype);
  else
    s_xtype = scm_makfrom0str ("");

  if (c_body->subtype)
    s_subtype = scm_makfrom0str (c_body->subtype);
  else
    s_subtype = scm_makfrom0str ("");

  s_pair = scm_cons (s_xtype, s_subtype);

  return s_pair;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_body_content_type_set, "body-content-type-set!", 2, 0, 0,
	    (SCM body, SCM contenttype),
	    "Set @var{body}'s content type to @var{contenttype}, a pair "
	    "such as @code{(\"text\" . \"plain\")} or a string such as "
	    "@code{\"text/plain\"}.")
#define FUNC_NAME s_smutt_body_content_type_set
{
  /* This was greatly inspired by parse.c:mutt_parse_content_type ()
     and friends.  */
  BODY *c_body;
  
  SCM_VALIDATE_MUTT_TYPE (body, 0, body);
  TRANSLATE_SMOB (c_body, body, BODY);

  if (!SCM_STRINGP (contenttype))
    {
      /* Assume the parameter is a string pair */
      char *xtype;
      SCM_VALIDATE_STRING (1, SCM_CAR (contenttype));
      SCM_VALIDATE_STRING (1, SCM_CDR (contenttype));
      
      FREE (&c_body->xtype);
      FREE (&c_body->subtype);

      xtype = SCM_STRING_CHARS (SCM_CAR (contenttype));
      c_body->xtype = safe_strdup (xtype);
      c_body->subtype = safe_strdup (SCM_STRING_CHARS (SCM_CDR (contenttype)));
      c_body->type = mutt_check_mime_type (xtype);
    }
  else
    {
      /* Assume the parameter is a string to be parsed */
      SCM_VALIDATE_STRING (1, contenttype);

      FREE (&c_body->xtype);
      FREE (&c_body->subtype);
      
      mutt_parse_content_type (SCM_STRING_CHARS (contenttype), c_body);
    }

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_body_parameters_ref, "body-parameters-ref", 1, 0, 0,
	    (SCM body),
	    "Get @var{body}'s parameters (charset, format, etc.), "
	    "a string alist.")
#define FUNC_NAME s_smutt_body_parameters_ref
STRING_ALIST_GETTER_FUNCTION_BODY (body, body, BODY,
				   parameter)
#undef FUNC_NAME

SCM_DEFINE (smutt_body_parameters_set, "body-parameters-set!", 2, 0, 0,
	    (SCM body, SCM parameters),
	    "Set @var{body}'s parameters (charset, format, etc.) "
	    "to @var{parameters}, a string alist.")
#define FUNC_NAME s_smutt_body_parameters_set
{
  BODY *c_body;

  SCM_VALIDATE_MUTT_TYPE (body, 0, body);
  SCM_VALIDATE_STRING_ALIST (1, parameters);
  TRANSLATE_SMOB (c_body, body, BODY);

  mutt_free_parameter (&c_body->parameter);
  
  for (/* parameters */;
       parameters != SCM_EOL;
       parameters = SCM_CDR (parameters))
    {
      SCM s_pair;
      char *c_attr, *c_val;

      s_pair = SCM_CAR (parameters);
      c_attr = SCM_STRING_CHARS (SCM_CAR (s_pair));
      c_val  = SCM_STRING_CHARS (SCM_CDR (s_pair));

      mutt_set_parameter (c_attr, c_val,
			  &c_body->parameter);

      if (!strcmp (c_attr, "encoding"))
	c_body->encoding = mutt_check_encoding (c_val);
      
      /* FIXME: We may need to do something equivalent for the
	 `disposition' and `type' fields.  */
    }

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_message_body_ref, "message-body-ref", 1, 0, 0,
	    (SCM message),
	    "Return @var{message}'s body (a body object).")
#define FUNC_NAME s_smutt_message_body_ref
OBJECT_GETTER_FUNCTION_BODY (HEADER, message, message,
			     content, BODY *, body)
#undef FUNC_NAME

SCM_DEFINE (smutt_message_body_set, "message-body-set!", 2, 0, 0,
	    (SCM message, SCM body),
	    "Set @var{message}'s body.")
#define FUNC_NAME s_smutt_message_body_set
/* FIXME: We may need to set BODY->HDR accordingly?  */
OBJECT_SETTER_FUNCTION_BODY (message, message, HEADER,
			     body,    body,    BODY,
			     content)
#undef FUNC_NAME

SCM_DEFINE (smutt_envelope_user_headers_ref,
	    "envelope-user-headers-ref", 1, 0, 0,
	    (SCM envelope),
	    "Get @var{envelope}'s user headers.")
#define FUNC_NAME s_smutt_envelope_user_headers_ref
STRING_LIST_GETTER_FUNCTION_BODY (envelope, envelope, ENVELOPE,
				  userhdrs)
#undef FUNC_NAME

SCM_DEFINE (smutt_envelope_user_headers_set,
	    "envelope-user-headers-set!", 2, 0, 0,
	    (SCM envelope, SCM user_headers),
	    "Set @var{envelope}'s user headers to those define in "
	    "@var{user_headers}, a string list.")
#define FUNC_NAME s_smutt_envelope_user_headers_set
STRING_LIST_SETTER_FUNCTION_BODY (envelope, envelope, ENVELOPE,
				  user_headers, userhdrs)
#undef FUNC_NAME

SCM_DEFINE (smutt_user_headers_ref, "user-headers-ref", 0, 0, 0,
	    (void),
	    "Get the list of global user-defined headers.")
#define FUNC_NAME s_smutt_user_headers_ref
{
  SCM s_string_list;

  SCM_MAKE_STRING_LIST (s_string_list, UserHeader);

  return s_string_list;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_user_headers_set, "user-headers-set!", 1, 0, 0,
	    (SCM string_list),
	    "Set the list of global user-defined headers to @var{string_list}.")
#define FUNC_NAME s_smutt_user_headers_set
{
  SCM_VALIDATE_STRING_LIST (0, string_list);
  TRANSLATE_STRING_LIST (&UserHeader, string_list);
  
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_aliases_ref, "aliases-ref", 0, 0, 0,
	    (void),
	    "Get the list of defined aliases (i.e. the first alias).")
#define FUNC_NAME s_smutt_aliases_ref
{
  SCM s_alias;

  MAKE_MUTT_SMOB (s_alias, alias, Aliases);

  return s_alias;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_aliases_set, "aliases-set!", 1, 0, 0,
	    (SCM alias),
	    "Set the list of defined aliases to @var{alias}, an alias object.")
#define FUNC_NAME s_smutt_aliases_set
{
  ALIAS *c_alias, *a;

  SCM_VALIDATE_MUTT_TYPE (alias, 0, alias);
  TRANSLATE_SMOB (c_alias, alias, ALIAS);

  if (!Aliases->extdata)
    mutt_free_alias (&Aliases);
  else
    for (a = Aliases; a != NULL; a = a->next)
      {
	if (a->extdata)
	  MARK_AS_DESTROYABLE (a);
      }

  Aliases = c_alias;

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_mailing_lists_ref, "mailing-lists-ref", 0, 0, 0,
	    (void),
	    "Get the list of mailing-lists.")
#define FUNC_NAME s_smutt_mailing_lists_ref
{
  SCM s_string_list;

  SCM_MAKE_STRING_LIST (s_string_list, MailLists);

  return s_string_list;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_mailing_lists_set, "mailing-lists-set!", 1, 0, 0,
	    (SCM string_list),
	    "Set the list of mailing-lists to @var{string_list}.")
#define FUNC_NAME s_smutt_mailing_lists_set
{
  SCM_VALIDATE_STRING_LIST (0, string_list);
  TRANSLATE_STRING_LIST (&MailLists, string_list);
  
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_subscribed_lists_ref, "subscribed-lists-ref", 0, 0, 0,
	    (void),
	    "Get the list of subscribed mailing-lists.")
#define FUNC_NAME s_smutt_subscribed_lists_ref
{
  SCM s_string_list;

  SCM_MAKE_STRING_LIST (s_string_list, SubscribedLists);

  return s_string_list;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_subscribed_lists_set, "subscribed-lists-set!", 1, 0, 0,
	    (SCM string_list),
	    "Set the list of subscribed mailing-lists to @var{string_list}.")
#define FUNC_NAME s_smutt_subscribed_lists_set
{
  SCM_VALIDATE_STRING_LIST (0, string_list);
  TRANSLATE_STRING_LIST (&SubscribedLists, string_list);
  
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

/* Built-in mechanisms.  */

SCM_DEFINE (smutt_builtin_source_rc_file, "source-rc-file", 1, 0, 0,
	    (SCM filename),
	    "Sources @var{filename}, a `muttrc-style' file.")
#define FUNC_NAME s_smutt_builtin_source_rc_file
{
  int err;
  BUFFER errbuf;

  SCM_VALIDATE_STRING (0, filename);

  errbuf.data = errbuf.dptr = last_error_message;
  errbuf.dsize = sizeof (last_error_message);
  err = builtin_source_rc_file (SCM_STRING_CHARS (filename), &errbuf);

  if (err)
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_current_mailbox, "current-mailbox", 0, 0, 0,
	    (void),
	    "Returns the current mailbox object or false if there is no "
	    "opened mailbox.")
#define FUNC_NAME s_smutt_current_mailbox
{
  SCM mailbox;

  if (!Context)
    return SCM_BOOL_F;
  
  MAKE_MUTT_SMOB (mailbox, mailbox, Context);

  return mailbox;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_current_menu, "current-menu", 0, 0, 0,
	    (void),
	    "Return the current menu ID (an integer).")
#define FUNC_NAME s_smutt_current_menu
{
  return scm_int2num (CurrentMenu);
}
#undef FUNC_NAME

SCM_DEFINE (smutt_last_error, "last-error", 0, 0, 0,
	    (void),
	    "Returns the last error message produced by a function.")
#define FUNC_NAME s_smutt_last_error
{
  return scm_makfrom0str (last_error_message);
}
#undef FUNC_NAME

SCM_DEFINE (smutt_set_error_message_x, "set-error-message!", 1, 0, 0,
	    (SCM msg),
	    "Set the error message to be displayed next time a command "
	    "returns @code{#f} (error status).")
#define FUNC_NAME s_smutt_set_error_message_x
{
  char *errmsg;

  SCM_VALIDATE_STRING (0, msg);

  errmsg = SCM_STRING_CHARS (msg);
  assert (strlen (errmsg) < ERRMSG_SIZE_MAX);
  strncpy (last_error_message, errmsg, ERRMSG_SIZE_MAX - 1);
  last_error_message[ERRMSG_SIZE_MAX - 1] = '\0';

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_parse_rc_line, "builtin-parse-rc-line", 1, 0, 0,
	    (SCM line),
	    "Parse muttrc line @var{line}, a string, and return true on "
	    "success, false otherwise.")
#define FUNC_NAME s_smutt_builtin_parse_rc_line
{
  int err;

  SCM_VALIDATE_STRING (0, line);

  err = builtin_parse_rc_line (SCM_STRING_CHARS (line), last_error_message);
  if (err)
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_execute_command, "builtin-execute-command", 1, 1, 0,
	    (SCM command, SCM args),
	    "Execute command @var{command} with arguments @var{args} if "
	    "provided.")
#define FUNC_NAME s_smutt_builtin_execute_command
{
  int err;
  char *c_args = "";

  SCM_VALIDATE_STRING (0, command);
  if (args != SCM_UNDEFINED)
  {
    SCM_VALIDATE_STRING (1, args);
    c_args = SCM_STRING_CHARS (args);
  }

  err = builtin_execute_command (SCM_STRING_CHARS (command), c_args,
				 last_error_message);

  if (err)
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME


SCM_DEFINE (smutt_builtin_execute_function, "builtin-execute-function", 1, 0, 0,
	    (SCM function),
	    "Execute function @var{function}.")
#define FUNC_NAME s_smutt_builtin_execute_function
{
  int err;

  SCM_VALIDATE_STRING (0, function);

  err = builtin_execute_function (SCM_STRING_CHARS (function),
				  last_error_message);

  if (err)
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_set_option, "builtin-set-option", 2, 1, 0,
	    (SCM variable, SCM value, SCM hint),
	    "Set built-in variable @var{variable} to @var{value}. If "
	    "@var{hint} is provided, it should be an integer equal to "
	    "@code{M_SET_UNSET}, @code{M_SET_INV} or @code{M_SET_RESET} or 0.")
#define FUNC_NAME s_smutt_builtin_set_option
{
  int err, c_hint = 0;

  SCM_VALIDATE_STRING (0, variable);
  SCM_VALIDATE_STRING (1, value);
  if (hint != SCM_UNDEFINED)
  {
    SCM_VALIDATE_NUMBER (2, hint);
    c_hint = SCM_NUM2INT (2, hint);
  }

  err = builtin_set_option (SCM_STRING_CHARS (variable),
			    SCM_STRING_CHARS (value),
			    c_hint, last_error_message);
  if (err)
    return SCM_BOOL_F;

  return value;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_query_option, "builtin-query-option", 1, 0, 0,
	    (SCM variable),
	    "Return the value of @var{variable} (a built-in variable) "
	    "as a string.")
#define FUNC_NAME s_smutt_builtin_query_option
{
  int err;
  char value[500];

  SCM_VALIDATE_STRING (0, variable);

  err = builtin_query_option (value, SCM_STRING_CHARS (variable),
			      last_error_message);
  if (err)
    return SCM_BOOL_F;

  return scm_makfrom0str (value);
}
#undef FUNC_NAME

SCM_DEFINE (smutt_create_address, "create-address", 0, 1, 0,
	    (SCM string),
	    "If @var{string} is provided, parse @var{string} and return "
	    "the corresponding address string, following RFC822; otherwise "
	    "return an empty address object.")
#define FUNC_NAME s_smutt_create_address
{
  ADDRESS *address;
  SCM s_address;
  char *c_string = NULL;


  if (string != SCM_UNDEFINED)
    {
      SCM_VALIDATE_STRING (0, string);
      c_string = SCM_STRING_CHARS (string);
    }

  if (c_string)
    address = mutt_parse_adrlist (NULL, c_string);
  else
    address = calloc (1, sizeof (ADDRESS));
    
  if (!address)
    return SCM_BOOL_F;

  /* Return a destroyable object */
  MAKE_SMOB (s_address, address, address, 1);
  
  return s_address;
}
#undef FUNC_NAME

/* FIXME: We should clearly seperate define-alias from add-alias or
   some such.  */
SCM_DEFINE (smutt_builtin_define_alias, "builtin-define-alias", 2, 0, 0,
	    (SCM alias_name, SCM address),
	    "Create an alias @var{alias_name} for address @var{address} "
	    "and register it in the global aliases table.")
#define FUNC_NAME s_smutt_builtin_define_alias
{
  int err;
  ADDRESS *c_address;
  ALIAS *alias;
  SCM s_alias;

  SCM_VALIDATE_STRING (0, alias_name);
  SCM_VALIDATE_MUTT_TYPE (address, 1, address);
  TRANSLATE_SMOB (c_address, address, ADDRESS);

  err = builtin_define_alias (SCM_STRING_CHARS (alias_name), c_address,
			      &alias, last_error_message);

  if (err)
    return SCM_BOOL_F;
  
  /* Create a new smob with the `destroy' bit clear since a reference
     to it is kept in the ALIASES global variable.  */
  MAKE_MUTT_SMOB (s_alias, alias, alias);
  MARK_AS_UNDESTROYABLE (alias->addr);
  { /* FIXME: This is a bit hackish.  */
    smutt_alias_t *smutt_alias_object;
    smutt_alias_object = (smutt_alias_t *) SCM_SMOB_DATA (s_alias);
    smutt_alias_object->addr = address;
  }
  
  return s_alias;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_save_alias, "builtin-save-alias", 2, 0, 0,
	    (SCM alias, SCM filename),
	    "Append @var{alias}'s definition into @var{filename}.")
#define FUNC_NAME s_smutt_builtin_save_alias
{
  int err;
  ALIAS *c_alias;

  SCM_VALIDATE_MUTT_TYPE (alias, 0, alias);
  SCM_VALIDATE_STRING (1, filename);

  TRANSLATE_SMOB (c_alias, alias, ALIAS);

  err = builtin_save_alias (c_alias, SCM_STRING_CHARS (filename),
			    last_error_message);

  if (err)
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_generate_message_id,
	    "builtin-generate-message-id", 0, 0, 0,
	    (void),
	    "Return a new message ID (a string).")
#define FUNC_NAME s_smutt_builtin_generate_message_id
{
  int ret;
  char *messageid;

  ret = builtin_generate_message_id (&messageid);
  if (ret || (!messageid))
    return SCM_BOOL_F;

  return scm_makfrom0str (messageid);
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_generate_boundary,
	    "generate-boundary", 0, 0, 0,
	    (void),
	    "Generate a multi-part message `boundary' parameter "
	    "(a string pair whose car is @code{\"boundary\"}).")
#define FUNC_NAME s_smutt_builtin_generate_boundary
{
  SCM s_pair;
  PARAMETER *param = NULL;

  /* I know, this is not very elegant  XXX */
  mutt_generate_boundary (&param);

  s_pair = scm_cons (scm_makfrom0str (param->attribute),
		     scm_makfrom0str (param->value));
  
  mutt_free_parameter (&param);

  return s_pair;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_display_message, "builtin-display-message", 1, 0, 0,
	    (SCM message),
	    "Display the whose message is @var{message}.")
#define FUNC_NAME s_smutt_builtin_display_message
{
  int err;
  HEADER *c_message;

  SCM_VALIDATE_MUTT_TYPE (message, 0, message);
  TRANSLATE_SMOB (c_message, message, HEADER);

  err = builtin_display_message (c_message);
  if (err)
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_make_forward_subject,
	    "builtin-make-forward-subject!", 2, 1, 0,
	    (SCM envelope, SCM message, SCM mailbox),
	    "Sets the subject of @var{envelope} to that of a forwarded message "
	    "of @var{message}.")
#define FUNC_NAME s_smutt_builtin_make_forward_subject
{
  int err;
  ENVELOPE *c_envelope;
  HEADER *c_message;
  CONTEXT *c_mailbox = Context;

  SCM_VALIDATE_MUTT_TYPE (envelope, 0, envelope);
  SCM_VALIDATE_MUTT_TYPE (message,   1, message);

  TRANSLATE_SMOB (c_envelope, envelope, ENVELOPE);
  TRANSLATE_SMOB (c_message, message, HEADER);
  if (mailbox != SCM_UNDEFINED)
    {
      SCM_VALIDATE_MUTT_TYPE (mailbox, 2, mailbox);
      TRANSLATE_SMOB (c_mailbox, mailbox, CONTEXT);
    }

  err = builtin_make_forward_subject (c_envelope, c_mailbox, c_message);
  if (err)
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_score_message, "builtin-score-message", 1, 2, 0,
	    (SCM message, SCM update_mailbox, SCM mailbox),
	    "Compute @var{message}'s score and update it.  If "
	    "@var{update_mailbox} is true (default), then @var{mailbox} "
	    "should be updated.")
#define FUNC_NAME s_smutt_builtin_score_message
{
  int err, c_update_mailbox = 1;
  HEADER *c_message;
  CONTEXT *c_mailbox = Context;

  SCM_VALIDATE_MUTT_TYPE (message, 0, message);
  TRANSLATE_SMOB (c_message, message, HEADER);

  if (mailbox != SCM_UNDEFINED)
  {
    SCM_VALIDATE_MUTT_TYPE (mailbox, 0, mailbox);
    TRANSLATE_SMOB (c_mailbox, mailbox, CONTEXT);
  }

  if (update_mailbox != SCM_UNDEFINED)
  {
    SCM_VALIDATE_BOOL (2, update_mailbox);
    c_update_mailbox = (update_mailbox == SCM_BOOL_F) ? 0 : 1;
  }

  err = builtin_score_message (c_mailbox, c_message, c_update_mailbox);
  if (err)
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_add_scoring_rule,
	    "builtin-add-scoring-rule!", 2, 0, 0,
	    (SCM pattern, SCM value),
	    "Add a message scoring rule: messages matching @var{pattern}, "
	    "a string, should be added @var{value}, a string representing an "
	    "integer.  Return the new score object on success.")
#define FUNC_NAME s_smutt_builtin_add_scoring_rule
{
  int err;
  SCM s_score;
  SCORE *c_score;

  SCM_VALIDATE_STRING (0, pattern);
  SCM_VALIDATE_STRING (1, value);

  err = builtin_add_scoring_rule (SCM_STRING_CHARS (pattern),
				  SCM_STRING_CHARS (value),
				  &c_score, last_error_message);
  if (err)
    return SCM_BOOL_F;

  /* Keep a reference to the pattern since C_SCORE now belongs to the
     C world and therefore is not destroyable.  */
  MAKE_MUTT_SMOB (s_score, score, c_score);
  /*REFERENCE_OBJECT (c_score, c_score->pat);*/

  return s_score;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_compile_pattern, "builtin-compile-pattern", 1, 1, 0,
	    (SCM string, SCM full_msg),
	    "Compiles @var{string}, a pattern description, and return "
	    "a pattern object.  If @var{full_msg} is true (default), this "
	    "means that this pattern may apply to a whole header, not only "
	    "to its subject, to, from, etc.")
#define FUNC_NAME s_smutt_builtin_compile_pattern
{
  int err, c_flags = M_FULL_MSG;
  pattern_t *pattern;
  SCM s_pattern;

  SCM_VALIDATE_STRING (0, string);
  if (full_msg != SCM_UNDEFINED)
  {
    SCM_VALIDATE_BOOL (1, full_msg);
    c_flags = (full_msg == SCM_BOOL_T) ? M_FULL_MSG : 0;
  }

  err = builtin_compile_pattern (&pattern, SCM_STRING_CHARS (string),
				 c_flags, last_error_message);
  if ((err) || (!pattern))
    return SCM_BOOL_F;

  /* Return a destroyable object */
  MAKE_SMOB (s_pattern, pattern, pattern, 1);

  return s_pattern;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_execute_pattern,
	    "builtin-execute-pattern", 2, 2, 0,
	    (SCM pattern, SCM message, SCM flags, SCM mailbox),
	    "Execute @var{pattern} on @var{message}.  Return true if "
	    "@var{message} matches @var{pattern}.  @var{flags} may be equal "
	    "to @code{M_MATCH_FULL_ADDRESS}.")
#define FUNC_NAME s_smutt_builtin_execute_pattern
{
  int err;
  pattern_t *c_pattern;
  HEADER *c_message;
  CONTEXT *c_mailbox = Context;
  pattern_exec_flag c_flags = 0;

  SCM_VALIDATE_MUTT_TYPE (pattern, 0, pattern);
  SCM_VALIDATE_MUTT_TYPE (message, 1, message);

  if (flags != SCM_UNDEFINED)
  {
    SCM_VALIDATE_NUMBER (2, flags);
    c_flags = SCM_NUM2INT (2, flags);
  }

  if (mailbox != SCM_UNDEFINED)
  {
    SCM_VALIDATE_MUTT_TYPE (mailbox, 3, mailbox);
    TRANSLATE_SMOB (c_mailbox, mailbox, CONTEXT);
  }

  TRANSLATE_SMOB (c_pattern, pattern, pattern_t);
  TRANSLATE_SMOB (c_message, message, HEADER);
  err = builtin_execute_pattern (c_pattern, c_message,
				 c_mailbox, c_flags);
  if (err <= 0)
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_save_message, "builtin-save-message", 2, 3, 0,
	    (SCM message, SCM mailbox, SCM delete, SCM decode, SCM decrypt),
	    "If @var{message} is a message header, save @var{message} to "
	    "mailbox @var{mailbox}, a string.  If @var{message} is false, "
	    "then save all tagged messages to @var{mailbox}.")
#define FUNC_NAME s_smutt_builtin_save_message
{
  int err;
  int c_delete = 0, c_decode = 0, c_decrypt = 0;
  HEADER *c_message = NULL;

  if (message != SCM_BOOL_F)
  {
    SCM_VALIDATE_MUTT_TYPE (message, 0, message);
    TRANSLATE_SMOB (c_message, message, HEADER);
  }

  if (delete != SCM_UNDEFINED)
  {
    SCM_VALIDATE_BOOL (2, delete);
    c_delete = (delete == SCM_BOOL_T) ? 1 : 0;
  }

  if (decode != SCM_UNDEFINED)
  {
    SCM_VALIDATE_BOOL (2, decode);
    c_decode = (decode == SCM_BOOL_T) ? 1 : 0;
  }

  if (decrypt != SCM_UNDEFINED)
  {
    SCM_VALIDATE_BOOL (2, decrypt);
    c_decrypt = (decrypt == SCM_BOOL_T) ? 1 : 0;
  }

  err = builtin_save_message (c_message, SCM_STRING_CHARS (mailbox),
			      c_delete, c_decode, c_decrypt);
  if (err)
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_is_mailing_list,
	    "builtin-is-mailing-list?", 1, 0, 0,
	    (SCM address),
	    "Returns true if @var{address} is a known mailing-list address.")
#define FUNC_NAME s_smutt_builtin_is_mailing_list
{
  ADDRESS *c_address;

  SCM_VALIDATE_MUTT_TYPE (address, 0, address);

  TRANSLATE_SMOB (c_address, address, ADDRESS);
  if (builtin_is_mailing_list (c_address))
    return SCM_BOOL_T;

  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_is_subscribed_list,
	    "builtin-is-subscribed-list?", 1, 0, 0,
	    (SCM address),
	    "Returns true if @var{address} is a subscribed mailing-list "
	    "address.")
#define FUNC_NAME s_smutt_builtin_is_subscribed_list
{
  ADDRESS *c_address;

  SCM_VALIDATE_MUTT_TYPE (address, 0, address);

  TRANSLATE_SMOB (c_address, address, ADDRESS);
  if (builtin_is_subscribed_list (c_address))
    return SCM_BOOL_T;

  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_addr_is_user, "builtin-address-is-user?", 1, 0, 0,
	    (SCM address),
	    "Return true if @var{address} is the user's address.")
#define FUNC_NAME s_smutt_builtin_addr_is_user
{
  ADDRESS *c_address;

  SCM_VALIDATE_MUTT_TYPE (address, 0, address);

  TRANSLATE_SMOB (c_address, address, ADDRESS);
  if (builtin_addr_is_user (c_address))
    return SCM_BOOL_T;

  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_default_from_address,
	    "builtin-default-from-address", 0, 0, 0,
	    (void),
	    "Return a copy of the default `from' address.")
#define FUNC_NAME s_smutt_builtin_default_from_address
{
  SCM s_from;
  ADDRESS *c_from;

  builtin_default_from_address (&c_from);
  MAKE_MUTT_SMOB (s_from, address, c_from);

  return s_from;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_menu_jump, "builtin-menu-jump", 2, 0, 0,
	    (SCM entry, SCM menu),
	    "Jump to the entry numbered @var{entry} in @var{menu}.")
#define FUNC_NAME s_smutt_builtin_menu_jump
{
  MUTTMENU *c_menu;
  unsigned int c_entry;

  SCM_VALIDATE_NUMBER (0, entry);
  SCM_VALIDATE_MUTT_TYPE (menu, 1, menu);

  TRANSLATE_SMOB (c_menu, menu, MUTTMENU);
  c_entry = SCM_NUM2UINT (0, entry);

  if (builtin_menu_jump (c_menu, c_entry, last_error_message))
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_pipe_message,
	    "builtin-pipe-message", 2, 4, 0,
	    (SCM message, SCM command, SCM print,
	     SCM decode, SCM split, SCM separator),
	    "If @var{message} is a message header, try to pipe it through "
	    "@var{command}, a string.  If @var{message} is false, then try to "
	    "pipe all messages through @var{command}.")
#define FUNC_NAME s_smutt_builtin_pipe_message
{
  HEADER *c_message = NULL;
  int c_print = 0, err;
  int c_decode = option (OPTPIPEDECODE);
  int c_split = option (OPTPIPESPLIT);
  char *c_separator = PipeSep;

  if (message != SCM_BOOL_F)
  {
    SCM_VALIDATE_MUTT_TYPE (message, 0, message);
    TRANSLATE_SMOB (c_message, message, HEADER);
  }
  SCM_VALIDATE_STRING (1, command);
  if (print != SCM_UNDEFINED)
  {
    SCM_VALIDATE_BOOL (2, print);
    c_print = (print == SCM_BOOL_T) ? 1 : 0;
  }
  if (decode != SCM_UNDEFINED)
  {
    SCM_VALIDATE_BOOL (3, decode);
    c_decode = (decode == SCM_BOOL_T) ? 1 : 0;
  }
  if (split != SCM_UNDEFINED)
  {
    SCM_VALIDATE_BOOL (4, split);
    c_split = (split == SCM_BOOL_T) ? 1 : 0;
  }
  if (separator != SCM_UNDEFINED)
  {
    SCM_VALIDATE_STRING (5, separator);
    c_separator = SCM_STRING_CHARS (separator);
  }

  err = builtin_pipe_message (c_message, SCM_STRING_CHARS (command),
			      c_print,
			      c_decode, c_split, c_separator);
  if (err)
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_send_message, "builtin-send-message", 1, 0, 0,
	    (SCM message),
	    "Send message @var{message}.")
#define FUNC_NAME s_smutt_builtin_send_message
{
  int err;
  HEADER *c_message;

  SCM_VALIDATE_MUTT_TYPE (message, 0, message);
  TRANSLATE_SMOB (c_message, message, HEADER);

  err = builtin_send_message (c_message);
  if (err)
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_make_reply_header,
	    "builtin-make-reply-header!", 2, 2, 0,
	    (SCM replyenv, SCM current, SCM currentenv, SCM mailbox),
	    "Fill @var{replyenv}, the envelope of a reply message to "
	    "@var{current} with the appropriate subject.")
#define FUNC_NAME s_smutt_builtin_make_reply_header
{
  int err;
  ENVELOPE *c_replyenv, *c_currentenv;
  HEADER *c_current;
  CONTEXT *c_mailbox = Context;

  SCM_VALIDATE_MUTT_TYPE (envelope, 0, replyenv);
  SCM_VALIDATE_MUTT_TYPE (message, 1, current);
  TRANSLATE_SMOB (c_replyenv, replyenv, ENVELOPE);
  TRANSLATE_SMOB (c_current, current, HEADER);

  if (currentenv != SCM_UNDEFINED)
  {
    SCM_VALIDATE_MUTT_TYPE (envelope, 2, currentenv);
    TRANSLATE_SMOB (c_currentenv, currentenv, ENVELOPE);
  }
  else
    c_currentenv = c_current->env;

  if (mailbox != SCM_UNDEFINED)
  {
    SCM_VALIDATE_MUTT_TYPE (mailbox, 3, mailbox);
    TRANSLATE_SMOB (c_mailbox, mailbox, CONTEXT);
  }

  err = builtin_make_reply_header (c_replyenv, c_current,
				   c_currentenv, c_mailbox);
  if (err)
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_append_signature,
	    "builtin-append-signature", 1, 1, 0,
	    (SCM port, SCM message),
	    "Append a signature to open file @var{port} which "
	    "represents header @var{message}.")
#define FUNC_NAME s_smutt_builtin_append_signature
{
  int err;
  FILE *file;
  HEADER *c_message = NULL;

  SCM_VALIDATE_PORT (0, port);
  if (message != SCM_UNDEFINED)
    {
      SCM_VALIDATE_MUTT_TYPE (message, 1, message);
      TRANSLATE_SMOB (c_message, message, HEADER);
    }

  MAKE_FILE_FROM_PORT (file, port);
  if (!file)
    return SCM_BOOL_F;

  err = builtin_append_signature (file, c_message);
  if (err)
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_append_forward_intro,
	    "builtin-append-forward-intro", 2, 0, 0,
	    (SCM port, SCM forwarded),
	    "Append a forward introduction to @var{port} which contains "
	    "a message forwarding message @var{forwarded}.")
#define FUNC_NAME s_smutt_builtin_append_forward_intro
{
  int err;
  FILE *file;
  HEADER *c_forwarded = NULL;

  SCM_VALIDATE_PORT (0, port);
  SCM_VALIDATE_MUTT_TYPE (message, 1, forwarded);
  TRANSLATE_SMOB (c_forwarded, forwarded, HEADER);

  MAKE_FILE_FROM_PORT (file, port);
  if (!file)
    return SCM_BOOL_F;

  err = builtin_append_forward_intro (file, c_forwarded);
  if (err)
    return SCM_BOOL_F;

  if (fflush (file))
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_append_forward_trailer,
	    "builtin-append-forward-trailer", 2, 0, 0,
	    (SCM port, SCM forwarded),
	    "Append a forward trailer to @var{port} which contains "
	    "a message forwarding message @var{forwarded}.")
#define FUNC_NAME s_smutt_builtin_append_forward_intro
{
  int err;
  FILE *file;
  HEADER *c_forwarded = NULL;

  SCM_VALIDATE_PORT (0, port);
  SCM_VALIDATE_MUTT_TYPE (message, 1, forwarded);
  TRANSLATE_SMOB (c_forwarded, forwarded, HEADER);

  MAKE_FILE_FROM_PORT (file, port);
  if (!file)
    return SCM_BOOL_F;

  err = builtin_append_forward_trailer (file, c_forwarded);
  if (err)
    return SCM_BOOL_F;

  if (fflush (file))
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_append_message_attribution,
	    "builtin-append-message-attribution", 2, 1, 0,
	    (SCM port, SCM replied, SCM mailbox),
	    "Append a message attribution line for message @var{replied} "
	    "to file @var{port}.")
#define FUNC_NAME s_smutt_builtin_append_message_attribution
{
  int err;
  FILE *file;
  HEADER *c_replied;
  CONTEXT *c_mailbox = Context;

  SCM_VALIDATE_PORT (0, port);
  SCM_VALIDATE_MUTT_TYPE (message, 1, replied);
  if (mailbox != SCM_UNDEFINED)
    {
      SCM_VALIDATE_MUTT_TYPE (mailbox, 2, mailbox);
      TRANSLATE_SMOB (c_mailbox, mailbox, CONTEXT);
    }

  TRANSLATE_SMOB (c_replied, replied, HEADER);
  MAKE_FILE_FROM_PORT (file, port);
  if (!file)
    return SCM_BOOL_F;

  err = builtin_append_message_attribution (file, c_replied, c_mailbox);
  if (err)
    return SCM_BOOL_F;

  if (fflush (file))
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_generate_reply_body,
	    "builtin-generate-reply-body", 3, 1, 0,
	    (SCM port, SCM message, SCM replied, SCM mailbox),
	    "Append to @var{port} a body for @var{message} which replies "
	    "to @var{replied}.")
#define FUNC_NAME s_smutt_builtin_generate_reply_body
{
  int err;
  FILE *file;
  HEADER *c_replied, *c_message;
  CONTEXT *c_mailbox = Context;

  SCM_VALIDATE_PORT (0, port);
  SCM_VALIDATE_MUTT_TYPE (message, 1, message);
  SCM_VALIDATE_MUTT_TYPE (message, 2, replied);
  if (mailbox != SCM_UNDEFINED)
    {
      SCM_VALIDATE_MUTT_TYPE (mailbox, 3, mailbox);
      TRANSLATE_SMOB (c_mailbox, mailbox, CONTEXT);
    }
  
  TRANSLATE_SMOB (c_message, message, HEADER);
  TRANSLATE_SMOB (c_replied, replied, HEADER);

  MAKE_FILE_FROM_PORT (file, port);
  if (!file)
    return SCM_BOOL_F;

  err = builtin_generate_reply_body (file, c_message, c_mailbox,
				     c_replied);
  if (err)
    return SCM_BOOL_F;

  if (fflush (file))
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_generate_forward_body,
	    "builtin-generate-forward-body", 3, 1, 0,
	    (SCM port, SCM message, SCM forwarded, SCM mailbox),
	    "Append to @var{port} a body for @var{message} which forwards "
	    "@var{forwarded}.")
#define FUNC_NAME s_smutt_builtin_generate_forward_body
{
  int err;
  FILE *file;
  HEADER *c_forwarded, *c_message;
  CONTEXT *c_mailbox = Context;

  SCM_VALIDATE_PORT (0, port);
  SCM_VALIDATE_MUTT_TYPE (message, 1, message);
  SCM_VALIDATE_MUTT_TYPE (message, 2, forwarded);
  if (mailbox != SCM_UNDEFINED)
    {
      SCM_VALIDATE_MUTT_TYPE (mailbox, 3, mailbox);
      TRANSLATE_SMOB (c_mailbox, mailbox, CONTEXT);
    }
  
  TRANSLATE_SMOB (c_message, message, HEADER);
  TRANSLATE_SMOB (c_forwarded, forwarded, HEADER);

  MAKE_FILE_FROM_PORT (file, port);
  if (!file)
    return SCM_BOOL_F;

  err = builtin_generate_forward_body (file, c_message, c_mailbox,
				       c_forwarded);
  if (err)
    return SCM_BOOL_F;

  if (fflush (file))
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_include_forward_body,
	    "builtin-include-forward-body", 2, 1, 0,
	    (SCM port, SCM forwarded, SCM mailbox),
	    "Append to @var{port} a body representing a forward of "
	    "@var{forwarded} (a message), including intro and trailer.")
#define FUNC_NAME s_smutt_builtin_include_forward_body
{
  int err;
  FILE *file;
  HEADER *c_forwarded;
  CONTEXT *c_mailbox = Context;

  SCM_VALIDATE_PORT (0, port);
  SCM_VALIDATE_MUTT_TYPE (message, 1, forwarded);
  if (mailbox != SCM_UNDEFINED)
    {
      SCM_VALIDATE_MUTT_TYPE (mailbox, 2, mailbox);
      TRANSLATE_SMOB (c_mailbox, mailbox, CONTEXT);
    }
  
  TRANSLATE_SMOB (c_forwarded, forwarded, HEADER);

  MAKE_FILE_FROM_PORT (file, port);
  if (!file)
    return SCM_BOOL_F;

  err = builtin_include_forward_body (file, c_forwarded, c_mailbox);
  if (err)
    return SCM_BOOL_F;

  if (fflush (file))
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_include_reply_body,
	    "builtin-include-reply-body", 2, 1, 0,
	    (SCM port, SCM replied, SCM mailbox),
	    "Append to @var{port} a body denoting a reply to @var{replied} "
	    "(a message), including email attribution if needed.")
#define FUNC_NAME s_smutt_builtin_include_reply_body
{
  int err;
  FILE *file;
  HEADER *c_replied;
  CONTEXT *c_mailbox = Context;

  SCM_VALIDATE_PORT (0, port);
  SCM_VALIDATE_MUTT_TYPE (message, 1, replied);
  if (mailbox != SCM_UNDEFINED)
    {
      SCM_VALIDATE_MUTT_TYPE (mailbox, 2, mailbox);
      TRANSLATE_SMOB (c_mailbox, mailbox, CONTEXT);
    }
  
  TRANSLATE_SMOB (c_replied, replied, HEADER);

  MAKE_FILE_FROM_PORT (file, port);
  if (!file)
    return SCM_BOOL_F;

  err = builtin_include_reply_body (file, c_replied, c_mailbox);
  if (err)
    return SCM_BOOL_F;

  if (fflush (file))
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_add_mailbox, "builtin-add-mailbox!", 1, 0, 0,
	    (SCM name),
	    "Add mailbox @var{name} to the list of incoming mailboxes.")
#define FUNC_NAME s_smutt_builtin_add_mailbox
{
  int ret;
  SCM s_mailbox;
  BUFFY *c_mailbox;

  SCM_VALIDATE_STRING (0, name);

  ret = builtin_add_mailbox (&c_mailbox, SCM_STRING_CHARS (name));
  if (ret)
    return SCM_BOOL_F;

  MAKE_MUTT_SMOB (s_mailbox, buffy, c_mailbox);

  return s_mailbox;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_remove_mailbox, "builtin-remove-mailbox!", 1, 0, 0,
	    (SCM mailbox),
	    "Remove @var{mailbox} from the list of incoming mailboxes.")
#define FUNC_NAME s_smutt_builtin_remove_mailbox
{
  int ret;
  BUFFY *c_mailbox;

  SCM_VALIDATE_MUTT_TYPE (buffy, 0, mailbox);
  TRANSLATE_SMOB (c_mailbox, mailbox, BUFFY);

  ret = builtin_remove_mailbox (c_mailbox);
  if (ret)
    return SCM_BOOL_F;

  /* This object is not referenced anymore by C code so release it */
  
  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_expand_path, "builtin-expand-path", 1, 0, 0,
	    (SCM path),
	    "Return expansion of mailbox path @var{path}, a string.")
#define FUNC_NAME s_smutt_builtin_expand_path
{
  int ret;
  char expanded_path[_POSIX_PATH_MAX + 1] = { '\0' };

  SCM_VALIDATE_STRING (0, path);
  
  strncpy (expanded_path, SCM_STRING_CHARS (path), _POSIX_PATH_MAX);
  ret = builtin_expand_path (expanded_path,
			     _POSIX_PATH_MAX);
  if (ret)
    return SCM_BOOL_F;

  return scm_makfrom0str (expanded_path);
}
#undef FUNC_NAME

SCM_DEFINE (smutt_builtin_query_exit, "builtin-query-exit", 0, 0, 0,
	    (void),
	    "Quit the MUA.")
#define FUNC_NAME s_smutt_builtin_query_exit
{
  int err;

  err = builtin_query_exit ();
  if (err)
    return SCM_BOOL_F;

  return SCM_BOOL_T;
}
#undef FUNC_NAME


/* User-interface control functions */

SCM_DEFINE (smutt_ui_message, "ui-message", 1, 0, 0,
	    (SCM message),
	    "Displays @var{message} on the user-interface.")
#define FUNC_NAME s_smutt_ui_message
{
  SCM_VALIDATE_STRING (0, message);

  mutt_message (SCM_STRING_CHARS (message));

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_ui_error_message, "ui-error-message", 1, 0, 0,
	    (SCM message),
	    "Displays error message @var{message} on the user-interface.")
#define FUNC_NAME s_smutt_ui_error_message
{
  SCM_VALIDATE_STRING (0, message);

  mutt_error (SCM_STRING_CHARS (message));

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_ui_yes_or_no, "ui-yes-or-no?", 1, 1, 0,
	    (SCM message, SCM dflt),
	    "Display @var{message} and ask the user to enter \"yes\" or "
	    "\"no\".  If @var{dflt} is @code{#t}, then the default answer "
	    "is \"yes\".  If @var{dflt} is not provided, the default "
	    "answer is \"no\".")
#define FUNC_NAME s_smutt_ui_yes_or_no
{
  int c_dflt = M_NO, whether;

  SCM_VALIDATE_STRING (0, message);

  /* Check whether this optional argument was provided by the caller */
  if (dflt != SCM_UNDEFINED)
  {
    SCM_VALIDATE_BOOL (1, dflt);
    c_dflt = (dflt == SCM_BOOL_F) ? M_NO : M_YES;
  }

  whether = mutt_yesorno (SCM_STRING_CHARS (message), c_dflt);

  return (whether == M_YES) ? SCM_BOOL_T : SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (smutt_split_argument_string, "split-argument-string", 1, 0, 0,
	    (SCM argstring),
	    "Parse command argument string @var{argstring} and return a "
	    "list of arguments.  Warning: backquoted expression are also "
	    "evaluated by a shell!")
#define FUNC_NAME s_smutt_split_argument_string
{
  SCM s_list;
  BUFFER buffer, token;

  SCM_VALIDATE_STRING (0, argstring);
  if (scm_string_null_p (argstring) == SCM_BOOL_T)
    return SCM_EOL;
  
  buffer.destroy = token.destroy = 0;
  buffer.data = buffer.dptr = safe_strdup (SCM_STRING_CHARS (argstring));
  buffer.dsize = strlen (buffer.data);
  token.data = token.dptr = NULL;
  token.dsize = 0;

  s_list = SCM_EOL;
  while (MoreArgs ((&buffer)))
    {
      mutt_extract_token (&token, &buffer, 0);
      s_list =
	scm_append (SCM_LIST2 (s_list,
			       SCM_LIST1 (scm_makfrom0str (token.data))));
    }

  free (buffer.data);
  free (token.data);
  
  return s_list;
}
#undef FUNC_NAME
  
SCM_DEFINE (smutt_create_message, "create-message", 0, 0, 0,
	    (void),
	    "Return a new message object.")
#define FUNC_NAME s_smutt_create_message
OBJECT_CONSTRUCTOR_FUNCTION_BODY (message, HEADER)
#undef FUNC_NAME

SCM_DEFINE (smutt_create_envelope, "create-envelope", 0, 0, 0,
	    (void),
	    "Return a new envelope object.")
#define FUNC_NAME s_smutt_create_envelope
OBJECT_CONSTRUCTOR_FUNCTION_BODY (envelope, ENVELOPE)
#undef FUNC_NAME

SCM_DEFINE (smutt_create_body, "create-body", 0, 0, 0,
	    (void),
	    "Return a new body object.")
#define FUNC_NAME s_smutt_create_body
OBJECT_CONSTRUCTOR_FUNCTION_BODY (body, BODY)
#undef FUNC_NAME

SCM_DEFINE (smutt_create_content, "create-content", 0, 0, 0,
	    (void),
	    "Return a new content object.")
#define FUNC_NAME s_smutt_create_content
OBJECT_CONSTRUCTOR_FUNCTION_BODY (content, CONTENT)
#undef FUNC_NAME



/* Free SMOB depending on whether its `destroy' field is set or not.
   Typically, SMOBs representing data allocated from Scheme code
   (eg. using `create-message') have their `destroy' field set while
   SMOBs representing Mutt's internal data don't.  */
static size_t
smutt_free_smob (SCM smob)
{
  size_t freed = 0;
  smutt_object_t *smutt_object;

  smutt_object = (smutt_object_t *) SCM_SMOB_DATA (smob);
  assert (smutt_object);

  /* Any C object that Scheme code is aware of (because there exist a
     smob representing it) is ultimately destroyed from here, unless
     it is owned by C code (i.e. it is `undestroyable').  This means
     that this function is the only one which may set the `object'
     field to NULL, so it can't be NULL when we enter it.  */
  assert (smutt_object->object);
  assert (smutt_object->object_extdata);
  
  *smutt_object->object_extdata = NULL;

  if (smutt_object->destroy)
    {
      /* The underlying C object was allocated by Scheme code and
	 no C code references it so it can be freed now.  */
      size_t (*free_object) (void *) = smutt_object->free_object;
	  
#ifdef DEBUG_GUILE
      assert (mprobe (smutt_object->object) == MCHECK_OK);
#endif
      if (free_object)
	freed += free_object (smutt_object->object);
      else
	{
	  free (smutt_object->object);
	  /* freed += smutt_object->object_size; */
	}
    }

  smutt_object->object = NULL;
  scm_must_free (smutt_object);

  return freed;
}



/* Define a type predicate function */
#define SMUTT_TYPE_PREDICATE(predicate_name, tag_name) \
  static SCM smutt_ ## tag_name ## _p (SCM object) \
  { \
    return SCM_BOOL (SCM_SMOB_PREDICATE (smutt_ ## tag_name ## _tag, \
					 object)); \
  }

SMUTT_TYPE_PREDICATE ("mailbox?",       mailbox)
SMUTT_TYPE_PREDICATE ("alias?",         alias)
SMUTT_TYPE_PREDICATE ("address?",       address)
SMUTT_TYPE_PREDICATE ("message?",       message)
SMUTT_TYPE_PREDICATE ("envelope?",      envelope)
SMUTT_TYPE_PREDICATE ("body?",          body)
SMUTT_TYPE_PREDICATE ("content?",       content)
SMUTT_TYPE_PREDICATE ("pattern?",       pattern)
SMUTT_TYPE_PREDICATE ("menu?",          menu)
SMUTT_TYPE_PREDICATE ("scoring-rule?",  score)
SMUTT_TYPE_PREDICATE ("buffy-mailbox?", buffy)

/* Initialization */

static void smutt_idle_hook (void);

void mutt_init_guile_extension (void *closure,
				int argc, char *argv[])
{
  /* Create the appropriate SMOB types and assign them the
     corresponding mark and free functions.  */
#define CREATE_SMOB_TYPE(_name, _scm_name)				\
  smutt_ ## _name ## _tag =						\
    scm_make_smob_type (_scm_name, sizeof (smutt_ ## _name ## _t));	\
  scm_set_smob_free (smutt_ ## _name ## _tag, smutt_free_smob);		\
  scm_set_smob_mark (smutt_ ## _name ## _tag, smutt_mark_object);	\
  scm_c_define_gsubr (_scm_name "?", 1, 0, 0,				\
		      (SCM (*)() ) smutt_ ## _name ## _p)


  CREATE_SMOB_TYPE (mailbox,  "mailbox");
  CREATE_SMOB_TYPE (alias,    "alias");
  CREATE_SMOB_TYPE (address,  "address");
  CREATE_SMOB_TYPE (message,   "message");
  CREATE_SMOB_TYPE (envelope, "envelope");
  CREATE_SMOB_TYPE (body,     "body");
  CREATE_SMOB_TYPE (content,  "content");
  CREATE_SMOB_TYPE (pattern,  "pattern");
  CREATE_SMOB_TYPE (menu,     "menu");
  CREATE_SMOB_TYPE (score,    "scoring-rule");
  CREATE_SMOB_TYPE (buffy,    "buffy-mailbox");

  /* Register deletion hooks for these types */
  extension_free_body = free_body_hook;
  extension_free_header = free_message_hook;
  extension_free_envelope = free_envelope_hook;
  extension_free_alias = free_alias_hook;
  extension_free_address = free_address_hook;

  /* Register our idle hook */
  extension_idle_hook = smutt_idle_hook;
  scm_c_define ("idle-hook", scm_make_hook (scm_int2num (0)));
  
#define EXPORT_VALUE(_value) \
  scm_c_define (STRINGIFY (_value), scm_int2num (_value))

  EXPORT_VALUE (MENU_EDITOR);
  EXPORT_VALUE (MENU_ALIAS);
  EXPORT_VALUE (MENU_PAGER);
  EXPORT_VALUE (MENU_MAIN);
  EXPORT_VALUE (MENU_GENERIC);
  EXPORT_VALUE (MENU_ATTACH);
  EXPORT_VALUE (MENU_FOLDER);
  EXPORT_VALUE (MENU_COMPOSE);
  EXPORT_VALUE (MENU_POST);
  EXPORT_VALUE (MENU_PGP);
  EXPORT_VALUE (MENU_SMIME);
#ifdef MIXMASTER
  EXPORT_VALUE (MENU_MIX);
#endif
  EXPORT_VALUE (MENU_QUERY);
  EXPORT_VALUE (MENU_MAX);

  /* From pattern_exec_flag */
  EXPORT_VALUE (M_MATCH_FULL_ADDRESS);

  /* Hints when setting variables (the above macro seems to work only
     with enums). */
  scm_c_define ("M_SET_UNSET", scm_uint2num (M_SET_UNSET));
  scm_c_define ("M_SET_INV",   scm_uint2num (M_SET_INV));
  scm_c_define ("M_SET_RESET", scm_uint2num (M_SET_RESET));

#if 0 /* XXX: Not sure we really need this */
  /* Action codes used by mutt_set_flag () and mutt_pattern_function ()
     and defined in mutt.h.  */
  EXPORT_VALUE (M_ALL);
  EXPORT_VALUE (M_NONE);
  EXPORT_VALUE (M_NEW);
  EXPORT_VALUE (M_OLD);
  EXPORT_VALUE (M_REPLIED);
  EXPORT_VALUE (M_READ);
  EXPORT_VALUE (M_UNREAD);
  EXPORT_VALUE (M_DELETE);
  EXPORT_VALUE (M_UNDELETE);
  EXPORT_VALUE (M_DELETED);
  EXPORT_VALUE (M_FLAG);
  EXPORT_VALUE (M_TAG);
  EXPORT_VALUE (M_UNTAG);
  EXPORT_VALUE (M_LIMIT);
  EXPORT_VALUE (M_EXPIRED);
  EXPORT_VALUE (M_SUPERSEDED);
#endif

  /* Setup the correct bindings */
#include "guile-bindings.c.x"

  /* Reify directory information to the user */
  scm_c_define ("%mutt-data-directory",
		scm_makfrom0str (PKGDATADIR));
  scm_c_define ("%mutt-sysconfig-directory",
		scm_makfrom0str (SYSCONFDIR));

  /* Load the system-wide configuration file */
  scm_c_primitive_load (PKGDATADIR "/guile/mutt.scm");

  /*scm_shell (0, NULL);*/
  mutt_main (argc, argv);
}

void
smutt_init (int argc, char *argv[])
{
#ifdef DEBUG_GUILE
  /* mcheck () has to be called before the first malloc ().  */
  assert (mcheck (0) == 0);
#endif
  scm_boot_guile (argc, argv, mutt_init_guile_extension, NULL);
}

/* Read FILENAME, a Scheme configuration file.  */
int
smutt_load_rc_file (const char *filename)
{
  struct stat file_stats;
  char *file = (char *)filename;
  char *basename = "/.mutt.scm";
  char *home;

  if (!file)
  {
    home = getenv ("HOME");
    if (!home)
      home = "./";

    file = calloc (strlen (basename) + strlen (home) + 1, sizeof (char));
    if (!file)
      return -1;

    strcpy (file, home);
    strcpy (file + strlen (home), basename);
  }

  if (lstat (file, &file_stats))
    mutt_error ("%s: %s", file, strerror (errno));
  else
    scm_c_primitive_load (file);

  free (file);

  return 0;
}


/* Different stages of a Scheme procedure call */
typedef enum
  {
    CALL_BEFORE = 0,
    CALL_RESOLVE,     /* Procedure name resolution */
    CALL_EVAL,        /* Evaluate the procedure call */
    CALL_DONE         /* Finished the procedure call */
  } smutt_procedure_call_stage_t;

/* A (safe) Scheme procedure call.  */
typedef struct
{
  /* Scheme procedure name */
  char *proc;

  /* Argument list for that procedure */
  SCM   arglist;

  /* After the call, if different from SCM_UNDEFINED, specifies the
     tag of an exception that occured during the call.  When an
     exception has occured, the STAGE field gives a hint on during
     what stage the exception arose.  */
  SCM   exception;

  /* State of this procedure call (i.e. what stage it is in) */
  smutt_procedure_call_stage_t stage;

} smutt_procedure_call_t;


/* Call a Scheme procedure as specified by the passed object.  */
static SCM
call_scheme_procedure (void *data)
{
  SCM proc, ret;
  smutt_procedure_call_t *call = (smutt_procedure_call_t *)data;

  assert (call);
  assert (call->proc);
  
  call->stage = CALL_RESOLVE;
  proc = scm_c_eval_string (call->proc);

  call->stage = CALL_EVAL;
  ret = scm_apply_0 (proc, call->arglist);

  call->stage = CALL_DONE;
  return ret;
}

/* Handle exception TAG with args ARGS which arose during the Scheme
   procedure call specified by DATA.  */
static SCM
scheme_exception_handler (void *data, SCM tag, SCM args)
{
  char *errmsg = last_error_message;
  char *c_tag, *c_proc;
  smutt_procedure_call_t *call = (smutt_procedure_call_t *)data;

  assert (call);

  /* Get the exception name */
  call->exception = tag;
  if (SCM_SYMBOLP (tag))
    c_tag = SCM_SYMBOL_CHARS (tag);
  else
    c_tag = "<unknown-exception>";

  /* Get the name of the procedure where this happened */
  if (scm_ilength (args) >= 4)
    {
      SCM proc;
      
      proc = SCM_CAR (args);
      c_proc = SCM_STRINGP (proc) ? SCM_STRING_CHARS (proc) : call->proc;
      /* FIXME: We might want to use the message from ARGS */
    }      
  else
    c_proc = call->proc;

  if (!c_proc)
    c_proc = "<unknown-procedure>";
  
  switch (call->stage)
    {
    case CALL_RESOLVE:
      snprintf (errmsg, ERRMSG_SIZE_MAX,
		"%s: Scheme procedure not found (%s)",
		c_proc, c_tag);
      break;

    case CALL_EVAL:
      snprintf (errmsg, ERRMSG_SIZE_MAX,
		"In procedure %s: Scheme exception %s",
		c_proc, c_tag);
      break;

    default:
      snprintf (errmsg, ERRMSG_SIZE_MAX,
		"In procedure %s: Unexpected Scheme exception %s",
		c_proc, c_tag);
    }

  mutt_error ("%s", errmsg);
  mutt_sleep (1);

  return SCM_BOOL_F;
}

/* Call Scheme procedure _NAME with argument list _S_ARGLIST.  On
   return, set _S_RET to the return value of the procedure or false if
   an exception occured.  _CALL is a `smutt_procedure_call_t' object
   that may be inspected afterwards to known whether an exception
   occured.  */
#define SCM_CALL_PROCEDURE(_call, _name, _s_arglist, _s_ret)		\
do										\
  {										\
    (_call).stage = CALL_BEFORE;						\
    (_call).proc  = (_name);							\
    (_call).arglist = (_s_arglist);						\
    (_call).exception = SCM_UNDEFINED;						\
    *last_error_message = '\0';							\
										\
    /* Catch any uncaught exception */						\
    (_s_ret) = scm_internal_catch (SCM_BOOL_T, call_scheme_procedure, &(_call),	\
				   scheme_exception_handler, &(_call));		\
   }										\
while (0)

/* Return non-zero if _CALL resulted in a `procedure not found'
   error.  */
#define PROCEDURE_NOT_FOUND(_call) \
  (((_call).exception != SCM_UNDEFINED) && ((_call).stage == CALL_RESOLVE))


static SCM
run_idle_hook (void *data)
{
  smutt_procedure_call_t *call;
  SCM hook, ret;

  call = (smutt_procedure_call_t *)data;
  assert (call);
  
  call->stage = CALL_RESOLVE;
  hook = scm_c_eval_string ("idle-hook");
  
  if (scm_hook_p (hook))
    {
      /* Run the hook with no arguments */
      call->stage = CALL_EVAL;
      ret = scm_run_hook (hook, SCM_EOL);
    }
  else
    ret = SCM_BOOL_F;

  call->stage = CALL_DONE;
  
  return ret;
}

static void
smutt_idle_hook (void)
{
  smutt_procedure_call_t call;
  SCM ret;

  call.proc = "run-hook";
  call.stage = CALL_BEFORE;
  ret = scm_internal_catch (SCM_BOOL_T, run_idle_hook, &call,
			    scheme_exception_handler, &call);
}

/* The `smutt_cmd_*' functions below are wrappers which simply evaluate the
   corresponding Scheme version of a command.  */

int
smutt_cmd_parse_rc_line (const char *line, char *errmsg)
{
  smutt_procedure_call_t call;
  SCM ret, s_line;

  s_line = scm_makfrom0str (line);

  SCM_CALL_PROCEDURE (call, "parse-rc-line",
		      SCM_LIST1 (s_line), ret);
  
  if (PROCEDURE_NOT_FOUND (call))
    return builtin_parse_rc_line (line, errmsg);
  
  if (ret == SCM_BOOL_F)
    {
      strcpy (errmsg, last_error_message);
      return -1;
    }

  *errmsg = '\0';
  
  return 0;
}

int
smutt_cmd_execute_command (const char *command, const char *args,
			   char *errmsg)
{
  smutt_procedure_call_t call;
  SCM s_command, s_args, ret;
  
  s_command = scm_makfrom0str (command);
  s_args = scm_makfrom0str (args);

  SCM_CALL_PROCEDURE (call, "execute-command",
		      SCM_LIST2 (s_command, s_args), ret);

  if (PROCEDURE_NOT_FOUND (call))
    /* Fall back to the built-in version */
    return builtin_execute_command (command, args, errmsg);
  
  if (ret == SCM_BOOL_F)
    {
      /* Return the error message to the caller */
      strcpy (errmsg, last_error_message);
      
      return -1;
    }

  return 0;
}

int
smutt_cmd_execute_function (const char *function, char *errmsg)
{
  smutt_procedure_call_t call;
  SCM s_function, ret;

  s_function = scm_makfrom0str (function);

  SCM_CALL_PROCEDURE (call, "execute-function",
		      SCM_LIST1 (s_function), ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_execute_function (function, errmsg);

  if (ret == SCM_BOOL_F)
    {
      /* Return the error message to the caller */
      strcpy (errmsg, last_error_message);
      
      return -1;
    }

  return 0;
}

int
smutt_cmd_set_option (char *variable, char *value, int hint, char *errmsg)
{
  smutt_procedure_call_t call;
  SCM ret;
  SCM s_variable, s_value, s_hint;

  s_variable = scm_makfrom0str (variable);
  s_value = scm_makfrom0str (value);
  s_hint = scm_int2num (hint);

  SCM_CALL_PROCEDURE (call, "set-option",
		      SCM_LIST3 (s_variable, s_value, s_hint), ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_set_option (variable, value, hint, errmsg);
  
  if (ret == SCM_BOOL_F)
    {
      strcpy (errmsg, last_error_message);
      return -1;
    }

  return 0;
}

int
smutt_cmd_query_option (char *value, char *variable, char *errmsg)
#define FUNC_NAME __FUNCTION__
{
  smutt_procedure_call_t call;
  SCM s_value, s_variable;


  s_variable = scm_makfrom0str (variable);

  SCM_CALL_PROCEDURE (call, "query-option",
		      SCM_LIST1 (s_variable), s_value);
  
  if (PROCEDURE_NOT_FOUND (call))
    return builtin_query_option (value, variable, errmsg);
  
  if (s_value == SCM_BOOL_F)
    {
      *value = '\0';
      strcpy (errmsg, last_error_message);
      return -1;
    }

  SCM_VALIDATE_STRING (1, s_value);
  strcpy (value, SCM_STRING_CHARS (s_value));

  return 0;
}
#undef FUNC_NAME

int
smutt_cmd_define_alias (const char *alias_name, ADDRESS *address,
			ALIAS **alias, char *errmsg)
{
  smutt_procedure_call_t call;
  SCM s_alias_name, s_address, s_alias;

  s_alias_name = scm_makfrom0str (alias_name);
  MAKE_MUTT_SMOB (s_address, address, address);

  SCM_CALL_PROCEDURE (call, "define-alias",
		      SCM_LIST2 (s_alias_name, s_address), s_alias);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_define_alias (alias_name, address, alias, errmsg);

  if (s_alias == SCM_BOOL_F)
    {
      /* Return the error message to the caller */
      strcpy (errmsg, last_error_message);
      
      *alias = NULL;
      return -1;
    }

  SCM_VALIDATE_MUTT_TYPE (alias, 0, s_alias);
  TRANSLATE_SMOB (*alias, s_alias, ALIAS);
  MARK_AS_UNDESTROYABLE (*alias);

  return 0;
}

int
smutt_cmd_save_alias (const ALIAS *alias, const char *filename,
		      char *errmsg)
{
  smutt_procedure_call_t call;
  SCM s_alias, s_filename, ret;

  MAKE_MUTT_SMOB (s_alias, alias, ((ALIAS *)alias));
  s_filename = scm_makfrom0str (filename);

  SCM_CALL_PROCEDURE (call, "save-alias",
		      SCM_LIST2 (s_alias, s_filename), ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_save_alias (alias, filename, errmsg);

  if (ret == SCM_BOOL_F)
    {
      /* Return the error message to the caller */
      strcpy (errmsg, last_error_message);

      return -1;
    }

  return 0;
}

int
smutt_cmd_generate_message_id (char **messageid)
#define FUNC_NAME __FUNCTION__
{
  smutt_procedure_call_t call;
  SCM ret;

  SCM_CALL_PROCEDURE (call, "generate-message-id",
		      SCM_EOL, ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_generate_message_id (messageid);
  
  if (ret == SCM_BOOL_F)
    {
      *messageid = 0;
      return -1;
    }

  SCM_VALIDATE_STRING (0, ret);
  *messageid = safe_strdup (SCM_STRING_CHARS (ret));

  return 0;
}
#undef FUNC_NAME

int
smutt_cmd_display_message (HEADER *message)
{
  smutt_procedure_call_t call;
  SCM s_message, ret;

  MAKE_MUTT_SMOB (s_message, message, message);

  SCM_CALL_PROCEDURE (call, "display-message",
		      SCM_LIST1 (s_message), ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_display_message (message);

  if (ret == SCM_BOOL_F)
    {
      /* This should not happen, we do not handle error messages */
      return -1;
    }

  return 0;
}

int
smutt_cmd_make_forward_subject (ENVELOPE *envelope, CONTEXT *mailbox,
				HEADER *message)
{
  smutt_procedure_call_t call;
  SCM s_envelope, s_mailbox, s_message, ret;

  MAKE_MUTT_SMOB (s_envelope, envelope, envelope);
  MAKE_MUTT_SMOB (s_message, message, message);
  MAKE_MUTT_SMOB (s_mailbox, mailbox, mailbox);

  SCM_CALL_PROCEDURE (call, "make-forward-subject!",
		      SCM_LIST3 (s_envelope, s_message, s_mailbox),
		      ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_make_forward_subject (envelope, mailbox, message);
  
  if (ret == SCM_BOOL_F)
    {
      /* This should not happen */
      return -1;
    }

  return 0;
}

int
smutt_cmd_score_message (CONTEXT *mailbox, HEADER *message, int update_mailbox)
{
  smutt_procedure_call_t call;
  SCM s_mailbox, s_update_mailbox, s_message, ret;

  MAKE_MUTT_SMOB (s_mailbox, mailbox, mailbox);
  MAKE_MUTT_SMOB (s_message, message, message);
  s_update_mailbox = update_mailbox ? SCM_BOOL_T : SCM_BOOL_F;

  SCM_CALL_PROCEDURE (call, "score-message",
		      SCM_LIST3 (s_message, s_update_mailbox, s_mailbox),
		      ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_score_message (mailbox, message, update_mailbox);

  if (ret == SCM_BOOL_F)
    return -1;

  return 0;
}

int
smutt_cmd_add_scoring_rule (char *pattern, char *value,
			    SCORE **newrule, char *errmsg)
{
  smutt_procedure_call_t call;
  SCM s_score;

  SCM_CALL_PROCEDURE (call, "add-scoring-rule!",
		      SCM_LIST2 (scm_makfrom0str (pattern),
				 scm_makfrom0str (value)),
		      s_score);
  
  if (PROCEDURE_NOT_FOUND (call))
    return builtin_add_scoring_rule (pattern, value, newrule, errmsg);
  
  if (s_score == SCM_BOOL_F)
    {
      *newrule = NULL;
      strcpy (errmsg, last_error_message);
      return -1;
    }

  SCM_VALIDATE_MUTT_TYPE (score, 0, s_score);
  TRANSLATE_SMOB (*newrule, s_score, SCORE);
  MARK_AS_UNDESTROYABLE (*newrule);

  return 0;
}

int
smutt_cmd_compile_pattern (pattern_t **pattern, char *string,
			   int flags, char *errmsg)
{
  smutt_procedure_call_t call;
  SCM s_string, s_pattern;

  s_string = scm_makfrom0str (string);

  SCM_CALL_PROCEDURE (call, "compile-pattern",
		      SCM_LIST2 (s_string,
				 ((flags == M_FULL_MSG)
				  ? SCM_BOOL_T : SCM_BOOL_F)),
		      s_pattern);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_compile_pattern (pattern, string, flags, errmsg);

  if (s_pattern == SCM_BOOL_F)
    {
      *pattern = NULL;
      strcpy (errmsg, last_error_message);
      return -1;
    }

  SCM_VALIDATE_MUTT_TYPE (pattern, 0, s_pattern);
  TRANSLATE_SMOB (*pattern, s_pattern, pattern_t);

  /* We are giving this object to C code so this mustn't be
     destroyed later.  */
  MARK_AS_UNDESTROYABLE (*pattern);  

  return 0;
}

int
smutt_cmd_execute_pattern (pattern_t *pattern, HEADER *message,
			   CONTEXT *mailbox, pattern_exec_flag flags)
{
  smutt_procedure_call_t call;
  SCM s_pattern, s_mailbox, s_message, ret;

  MAKE_MUTT_SMOB (s_pattern, pattern, pattern);
  MAKE_MUTT_SMOB (s_message,  message,  message);
  MAKE_MUTT_SMOB (s_mailbox, mailbox, mailbox);

  SCM_CALL_PROCEDURE (call, "execute-pattern",
		      SCM_LIST4 (s_pattern, s_message,
				 scm_int2num (flags), s_mailbox),
		      ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_execute_pattern (pattern, message, mailbox, flags);
  
  if (ret == SCM_BOOL_F)
    return 0;

  return 1;
}

int
smutt_cmd_save_message (HEADER *message, const char *mailbox,
			int delete, int decode, int decrypt)
{
  smutt_procedure_call_t call;
  SCM s_message, args, ret;

  if (message)
    MAKE_MUTT_SMOB (s_message, message, message);
  else
    s_message = SCM_BOOL_F;

  args = SCM_LIST5 (s_message, scm_makfrom0str (mailbox),
		    (delete  ? SCM_BOOL_T : SCM_BOOL_F),
		    (decode  ? SCM_BOOL_T : SCM_BOOL_F),
		    (decrypt ? SCM_BOOL_T : SCM_BOOL_F));

  SCM_CALL_PROCEDURE (call, "save-message",
		      args, ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_save_message (message, mailbox, delete, decode, decrypt);
  
  if (ret == SCM_BOOL_F)
    return -1;

  return 0;
}

int
smutt_cmd_is_mailing_list (ADDRESS *address)
{
  smutt_procedure_call_t call;
  SCM s_address, ret;

  MAKE_MUTT_SMOB (s_address, address, address);

  SCM_CALL_PROCEDURE (call, "is-mailing-list?",
		      SCM_LIST1 (s_address), ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_is_mailing_list (address);
  
  if (ret == SCM_BOOL_F)
    return 0;

  return 1;
}

int
smutt_cmd_is_subscribed_list (ADDRESS *address)
{
  smutt_procedure_call_t call;
  SCM s_address, ret;

  MAKE_MUTT_SMOB (s_address, address, address);

  SCM_CALL_PROCEDURE (call, "is-subscribed-list?",
		      SCM_LIST1 (s_address), ret);
  
  if (PROCEDURE_NOT_FOUND (call))
    return builtin_is_subscribed_list (address);
  
  if (ret == SCM_BOOL_F)
    return 0;

  return 1;
}

int
smutt_cmd_addr_is_user (ADDRESS *address)
{
  smutt_procedure_call_t call;
  SCM s_address, ret;

  MAKE_MUTT_SMOB (s_address, address, address);

  SCM_CALL_PROCEDURE (call, "address-is-user?",
		      SCM_LIST1 (s_address), ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_addr_is_user (address);
  
  if (ret == SCM_BOOL_F)
    return 0;

  return 1;
}

int
smutt_cmd_default_from_address (ADDRESS **from)
{
  smutt_procedure_call_t call;
  ADDRESS *orig_from;
  SCM s_from;

  *from = NULL;
  SCM_CALL_PROCEDURE (call, "default-from-address",
		      SCM_EOL, s_from);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_default_from_address (from);
  
  SCM_VALIDATE_MUTT_TYPE (address, 0, s_from);

  TRANSLATE_SMOB (orig_from, s_from, ADDRESS);
  assert (orig_from);

  /* Return a copy of the address, which is what C code expects */
  *from = rfc822_cpy_adr_real (orig_from);
  if (!*from)
    return -1;
  
  MARK_AS_DESTROYABLE (orig_from);

  return 0;
}

int
smutt_cmd_menu_jump (MUTTMENU *menu, unsigned int entry,
		     char *errmsg)
{
  smutt_procedure_call_t call;
  SCM s_menu, err;

  MAKE_MUTT_SMOB (s_menu, menu, menu);

  SCM_CALL_PROCEDURE (call, "menu-jump",
		      SCM_LIST2 (scm_uint2num (entry),
				 s_menu),
		      err);
  
  if (PROCEDURE_NOT_FOUND (call))
    return builtin_menu_jump (menu, entry, errmsg);
  
  if (err == SCM_BOOL_F)
    {
      strcpy (errmsg, last_error_message);
      return -1;
    }

  *errmsg = 0;
  return 0;
}

int
smutt_cmd_pipe_message (HEADER *message, const char *command,
			int print,
			int decode, int split, const char *separator)
{
  smutt_procedure_call_t call;
  SCM s_message, args, ret;

  if (message)
    MAKE_MUTT_SMOB (s_message, message, message);
  else
    s_message = SCM_BOOL_F;

  args = SCM_LIST6 (s_message, scm_makfrom0str (command),
		    (print   ? SCM_BOOL_T : SCM_BOOL_F),
		    (decode  ? SCM_BOOL_T : SCM_BOOL_F),
		    (split   ? SCM_BOOL_T : SCM_BOOL_F),
		    scm_makfrom0str (separator));

  SCM_CALL_PROCEDURE (call, "pipe-message",
		      args, ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_pipe_message (message, command, print,
				 decode, split, separator);

  if (ret == SCM_BOOL_F)
    return -1;

  return 0;
}

int
smutt_cmd_send_message (HEADER *message)
{
  smutt_procedure_call_t call;
  SCM s_message, ret;

  MAKE_MUTT_SMOB (s_message, message, message);

  SCM_CALL_PROCEDURE (call, "send-message",
		      SCM_LIST1 (s_message), ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_send_message (message);

  if (ret == SCM_BOOL_F)
    return -1;

  return 0;
}

/* Try to convert _C_FILE to a file pointer and then to a standard
   Scheme port.  This is quite inefficient since we first have to flush
   FILE's buffer, and then the port's buffer.  XXX: Suggestions
   are welcome!  */
#define MAKE_PORT_FROM_FILE(_s_port, _c_file)			\
{								\
  SCM s_mode_str;						\
  								\
  /* FIXME: This is quite inefficient! */			\
  s_mode_str = scm_makfrom0str ("w");				\
								\
  if (fflush ((_c_file)))					\
    return -1;							\
  								\
  (_s_port) = scm_fdopen (scm_int2num (fileno ((_c_file))),	\
			  s_mode_str);				\
  if ((_s_port) == SCM_BOOL_F)					\
    return -1;							\
								\
  /* Prevent the underlying fd from garbage collection */	\
  scm_set_port_revealed_x (s_port, scm_int2num (1));		\
}

int
smutt_cmd_append_signature (FILE *file, HEADER *message)
{
  smutt_procedure_call_t call;
  SCM s_message, s_port, ret;

  MAKE_MUTT_SMOB (s_message, message, message);
  MAKE_PORT_FROM_FILE (s_port, file);

  SCM_CALL_PROCEDURE (call, "append-signature",
		      SCM_LIST2 (s_port, s_message), ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_append_signature (file, message);
  
  scm_force_output (s_port);
  if (ret == SCM_BOOL_F)
    return -1;

  return 0;
}

int
smutt_cmd_append_forward_intro (FILE *file, HEADER *forwarded)
{
  smutt_procedure_call_t call;
  SCM s_port, s_forwarded, ret;

  MAKE_MUTT_SMOB (s_forwarded, message, forwarded);
  MAKE_PORT_FROM_FILE (s_port, file);

  SCM_CALL_PROCEDURE (call, "append-forward-intro",
		      SCM_LIST2 (s_port, s_forwarded), ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_append_forward_intro (file, forwarded);
  
  scm_force_output (s_port);
  if (ret == SCM_BOOL_F)
    return -1;

  return 0;
}

int
smutt_cmd_append_forward_trailer (FILE *file, HEADER *forwarded)
{
  smutt_procedure_call_t call;
  SCM s_port, s_forwarded, ret;

  MAKE_MUTT_SMOB (s_forwarded, message, forwarded);
  MAKE_PORT_FROM_FILE (s_port, file);

  SCM_CALL_PROCEDURE (call, "append-forward-trailer",
		      SCM_LIST2 (s_port, s_forwarded), ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_append_forward_trailer (file, forwarded);
  
  scm_force_output (s_port);
  if (ret == SCM_BOOL_F)
    return -1;

  return 0;
}

int
smutt_cmd_append_message_attribution (FILE *file, HEADER *replied,
				      CONTEXT *mailbox)
{
  smutt_procedure_call_t call;
  SCM s_port, s_replied, s_mailbox, ret;

  MAKE_MUTT_SMOB (s_replied, message, replied);
  MAKE_MUTT_SMOB (s_mailbox, mailbox, mailbox);
  MAKE_PORT_FROM_FILE (s_port, file);

  SCM_CALL_PROCEDURE (call, "append-message-attribution",
		      SCM_LIST3 (s_port, s_replied, s_mailbox), ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_append_message_attribution (file, replied, mailbox);

  scm_force_output (s_port);
  if (ret == SCM_BOOL_F)
    return -1;

  return 0;
}

int
smutt_cmd_generate_reply_body (FILE *file, HEADER *message,
			       CONTEXT *mailbox, HEADER *replied)
{
  smutt_procedure_call_t call;
  SCM s_port, s_message, s_replied, s_mailbox, ret;

  MAKE_MUTT_SMOB (s_message, message, message);
  MAKE_MUTT_SMOB (s_replied, message, replied);
  MAKE_MUTT_SMOB (s_mailbox, mailbox, mailbox);
  MAKE_PORT_FROM_FILE (s_port, file);

  SCM_CALL_PROCEDURE (call, "generate-reply-body",
		      SCM_LIST4 (s_port, s_message, s_replied, s_mailbox),
		      ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_generate_reply_body (file, message, mailbox, replied);

  scm_force_output (s_port);
  if (ret == SCM_BOOL_F)
    return -1;

  return 0;
}

int
smutt_cmd_generate_forward_body (FILE *file, HEADER *message,
				 CONTEXT *mailbox, HEADER *forwarded)
{
  smutt_procedure_call_t call;
  SCM s_port, s_message, s_forwarded, s_mailbox, ret;

  MAKE_MUTT_SMOB (s_message, message, message);
  MAKE_MUTT_SMOB (s_forwarded, message, forwarded);
  MAKE_MUTT_SMOB (s_mailbox, mailbox, mailbox);
  MAKE_PORT_FROM_FILE (s_port, file);

  SCM_CALL_PROCEDURE (call, "generate-forward-body",
		      SCM_LIST4 (s_port, s_message, s_forwarded, s_mailbox),
		      ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_generate_forward_body (file, message, mailbox, forwarded);

  scm_force_output (s_port);
  if (ret == SCM_BOOL_F)
    return -1;

  return 0;
}

int
smutt_cmd_include_reply_body (FILE *file, HEADER *replied,
			      CONTEXT *mailbox)
{
  smutt_procedure_call_t call;
  SCM s_port, s_replied, s_mailbox, ret;

  MAKE_MUTT_SMOB (s_replied, message, replied);
  MAKE_MUTT_SMOB (s_mailbox, mailbox, mailbox);
  MAKE_PORT_FROM_FILE (s_port, file);

  SCM_CALL_PROCEDURE (call, "include-reply-body",
		      SCM_LIST3 (s_port, s_replied, s_mailbox),
		      ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_include_reply_body (file, replied, mailbox);

  scm_force_output (s_port);
  if (ret == SCM_BOOL_F)
    return -1;

  return 0;
}

int
smutt_cmd_include_forward_body (FILE *file, HEADER *forwarded,
				CONTEXT *mailbox)
{
  smutt_procedure_call_t call;
  SCM s_port, s_forwarded, s_mailbox, ret;

  MAKE_MUTT_SMOB (s_forwarded, message, forwarded);
  MAKE_MUTT_SMOB (s_mailbox, mailbox, mailbox);
  MAKE_PORT_FROM_FILE (s_port, file);

  SCM_CALL_PROCEDURE (call, "include-forward-body",
		      SCM_LIST3 (s_port, s_forwarded, s_mailbox),
		      ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_include_forward_body (file, forwarded, mailbox);

  scm_force_output (s_port);
  if (ret == SCM_BOOL_F)
    return -1;

  return 0;
}

int
smutt_cmd_make_reply_header (ENVELOPE *replyenv, HEADER *current,
			     ENVELOPE *currentenv, CONTEXT *mailbox)
{
  smutt_procedure_call_t call;
  SCM s_replyenv, s_current, s_currentenv, s_mailbox, ret;

  MAKE_MUTT_SMOB (s_replyenv, envelope, replyenv);
  MAKE_MUTT_SMOB (s_current, message, current);
  MAKE_MUTT_SMOB (s_currentenv, envelope, currentenv);
  MAKE_MUTT_SMOB (s_mailbox, mailbox, mailbox);

  SCM_CALL_PROCEDURE (call, "make-reply-header!",
		      SCM_LIST4 (s_replyenv, s_current,
				 s_currentenv, s_mailbox),
		      ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_make_reply_header (replyenv, current,
				      currentenv, mailbox);
  
  if (ret == SCM_BOOL_F)
    return -1;

  return 0;
}

int
smutt_cmd_add_mailbox (BUFFY **mailbox, const char *name)
{
  smutt_procedure_call_t call;
  SCM s_mailbox;

  SCM_CALL_PROCEDURE (call, "add-mailbox!",
		      SCM_LIST1 (scm_makfrom0str (name)),
		      s_mailbox);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_add_mailbox (mailbox, name);
  
  if (s_mailbox == SCM_BOOL_F)
    return -1;

  SCM_VALIDATE_MUTT_TYPE (buffy, 0, s_mailbox);
  TRANSLATE_SMOB (*mailbox, s_mailbox, BUFFY);
  MARK_AS_UNDESTROYABLE (*mailbox);

  return 0;
}

int
smutt_cmd_remove_mailbox (BUFFY *mailbox)
{
  smutt_procedure_call_t call;
  SCM s_mailbox, ret;

  MAKE_MUTT_SMOB (s_mailbox, buffy, mailbox);

  SCM_CALL_PROCEDURE (call, "remove-mailbox!",
		      SCM_LIST1 (s_mailbox), ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_remove_mailbox (mailbox);
  
  if (ret == SCM_BOOL_F)
    return -1;

  return 0;
}

int
smutt_cmd_expand_path (char *path, size_t pathlen)
{
  smutt_procedure_call_t call;
  SCM ret;

  SCM_CALL_PROCEDURE (call, "expand-path",
		      SCM_LIST1 (scm_makfrom0str (path)), ret);

  if (PROCEDURE_NOT_FOUND (call))
    return builtin_expand_path (path, pathlen);

  if (ret == SCM_BOOL_F)
    {
      *path = '\0';
      return -1;
    }

  strncpy (path, SCM_STRING_CHARS (ret), pathlen);
  
  return 0;
}

int
smutt_cmd_query_exit (void)
{
  smutt_procedure_call_t call;
  SCM ret;

  SCM_CALL_PROCEDURE (call, "query-exit",
		      SCM_EOL, ret);
  
  if (PROCEDURE_NOT_FOUND (call))
    return builtin_query_exit ();
  
  if (ret == SCM_BOOL_F)
    return -1;

  return 0;
}
