code:
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
 * Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#include "libguile/__scm.h"
#include "libguile/_scm.h"
#include "libguile/continuations.h"
#include "libguile/eq.h"
#include "libguile/list.h"
#include "libguile/macros.h"
#include "libguile/expand.h"
#include "libguile/modules.h"
#include "libguile/srcprop.h"
#include "libguile/ports.h"
#include "libguile/print.h"
#include "libguile/strings.h"
#include "libguile/throw.h"
#include "libguile/validate.h"

SCM scm_exp_vtable_vtable;
static SCM exp_vtables[SCM_NUM_EXPANDED_TYPES];
static size_t exp_nfields[SCM_NUM_EXPANDED_TYPES];
static const char* exp_names[SCM_NUM_EXPANDED_TYPES];
static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];

#define VOID(src) \
  SCM_MAKE_EXPANDED_VOID(src)
#define CONST(src, exp) \
  SCM_MAKE_EXPANDED_CONST(src, exp)
#define PRIMITIVE_REF_TYPE(src, name) \
  SCM_MAKE_EXPANDED_PRIMITIVE_REF_TYPE(src, name)
#define LEXICAL_REF(src, name, gensym) \
  SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym)
#define LEXICAL_SET(src, name, gensym, exp) \
  SCM_MAKE_EXPANDED_LEXICAL_SET(src, name, gensym, exp)
#define MODULE_REF(src, mod, name, public) \
  SCM_MAKE_EXPANDED_MODULE_REF(src, mod, name, public)
#define MODULE_SET(src, mod, name, public, exp) \
  SCM_MAKE_EXPANDED_MODULE_SET(src, mod, name, public, exp)
#define TOPLEVEL_REF(src, name) \
  SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, name)
#define TOPLEVEL_SET(src, name, exp) \
  SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, name, exp)
#define TOPLEVEL_DEFINE(src, name, exp) \
  SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp)
#define CONDITIONAL(src, test, consequent, alternate) \
  SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
#define APPLICATION(src, proc, exps) \
  SCM_MAKE_EXPANDED_APPLICATION(src, proc, exps)
#define SEQUENCE(src, exps) \
  SCM_MAKE_EXPANDED_SEQUENCE(src, exps)
#define LAMBDA(src, meta, body) \
  SCM_MAKE_EXPANDED_LAMBDA(src, meta, body)
#define LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \
  SCM_MAKE_EXPANDED_LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate)
#define LET(src, names, gensyms, vals, body) \
  SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body)
#define LETREC(src, in_order_p, names, gensyms, vals, body) \
  SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body)
#define DYNLET(src, fluids, vals, body) \
  SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body)

#define CAR(x)   SCM_CAR(x)
#define CDR(x)   SCM_CDR(x)
#define CAAR(x)  SCM_CAAR(x)
#define CADR(x)  SCM_CADR(x)
#define CDAR(x)  SCM_CDAR(x)
#define CDDR(x)  SCM_CDDR(x)
#define CADDR(x) SCM_CADDR(x)
#define CDDDR(x) SCM_CDDDR(x)
#define CADDDR(x) SCM_CADDDR(x)

static const char s_bad_expression[] = "Bad expression";
static const char s_expression[] = "Missing or extra expression in";
static const char s_missing_expression[] = "Missing expression in";
static const char s_extra_expression[] = "Extra expression in";
static const char s_empty_combination[] = "Illegal empty combination";
static const char s_missing_body_expression[] = "Missing body expression in";
static const char s_mixed_body_forms[] = "Mixed definitions and expressions in";
static const char s_bad_define[] = "Bad define placement";
static const char s_missing_clauses[] = "Missing clauses";
static const char s_misplaced_else_clause[] = "Misplaced else clause";
static const char s_bad_case_clause[] = "Bad case clause";
static const char s_bad_case_labels[] = "Bad case labels";
static const char s_duplicate_case_label[] = "Duplicate case label";
static const char s_bad_cond_clause[] = "Bad cond clause";
static const char s_missing_recipient[] = "Missing recipient in";
static const char s_bad_variable[] = "Bad variable";
static const char s_bad_bindings[] = "Bad bindings";
static const char s_bad_binding[] = "Bad binding";
static const char s_duplicate_binding[] = "Duplicate binding";
static const char s_bad_exit_clause[] = "Bad exit clause";
static const char s_bad_formals[] = "Bad formals";
static const char s_bad_formal[] = "Bad formal";
static const char s_duplicate_formal[] = "Duplicate formal";
static const char s_splicing[] = "Non-list result for unquote-splicing";
static const char s_bad_slot_number[] = "Bad slot number";

static void syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN;

SCM_SYMBOL (syntax_error_key, "syntax-error");

/* Shortcut macros to simplify syntax error handling. */
#define ASSERT_SYNTAX(cond, message, form)		\
  { if (SCM_UNLIKELY (!(cond)))			\
      syntax_error (message, form, SCM_UNDEFINED); }
#define ASSERT_SYNTAX_2(cond, message, form, expr)	\
  { if (SCM_UNLIKELY (!(cond)))			\
      syntax_error (message, form, expr); }

/* Primitive syntax.  */

#define SCM_SYNTAX(STR, CFN)  \
SCM_SNARF_HERE(static SCM CFN (SCM xorig, SCM env))                     \
SCM_SNARF_INIT(scm_c_define (STR, scm_i_make_primitive_macro (STR, CFN)))

/* True primitive syntax */
SCM_SYNTAX ("@", expand_at);
SCM_SYNTAX ("@@", expand_atat);
SCM_SYNTAX ("begin", expand_begin);
SCM_SYNTAX ("define", expand_define);
SCM_SYNTAX ("with-fluids", expand_with_fluids);
SCM_SYNTAX ("eval-when", expand_eval_when);
SCM_SYNTAX ("if", expand_if);
SCM_SYNTAX ("lambda", expand_lambda);
SCM_SYNTAX ("let", expand_let);
SCM_SYNTAX ("quote", expand_quote);
SCM_SYNTAX ("set!", expand_set_x);

/* Convenient syntax during boot, expands to primitive syntax. Replaced after
   psyntax boots. */
SCM_SYNTAX ("and", expand_and);
SCM_SYNTAX ("cond", expand_cond);
SCM_SYNTAX ("letrec", expand_letrec);
SCM_SYNTAX ("letrec*", expand_letrec_star);
SCM_SYNTAX ("let*", expand_letstar);
SCM_SYNTAX ("or", expand_or);
SCM_SYNTAX ("lambda*", expand_lambda_star);
SCM_SYNTAX ("case-lambda", expand_case_lambda);
SCM_SYNTAX ("case-lambda*", expand_case_lambda_star);

SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply");
SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
SCM_GLOBAL_SYMBOL (scm_sym_at, "@");
SCM_GLOBAL_SYMBOL (scm_sym_atat, "@@");
SCM_GLOBAL_SYMBOL (scm_sym_at_call_with_values, "@call-with-values");
SCM_GLOBAL_SYMBOL (scm_sym_atapply, "@apply");
SCM_GLOBAL_SYMBOL (scm_sym_atcall_cc, "@call-with-current-continuation");
SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
SCM_GLOBAL_SYMBOL (scm_sym_at_dynamic_wind, "@dynamic-wind");
SCM_GLOBAL_SYMBOL (scm_sym_with_fluids, "with-fluids");
SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
SCM_GLOBAL_SYMBOL (scm_sym_lambda, "lambda");
SCM_GLOBAL_SYMBOL (scm_sym_let, "let");
SCM_GLOBAL_SYMBOL (scm_sym_letrec, "letrec");
SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*");
SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
SCM_GLOBAL_SYMBOL (scm_sym_at_prompt, "@prompt");
SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
SCM_SYMBOL (sym_lambda_star, "lambda*");
SCM_SYMBOL (sym_eval, "eval");
SCM_SYMBOL (sym_load, "load");

SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");

SCM_KEYWORD (kw_allow_other_keys, "allow-other-keys");
SCM_KEYWORD (kw_optional, "optional");
SCM_KEYWORD (kw_key, "key");
SCM_KEYWORD (kw_rest, "rest");

/* Signal a syntax error.  We distinguish between the form that caused the
 * error and the enclosing expression.  The error message will print out as
 * shown in the following pattern.  The file name and line number are only
 * given when they can be determined from the erroneous form or from the
 * enclosing expression.
 *
 * <filename>: In procedure memoization:
 * <filename>: In file <name>, line <nr>: <error-message> in <expression>.  */

static void
syntax_error (const char* const msg, const SCM form, const SCM expr)
{
  SCM msg_string = scm_from_locale_string (msg);
  SCM filename = SCM_BOOL_F;
  SCM linenr = SCM_BOOL_F;
  const char *format;
  SCM args;

  if (scm_is_pair (form))
    {
      filename = scm_source_property (form, scm_sym_filename);
      linenr = scm_source_property (form, scm_sym_line);
    }

  if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
    {
      filename = scm_source_property (expr, scm_sym_filename);
      linenr = scm_source_property (expr, scm_sym_line);
    }

  if (!SCM_UNBNDP (expr))
    {
      if (scm_is_true (filename))
	{
	  format = "In file ~S, line ~S: ~A ~S in expression ~S.";
	  args = scm_list_5 (filename, linenr, msg_string, form, expr);
	}
      else if (scm_is_true (linenr))
	{
	  format = "In line ~S: ~A ~S in expression ~S.";
	  args = scm_list_4 (linenr, msg_string, form, expr);
	}
      else
	{
	  format = "~A ~S in expression ~S.";
	  args = scm_list_3 (msg_string, form, expr);
	}
    }
  else
    {
      if (scm_is_true (filename))
	{
	  format = "In file ~S, line ~S: ~A ~S.";
	  args = scm_list_4 (filename, linenr, msg_string, form);
	}
      else if (scm_is_true (linenr))
	{
	  format = "In line ~S: ~A ~S.";
	  args = scm_list_3 (linenr, msg_string, form);
	}
      else
	{
	  format = "~A ~S.";
	  args = scm_list_2 (msg_string, form);
	}
    }

  scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
}

static int
expand_env_var_is_free (SCM env, SCM x)
{
  for (; scm_is_pair (env); env = CDR (env))
    if (scm_is_eq (x, CAAR (env)))
      return 0; /* bound */
  return 1; /* free */
}

static SCM
expand_env_ref_macro (SCM env, SCM x)
{
  SCM var;
  if (!expand_env_var_is_free (env, x))
    return SCM_BOOL_F; /* lexical */

  var = scm_module_variable (scm_current_module (), x);
  if (scm_is_true (var) && scm_is_true (scm_variable_bound_p (var))
      && scm_is_true (scm_macro_p (scm_variable_ref (var))))
    return scm_variable_ref (var);
  else
    return SCM_BOOL_F; /* anything else */
}

static SCM
expand_env_lexical_gensym (SCM env, SCM name)
{
  for (; scm_is_pair (env); env = CDR (env))
    if (scm_is_eq (name, CAAR (env)))
      return CDAR (env); /* bound */
  return SCM_BOOL_F; /* free */
}

static SCM
expand_env_extend (SCM env, SCM names, SCM vars)
{
  while (scm_is_pair (names))
    {
      env = scm_acons (CAR (names), CAR (vars), env);
      names = CDR (names);
      vars = CDR (vars);
    }
  return env;
}

static SCM
expand (SCM exp, SCM env)
{
  if (scm_is_pair (exp))
    {
      SCM car;
      scm_t_macro_primitive trans = NULL;
      SCM macro = SCM_BOOL_F;

      car = CAR (exp);
      if (scm_is_symbol (car))
        macro = expand_env_ref_macro (env, car);

      if (scm_is_true (macro))
        trans = scm_i_macro_primitive (macro);

      if (trans)
        return trans (exp, env);
      else
        {
          SCM arg_exps = SCM_EOL;
          SCM args = SCM_EOL;
          SCM proc = CAR (exp);

          for (arg_exps = CDR (exp); scm_is_pair (arg_exps);
               arg_exps = CDR (arg_exps))
            args = scm_cons (expand (CAR (arg_exps), env), args);
          if (scm_is_null (arg_exps))
            return APPLICATION (scm_source_properties (exp),
                                expand (proc, env),
                                scm_reverse_x (args, SCM_UNDEFINED));
          else
            syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
        }
    }
  else if (scm_is_symbol (exp))
    {
      SCM gensym = expand_env_lexical_gensym (env, exp);
      if (scm_is_true (gensym))
        return LEXICAL_REF (SCM_BOOL_F, exp, gensym);
      else
        return TOPLEVEL_REF (SCM_BOOL_F, exp);
    }
  else
    return CONST (SCM_BOOL_F, exp);
}

static SCM
expand_exprs (SCM forms, const SCM env)
{
  SCM ret = SCM_EOL;

  for (; !scm_is_null (forms); forms = CDR (forms))
    ret = scm_cons (expand (CAR (forms), env), ret);
  return scm_reverse_x (ret, SCM_UNDEFINED);
}

static SCM
expand_sequence (const SCM forms, const SCM env)
{
  ASSERT_SYNTAX (scm_ilength (forms) >= 1, s_bad_expression,
                 scm_cons (scm_sym_begin, forms));
  if (scm_is_null (CDR (forms)))
    return expand (CAR (forms), env);
  else
    return SEQUENCE (SCM_BOOL_F, expand_exprs (forms, env));
}

static SCM
expand_at (SCM expr, SCM env SCM_UNUSED)
{
  ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
  ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
  ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);

  return MODULE_REF (scm_source_properties (expr),
                     CADR (expr), CADDR (expr), SCM_BOOL_T);
}

static SCM
expand_atat (SCM expr, SCM env SCM_UNUSED)
{
  ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
  ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
  ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);

  return MODULE_REF (scm_source_properties (expr),
                     CADR (expr), CADDR (expr), SCM_BOOL_F);
}

static SCM
expand_and (SCM expr, SCM env)
{
  const SCM cdr_expr = CDR (expr);

  if (scm_is_null (cdr_expr))
    return CONST (SCM_BOOL_F, SCM_BOOL_T);

  ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);

  if (scm_is_null (CDR (cdr_expr)))
    return expand (CAR (cdr_expr), env);
  else
    return CONDITIONAL (scm_source_properties (expr),
                        expand (CAR (cdr_expr), env),
                        expand_and (cdr_expr, env),
                        CONST (SCM_BOOL_F, SCM_BOOL_F));
}

static SCM
expand_begin (SCM expr, SCM env)
{
  const SCM cdr_expr = CDR (expr);
  ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_bad_expression, expr);
  return expand_sequence (cdr_expr, env);
}

static SCM
expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env)
{
  SCM test;
  const long length = scm_ilength (clause);
  ASSERT_SYNTAX (length >= 1, s_bad_cond_clause, clause);

  test = CAR (clause);
  if (scm_is_eq (test, scm_sym_else) && elp)
    {
      const int last_clause_p = scm_is_null (rest);
      ASSERT_SYNTAX (length >= 2, s_bad_cond_clause, clause);
      ASSERT_SYNTAX (last_clause_p, s_misplaced_else_clause, clause);
      return expand_sequence (CDR (clause), env);
    }

  if (scm_is_null (rest))
    rest = VOID (SCM_BOOL_F);
  else
    rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env);

  if (length >= 2
      && scm_is_eq (CADR (clause), scm_sym_arrow)
      && alp)
    {
      SCM tmp = scm_gensym (scm_from_locale_string ("cond "));
      SCM new_env = scm_acons (tmp, tmp, env);
      ASSERT_SYNTAX (length > 2, s_missing_recipient, clause);
      ASSERT_SYNTAX (length == 3, s_extra_expression, clause);
      return LET (SCM_BOOL_F,
                  scm_list_1 (tmp),
                  scm_list_1 (tmp),
                  scm_list_1 (expand (test, env)),
                  CONDITIONAL (SCM_BOOL_F,
                               LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
                               APPLICATION (SCM_BOOL_F,
                                            expand (CADDR (clause), new_env),
                                            scm_list_1 (LEXICAL_REF (SCM_BOOL_F,
                                                                     tmp, tmp))),
                               rest));
    }
  /* FIXME length == 1 case */
  else
    return CONDITIONAL (SCM_BOOL_F,
                        expand (test, env),
                        expand_sequence (CDR (clause), env),
                        rest);
}

static SCM
expand_cond (SCM expr, SCM env)
{
  const int else_literal_p = expand_env_var_is_free (env, scm_sym_else);
  const int arrow_literal_p = expand_env_var_is_free (env, scm_sym_arrow);
  const SCM clauses = CDR (expr);

  ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr);
  ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr);

  return expand_cond_clauses (CAR (clauses), CDR (clauses),
                              else_literal_p, arrow_literal_p, env);
}

/* lone forward decl */
static SCM expand_lambda (SCM expr, SCM env);

/* According to Section 5.2.1 of R5RS we first have to make sure that the
   variable is bound, and then perform the `(set! variable expression)'
   operation.  However, EXPRESSION _can_ be evaluated before VARIABLE is
   bound.  This means that EXPRESSION won't necessarily be able to assign
   values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'.  */
static SCM
expand_define (SCM expr, SCM env)
{
  const SCM cdr_expr = CDR (expr);
  SCM body;
  SCM variable;

  ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
  ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
  ASSERT_SYNTAX (!scm_is_pair (env), s_bad_define, expr);

  body = CDR (cdr_expr);
  variable = CAR (cdr_expr);

  if (scm_is_pair (variable))
    {
      ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr);
      return TOPLEVEL_DEFINE
        (scm_source_properties (expr),
         CAR (variable),
         expand_lambda (scm_cons (scm_sym_lambda, scm_cons (CDR (variable), body)),
                        env));
    }
  ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
  ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
  return TOPLEVEL_DEFINE (scm_source_properties (expr), variable,
                          expand (CAR (body), env));
}

static SCM
expand_with_fluids (SCM expr, SCM env)
{
  SCM binds, fluids, vals;
  ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
  binds = CADR (expr);
  ASSERT_SYNTAX_2 (scm_ilength (binds) >= 0, s_bad_bindings, binds, expr);
  for (fluids = SCM_EOL, vals = SCM_EOL;
       scm_is_pair (binds);
       binds = CDR (binds))
    {
      SCM binding = CAR (binds);
      ASSERT_SYNTAX_2 (scm_ilength (CAR (binds)) == 2, s_bad_binding,
                       binding, expr);
      fluids = scm_cons (expand (CAR (binding), env), fluids);
      vals = scm_cons (expand (CADR (binding), env), vals);
    }

  return DYNLET (scm_source_properties (expr),
                 scm_reverse_x (fluids, SCM_UNDEFINED),
                 scm_reverse_x (vals, SCM_UNDEFINED),
                 expand_sequence (CDDR (expr), env));
}

static SCM
expand_eval_when (SCM expr, SCM env)
{
  ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
  ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);

  if (scm_is_true (scm_memq (sym_eval, CADR (expr)))
      || scm_is_true (scm_memq (sym_load, CADR (expr))))
    return expand_sequence (CDDR (expr), env);
  else
    return VOID (scm_source_properties (expr));
}

static SCM
expand_if (SCM expr, SCM env SCM_UNUSED)
{
  const SCM cdr_expr = CDR (expr);
  const long length = scm_ilength (cdr_expr);
  ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
  return CONDITIONAL (scm_source_properties (expr),
                      expand (CADR (expr), env),
                      expand (CADDR (expr), env),
                      ((length == 3)
                       ? expand (CADDDR (expr), env)
                       : VOID (SCM_BOOL_F)));
}

/* A helper function for expand_lambda to support checking for duplicate
 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
 * LIST or to the CDR of the last cons.  Therefore, LIST may have any of the
 * forms that a formal argument can have:
 *   <rest>, (<arg1> ...), (<arg1> ...  .  <rest>) */
static int
c_improper_memq (SCM obj, SCM list)
{
  for (; scm_is_pair (list); list = CDR (list))
    {
      if (scm_is_eq (CAR (list), obj))
        return 1;
    }
  return scm_is_eq (list, obj);
}

static SCM
expand_lambda_case (SCM clause, SCM alternate, SCM env)
{
  SCM formals;
  SCM rest;
  SCM req = SCM_EOL;
  SCM vars = SCM_EOL;
  SCM body;
  int nreq = 0;

  ASSERT_SYNTAX (scm_is_pair (clause) && scm_is_pair (CDR (clause)),
                 s_bad_expression, scm_cons (scm_sym_lambda, clause));

  /* Before iterating the list of formal arguments, make sure the formals
   * actually are given as either a symbol or a non-cyclic list.  */
  formals = CAR (clause);
  if (scm_is_pair (formals))
    {
      /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
       * detected, report a 'Bad formals' error.  */
    }
  else
    ASSERT_SYNTAX_2 (scm_is_symbol (formals) || scm_is_null (formals),
                     s_bad_formals, formals, scm_cons (scm_sym_lambda, clause));

  /* Now iterate the list of formal arguments to check if all formals are
   * symbols, and that there are no duplicates.  */
  while (scm_is_pair (formals))
    {
      const SCM formal = CAR (formals);
      formals = CDR (formals);
      ASSERT_SYNTAX_2 (scm_is_symbol (formal), s_bad_formal, formal,
                       scm_cons (scm_sym_lambda, clause));
      ASSERT_SYNTAX_2 (!c_improper_memq (formal, formals), s_duplicate_formal,
                       formal, scm_cons (scm_sym_lambda, clause));
      nreq++;
      req = scm_cons (formal, req);
      vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
      env = scm_acons (formal, CAR (vars), env);
    }

  ASSERT_SYNTAX_2 (scm_is_null (formals) || scm_is_symbol (formals),
                   s_bad_formal, formals, scm_cons (scm_sym_lambda, clause));
  if (scm_is_symbol (formals))
    {
      rest = formals;
      vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
      env = scm_acons (rest, CAR (vars), env);
    }
  else
    rest = SCM_BOOL_F;

  body = expand_sequence (CDR (clause), env);
  req = scm_reverse_x (req, SCM_UNDEFINED);
  vars = scm_reverse_x (vars, SCM_UNDEFINED);

  if (scm_is_true (alternate) && !(SCM_EXPANDED_P (alternate) && SCM_EXPANDED_TYPE (alternate) == SCM_EXPANDED_LAMBDA_CASE))
    abort ();

  return LAMBDA_CASE (SCM_BOOL_F, req, SCM_BOOL_F, rest, SCM_BOOL_F,
                      SCM_EOL, vars, body, alternate);
}

static SCM
expand_lambda (SCM expr, SCM env)
{
  return LAMBDA (scm_source_properties (expr),
                 SCM_EOL,
                 expand_lambda_case (CDR (expr), SCM_BOOL_F, env));
}

static SCM
expand_lambda_star_case (SCM clause, SCM alternate, SCM env)
{
  SCM req, opt, kw, allow_other_keys, rest, formals, vars, body, tmp;
  SCM inits;
  int nreq, nopt;

  const long length = scm_ilength (clause);
  ASSERT_SYNTAX (length >= 1, s_bad_expression,
                 scm_cons (sym_lambda_star, clause));
  ASSERT_SYNTAX (length >= 2, s_missing_expression,
                 scm_cons (sym_lambda_star, clause));

  formals = CAR (clause);
  body = CDR (clause);

  nreq = nopt = 0;
  req = opt = kw = SCM_EOL;
  rest = allow_other_keys = SCM_BOOL_F;

  while (scm_is_pair (formals) && scm_is_symbol (CAR (formals)))
    {
      nreq++;
      req = scm_cons (CAR (formals), req);
      formals = scm_cdr (formals);
    }

  if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_optional))
    {
      formals = CDR (formals);
      while (scm_is_pair (formals)
             && (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
        {
          nopt++;
          opt = scm_cons (CAR (formals), opt);
          formals = scm_cdr (formals);
        }
    }

  if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_key))
    {
      formals = CDR (formals);
      while (scm_is_pair (formals)
             && (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
        {
          kw = scm_cons (CAR (formals), kw);
          formals = scm_cdr (formals);
        }
    }

  if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_allow_other_keys))
    {
      formals = CDR (formals);
      allow_other_keys = SCM_BOOL_T;
    }

  if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_rest))
    {
      ASSERT_SYNTAX (scm_ilength (formals) == 2, s_bad_formals,
                     CAR (clause));
      rest = CADR (formals);
    }
  else if (scm_is_symbol (formals))
    rest = formals;
  else
    {
      ASSERT_SYNTAX (scm_is_null (formals), s_bad_formals, CAR (clause));
      rest = SCM_BOOL_F;
    }

  /* Now, iterate through them a second time, building up an expansion-time
     environment, checking, expanding and canonicalizing the opt/kw init forms,
     and eventually memoizing the body as well. Note that the rest argument, if
     any, is expanded before keyword args, thus necessitating the second
     pass.

     Also note that the specific environment during expansion of init
     expressions here needs to coincide with the environment when psyntax
     expands. A lot of effort for something that is only used in the bootstrap
     expandr, you say? Yes. Yes it is.
  */

  vars = SCM_EOL;
  req = scm_reverse_x (req, SCM_EOL);
  for (tmp = req; scm_is_pair (tmp); tmp = scm_cdr (tmp))
    {
      vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
      env = scm_acons (CAR (tmp), CAR (vars), env);
    }

  /* Build up opt inits and env */
  inits = SCM_EOL;
  opt = scm_reverse_x (opt, SCM_EOL);
  for (tmp = opt; scm_is_pair (tmp); tmp = scm_cdr (tmp))
    {
      SCM x = CAR (tmp);
      vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
      env = scm_acons (x, CAR (vars), env);
      if (scm_is_symbol (x))
        inits = scm_cons (CONST (SCM_BOOL_F, SCM_BOOL_F), inits);
      else
        {
          ASSERT_SYNTAX (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)),
                         s_bad_formals, CAR (clause));
          inits = scm_cons (expand (CADR (x), env), inits);
        }
      env = scm_acons (scm_is_symbol (x) ? x : CAR (x), CAR (vars), env);
    }
  if (scm_is_null (opt))
    opt = SCM_BOOL_F;

  /* Process rest before keyword args */
  if (scm_is_true (rest))
    {
      vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
      env = scm_acons (rest, CAR (vars), env);
    }

  /* Build up kw inits, env, and kw-canon list */
  if (scm_is_null (kw))
    kw = SCM_BOOL_F;
  else
    {
      SCM kw_canon = SCM_EOL;
      kw = scm_reverse_x (kw, SCM_UNDEFINED);
      for (tmp = kw; scm_is_pair (tmp); tmp = scm_cdr (tmp))
        {
          SCM x, sym, k, init;
          x = CAR (tmp);
          if (scm_is_symbol (x))
            {
              sym = x;
              init = SCM_BOOL_F;
              k = scm_symbol_to_keyword (sym);
            }
          else if (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)))
            {
              sym = CAR (x);
              init = CADR (x);
              k = scm_symbol_to_keyword (sym);
            }
          else if (scm_ilength (x) == 3 && scm_is_symbol (CAR (x))
                   && scm_is_keyword (CADDR (x)))
            {
              sym = CAR (x);
              init = CADR (x);
              k = CADDR (x);
            }
          else
            syntax_error (s_bad_formals, CAR (clause), SCM_UNDEFINED);

          inits = scm_cons (expand (init, env), inits);
          vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
          kw_canon = scm_cons (scm_list_3 (k, sym, CAR (vars)), kw_canon);
          env = scm_acons (sym, CAR (vars), env);
        }
      kw_canon = scm_reverse_x (kw_canon, SCM_UNDEFINED);
      kw = scm_cons (allow_other_keys, kw_canon);
    }

  /* We should check for no duplicates, but given that psyntax does this
     already, we can punt on it here... */

  vars = scm_reverse_x (vars, SCM_UNDEFINED);
  inits = scm_reverse_x (inits, SCM_UNDEFINED);
  body = expand_sequence (body, env);

  return LAMBDA_CASE (SCM_BOOL_F, req, opt, rest, kw, inits, vars, body,
                      alternate);
}

static SCM
expand_lambda_star (SCM expr, SCM env)
{
  return LAMBDA (scm_source_properties (expr),
                 SCM_EOL,
                 expand_lambda_star_case (CDR (expr), SCM_BOOL_F, env));
}

static SCM
expand_case_lambda_clauses (SCM expr, SCM rest, SCM env)
{
  SCM alt;

  if (scm_is_pair (rest))
    alt = expand_case_lambda_clauses (CAR (rest), CDR (rest), env);
  else
    alt = SCM_BOOL_F;

  return expand_lambda_case (expr, alt, env);
}

static SCM
expand_case_lambda (SCM expr, SCM env)
{
  ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr);

  return LAMBDA (scm_source_properties (expr),
                 SCM_EOL,
                 expand_case_lambda_clauses (CADR (expr), CDDR (expr), env));
}

static SCM
expand_case_lambda_star_clauses (SCM expr, SCM rest, SCM env)
{
  SCM alt;

  if (scm_is_pair (rest))
    alt = expand_case_lambda_star_clauses (CAR (rest), CDR (rest), env);
  else
    alt = SCM_BOOL_F;

  return expand_lambda_star_case (expr, alt, env);
}

static SCM
expand_case_lambda_star (SCM expr, SCM env)
{
  ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr);

  return LAMBDA (scm_source_properties (expr),
                 SCM_EOL,
                 expand_case_lambda_star_clauses (CADR (expr), CDDR (expr), env));
}

/* Check if the format of the bindings is ((<symbol> <init-form>) ...).  */
static void
check_bindings (const SCM bindings, const SCM expr)
{
  SCM binding_idx;

  ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
                   s_bad_bindings, bindings, expr);

  binding_idx = bindings;
  for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
    {
      SCM name;         /* const */

      const SCM binding = CAR (binding_idx);
      ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
                       s_bad_binding, binding, expr);

      name = CAR (binding);
      ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
    }
}

/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
 * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
 * variable name is detected, an error is signalled. */
static void
transform_bindings (const SCM bindings, const SCM expr,
                    SCM *const names, SCM *const vars, SCM *const initptr)
{
  SCM rnames = SCM_EOL;
  SCM rvars = SCM_EOL;
  SCM rinits = SCM_EOL;
  SCM binding_idx = bindings;
  for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
    {
      const SCM binding = CAR (binding_idx);
      const SCM CDR_binding = CDR (binding);
      const SCM name = CAR (binding);
      ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rnames)),
                       s_duplicate_binding, name, expr);
      rnames = scm_cons (name, rnames);
      rvars = scm_cons (scm_gensym (SCM_UNDEFINED), rvars);
      rinits = scm_cons (CAR (CDR_binding), rinits);
    }
  *names = scm_reverse_x (rnames, SCM_UNDEFINED);
  *vars = scm_reverse_x (rvars, SCM_UNDEFINED);
  *initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
}

/* FIXME: Remove named let in this boot expander. */
static SCM
expand_named_let (const SCM expr, SCM env)
{
  SCM var_names, var_syms, inits;
  SCM inner_env;
  SCM name_sym;

  const SCM cdr_expr = CDR (expr);
  const SCM name = CAR (cdr_expr);
  const SCM cddr_expr = CDR (cdr_expr);
  const SCM bindings = CAR (cddr_expr);
  check_bindings (bindings, expr);

  transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
  name_sym = scm_gensym (SCM_UNDEFINED);
  inner_env = scm_acons (name, name_sym, env);
  inner_env = expand_env_extend (inner_env, var_names, var_syms);

  return LETREC
    (scm_source_properties (expr), SCM_BOOL_F,
     scm_list_1 (name), scm_list_1 (name_sym),
     scm_list_1 (LAMBDA (SCM_BOOL_F,
                         SCM_EOL,
                         LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_BOOL_F, SCM_BOOL_F,
                                      SCM_BOOL_F, SCM_BOOL_F, var_syms,
                                      expand_sequence (CDDDR (expr), inner_env),
                                      SCM_BOOL_F))),
     APPLICATION (SCM_BOOL_F,
                  LEXICAL_REF (SCM_BOOL_F, name, name_sym),
                  expand_exprs (inits, env)));
}

static SCM
expand_let (SCM expr, SCM env)
{
  SCM bindings;

  const SCM cdr_expr = CDR (expr);
  const long length = scm_ilength (cdr_expr);
  ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
  ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);

  bindings = CAR (cdr_expr);
  if (scm_is_symbol (bindings))
    {
      ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
      return expand_named_let (expr, env);
    }

  check_bindings (bindings, expr);
  if (scm_is_null (bindings))
    return expand_sequence (CDDR (expr), env);
  else
    {
      SCM var_names, var_syms, inits;
      transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
      return LET (SCM_BOOL_F,
                  var_names, var_syms, expand_exprs (inits, env),
                  expand_sequence (CDDR (expr),
                                   expand_env_extend (env, var_names,
                                                      var_syms)));
    }
}

static SCM
expand_letrec_helper (SCM expr, SCM env, SCM in_order_p)
{
  SCM bindings;

  const SCM cdr_expr = CDR (expr);
  const long length = scm_ilength (cdr_expr);
  ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
  ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);

  bindings = CAR (cdr_expr);
  check_bindings (bindings, expr);
  if (scm_is_null (bindings))
    return expand_sequence (CDDR (expr), env);
  else
    {
      SCM var_names, var_syms, inits;
      transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
      env = expand_env_extend (env, var_names, var_syms);
      return LETREC (SCM_BOOL_F, in_order_p,
                     var_names, var_syms, expand_exprs (inits, env),
                     expand_sequence (CDDR (expr), env));
    }
}

static SCM
expand_letrec (SCM expr, SCM env)
{
  return expand_letrec_helper (expr, env, SCM_BOOL_F);
}

static SCM
expand_letrec_star (SCM expr, SCM env)
{
  return expand_letrec_helper (expr, env, SCM_BOOL_T);
}

static SCM
expand_letstar_clause (SCM bindings, SCM body, SCM env SCM_UNUSED)
{
  if (scm_is_null (bindings))
    return expand_sequence (body, env);
  else
    {
      SCM bind, name, sym, init;

      ASSERT_SYNTAX (scm_is_pair (bindings), s_bad_expression, bindings);
      bind = CAR (bindings);
      ASSERT_SYNTAX (scm_ilength (bind) == 2, s_bad_binding, bind);
      name = CAR (bind);
      sym = scm_gensym (SCM_UNDEFINED);
      init = CADR (bind);

      return LET (SCM_BOOL_F, scm_list_1 (name), scm_list_1 (sym),
                  scm_list_1 (expand (init, env)),
                  expand_letstar_clause (CDR (bindings), body,
                                         scm_acons (name, sym, env)));
    }
}

static SCM
expand_letstar (SCM expr, SCM env SCM_UNUSED)
{
  const SCM cdr_expr = CDR (expr);
  ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
  ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);

  return expand_letstar_clause (CADR (expr), CDDR (expr), env);
}

static SCM
expand_or (SCM expr, SCM env SCM_UNUSED)
{
  SCM tail = CDR (expr);
  const long length = scm_ilength (tail);

  ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);

  if (scm_is_null (CDR (expr)))
    return CONST (SCM_BOOL_F, SCM_BOOL_F);
  else
    {
      SCM tmp = scm_gensym (SCM_UNDEFINED);
      return LET (SCM_BOOL_F,
                  scm_list_1 (tmp), scm_list_1 (tmp),
                  scm_list_1 (expand (CADR (expr), env)),
                  CONDITIONAL (SCM_BOOL_F,
                               LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
                               LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
                               expand_or (CDR (expr),
                                          scm_acons (tmp, tmp, env))));
    }
}

static SCM
expand_quote (SCM expr, SCM env SCM_UNUSED)
{
  SCM quotee;

  const SCM cdr_expr = CDR (expr);
  ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
  ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
  quotee = CAR (cdr_expr);
  return CONST (scm_source_properties (expr), quotee);
}

static SCM
expand_set_x (SCM expr, SCM env)
{
  SCM variable;
  SCM vmem;

  const SCM cdr_expr = CDR (expr);
  ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
  ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
  variable = CAR (cdr_expr);
  vmem = expand (variable, env);

  switch (SCM_EXPANDED_TYPE (vmem))
    {
    case SCM_EXPANDED_LEXICAL_REF:
      return LEXICAL_SET (scm_source_properties (expr),
                          SCM_EXPANDED_REF (vmem, LEXICAL_REF, NAME),
                          SCM_EXPANDED_REF (vmem, LEXICAL_REF, GENSYM),
                          expand (CADDR (expr), env));
    case SCM_EXPANDED_TOPLEVEL_REF:
      return TOPLEVEL_SET (scm_source_properties (expr),
                           SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, NAME),
                           expand (CADDR (expr), env));
    case SCM_EXPANDED_MODULE_REF:
      return MODULE_SET (scm_source_properties (expr),
                         SCM_EXPANDED_REF (vmem, MODULE_REF, MOD),
                         SCM_EXPANDED_REF (vmem, MODULE_REF, NAME),
                         SCM_EXPANDED_REF (vmem, MODULE_REF, PUBLIC),
                         expand (CADDR (expr), env));
    default:
      syntax_error (s_bad_variable, variable, expr);
    }
}

/* This is the boot expander. It is later replaced with psyntax's sc-expand. */
SCM_DEFINE (scm_macroexpand, "macroexpand", 1, 0, 0,
            (SCM exp),
	    "Expand the expression @var{exp}.")
#define FUNC_NAME s_scm_macroexpand
{
  return expand (exp, scm_current_module ());
}
#undef FUNC_NAME

SCM_DEFINE (scm_macroexpanded_p, "macroexpanded?", 1, 0, 0,
            (SCM exp),
	    "Return @code{#t} if @var{exp} is an expanded expression.")
#define FUNC_NAME s_scm_macroexpanded_p
{
  return scm_from_bool (SCM_EXPANDED_P (exp));
}
#undef FUNC_NAME

#define DEFINE_NAMES(type)                                              \
  {                                                                     \
    static const char *fields[] = SCM_EXPANDED_##type##_FIELD_NAMES;    \
    exp_field_names[SCM_EXPANDED_##type] = fields;                      \
    exp_names[SCM_EXPANDED_##type] = SCM_EXPANDED_##type##_TYPE_NAME;   \
    exp_nfields[SCM_EXPANDED_##type] = SCM_NUM_EXPANDED_##type##_FIELDS; \
  }

static SCM
make_exp_vtable (size_t n)
{
  SCM layout, printer, name, code, fields;

  layout = scm_string_to_symbol
    (scm_string_append (scm_make_list (scm_from_size_t (exp_nfields[n]),
                                       scm_from_locale_string ("pw"))));
  printer = SCM_BOOL_F;
  name = scm_from_locale_symbol (exp_names[n]);
  code = scm_from_size_t (n);
  fields = SCM_EOL;
  {
    size_t m = exp_nfields[n];
    while (m--)
      fields = scm_cons (scm_from_locale_symbol (exp_field_names[n][m]), fields);
  }

  return scm_c_make_struct (scm_exp_vtable_vtable, 0, 5,
                            SCM_UNPACK (layout), SCM_UNPACK (printer), SCM_UNPACK (name),
                            SCM_UNPACK (code), SCM_UNPACK (fields));
}

void
scm_init_expand ()
{
  size_t n;
  SCM exp_vtable_list = SCM_EOL;

  DEFINE_NAMES (VOID);
  DEFINE_NAMES (CONST);
  DEFINE_NAMES (PRIMITIVE_REF);
  DEFINE_NAMES (LEXICAL_REF);
  DEFINE_NAMES (LEXICAL_SET);
  DEFINE_NAMES (MODULE_REF);
  DEFINE_NAMES (MODULE_SET);
  DEFINE_NAMES (TOPLEVEL_REF);
  DEFINE_NAMES (TOPLEVEL_SET);
  DEFINE_NAMES (TOPLEVEL_DEFINE);
  DEFINE_NAMES (CONDITIONAL);
  DEFINE_NAMES (APPLICATION);
  DEFINE_NAMES (SEQUENCE);
  DEFINE_NAMES (LAMBDA);
  DEFINE_NAMES (LAMBDA_CASE);
  DEFINE_NAMES (LET);
  DEFINE_NAMES (LETREC);
  DEFINE_NAMES (DYNLET);

  scm_exp_vtable_vtable =
    scm_make_vtable (scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT "pwuwpw"),
                     SCM_BOOL_F);

  for (n = 0; n < SCM_NUM_EXPANDED_TYPES; n++)
    exp_vtables[n] = make_exp_vtable (n);

  /* Now walk back down, consing in reverse. */
  while (n--)
    exp_vtable_list = scm_cons (exp_vtables[n], exp_vtable_list);

  scm_c_define ("%expanded-vtables", scm_vector (exp_vtable_list));

#include "libguile/expand.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_EXPAND_H
#define SCM_EXPAND_H

/* Copyright (C) 2010
 * Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"

#ifdef BUILDING_LIBGUILE

/* All private for now. Ask if you want to use this. Surely this should be
   auto-generated by something; for now I wrangle it with keyboard macros. */

typedef enum
  {
    SCM_EXPANDED_VOID,
    SCM_EXPANDED_CONST,
    SCM_EXPANDED_PRIMITIVE_REF,
    SCM_EXPANDED_LEXICAL_REF,
    SCM_EXPANDED_LEXICAL_SET,
    SCM_EXPANDED_MODULE_REF,
    SCM_EXPANDED_MODULE_SET,
    SCM_EXPANDED_TOPLEVEL_REF,
    SCM_EXPANDED_TOPLEVEL_SET,
    SCM_EXPANDED_TOPLEVEL_DEFINE,
    SCM_EXPANDED_CONDITIONAL,
    SCM_EXPANDED_APPLICATION,
    SCM_EXPANDED_SEQUENCE,
    SCM_EXPANDED_LAMBDA,
    SCM_EXPANDED_LAMBDA_CASE,
    SCM_EXPANDED_LET,
    SCM_EXPANDED_LETREC,
    SCM_EXPANDED_DYNLET,
    SCM_NUM_EXPANDED_TYPES,
  } scm_t_expanded_type;

/* {Expanded Source}
 */

SCM_INTERNAL SCM scm_exp_vtable_vtable;

enum
  {
    SCM_EXPANDED_TYPE_NAME = scm_vtable_offset_user,
    SCM_EXPANDED_TYPE_CODE,
    SCM_EXPANDED_TYPE_FIELDS,
  };

#define SCM_EXPANDED_P(x) \
  (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE (SCM_STRUCT_VTABLE (x)) == scm_exp_vtable_vtable))
#define SCM_EXPANDED_REF(x,type,field) \
  (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
#define SCM_EXPANDED_TYPE(x) \
  SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (x), SCM_EXPANDED_TYPE_CODE)

#define SCM_EXPANDED_VOID_TYPE_NAME "void"
#define SCM_EXPANDED_VOID_FIELD_NAMES \
  { "src" }
enum
  {
    SCM_EXPANDED_VOID_SRC,
    SCM_NUM_EXPANDED_VOID_FIELDS,
  };
#define SCM_MAKE_EXPANDED_VOID(src) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_VOID], 0, SCM_NUM_EXPANDED_VOID_FIELDS, SCM_UNPACK (src))

#define SCM_EXPANDED_CONST_TYPE_NAME "const"
#define SCM_EXPANDED_CONST_FIELD_NAMES          \
  { "src", "exp", }
enum
  {
    SCM_EXPANDED_CONST_SRC,
    SCM_EXPANDED_CONST_EXP,
    SCM_NUM_EXPANDED_CONST_FIELDS,
  };
#define SCM_MAKE_EXPANDED_CONST(src, exp) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_CONST], 0, SCM_NUM_EXPANDED_CONST_FIELDS, SCM_UNPACK (src), SCM_UNPACK (exp))

#define SCM_EXPANDED_PRIMITIVE_REF_TYPE_NAME "primitive-ref"
#define SCM_EXPANDED_PRIMITIVE_REF_FIELD_NAMES  \
  { "src", "name", }
enum
  {
    SCM_EXPANDED_PRIMITIVE_REF_SRC,
    SCM_EXPANDED_PRIMITIVE_REF_NAME,
    SCM_NUM_EXPANDED_PRIMITIVE_REF_FIELDS,
  };
#define SCM_MAKE_EXPANDED_PRIMITIVE_REF(src, name) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_PRIMITIVE_REF], 0, SCM_NUM_EXPANDED_PRIMITIVE_REF_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name))

#define SCM_EXPANDED_LEXICAL_REF_TYPE_NAME "lexical-ref"
#define SCM_EXPANDED_LEXICAL_REF_FIELD_NAMES    \
  { "src", "name", "gensym", }
enum
  {
    SCM_EXPANDED_LEXICAL_REF_SRC,
    SCM_EXPANDED_LEXICAL_REF_NAME,
    SCM_EXPANDED_LEXICAL_REF_GENSYM,
    SCM_NUM_EXPANDED_LEXICAL_REF_FIELDS,
  };
#define SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_LEXICAL_REF], 0, SCM_NUM_EXPANDED_LEXICAL_REF_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name), SCM_UNPACK (gensym))

#define SCM_EXPANDED_LEXICAL_SET_TYPE_NAME "lexical-set"
#define SCM_EXPANDED_LEXICAL_SET_FIELD_NAMES    \
  { "src", "name", "gensym", "exp", }
enum
  {
    SCM_EXPANDED_LEXICAL_SET_SRC,
    SCM_EXPANDED_LEXICAL_SET_NAME,
    SCM_EXPANDED_LEXICAL_SET_GENSYM,
    SCM_EXPANDED_LEXICAL_SET_EXP,
    SCM_NUM_EXPANDED_LEXICAL_SET_FIELDS,
  };
#define SCM_MAKE_EXPANDED_LEXICAL_SET(src, name, gensym, exp) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_LEXICAL_SET], 0, SCM_NUM_EXPANDED_LEXICAL_SET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name), SCM_UNPACK (gensym), SCM_UNPACK (exp))

#define SCM_EXPANDED_MODULE_REF_TYPE_NAME "module-ref"
#define SCM_EXPANDED_MODULE_REF_FIELD_NAMES     \
  { "src", "mod", "name", "public?", }
enum
  {
    SCM_EXPANDED_MODULE_REF_SRC,
    SCM_EXPANDED_MODULE_REF_MOD,
    SCM_EXPANDED_MODULE_REF_NAME,
    SCM_EXPANDED_MODULE_REF_PUBLIC,
    SCM_NUM_EXPANDED_MODULE_REF_FIELDS,
  };
#define SCM_MAKE_EXPANDED_MODULE_REF(src, mod, name, public) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_MODULE_REF], 0, SCM_NUM_EXPANDED_MODULE_REF_FIELDS, SCM_UNPACK (src), SCM_UNPACK (mod), SCM_UNPACK (name), SCM_UNPACK (public))

#define SCM_EXPANDED_MODULE_SET_TYPE_NAME "module-set"
#define SCM_EXPANDED_MODULE_SET_FIELD_NAMES     \
  { "src", "mod", "name", "public?", "exp", }
enum
  {
    SCM_EXPANDED_MODULE_SET_SRC,
    SCM_EXPANDED_MODULE_SET_MOD,
    SCM_EXPANDED_MODULE_SET_NAME,
    SCM_EXPANDED_MODULE_SET_PUBLIC,
    SCM_EXPANDED_MODULE_SET_EXP,
    SCM_NUM_EXPANDED_MODULE_SET_FIELDS,
  };
#define SCM_MAKE_EXPANDED_MODULE_SET(src, mod, name, public, exp) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_MODULE_SET], 0, SCM_NUM_EXPANDED_MODULE_SET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (mod), SCM_UNPACK (name), SCM_UNPACK (public), SCM_UNPACK (exp))

#define SCM_EXPANDED_TOPLEVEL_REF_TYPE_NAME "toplevel-ref"
#define SCM_EXPANDED_TOPLEVEL_REF_FIELD_NAMES   \
  { "src", "name", }
enum
  {
    SCM_EXPANDED_TOPLEVEL_REF_SRC,
    SCM_EXPANDED_TOPLEVEL_REF_NAME,
    SCM_NUM_EXPANDED_TOPLEVEL_REF_FIELDS,
  };
#define SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, name) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_REF], 0, SCM_NUM_EXPANDED_TOPLEVEL_REF_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name))

#define SCM_EXPANDED_TOPLEVEL_SET_TYPE_NAME "toplevel-set"
#define SCM_EXPANDED_TOPLEVEL_SET_FIELD_NAMES   \
  { "src", "name", "exp", }
enum
  {
    SCM_EXPANDED_TOPLEVEL_SET_SRC,
    SCM_EXPANDED_TOPLEVEL_SET_NAME,
    SCM_EXPANDED_TOPLEVEL_SET_EXP,
    SCM_NUM_EXPANDED_TOPLEVEL_SET_FIELDS,
  };
#define SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, name, exp) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_SET], 0, SCM_NUM_EXPANDED_TOPLEVEL_SET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name), SCM_UNPACK (exp))

#define SCM_EXPANDED_TOPLEVEL_DEFINE_TYPE_NAME "toplevel-define"
#define SCM_EXPANDED_TOPLEVEL_DEFINE_FIELD_NAMES        \
  { "src", "name", "exp", }
enum
  {
    SCM_EXPANDED_TOPLEVEL_DEFINE_SRC,
    SCM_EXPANDED_TOPLEVEL_DEFINE_NAME,
    SCM_EXPANDED_TOPLEVEL_DEFINE_EXP,
    SCM_NUM_EXPANDED_TOPLEVEL_DEFINE_FIELDS,
  };
#define SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_DEFINE], 0, SCM_NUM_EXPANDED_TOPLEVEL_DEFINE_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name), SCM_UNPACK (exp))

#define SCM_EXPANDED_CONDITIONAL_TYPE_NAME "conditional"
#define SCM_EXPANDED_CONDITIONAL_FIELD_NAMES    \
  { "src", "test", "consequent", "alternate", }
enum
  {
    SCM_EXPANDED_CONDITIONAL_SRC,
    SCM_EXPANDED_CONDITIONAL_TEST,
    SCM_EXPANDED_CONDITIONAL_CONSEQUENT,
    SCM_EXPANDED_CONDITIONAL_ALTERNATE,
    SCM_NUM_EXPANDED_CONDITIONAL_FIELDS,
  };
#define SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_CONDITIONAL], 0, SCM_NUM_EXPANDED_CONDITIONAL_FIELDS, SCM_UNPACK (src), SCM_UNPACK (test), SCM_UNPACK (consequent), SCM_UNPACK (alternate))

#define SCM_EXPANDED_APPLICATION_TYPE_NAME "application"
#define SCM_EXPANDED_APPLICATION_FIELD_NAMES    \
  { "src", "proc", "args", }
enum
  {
    SCM_EXPANDED_APPLICATION_SRC,
    SCM_EXPANDED_APPLICATION_PROC,
    SCM_EXPANDED_APPLICATION_ARGS,
    SCM_NUM_EXPANDED_APPLICATION_FIELDS,
  };
#define SCM_MAKE_EXPANDED_APPLICATION(src, proc, args) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_APPLICATION], 0, SCM_NUM_EXPANDED_APPLICATION_FIELDS, SCM_UNPACK (src), SCM_UNPACK (proc), SCM_UNPACK (args))

#define SCM_EXPANDED_SEQUENCE_TYPE_NAME "sequence"
#define SCM_EXPANDED_SEQUENCE_FIELD_NAMES       \
  {  "src", "exps", }
enum
  {
    SCM_EXPANDED_SEQUENCE_SRC,
    SCM_EXPANDED_SEQUENCE_EXPS,
    SCM_NUM_EXPANDED_SEQUENCE_FIELDS,
  };
#define SCM_MAKE_EXPANDED_SEQUENCE(src, exps) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_SEQUENCE], 0, SCM_NUM_EXPANDED_SEQUENCE_FIELDS, SCM_UNPACK (src), SCM_UNPACK (exps))

#define SCM_EXPANDED_LAMBDA_TYPE_NAME "lambda"
#define SCM_EXPANDED_LAMBDA_FIELD_NAMES         \
  { "src", "meta", "body", }
enum
  {
    SCM_EXPANDED_LAMBDA_SRC,
    SCM_EXPANDED_LAMBDA_META,
    SCM_EXPANDED_LAMBDA_BODY,
    SCM_NUM_EXPANDED_LAMBDA_FIELDS,
  };
#define SCM_MAKE_EXPANDED_LAMBDA(src, meta, body) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_LAMBDA], 0, SCM_NUM_EXPANDED_LAMBDA_FIELDS, SCM_UNPACK (src), SCM_UNPACK (meta), SCM_UNPACK (body))

#define SCM_EXPANDED_LAMBDA_CASE_TYPE_NAME "lambda-case"
#define SCM_EXPANDED_LAMBDA_CASE_FIELD_NAMES    \
  { "src", "req", "opt", "rest", "kw", "inits", "gensyms", "body", "alternate", }
enum
  {
    SCM_EXPANDED_LAMBDA_CASE_SRC,
    SCM_EXPANDED_LAMBDA_CASE_REQ,
    SCM_EXPANDED_LAMBDA_CASE_OPT,
    SCM_EXPANDED_LAMBDA_CASE_REST,
    SCM_EXPANDED_LAMBDA_CASE_KW,
    SCM_EXPANDED_LAMBDA_CASE_INITS,
    SCM_EXPANDED_LAMBDA_CASE_GENSYMS,
    SCM_EXPANDED_LAMBDA_CASE_BODY,
    SCM_EXPANDED_LAMBDA_CASE_ALTERNATE,
    SCM_NUM_EXPANDED_LAMBDA_CASE_FIELDS,
  };
#define SCM_MAKE_EXPANDED_LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_LAMBDA_CASE], 0, SCM_NUM_EXPANDED_LAMBDA_CASE_FIELDS, SCM_UNPACK (src), SCM_UNPACK (req), SCM_UNPACK (opt), SCM_UNPACK (rest), SCM_UNPACK (kw), SCM_UNPACK (inits), SCM_UNPACK (gensyms), SCM_UNPACK (body), SCM_UNPACK (alternate))

#define SCM_EXPANDED_LET_TYPE_NAME "let"
#define SCM_EXPANDED_LET_FIELD_NAMES            \
  { "src", "names", "gensyms", "vals", "body", }
enum
  {
    SCM_EXPANDED_LET_SRC,
    SCM_EXPANDED_LET_NAMES,
    SCM_EXPANDED_LET_GENSYMS,
    SCM_EXPANDED_LET_VALS,
    SCM_EXPANDED_LET_BODY,
    SCM_NUM_EXPANDED_LET_FIELDS,
  };
#define SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_LET], 0, SCM_NUM_EXPANDED_LET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (names), SCM_UNPACK (gensyms), SCM_UNPACK (vals), SCM_UNPACK (body))

#define SCM_EXPANDED_LETREC_TYPE_NAME "letrec"
#define SCM_EXPANDED_LETREC_FIELD_NAMES         \
  { "src", "in-order?", "names", "gensyms", "vals", "body", }
enum
  {
    SCM_EXPANDED_LETREC_SRC,
    SCM_EXPANDED_LETREC_IN_ORDER_P,
    SCM_EXPANDED_LETREC_NAMES,
    SCM_EXPANDED_LETREC_GENSYMS,
    SCM_EXPANDED_LETREC_VALS,
    SCM_EXPANDED_LETREC_BODY,
    SCM_NUM_EXPANDED_LETREC_FIELDS,
  };
#define SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_LETREC], 0, SCM_NUM_EXPANDED_LETREC_FIELDS, SCM_UNPACK (src), SCM_UNPACK (in_order_p), SCM_UNPACK (names), SCM_UNPACK (gensyms), SCM_UNPACK (vals), SCM_UNPACK (body))

#define SCM_EXPANDED_DYNLET_TYPE_NAME "dynlet"
#define SCM_EXPANDED_DYNLET_FIELD_NAMES         \
  { "src", "fluids", "vals", "body", }
enum
  {
    SCM_EXPANDED_DYNLET_SRC,
    SCM_EXPANDED_DYNLET_FLUIDS,
    SCM_EXPANDED_DYNLET_VALS,
    SCM_EXPANDED_DYNLET_BODY,
    SCM_NUM_EXPANDED_DYNLET_FIELDS,
  };
#define SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body) \
  scm_c_make_struct (exp_vtables[SCM_EXPANDED_DYNLET], 0, SCM_NUM_EXPANDED_DYNLET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (fluids), SCM_UNPACK (vals), SCM_UNPACK (body))

#endif /* BUILDING_LIBGUILE */

SCM_INTERNAL SCM scm_macroexpand (SCM exp);
SCM_INTERNAL SCM scm_macroexpanded_p (SCM exp);

SCM_INTERNAL void scm_init_expand (void);

#endif  /* SCM_EXPAND_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/

license: mit


code:
/* extensions.c - registering and loading extensions.
 *
 * Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#include <string.h>

#include "libguile/_scm.h"
#include "libguile/strings.h"
#include "libguile/gc.h"
#include "libguile/dynl.h"
#include "libguile/dynwind.h"

#include "libguile/extensions.h"

typedef struct extension_t
{
  struct extension_t *next;
  const char *lib;
  const char *init;
  void (*func)(void *);
  void *data;
} extension_t;

static extension_t *registered_extensions = NULL;

/* Register a LIB/INIT pair for use by `scm_load_extension'.  LIB is
   allowed to be NULL and then only INIT is used to identify the
   registered entry.  This is useful when you don't know the library
   name (which isn't really relevant anyway in a completely linked
   program) and you are sure that INIT is unique (which it must be for
   static linking).  Hmm, given this reasoning, what use is LIB
   anyway?
*/

void
scm_c_register_extension (const char *lib, const char *init,
			  void (*func) (void *), void *data)
{
  extension_t *ext = scm_malloc (sizeof(extension_t));
  if (lib)
    ext->lib = scm_strdup (lib);
  else
    ext->lib = NULL;
  ext->init = scm_strdup (init);
  ext->func = func;
  ext->data = data;

  ext->next = registered_extensions;
  registered_extensions = ext;
}

static void
load_extension (SCM lib, SCM init)
{
  /* Search the registry. */
  if (registered_extensions != NULL)
    {
      extension_t *ext;
      char *clib, *cinit;
      int found = 0;

      scm_dynwind_begin (0);

      clib = scm_to_locale_string (lib);
      scm_dynwind_free (clib);
      cinit = scm_to_locale_string (init);
      scm_dynwind_free (cinit);

      for (ext = registered_extensions; ext; ext = ext->next)
	if ((ext->lib == NULL || !strcmp (ext->lib, clib))
	    && !strcmp (ext->init, cinit))
	  {
	    ext->func (ext->data);
            found = 1;
	    break;
	  }

      scm_dynwind_end ();

      if (found)
        return;
    }

  /* Dynamically link the library. */
  scm_dynamic_call (init, scm_dynamic_link (lib));
}

void
scm_c_load_extension (const char *lib, const char *init)
{
  load_extension (scm_from_locale_string (lib), scm_from_locale_string (init));
}

SCM_DEFINE (scm_load_extension, "load-extension", 2, 0, 0,
	    (SCM lib, SCM init),
	    "Load and initialize the extension designated by LIB and INIT.\n"
	    "When there is no pre-registered function for LIB/INIT, this is\n"
	    "equivalent to\n"
	    "\n"
	    "@lisp\n"
	    "(dynamic-call INIT (dynamic-link LIB))\n"
	    "@end lisp\n"
	    "\n"
	    "When there is a pre-registered function, that function is called\n"
	    "instead.\n"
	    "\n"
	    "Normally, there is no pre-registered function.  This option exists\n"
	    "only for situations where dynamic linking is unavailable or unwanted.\n"
	    "In that case, you would statically link your program with the desired\n"
	    "library, and register its init function right after Guile has been\n"
	    "initialized.\n"
	    "\n"
	    "LIB should be a string denoting a shared library without any file type\n"
	    "suffix such as \".so\".  The suffix is provided automatically.  It\n"
	    "should also not contain any directory components.  Libraries that\n"
	    "implement Guile Extensions should be put into the normal locations for\n"
	    "shared libraries.  We recommend to use the naming convention\n"
	    "libguile-bla-blum for a extension related to a module `(bla blum)'.\n"
	    "\n"
	    "The normal way for a extension to be used is to write a small Scheme\n"
	    "file that defines a module, and to load the extension into this\n"
	    "module.  When the module is auto-loaded, the extension is loaded as\n"
	    "well.  For example,\n"
	    "\n"
	    "@lisp\n"
	    "(define-module (bla blum))\n"
	    "\n"
	    "(load-extension \"libguile-bla-blum\" \"bla_init_blum\")\n"
	    "@end lisp")
#define FUNC_NAME s_scm_load_extension
{
  load_extension (lib, init);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_init_extensions ()
{
#include "libguile/extensions.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_EXTENSIONS_H
#define SCM_EXTENSIONS_H

/* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"

typedef void (*scm_t_extension_init_func)(void*);

SCM_API void scm_c_register_extension (const char *lib, const char *init,
				       void (*func) (void *), void *data);

SCM_API void scm_c_load_extension (const char *lib, const char *init);
SCM_API SCM scm_load_extension (SCM lib, SCM init);

SCM_INTERNAL void scm_init_extensions (void);

#endif  /* SCM_EXTENSIONS_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006, 2007, 2009 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#ifdef HAVE_STRING_H
#include <string.h>
#endif

#include "libguile/_scm.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/validate.h"
#include "libguile/fluids.h"

#include "libguile/feature.h"

static SCM progargs_fluid;
static SCM features_var;

void
scm_add_feature (const char *str)
{
  SCM old = SCM_VARIABLE_REF (features_var);
  SCM new = scm_cons (scm_from_locale_symbol (str), old);
  SCM_VARIABLE_SET (features_var, new);
}

SCM_DEFINE (scm_program_arguments, "program-arguments", 0, 0, 0,
	    (),
	    "@deffnx {Scheme Procedure} command-line\n"
	    "Return the list of command line arguments passed to Guile, as a list of\n"
	    "strings.  The list includes the invoked program name, which is usually\n"
	    "@code{\"guile\"}, but excludes switches and parameters for command line\n"
	    "options like @code{-e} and @code{-l}.")
#define FUNC_NAME s_scm_program_arguments
{
  return scm_fluid_ref (progargs_fluid);
}
#undef FUNC_NAME

/* Set the value returned by program-arguments, given ARGC and ARGV.

   If FIRST is non-zero, make it the first element; we do this in
   situations where other code (like getopt) has parsed out a few
   arguments, but we still want the script name to be the first
   element.  */
void
scm_set_program_arguments (int argc, char **argv, char *first)
{
  SCM args = scm_makfromstrs (argc, argv);
  if (first)
    args = scm_cons (scm_from_locale_string (first), args);
  scm_fluid_set_x (progargs_fluid, args);
}

SCM_DEFINE (scm_set_program_arguments_scm, "set-program-arguments", 1, 0, 0,
	    (SCM lst),
	    "Set the command line arguments to be returned by\n"
	    "@code{program-arguments} (and @code{command-line}).  @var{lst}\n"
	    "should be a list of strings, the first of which is the program\n"
	    "name (either a script name, or just @code{\"guile\"}).\n"
	    "\n"
	    "Program arguments are held in a fluid and therefore have a\n"
	    "separate value in each Guile thread.  Neither the list nor the\n"
	    "strings within it are copied, so should not be modified later.")
#define FUNC_NAME s_scm_set_program_arguments_scm
{
  return scm_fluid_set_x (progargs_fluid, lst);
}
#undef FUNC_NAME

void
scm_init_feature()
{
  progargs_fluid = scm_make_fluid ();

  features_var = scm_c_define ("*features*", SCM_EOL);
#ifndef _Windows
  scm_add_feature("system");
#endif
#ifdef vms
  scm_add_feature(s_ed);
#endif
#ifdef SICP
  scm_add_feature("sicp");
#endif
#ifndef GO32
  scm_add_feature("char-ready?");
#endif
#ifndef CHEAP_CONTINUATIONS
  scm_add_feature ("full-continuation");
#endif
#if SCM_USE_PTHREAD_THREADS
  scm_add_feature ("threads");
#endif

  scm_c_define ("char-code-limit", scm_from_int (SCM_CHAR_CODE_LIMIT));

#include "libguile/feature.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_FEATURE_H
#define SCM_FEATURE_H

/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2007, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"

SCM_API void scm_add_feature (const char* str);
SCM_API SCM scm_program_arguments (void);
SCM_API void scm_set_program_arguments (int argc, char **argv, char *first);
SCM_API SCM scm_set_program_arguments_scm (SCM lst);
SCM_INTERNAL void scm_init_feature (void);

#endif  /* SCM_FEATURE_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/