Gauche support collapsed in 0.8.14.  Here are the xen portions
of that code:

xen.h:

/* ------------------------------ GAUCHE ------------------------------ */

#if HAVE_GAUCHE

/* gauche.h requires its config.h thereby clobbering some of our macros.  I'll try to protect the ones I notice */
#define LOCAL_SIZEOF_OFF_T SIZEOF_OFF_T
#undef SIZEOF_OFF_T
#include <gauche.h>
#undef SIZEOF_OFF_T
#define SIZEOF_OFF_T LOCAL_SIZEOF_OFF_T

#define XEN_OK 1

#define XEN_FILE_EXTENSION           "scm"
#define XEN_COMMENT_STRING           ";"
#define XEN_EMPTY_LIST               SCM_NIL
#define XEN_LANGUAGE_NAME            "Gauche"

#define XEN                          ScmObj
#define XEN_TRUE                     SCM_TRUE
#define XEN_FALSE                    SCM_FALSE
#define XEN_TRUE_P(a)                SCM_TRUEP(a)
#define XEN_FALSE_P(a)               SCM_FALSEP(a)

#define XEN_UNDEFINED                SCM_UNDEFINED
/* XEN_DEFINED_P is used in the sense of "is this identifier (a string) defined" */
/*   as a function argument, XEN_UNDEFINED is a marker that the given argument was not supplied */
#define XEN_DEFINED_P(Name)          (Scm_FindBinding(Scm_UserModule(), SCM_SYMBOL(SCM_INTERN(Name)), false) != NULL)
/* in Gauche, undefined != unbound (SCM_UNDEFINED, SCM_UNBOUND), but the distinction is blurred in other cases */
/* XEN_NOT_BOUND_P is applied to XEN objects, not strings */
#define XEN_BOUND_P(Arg)             (!(SCM_UNDEFINEDP(Arg)))
#define XEN_NOT_BOUND_P(Arg)         SCM_UNDEFINEDP(Arg)

#define XEN_EQ_P(a, b)               SCM_EQ(a, b)
#define XEN_EQV_P(A, B)              ((bool)Scm_EqvP(A, B))
#define XEN_EQUAL_P(A, B)            ((bool)Scm_EqualP(A, B))
#define XEN_NULL_P(a)                SCM_NULLP(a)

#define XEN_BOOLEAN_P(Arg)           SCM_BOOLP(Arg)
#define C_TO_XEN_BOOLEAN(a)          SCM_MAKE_BOOL(a)
#define XEN_TO_C_BOOLEAN(a)          SCM_BOOL_VALUE(a)

#define XEN_CAR(a)                   SCM_CAR(a)
#define XEN_CADR(a)                  SCM_CADR(a)
#define XEN_CADDR(a)                 SCM_CAR(SCM_CDDR(a))
#define XEN_CADDDR(a)                SCM_CAR(SCM_CDR(SCM_CDDR(a)))
#define XEN_CDR(a)                   SCM_CDR(a)
#define XEN_CDDR(a)                  SCM_CDDR(a)

#define XEN_CONS_P(Arg)              SCM_PAIRP(Arg)
#define XEN_PAIR_P(Arg)              ((SCM_PAIRP(Arg)) && (SCM_DOTTED_LIST_P(Arg)))
/* probably not PAIRP since it seems to refer to any list or even #f!! */
#define XEN_CONS(Arg1, Arg2)         Scm_Cons(Arg1, Arg2)
#define XEN_CONS_2(Arg1, Arg2, Arg3) Scm_Cons(Arg1, Scm_Cons(Arg2, Arg3))

#define XEN_LIST_P(Arg)              ((SCM_LISTP(Arg)) && (SCM_PROPER_LIST_P(Arg)))
#define XEN_LIST_P_WITH_LENGTH(Arg, Len) ((Len = ((int)Scm_Length(Arg))) >= 0)
#define XEN_LIST_LENGTH(Arg)         Scm_Length(Arg)
#define XEN_LIST_REF(Lst, Num)       Scm_ListRef(Lst, Num, XEN_FALSE)
#define XEN_LIST_SET(Lst, Loc, Val)  xen_gauche_list_set_x(Lst, Loc, Val)
#define XEN_LIST_REVERSE(Lst)        Scm_Reverse(Lst)
#define XEN_LIST_1(a)                SCM_LIST1(a)
#define XEN_LIST_2(a, b)             SCM_LIST2(a, b)
#define XEN_LIST_3(a, b, c)          SCM_LIST3(a, b, c)
#define XEN_LIST_4(a, b, c, d)       SCM_LIST4(a, b, c, d)
#define XEN_LIST_5(a, b, c, d, e)    SCM_LIST5(a, b, c, d, e)
#define XEN_LIST_6(a, b, c, d, e, f)          Scm_List(a, b, c, d, e, f, NULL)
#define XEN_LIST_7(a, b, c, d, e, f, g)       Scm_List(a, b, c, d, e, f, g, NULL)
#define XEN_LIST_8(a, b, c, d, e, f, g, h)    Scm_List(a, b, c, d, e, f, g, h, NULL)
#define XEN_LIST_9(a, b, c, d, e, f, g, h, i) Scm_List(a, b, c, d, e, f, g, h, i, NULL)
#define XEN_APPEND(a, b)             Scm_Append2(a, b)
#define XEN_COPY_ARG(Lst)            Lst
#define XEN_MEMBER(a, b)             Scm_Member(a, b, SCM_CMP_EQUAL)
#define XEN_ASSOC(a, b)              Scm_Assoc(a, b, SCM_CMP_EQUAL)

#define XEN_VECTOR_P(Arg)            SCM_VECTORP(Arg)
#define XEN_VECTOR_LENGTH(Arg)       SCM_VECTOR_SIZE(Arg)
#define XEN_VECTOR_REF(Vect, Num)    Scm_VectorRef(SCM_VECTOR(Vect), Num, XEN_FALSE)
#define XEN_VECTOR_SET(Vect, Num, Val) Scm_VectorSet(SCM_VECTOR(Vect), Num, Val)
#define XEN_VECTOR_TO_LIST(Vect)     Scm_VectorToList(SCM_VECTOR(Vect), 0, XEN_VECTOR_LENGTH(Vect) - 1)
#define XEN_MAKE_VECTOR(Num, Fill)   Scm_MakeVector(Num, Fill)

#define XEN_NUMBER_P(Arg)            SCM_REALP(Arg)
#define XEN_ZERO                     SCM_MAKE_INT(0)
#define XEN_INTEGER_P(Arg)           SCM_INTEGERP(Arg)

/* Gauche "ints" are apparently 29-bit quantities -- might have to stick with ULONG everywhere */
#if defined(__GNUC__) && (!(defined(__cplusplus)))
  #define XEN_TO_C_INT(a)               ({ XEN _xen_ga_9_ = a; (SCM_INTP(_xen_ga_9_) ? SCM_INT_VALUE(_xen_ga_9_) : Scm_GetInteger(_xen_ga_9_)); })
  #define XEN_TO_C_INT_OR_ELSE(a, b)    ({ XEN _xen_ga_1_ = a; ((XEN_INTEGER_P(_xen_ga_1_)) ? XEN_TO_C_INT(_xen_ga_1_) : b); })
  #define XEN_TO_C_DOUBLE_OR_ELSE(a, b) ({ XEN _xen_ga_2_ = a; ((XEN_NUMBER_P(_xen_ga_2_)) ? XEN_TO_C_DOUBLE(_xen_ga_2_) : b); })
  #define C_TO_XEN_INT(a)               ({ int _xen_ga_8_ = a; \
                                            (SCM_SMALL_INT_FITS(_xen_ga_8_)) ? \
                                              SCM_MAKE_INT(_xen_ga_8_) : Scm_MakeInteger((long)_xen_ga_8_); })
#else
  #define XEN_TO_C_INT(a)               (SCM_INTP(a) ? SCM_INT_VALUE(a) : Scm_GetInteger(a))
  #define XEN_TO_C_INT_OR_ELSE(a, b)    ((XEN_INTEGER_P(a)) ? XEN_TO_C_INT(a) : b)
  #define XEN_TO_C_DOUBLE_OR_ELSE(a, b) ((XEN_NUMBER_P(a)) ? XEN_TO_C_DOUBLE(a) : b)
  #define C_TO_XEN_INT(a)               Scm_MakeInteger((long)a)
#endif
#define XEN_DOUBLE_P(Arg)            SCM_REALP(Arg)
#define XEN_TO_C_DOUBLE(a)           xen_to_c_double(a)
#define C_TO_XEN_DOUBLE(a)           Scm_MakeFlonum(a)
#define XEN_TO_C_ULONG(a)            Scm_GetIntegerU(a)
#define C_TO_XEN_ULONG(a)            Scm_MakeIntegerU((unsigned long)a)
#define XEN_ULONG_P(Arg)             SCM_INTEGERP(Arg)
#define XEN_EXACT_P(Arg)             SCM_EXACTP(Arg)
#define C_TO_XEN_LONG_LONG(a)        Scm_MakeBignumFromSI(a)
#define XEN_COMPLEX_P(Arg)           SCM_NUMBERP(Arg)

#if defined(__GNUC__) && (!(defined(__cplusplus)))
  #define XEN_OFF_T_P(Arg)           ({ XEN _xen_ga_3_ = Arg; (SCM_INTEGERP(_xen_ga_3_) || SCM_BIGNUMP(_xen_ga_3_)); })
  #define XEN_TO_C_LONG_LONG(a)      ({ XEN _xen_ga_4_ = a; \
                                         (SCM_BIGNUMP(_xen_ga_4_) ? \
                                            ((off_t)(Scm_BignumToSI64(SCM_BIGNUM(_xen_ga_4_), SCM_CLAMP_NONE, NULL))) : \
                                            ((off_t)XEN_TO_C_INT(_xen_ga_4_))); })
#else
  #define XEN_OFF_T_P(Arg)           (SCM_INTEGERP(Arg) || SCM_BIGNUMP(Arg))
  #define XEN_TO_C_LONG_LONG(a)      (SCM_BIGNUMP(a) ? ((off_t)(Scm_BignumToSI64(SCM_BIGNUM(a), SCM_CLAMP_NONE, NULL))) : ((off_t)XEN_TO_C_INT(a)))
#endif

#if defined(SCM_COMPNUMP)
  #define XEN_HAVE_COMPLEX_NUMBERS 1
  #if defined(__GNUC__) && (!(defined(__cplusplus)))
    #ifdef SCM_COMPNUM_REAL
      #define XEN_TO_C_COMPLEX(a)      ({ XEN _xen_ga_5_ = a; (SCM_COMPNUM_REAL(_xen_ga_5_) + SCM_COMPNUM_IMAG(_xen_ga_5_) * _Complex_I); })
    #else
      #define XEN_TO_C_COMPLEX(a)      ({ XEN _xen_ga_5_ = a; (SCM_COMPLEX_REAL(_xen_ga_5_) + SCM_COMPLEX_IMAG(_xen_ga_5_) * _Complex_I); })
    #endif
    #define C_TO_XEN_COMPLEX(a)        ({ complex double _xen_ga_6_ = a; Scm_MakeComplex(creal(_xen_ga_6_), cimag(_xen_ga_6_)); })
  #else
    #ifdef SCM_COMPNUM_REAL
      #define XEN_TO_C_COMPLEX(a)      ((SCM_COMPNUMP(a)) ? ((SCM_COMPNUM_REAL(a) + SCM_COMPNUM_IMAG(a) * _Complex_I)) : (XEN_TO_C_DOUBLE(a)))
    #else
      #define XEN_TO_C_COMPLEX(a)      ((SCM_COMPLEXP(a)) ? ((SCM_COMPLEX_REAL(a) + SCM_COMPLEX_IMAG(a) * _Complex_I)) : (XEN_TO_C_DOUBLE(a)))
    #endif
    /* this actually needs to check SCM_COMPNUMP before accessing the imaginary part */
    #define C_TO_XEN_COMPLEX(a)        Scm_MakeComplex(creal(a), cimag(a))
  #endif
#else
  #define XEN_HAVE_COMPLEX_NUMBERS 0
#endif

#define XEN_CHAR_P(Arg)              SCM_CHARP(Arg)
#define XEN_TO_C_CHAR(Arg)           SCM_CHAR_VALUE(Arg)
#define C_TO_XEN_CHAR(c)             SCM_MAKE_CHAR(c)

#define XEN_KEYWORD_P(Obj)           SCM_KEYWORDP(Obj)
#define XEN_MAKE_KEYWORD(Arg)        SCM_MAKE_KEYWORD(Arg)
#define XEN_KEYWORD_EQ_P(k1, k2)     XEN_EQ_P(k1, k2)

#define XEN_STRING_P(Arg)            SCM_STRINGP(Arg)
#define XEN_TO_C_STRING(Str)         Scm_GetString(SCM_STRING(Str))
#define C_TO_XEN_STRING(a)           (a) ? SCM_MAKE_STR_COPYING(a) : XEN_FALSE
#define C_TO_XEN_STRINGN(Str, Len)   Scm_MakeString(Str, Len, Len, SCM_MAKSTR_COPYING)
#define C_STRING_TO_XEN_FORM(Str)    Scm_ReadFromCString(Str)
#define XEN_EVAL_FORM(Form)          xen_gauche_eval_form(Form)
#define XEN_EVAL_C_STRING(Arg)       xen_gauche_eval_c_string((char *)(Arg))
#define XEN_SYMBOL_P(Arg)            SCM_SYMBOLP(Arg)
#define XEN_SYMBOL_TO_C_STRING(a)    XEN_TO_C_STRING(SCM_SYMBOL_NAME(a))
#define XEN_TO_STRING(Obj)           xen_gauche_object_to_string(Obj)

#if (SIZEOF_VOID_P == SIZEOF_UNSIGNED_LONG)
  #define XEN_WRAP_C_POINTER(a)      ((XEN)(C_TO_XEN_ULONG((unsigned long)a)))
  #define XEN_UNWRAP_C_POINTER(a)    XEN_TO_C_ULONG(a)
#else
  #define XEN_WRAP_C_POINTER(a)      C_TO_XEN_OFF_T((off_t)(a))
  #define XEN_UNWRAP_C_POINTER(a)    XEN_TO_C_OFF_T(a)
#endif

#define XEN_WRAPPED_C_POINTER_P(a)   XEN_NUMBER_P(a)

#define XEN_DEFINE_CONSTANT(Name, Value, Help) xen_gauche_define_constant(Name, Value, Help)
#define XEN_DEFINE_VARIABLE(Name, Var, Value)  Var = SCM_DEFINE(Scm_UserModule(), Name, Value)
#define C_STRING_TO_XEN_SYMBOL(a)           SCM_INTERN(a)
#define XEN_STRING_TO_SYMBOL(Str)           C_STRING_TO_XEN_SYMBOL(XEN_TO_C_STRING(Str))
#define XEN_NAME_AS_C_STRING_TO_VARIABLE(a) Scm_FindBinding(Scm_UserModule(), SCM_SYMBOL(SCM_INTERN(a)), false)
#define XEN_SYMBOL_TO_VARIABLE(a)           Scm_FindBinding(Scm_UserModule(), SCM_SYMBOL(a), false)
#define XEN_VARIABLE_REF(Var)               Scm_SymbolValue(Scm_UserModule(), SCM_SYMBOL(SCM_INTERN(Var)))
#define XEN_VARIABLE_SET(Var, Val)          SCM_GLOC_SET(SCM_GLOC(XEN_NAME_AS_C_STRING_TO_VARIABLE(Var)), Val)
#define XEN_NAME_AS_C_STRING_TO_VALUE(a)    XEN_VARIABLE_REF(a)

#define XEN_SET_DOCUMENTATION(Name, Help)   xen_gauche_set_help((XEN)(SCM_INTERN(Name)), Help)
#define XEN_DOCUMENTATION_SYMBOL            SCM_SYMBOL(SCM_INTERN("documentation"))
#define XEN_OBJECT_HELP(Name)               xen_gauche_help(Name)

#define XEN_MAKE_AND_RETURN_OBJECT(Tag, Val, Protect, Ignore2) return(xen_gauche_make_object(Tag, (void *)Val, Protect))
/* tag here is int -- needs ScmClass* for underlying call */
#define XEN_OBJECT_REF(a)                   xen_gauche_object_ref(a)
#define XEN_OBJECT_TYPE                     int
/* the "Tag" type in other calls */
#define XEN_MAKE_OBJECT_TYPE(Type, Size, Print, Cleanup) xen_gauche_new_type(Type, Print, Cleanup)
/* Type here is a string like "Vct" */
#define XEN_MARK_OBJECT_TYPE                ScmObj
/* used only in clm2xen for mark_mus_xen */
#define XEN_OBJECT_TYPE_P(OBJ, TAG)         xen_gauche_type_p(OBJ, TAG)

#define XEN_MAKE_OBJECT_PRINT_PROCEDURE(Type, Wrapped_Print, Original_Print) \
  static void Wrapped_Print(XEN obj, ScmPort *port, ScmWriteContext *pstate) \
  { \
    char *str; \
    str = Original_Print((Type *)XEN_OBJECT_REF(obj)); \
    XEN_PUTS(str, port); \
    FREE(str); \
  }

#define XEN_MAKE_OBJECT_FREE_PROCEDURE(Type, Wrapped_Free, Original_Free) \
  static void Wrapped_Free(XEN obj) \
  { \
    Original_Free((Type *)XEN_OBJECT_REF(obj)); \
  }

#define XEN_YES_WE_HAVE(Feature)      xen_gauche_provide(Feature)
#define XEN_PROTECT_FROM_GC(Obj)      xen_gauche_permanent_object(Obj)
#define XEN_LOAD_FILE(File)           xen_gauche_load_file(File)
#define XEN_LOAD_FILE_WITH_PATH(File) Scm_VMLoad(SCM_STRING(C_TO_XEN_STRING(File)), XEN_FALSE, XEN_FALSE, 0)
#define XEN_LOAD_PATH                 Scm_GetLoadPath()
#define XEN_ADD_TO_LOAD_PATH(Path)    xen_gauche_add_to_load_path(Path)

#define XEN_DEFINE(Name, Value)       SCM_DEFINE(Scm_UserModule(), Name, Value)

#define XEN_HOOK_P(Arg)                    xen_hook_p(Arg)
#define XEN_DEFINE_HOOK(Name, Arity, Help) xen_gauche_define_hook(Name, Arity, Help)
/* "simple hooks are for channel-local hooks (unnamed, accessed through the channel) */
#define XEN_DEFINE_SIMPLE_HOOK(Arity)      xen_gauche_define_hook(NULL, Arity, NULL)
#define XEN_HOOKED(Arg)                    (!xen_hook_empty_p(Arg))
#define XEN_CLEAR_HOOK(Arg)                xen_gauche_reset_hook(Arg)
#define XEN_HOOK_PROCEDURES(Arg)           xen_hook_to_list(Arg)

#define XEN_ERROR_TYPE(Typ)                 C_STRING_TO_XEN_SYMBOL(Typ)
#define XEN_ERROR(Type, Info)               Scm_Raise(XEN_CONS(Type, Info))
#define XEN_THROW(Tag, Arg)                 Scm_Raise(XEN_CONS(Tag, Arg))

#define XEN_ASSERT_TYPE(Assertion, Arg, Position, Caller, Correct_Type) \
  do {if (!(Assertion)) \
      XEN_ERROR(XEN_ERROR_TYPE("wrong-type-arg"),\
		XEN_LIST_3(C_TO_XEN_STRING(Caller),			\
			   C_TO_XEN_STRING("wrong type argument (arg %S): %S, wanted %S"), \
			   XEN_LIST_3(C_TO_XEN_INT(Position), \
				      Arg,				\
				      C_TO_XEN_STRING(Correct_Type))));} while (0)

#define XEN_WRONG_TYPE_ARG_ERROR(Caller, ArgN, Arg, Descr) XEN_ASSERT_TYPE(false, Arg, ArgN, Caller, Descr)

#define XEN_OUT_OF_RANGE_ERROR(Caller, ArgN, Arg, Descr) \
  XEN_ERROR(XEN_ERROR_TYPE("out-of-range"), \
            XEN_LIST_3(C_TO_XEN_STRING(Caller), \
                       C_TO_XEN_STRING(Descr), \
                       XEN_LIST_1(Arg)))

#define XEN_PROCEDURE_P(Arg)              SCM_PROCEDUREP(Arg)

/* unfortunately, SCM_PROCEDUREP doesn't include applicable objects, so it's not like the Guile case.
 *   we apparently have to use compute-applicable-method to find out whether an object
 *   has a matching object-apply method, but in much of the xen code, once XEN_PROCEDURE_P returns true,
 *   we assume we can check arity etc -- this is not pretty...  Here's a stab at the 1st level:
 *     ((SCM_PROCEDUREP(Arg)) || ((SCM_GENERICP(Arg)) && (!(SCM_NULLP((ScmObj)(Scm_ComputeApplicableMethods(SCM_GENERIC(Arg), NULL, 0)))))))
 *     then XEN_ARITY would be ((SCM_PROCEDUREP(Func)) ? <as is below> : -1) or something like that?
 *   but this is Ugly. So we're stuck -- Gauche users will have to wrap applicable objects in thunks.
 */

#define XEN_PROCEDURE_HELP(Sym)           XEN_OBJECT_HELP(Sym)
#define XEN_PROCEDURE_SOURCE_HELP(Name)   XEN_FALSE
#define XEN_PROCEDURE_SOURCE(Func)        XEN_FALSE
#define XEN_ARITY(Func)                   XEN_CONS(C_TO_XEN_INT(SCM_PROCEDURE_REQUIRED(Func)), C_TO_XEN_INT(SCM_PROCEDURE_OPTIONAL(Func)))
#define XEN_REQUIRED_ARGS(Func)           SCM_PROCEDURE_REQUIRED(Func)
#define XEN_REQUIRED_ARGS_OK(Func, Args)  (SCM_PROCEDURE_REQUIRED(Func) == Args)

#ifndef __cplusplus
#define XEN_PROCEDURE_CAST (XEN (*)())
#define XEN_DEFINE_PROCEDURE(Name, Func, ReqArg, OptArg, RstArg, Doc) \
  xen_gauche_define_procedure(Name, XEN_PROCEDURE_CAST Func, ReqArg, OptArg, RstArg, Doc)

#define XEN_DEFINE_PROCEDURE_WITH_SETTER(Get_Name, Get_Func, Get_Help, Set_Name, Set_Func, Get_Req, Get_Opt, Set_Req, Set_Opt) \
  xen_gauche_define_procedure_with_setter(Get_Name, Get_Func, Get_Help, Set_Func, Get_Req, Get_Opt, Set_Req, Set_Opt)

#define XEN_DEFINE_PROCEDURE_WITH_REVERSED_SETTER(Get_Name, Get_Func, Get_Help, Set_Name, Set_Func, Rev_Func, Get_Req, Get_Opt, Set_Req, Set_Opt) \
  xen_gauche_define_procedure_with_reversed_setter(Get_Name, Get_Func, Get_Help, Set_Func, Rev_Func, Get_Req, Get_Opt, Set_Req, Set_Opt)


void xen_gauche_define_procedure(const char *Name, XEN (*Func)(), int ReqArg, int OptArg, int RstArg, const char *Doc);
void xen_gauche_define_procedure_with_reversed_setter(const char *get_name, XEN (*get_func)(), const char *get_help, XEN (*set_func)(), XEN (*reversed_set_func)(), 
  int get_req, int get_opt, int set_req, int set_opt);
void xen_gauche_define_procedure_with_setter(const char *get_name, XEN (*get_func)(), const char *get_help, XEN (*set_func)(),
  int get_req, int get_opt, int set_req, int set_opt);

#else

#define XEN_PROCEDURE_CAST (ScmHeaderRec* (*)(ScmHeaderRec**, int, void*))
#define XEN_DEFINE_PROCEDURE(Name, Func, ReqArg, OptArg, RstArg, Doc) \
  xen_gauche_define_procedure(Name, XEN_PROCEDURE_CAST Func, ReqArg, OptArg, RstArg, Doc)

#define XEN_DEFINE_PROCEDURE_WITH_SETTER(Get_Name, Get_Func, Get_Help, Set_Name, Set_Func, Get_Req, Get_Opt, Set_Req, Set_Opt) \
  xen_gauche_define_procedure_with_setter(Get_Name, XEN_PROCEDURE_CAST Get_Func, Get_Help, XEN_PROCEDURE_CAST Set_Func, Get_Req, Get_Opt, Set_Req, Set_Opt)

#define XEN_DEFINE_PROCEDURE_WITH_REVERSED_SETTER(Get_Name, Get_Func, Get_Help, Set_Name, Set_Func, Rev_Func, Get_Req, Get_Opt, Set_Req, Set_Opt) \
  xen_gauche_define_procedure_with_reversed_setter(Get_Name, XEN_PROCEDURE_CAST Get_Func, Get_Help, XEN_PROCEDURE_CAST Set_Func, XEN_PROCEDURE_CAST Rev_Func, Get_Req, Get_Opt, Set_Req, Set_Opt)

void xen_gauche_define_procedure(const char *Name, ScmHeaderRec* (*Func)(ScmHeaderRec**, int, void*), int ReqArg, int OptArg, int RstArg, const char *Doc);
void xen_gauche_define_procedure_with_reversed_setter(const char *get_name, ScmHeaderRec* (*get_func)(ScmHeaderRec**, int, void*), const char *get_help, 
  ScmHeaderRec* (*set_func)(ScmHeaderRec**, int, void*), ScmHeaderRec* (*reversed_set_func)(ScmHeaderRec**, int, void*), 
  int get_req, int get_opt, int set_req, int set_opt);
void xen_gauche_define_procedure_with_setter(const char *get_name, ScmHeaderRec* (*get_func)(ScmHeaderRec**, int, void*), const char *get_help, 
  ScmHeaderRec* (*set_func)(ScmHeaderRec**, int, void*),
  int get_req, int get_opt, int set_req, int set_opt);
#endif

#if GAUCHE_API_0_8_8 || GAUCHE_API_0_9
  #define Xen_Scm_Apply(Func, Args) Scm_ApplyRec(Func, Args)
#else
  #define Xen_Scm_Apply(Func, Args) Scm_Apply(Func, Args)
#endif
  
#define XEN_CALL_0(Func, Caller)                   Xen_Scm_Apply(Func, XEN_EMPTY_LIST)
#define XEN_CALL_1(Func, Arg1, Caller)             Xen_Scm_Apply(Func, XEN_LIST_1(Arg1))
#define XEN_CALL_2(Func, Arg1, Arg2, Caller)       Xen_Scm_Apply(Func, XEN_LIST_2(Arg1, Arg2))
#define XEN_CALL_3(Func, Arg1, Arg2, Arg3, Caller) Xen_Scm_Apply(Func, XEN_LIST_3(Arg1, Arg2, Arg3))
#define XEN_APPLY(Func, Args, Caller)              Xen_Scm_Apply(Func, Args)
#define XEN_CALL_4(Func, Arg1, Arg2, Arg3, Arg4, Caller) Xen_Scm_Apply(Func, XEN_LIST_4(Arg1, Arg2, Arg3, Arg4))
#define XEN_CALL_5(Func, Arg1, Arg2, Arg3, Arg4, Arg5, Caller) Xen_Scm_Apply(Func, XEN_LIST_5(Arg1, Arg2, Arg3, Arg4, Arg5))
#define XEN_CALL_6(Func, Arg1, Arg2, Arg3, Arg4, Arg5, Arg6, Caller) Xen_Scm_Apply(Func, XEN_LIST_6(Arg1, Arg2, Arg3, Arg4, Arg5, Arg6))
#define XEN_APPLY_NO_CATCH(Func, Args)              Xen_Scm_Apply(Func, Args)
#define XEN_CALL_0_NO_CATCH(Func)                   Xen_Scm_Apply(Func, XEN_EMPTY_LIST)
#define XEN_CALL_1_NO_CATCH(Func, Arg1)             Xen_Scm_Apply(Func, XEN_LIST_1(Arg1))
#define XEN_CALL_2_NO_CATCH(Func, Arg1, Arg2)       Xen_Scm_Apply(Func, XEN_LIST_2(Arg1, Arg2))
#define XEN_CALL_3_NO_CATCH(Func, Arg1, Arg2, Arg3) Xen_Scm_Apply(Func, XEN_LIST_3(Arg1, Arg2, Arg3))

/* puts arg=string, display arg=obj */
#define XEN_PUTS(Str, Port)      Scm_Puts(SCM_STRING(C_TO_XEN_STRING(Str)), Port)
#define XEN_DISPLAY(Val, Port)   xen_gauche_display(Val, Port)
#define XEN_FLUSH_PORT(Port)     Scm_Flush(Port)
#define XEN_CLOSE_PORT(Port)     Scm_ClosePort(Port)

#if GAUCHE_API_0_9
  #define XEN_PORT_TO_STRING(Port) Scm_GetOutputString(SCM_PORT(Port), 0)
#else
  #define XEN_PORT_TO_STRING(Port) Scm_GetOutputString(SCM_PORT(Port))
#endif

typedef XEN (*XEN_CATCH_BODY_TYPE) (void *data);

#define XEN_ARGIFY_1(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
  { \
    XEN args[1];\
    SCM_ENTER_SUBR(#InName); \
    xen_gauche_load_args(args, argc, 1, argv);	\
    return(InName(args[0])); \
  }

#define XEN_ARGIFY_2(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
  { \
    XEN args[2];\
    SCM_ENTER_SUBR(#InName); \
    xen_gauche_load_args(args, argc, 2, argv);	\
    return(InName(args[0], args[1])); \
  }

#define XEN_ARGIFY_3(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
  { \
    XEN args[3];\
    SCM_ENTER_SUBR(#InName); \
    xen_gauche_load_args(args, argc, 3, argv);    \
    return(InName(args[0], args[1], args[2]));	    \
  }

#define XEN_ARGIFY_4(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
  { \
    XEN args[4];\
    SCM_ENTER_SUBR(#InName); \
    xen_gauche_load_args(args, argc, 4, argv);	\
    return(InName(args[0], args[1], args[2], args[3]));	\
  }

#define XEN_ARGIFY_5(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
  { \
    XEN args[5];\
    SCM_ENTER_SUBR(#InName); \
    xen_gauche_load_args(args, argc, 5, argv);			\
    return(InName(args[0], args[1], args[2], args[3], args[4]));	\
  }

#define XEN_ARGIFY_6(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
  { \
    XEN args[6];\
    SCM_ENTER_SUBR(#InName); \
    xen_gauche_load_args(args, argc, 6, argv);			\
    return(InName(args[0], args[1], args[2], args[3], args[4], args[5]));	\
  }

#define XEN_ARGIFY_7(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
  { \
    XEN args[7];\
    SCM_ENTER_SUBR(#InName); \
    xen_gauche_load_args(args, argc, 7, argv);			\
    return(InName(args[0], args[1], args[2], args[3], args[4], args[5], args[6])); \
  }

#define XEN_ARGIFY_8(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
  { \
    XEN args[8];\
    SCM_ENTER_SUBR(#InName); \
    xen_gauche_load_args(args, argc, 8, argv);			\
    return(InName(args[0], args[1], args[2], args[3], args[4], args[5], args[6], args[7])); \
  }

#define XEN_ARGIFY_9(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
  { \
    XEN args[9];\
    SCM_ENTER_SUBR(#InName); \
    xen_gauche_load_args(args, argc, 9, argv);			\
    return(InName(args[0], args[1], args[2], args[3], args[4], args[5], args[6], args[7], args[8])); \
  }

#define XEN_ARGIFY_10(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
  { \
    XEN args[10];\
    SCM_ENTER_SUBR(#InName); \
    xen_gauche_load_args(args, argc, 10, argv);			\
    return(InName(args[0], args[1], args[2], args[3], args[4], args[5], args[6], args[7], args[8], args[9])); \
  }

#define XEN_NARGIFY_0(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
    {SCM_ENTER_SUBR(#InName); return(InName());}

#define XEN_NARGIFY_1(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
    {SCM_ENTER_SUBR(#InName); return(InName(argv[0]));}

#define XEN_NARGIFY_2(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
    {SCM_ENTER_SUBR(#InName); return(InName(argv[0], argv[1]));}

#define XEN_NARGIFY_3(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
    {SCM_ENTER_SUBR(#InName); return(InName(argv[0], argv[1], argv[2]));}

#define XEN_NARGIFY_4(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
    {SCM_ENTER_SUBR(#InName); return(InName(argv[0], argv[1], argv[2], argv[3]));}

#define XEN_NARGIFY_5(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
    {SCM_ENTER_SUBR(#InName); return(InName(argv[0], argv[1], argv[2], argv[3], argv[4]));}

#define XEN_NARGIFY_6(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
    {SCM_ENTER_SUBR(#InName); return(InName(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]));}

#define XEN_NARGIFY_7(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
    {SCM_ENTER_SUBR(#InName); return(InName(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]));}

#define XEN_NARGIFY_8(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
    {SCM_ENTER_SUBR(#InName); return(InName(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7]));}

#define XEN_NARGIFY_9(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
    {SCM_ENTER_SUBR(#InName); return(InName(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8]));}

#define XEN_VARGIFY(OutName, InName) \
  static XEN OutName(XEN *argv, int argc, void *self) \
  { \
    SCM_ENTER_SUBR(#InName); \
    return(InName(argv[0])); \
  }

void xen_gauche_list_set_x(XEN Lst, int Loc, XEN Val);
XEN xen_gauche_load_file(char *file);
XEN xen_gauche_add_to_load_path(char *path);
XEN xen_gauche_object_to_string(XEN obj);
void xen_gauche_permanent_object(XEN obj);
double xen_to_c_double(XEN a);
void xen_gauche_load_args(XEN *args, int incoming_args, int args_size, XEN *arg_list);
XEN xen_gauche_eval_c_string(char *arg);
XEN xen_gauche_eval_form(XEN form);
void xen_gauche_provide(const char *feature);
const char *xen_gauche_features(void);
XEN xen_gauche_make_object(XEN_OBJECT_TYPE type, void *val, XEN_MARK_OBJECT_TYPE (*protect_func)(XEN obj));
void *xen_gauche_object_ref(XEN obj);
XEN_OBJECT_TYPE xen_gauche_new_type(const char *name, ScmClassPrintProc print, ScmForeignCleanupProc cleanup);
XEN xen_gauche_help(XEN proc);
void xen_gauche_set_help(XEN proc, const char *help);
XEN xen_gauche_define_constant(const char *name, int value, const char *help);

bool xen_gauche_type_p(XEN obj, XEN_OBJECT_TYPE type);
XEN xen_gauche_define_hook(const char *name, int arity, const char *help);
XEN xen_gauche_reset_hook(XEN hook);
XEN xen_hook_to_list(XEN hook);
bool xen_hook_empty_p(XEN hook);
bool xen_hook_p(XEN val);
#endif





xen.c:

/* ------------------------------ GAUCHE ------------------------------ */

#if HAVE_GAUCHE

char *xen_version(void)
{
  char *buf;
  buf = (char *)calloc(64, sizeof(char));
#if HAVE_SNPRINTF
  snprintf(buf, 64, "Gauche: %s, Xen: %s", GAUCHE_VERSION, XEN_VERSION);
#else
  sprintf(buf, "Gauche: %s, Xen: %s", GAUCHE_VERSION, XEN_VERSION);
#endif
  return(buf);
}


off_t xen_to_c_off_t_or_else(XEN obj, off_t fallback)
{
  if (XEN_OFF_T_P(obj))
    return(Scm_GetInteger64(obj));
  if (XEN_NUMBER_P(obj))
    return((off_t)XEN_TO_C_DOUBLE(obj));
  return(fallback);
}


off_t xen_to_c_off_t(XEN obj)
{
  return(Scm_GetInteger64(obj));
}


XEN c_to_xen_off_t(off_t val)
{
  return(Scm_MakeInteger64(val));
}


int xen_to_c_int_or_else(XEN obj, int fallback)
{
  if (XEN_NUMBER_P(obj))
    return(XEN_TO_C_INT(obj));
  return(fallback);
}


double xen_to_c_double(XEN a) 
{
  double num = 0.0;
  if (SCM_REALP(a))
    return(Scm_GetDouble(a));
  if (SCM_INTP(a))
    return((double)Scm_GetInteger(a));
  if (SCM_BIGNUMP(a))
    return((double)Scm_GetInteger64(a));
  return(num);
}


void xen_repl(int argc, char **argv)
{
  XEN_EVAL_C_STRING("(if (not (defined? 'gauche-repl-prompt)) (define gauche-repl-prompt \">\"))");
  XEN_EVAL_C_STRING("(read-eval-print-loop #f #f #f (lambda () (display gauche-repl-prompt (current-output-port)) (flush (current-output-port))))");
}


static XEN g_defined_p(XEN sym)
{
  /* "defined?" is absolutely needed from the start */
  return(C_TO_XEN_BOOLEAN(Scm_FindBinding(Scm_UserModule(), SCM_SYMBOL(sym), false) != NULL));
}


void xen_gc_mark(XEN val)
{
}


void xen_gauche_load_args(XEN *args, int incoming_args, int args_size, XEN *arg_list)
{
  int i, len;
  XEN list;
  for (i = 0; i < incoming_args - 1; i++) args[i] = arg_list[i];
  if (incoming_args <= args_size)
    {
      int j;
      list = arg_list[incoming_args - 1];
      len = XEN_LIST_LENGTH(list);
      for (i = incoming_args - 1, j = 0; (j < len) && (i < args_size); i++, j++) args[i] = XEN_LIST_REF(list, j);
      for (i = incoming_args - 1 + len; i < args_size; i++) args[i] = XEN_UNDEFINED;
    }
}


static XEN help_hash_table = XEN_FALSE;

XEN xen_gauche_help(XEN sym)
{
  ScmHashEntry *e = NULL;
  if (XEN_STRING_P(sym))
    e = Scm_HashTableGet(SCM_HASH_TABLE(help_hash_table), SCM_INTERN(XEN_TO_C_STRING(sym)));
  else e = Scm_HashTableGet(SCM_HASH_TABLE(help_hash_table), sym);
  if (e) return((XEN)(e->value));
  return(XEN_FALSE);
}


void xen_gauche_set_help(XEN sym, const char *help)
{
  if (XEN_STRING_P(sym))
    Scm_HashTableAdd(SCM_HASH_TABLE(help_hash_table), SCM_INTERN(XEN_TO_C_STRING(sym)), (help) ? C_TO_XEN_STRING(help) : XEN_FALSE);
  else Scm_HashTableAdd(SCM_HASH_TABLE(help_hash_table), sym, (help) ? C_TO_XEN_STRING(help) : XEN_FALSE);
}


XEN xen_gauche_define_constant(const char *name, int value, const char *help)
{
  XEN obj, sym;
  sym = SCM_INTERN(name);
  obj = Scm_DefineConst(SCM_MODULE(Scm_UserModule()), SCM_SYMBOL(sym), C_TO_XEN_INT(value));
  xen_gauche_set_help(sym, help);
  return(obj);
}


#ifndef __cplusplus
void xen_gauche_define_procedure(const char *Name, XEN (*Func)(), int ReqArg, int OptArg, int RstArg, const char *Doc)
{
  XEN proc, sym;
  if (RstArg > 0)
    OptArg = 24; /* vargify but I think 24 args will handle most cases */
  proc = Scm_MakeSubr(Func, NULL, ReqArg, OptArg, SCM_MAKE_STR_COPYING(Name));
  sym = SCM_INTERN(Name);
  xen_gauche_set_help(sym, Doc);
  Scm_Define(SCM_MODULE(Scm_UserModule()), SCM_SYMBOL(sym), proc);
}


void xen_gauche_define_procedure_with_setter(const char *get_name, XEN (*get_func)(), const char *get_help, XEN (*set_func)(), 
					     int get_req, int get_opt, int set_req, int set_opt)
{
  XEN proc, set_proc, sym;
  proc = Scm_MakeSubr(get_func, NULL, get_req, get_opt, SCM_MAKE_STR_COPYING(get_name));
  sym = SCM_INTERN(get_name);
  xen_gauche_set_help(sym, get_help);
  Scm_Define(SCM_MODULE(Scm_UserModule()), SCM_SYMBOL(sym), proc);
  set_proc = Scm_MakeSubr(set_func, NULL, set_req, set_opt, SCM_MAKE_STR_COPYING(get_name));
  Scm_SetterSet((ScmProcedure *)proc, (ScmProcedure *)set_proc, false);
}


void xen_gauche_define_procedure_with_reversed_setter(const char *get_name, XEN (*get_func)(), const char *get_help, XEN (*set_func)(), XEN (*reversed_set_func)(), 
						      int get_req, int get_opt, int set_req, int set_opt)
{
  XEN proc, set_proc, sym;
  proc = Scm_MakeSubr(get_func, NULL, get_req, get_opt, SCM_MAKE_STR_COPYING(get_name));
  sym = SCM_INTERN(get_name);
  xen_gauche_set_help(sym, get_help);
  Scm_Define(SCM_MODULE(Scm_UserModule()), SCM_SYMBOL(sym), proc);
  set_proc = Scm_MakeSubr(reversed_set_func, NULL, set_req, set_opt, SCM_MAKE_STR_COPYING(get_name));
  Scm_SetterSet((ScmProcedure *)proc, (ScmProcedure *)set_proc, false);
}

#else

void xen_gauche_define_procedure(const char *Name, 
				 ScmHeaderRec* (*Func)(ScmHeaderRec**, int, void*), 
				 int ReqArg, int OptArg, int RstArg, const char *Doc)
{
  XEN proc, sym;
  if (RstArg > 0)
    OptArg = 24; /* vargify but I think 24 args will handle most cases */
  proc = Scm_MakeSubr(Func, NULL, ReqArg, OptArg, SCM_MAKE_STR_COPYING(Name));
  sym = SCM_INTERN(Name);
  xen_gauche_set_help(sym, Doc);
  Scm_Define(SCM_MODULE(Scm_UserModule()), SCM_SYMBOL(sym), proc);
}


void xen_gauche_define_procedure_with_reversed_setter(const char *get_name, 
						      ScmHeaderRec* (*get_func)(ScmHeaderRec**, int, void*), 
						      const char *get_help, 
						      ScmHeaderRec* (*set_func)(ScmHeaderRec**, int, void*), 
						      ScmHeaderRec* (*reversed_set_func)(ScmHeaderRec**, int, void*), 
						      int get_req, int get_opt, int set_req, int set_opt)
{
  XEN proc, set_proc, sym;
  proc = Scm_MakeSubr(get_func, NULL, get_req, get_opt, SCM_MAKE_STR_COPYING(get_name));
  sym = SCM_INTERN(get_name);
  xen_gauche_set_help(sym, get_help);
  Scm_Define(SCM_MODULE(Scm_UserModule()), SCM_SYMBOL(sym), proc);
  set_proc = Scm_MakeSubr(reversed_set_func, NULL, set_req, set_opt, SCM_MAKE_STR_COPYING(get_name));
  Scm_SetterSet((ScmProcedure *)proc, (ScmProcedure *)set_proc, false);
}


void xen_gauche_define_procedure_with_setter(const char *get_name, 
					     ScmHeaderRec* (*get_func)(ScmHeaderRec**, int, void*), 
					     const char *get_help, 
					     ScmHeaderRec* (*set_func)(ScmHeaderRec**, int, void*),
					     int get_req, int get_opt, int set_req, int set_opt)
{
  XEN proc, set_proc, sym;
  proc = Scm_MakeSubr(get_func, NULL, get_req, get_opt, SCM_MAKE_STR_COPYING(get_name));
  sym = SCM_INTERN(get_name);
  xen_gauche_set_help(sym, get_help);
  Scm_Define(SCM_MODULE(Scm_UserModule()), SCM_SYMBOL(sym), proc);
  set_proc = Scm_MakeSubr(set_func, NULL, set_req, set_opt, SCM_MAKE_STR_COPYING(get_name));
  Scm_SetterSet((ScmProcedure *)proc, (ScmProcedure *)set_proc, false);
}
#endif


void xen_gauche_list_set_x(XEN Lst, int Loc, XEN Val)
{
  /* modelled on Scm_ListRef in src/list.c */
  int k;
  if (Loc < 0) return;
  for (k = 0; k < Loc; k++)
    {
      if (!SCM_PAIRP(Lst)) return;
      Lst = SCM_CDR(Lst);
    }
  if (!SCM_PAIRP(Lst)) return;
  SCM_SET_CAR(Lst, Val);
}


XEN xen_gauche_add_to_load_path(char *path)
{
  if (XEN_FALSE_P(Scm_Member(C_TO_XEN_STRING(path), XEN_LOAD_PATH, SCM_CMP_EQUAL))) /* scheme spec says eq? and eqv? of strings is unspecified */
    Scm_AddLoadPath(path, false);
  return(XEN_FALSE);
}


XEN xen_gauche_object_to_string(XEN obj)
{
  /* return XEN string description of obj */
  ScmObj ostr;
  if (XEN_STRING_P(obj))
    {
      char *str, *newstr;
      int i, j, quotes = 0, len, oldlen;
      str = XEN_TO_C_STRING(obj);
      if (str)
	{
	  XEN result;
	  len = strlen(str);
	  oldlen = len;
	  for (i = 0; i < len; i++)
	    if (str[i] == '"') quotes++;
	  len = len + 2 + quotes;
	  newstr = (char *)calloc(len + 1, sizeof(char));
	  newstr[0] = '"';
	  newstr[len - 1] = '"';
	  for (j = 1, i = 0; i < oldlen; i++)
	    {
	      if (str[i] == '"')
		newstr[j++] = '\\';
	      newstr[j++] = str[i];
	    }
	  result = C_TO_XEN_STRING(newstr);
	  free(newstr);
	  return(result);
	}
      return(C_TO_XEN_STRING("\"\""));
    }
  ostr = Scm_MakeOutputStringPort(true);
  Scm_Write(obj, SCM_OBJ(ostr), true);
  return(XEN_PORT_TO_STRING(ostr));
}


void xen_gauche_permanent_object(XEN obj)
{
  /* I can't see how you're supposed to protect something from the gc, so I'll try
   *   simply placing this object under a gensymmed name in the user module??
   */
  Scm_DefineConst(Scm_UserModule(), SCM_SYMBOL(Scm_Gensym(SCM_STRING(C_TO_XEN_STRING("Snd")))), obj);
}


#if (!(GAUCHE_API_0_8_8 || GAUCHE_API_0_8_10 || GAUCHE_API_0_9))

XEN xen_gauche_load_file(char *file)
{
  Scm_Load(file, 0); /* returns an int, but we want (XEN) error indication */
  /* flags is or of SCM_LOAD_QUIET_NOFILE SCM_LOAD_IGNORE_CODING */
  return(XEN_FALSE);
}


XEN xen_gauche_eval_c_string(char *arg)
{
  XEN result = XEN_FALSE;
  SCM_UNWIND_PROTECT 
    {
#if (!HAVE_SCM_EVALREC)
      result = Scm_EvalCString(arg, SCM_OBJ(Scm_UserModule()));
#else
      result = Scm_EvalRec(Scm_ReadFromCString(arg), SCM_OBJ(Scm_UserModule()));
#endif
    }
  SCM_WHEN_ERROR 
    {
      fprintf(stderr, "Error in %s\n", arg);
      /* SCM_NEXT_HANDLER; */
      /* if this is left in, Snd exits on an error! -- exactly what we're trying to avoid */
    }
  SCM_END_PROTECT;
  return(result);
}

XEN xen_gauche_eval_form(XEN form)
{
#if HAVE_SCM_EVALREC
  return(Scm_EvalRec(form, SCM_OBJ(Scm_UserModule())));
#else
  return(Scm_Eval(form, SCM_OBJ(Scm_UserModule())));
#endif
}

#else

/* after endless attempts to redirect the goddamn current-error-port or get stack trace to work, I give up! */

#if USE_SND
static void report_error(ScmObj e)
{
  char str[1024];
  snprintf(str, 1024, "\n%s: %s", XEN_TO_C_STRING(Scm_ConditionTypeName(e)), XEN_TO_C_STRING(Scm_ConditionMessage(e)));
  listener_append(str); 
}
#else
static void report_error(ScmObj e)
{
  Scm_ReportError(e);
}
#endif


XEN xen_gauche_load_file(char *file)
{
  ScmLoadPacket lpak;
  if (Scm_Load(file, 0, &lpak) < 0)
    report_error(lpak.exception);
  return(XEN_FALSE);
}


XEN xen_gauche_eval_c_string(char *arg)
{
  ScmEvalPacket epak;
  if (Scm_EvalCString(arg, SCM_OBJ(Scm_UserModule()), &epak) < 0) 
    {
      report_error(epak.exception);
      return(XEN_FALSE);
    }
  return(epak.results[0]);
}


XEN xen_gauche_eval_form(XEN form)
{
  ScmEvalPacket epak;
  if (Scm_Eval(form, SCM_OBJ(Scm_UserModule()), &epak) < 0) 
    {
      report_error(epak.exception);
      return(XEN_FALSE);
    }
  return(epak.results[0]);
}

#endif


typedef struct {
  XEN_OBJECT_TYPE type;
  void *data;
} smob;

static XEN_OBJECT_TYPE smob_type = 0;
static ScmClass **smob_classes = NULL;
static int smob_classes_size = 0;


XEN xen_gauche_make_object(XEN_OBJECT_TYPE type, void *val, XEN_MARK_OBJECT_TYPE (*protect_func)(XEN obj))
{
  smob *s;
  XEN obj;
  s = (smob *)calloc(1, sizeof(smob));
  s->type = type;
  s->data = val;
  obj = Scm_MakeForeignPointer(smob_classes[type], (void *)s);
  if (protect_func) protect_func(obj);
  return(obj);
}


void *xen_gauche_object_ref(XEN obj)
{
  smob *s;
  s = (smob *)(((ScmForeignPointer *)obj)->ptr);
  if (s) 
    return(s->data);
  return(NULL);
}


XEN_OBJECT_TYPE xen_gauche_new_type(const char *name, ScmClassPrintProc print, ScmForeignCleanupProc cleanup)
{
  XEN_OBJECT_TYPE current_type;
  current_type = smob_type;
  smob_type++;
  if (current_type >= smob_classes_size)
    {
      if (smob_classes_size == 0)
	{
	  smob_classes_size = 8;
	  smob_classes = (ScmClass **)calloc(smob_classes_size, sizeof(ScmClass *));
	}
      else
	{
	  smob_classes_size += 8;
	  smob_classes = (ScmClass **)realloc(smob_classes, smob_classes_size * sizeof(ScmClass *));
	}
    }
  smob_classes[current_type] = Scm_MakeForeignPointerClass(Scm_UserModule(),
							   name,
							   print,
							   cleanup,
							   SCM_FOREIGN_POINTER_KEEP_IDENTITY | SCM_FOREIGN_POINTER_MAP_NULL);
  return(current_type);
}


bool xen_gauche_type_p(XEN obj, XEN_OBJECT_TYPE type)
{
  smob *s;
  if (SCM_FOREIGN_POINTER_P(obj))
    {
      s = SCM_FOREIGN_POINTER_REF(smob *, obj);
      return((s) &&
	     (s->type == type));
    }
  return(false);
}


void xen_gauche_provide(const char *feature)
{
  /* there is no *features* list built-in Gauche!! I've defined one below */
  /*   also Gauche's provide and provided? take strings! so I'll have to encapsulate them */
  char *expr;
  int len;
  Scm_Provide(C_TO_XEN_STRING(feature));
  len = strlen(feature) + 64;
  expr = (char *)calloc(len, sizeof(char));
  snprintf(expr, len, "(set! *features* (cons '%s *features*))", feature);
  XEN_EVAL_C_STRING(expr);
  free(expr);
}


const char *xen_gauche_features(void)
{
  return(XEN_AS_STRING(XEN_EVAL_C_STRING("*features*")));
}


static XEN g_xen_gauche_provide(XEN feature)
{
  if (XEN_SYMBOL_P(feature))
    xen_gauche_provide(XEN_SYMBOL_TO_C_STRING(feature));
  else xen_gauche_provide(XEN_TO_C_STRING(feature));
  return(feature);
}


static XEN g_xen_gauche_provided_p(XEN feature)
{
  if (XEN_SYMBOL_P(feature))
    return(C_TO_XEN_BOOLEAN(Scm_ProvidedP(SCM_OBJ(SCM_SYMBOL_NAME(feature)))));
  return(C_TO_XEN_BOOLEAN(Scm_ProvidedP(feature)));
}


#define FREE free
XEN_MAKE_OBJECT_PRINT_PROCEDURE(ghook, print_hook, hook_to_string)

XEN_MAKE_OBJECT_FREE_PROCEDURE(ghook, free_hook, free_ghook)

static XEN_MARK_OBJECT_TYPE mark_ghook(XEN obj)
{
  ghook *hook;
  hook = XEN_TO_GHOOK(obj);
  Scm_ForeignPointerAttrSet(SCM_FOREIGN_POINTER(obj), SCM_INTERN("functions"), hook->functions);
  return(XEN_FALSE);
}


static XEN g_make_hook(XEN arity, XEN help)
{
  ghook *hook;
  XEN_ASSERT_TYPE(XEN_INTEGER_P(arity), arity, XEN_ARG_1, "make-hook", "an integer");
  XEN_ASSERT_TYPE(XEN_STRING_P(help) || XEN_NOT_BOUND_P(help), help, XEN_ARG_2, "make-hook", "a string if bound");
  hook = make_ghook(XEN_TO_C_INT(arity));
  return(xen_gauche_make_object(ghook_tag, (void *)hook, mark_ghook));
}


static XEN g_add_hook(XEN hook, XEN function, XEN position)
{
  ghook *obj;
  bool at_end = false;
  XEN_ASSERT_TYPE(xen_hook_p(hook), hook, XEN_ARG_1, "add-hook!", "a hook");
  obj = XEN_TO_GHOOK(hook);
  XEN_ASSERT_TYPE(XEN_PROCEDURE_P(function) && 
		  ((XEN_REQUIRED_ARGS(function) == ghook_arity(obj)) ||
		   ((SCM_PROCEDURE_REQUIRED(function) + SCM_PROCEDURE_OPTIONAL(function)) == ghook_arity(obj))),
		  function, XEN_ARG_2, "add-hook!", "a function");
  XEN_ASSERT_TYPE(XEN_BOOLEAN_IF_BOUND_P(position), position, XEN_ARG_3, "add-hook!", "boolean");
  if (XEN_BOOLEAN_P(position)) at_end = XEN_TO_C_BOOLEAN(position);
  add_ghook(obj, function, at_end);
  Scm_ForeignPointerAttrSet(SCM_FOREIGN_POINTER(hook), SCM_INTERN("functions"), obj->functions);
  return(hook);
}


XEN xen_gauche_reset_hook(XEN hook)
{
  ghook *obj;
  XEN_ASSERT_TYPE(xen_hook_p(hook), hook, XEN_ONLY_ARG, "reset-hook!", "a hook");
  obj = XEN_TO_GHOOK(hook);
  reset_ghook(obj);
  Scm_ForeignPointerAttrSet(SCM_FOREIGN_POINTER(hook), SCM_INTERN("functions"), obj->functions);  
  return(hook);
}


static XEN g_run_hook(XEN all_args)
{
  XEN hook, args;
  ghook *obj;
  int arglen;
  XEN functions, val = XEN_FALSE;
  hook = XEN_CAR(all_args);
  XEN_ASSERT_TYPE(xen_hook_p(hook), hook, XEN_ARG_1, "run-hook", "a hook");
  obj = XEN_TO_GHOOK(hook);
  args = XEN_CDR(all_args);
  arglen = XEN_LIST_LENGTH(args);
  if (ghook_arity(obj) != arglen)
    XEN_ERROR(XEN_ERROR_TYPE("wrong-number-of-args"),
	      XEN_LIST_2(C_TO_XEN_STRING("run-hook"),
			 args));
  functions = ghook_functions(obj);
  while (XEN_NOT_NULL_P(functions))
    {
#if GAUCHE_API_0_8_8 || GAUCHE_API_0_9
      val = Scm_ApplyRec(XEN_CAR(functions), args);
#else
      val = Scm_Apply(XEN_CAR(functions), args);
#endif
      functions = XEN_CDR(functions);
    }
  return(val);
}


static XEN g_remove_hook(XEN hook, XEN function)
{
  ghook *obj;
  XEN_ASSERT_TYPE(xen_hook_p(hook), hook, XEN_ARG_1, "remove-hook!", "a hook");
  obj = XEN_TO_GHOOK(hook);
  XEN_ASSERT_TYPE(XEN_PROCEDURE_P(function), function, XEN_ARG_2, "remove-hook!", "a function");
  obj->functions = Scm_DeleteX(function, obj->functions, SCM_CMP_EQ);
  Scm_ForeignPointerAttrSet(SCM_FOREIGN_POINTER(hook), SCM_INTERN("functions"), obj->functions);  
  return(hook);
}


XEN xen_gauche_define_hook(const char *name, int arity, const char *help)
{
  XEN sym, hook;
  hook = g_make_hook(C_TO_XEN_INT(arity), (help) ? C_TO_XEN_STRING(help) : XEN_UNDEFINED);
  if (name)
    {
      sym = SCM_INTERN(name);
      Scm_Define(SCM_MODULE(Scm_UserModule()), SCM_SYMBOL(sym), hook);
      xen_gauche_set_help(sym, help);
    }
  return(hook);
}


static XEN g_procedure_arity(XEN func)
{
  return(XEN_ARITY(func));
}

XEN_NARGIFY_1(g_defined_p_w, g_defined_p)
XEN_NARGIFY_1(g_xen_gauche_provided_p_w, g_xen_gauche_provided_p)
XEN_NARGIFY_1(g_xen_gauche_provide_w, g_xen_gauche_provide)
XEN_NARGIFY_1(g_procedure_arity_w, g_procedure_arity)
XEN_NARGIFY_1(g_xen_gauche_object_to_string_w, xen_gauche_object_to_string)

XEN_NARGIFY_1(g_hook_p_w, g_hook_p);
XEN_NARGIFY_1(g_hook_empty_p_w, g_hook_empty_p)
XEN_NARGIFY_2(g_remove_hook_w, g_remove_hook)
XEN_NARGIFY_1(g_hook_to_list_w, xen_hook_to_list)
XEN_VARGIFY(g_run_hook_w, g_run_hook)
XEN_NARGIFY_1(g_reset_hook_w, xen_gauche_reset_hook)
XEN_ARGIFY_2(g_make_hook_w, g_make_hook)
XEN_ARGIFY_3(g_add_hook_w, g_add_hook)

void xen_initialize(void)
{
  Scm_Init(GAUCHE_SIGNATURE); /* signature is apparently a version mismatch check? (core.c) */
  {
    SCM_UNWIND_PROTECT {
#if GAUCHE_API_0_8_10 || GAUCHE_API_0_9
      Scm_Load("gauche-init.scm", 0, NULL);
#else
      Scm_Load("gauche-init.scm", 0);
#endif
    }
    SCM_WHEN_ERROR {
      fprintf(stderr, "Error in Gauche initialization file.\n");
      /* SCM_NEXT_HANDLER; */
    }
    SCM_END_PROTECT;
  }

  XEN_EVAL_C_STRING("(define *features* (list 'defmacro 'record))"); /* has to be first so *features* exists */
  help_hash_table = Scm_MakeHashTableSimple(SCM_HASH_EQ, 2048);
  xen_gauche_permanent_object(help_hash_table);

  XEN_DEFINE_PROCEDURE("defined?",        g_defined_p_w,                   1, 0, 0, "(defined? arg) -> #t if arg is defined");
  XEN_DEFINE_PROCEDURE("provided?",       g_xen_gauche_provided_p_w,       1, 0, 0, "(provided? arg) -> #t if arg is on the *features* list");
  XEN_DEFINE_PROCEDURE("provide",         g_xen_gauche_provide_w,          1, 0, 0, "(provide arg) -> add arg to *features* list");
  XEN_DEFINE_PROCEDURE("procedure-arity", g_procedure_arity_w,             1, 0, 0, "return (list required optional) args");
  XEN_DEFINE_PROCEDURE("object->string",  g_xen_gauche_object_to_string_w, 1, 0, 0, "return string representation of arg");

  ghook_tag = XEN_MAKE_OBJECT_TYPE("<hook>", sizeof(ghook), print_hook, free_hook);

  XEN_DEFINE_PROCEDURE("hook?",        g_hook_p_w,       1, 0, 0, "(hook? obj) -> #t if obj is a hook");
  XEN_DEFINE_PROCEDURE("hook-empty?",  g_hook_empty_p_w, 1, 0, 0, "(hook-empty? hook) -> #t if obj is an empty hook");
  XEN_DEFINE_PROCEDURE("remove-hook!", g_remove_hook_w,  2, 0, 0, "(remove-hook! hook func) removes func from hook obj");
  XEN_DEFINE_PROCEDURE("reset-hook!",  g_reset_hook_w,   1, 0, 0, "(reset-hook! hook) removes all funcs from hook obj");
  XEN_DEFINE_PROCEDURE("hook->list",   g_hook_to_list_w, 1, 0, 0, "(hook->list hook) -> list of functions on hook obj");
  XEN_DEFINE_PROCEDURE("run-hook",     g_run_hook_w,     0, 0, 1, "(run-hook hook . args) applies each hook function to args");
  XEN_DEFINE_PROCEDURE("make-hook",    g_make_hook_w,    1, 1, 0, "(make-hook arity :optional help) makes a new hook object");
  XEN_DEFINE_PROCEDURE("add-hook!",    g_add_hook_w,     2, 1, 0, "(add-hook! hook func :optional append) adds func to the hooks function list");
}


#endif



