libguile/expand.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012,2013
   2  * Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20 \f
  21
  22 #ifdef HAVE_CONFIG_H
  23 #  include <config.h>
  24 #endif
  25
  26 #include "libguile/__scm.h"
  27 #include "libguile/_scm.h"
  28 #include "libguile/continuations.h"
  29 #include "libguile/eq.h"
  30 #include "libguile/list.h"
  31 #include "libguile/macros.h"
  32 #include "libguile/expand.h"
  33 #include "libguile/modules.h"
  34 #include "libguile/srcprop.h"
  35 #include "libguile/ports.h"
  36 #include "libguile/print.h"
  37 #include "libguile/strings.h"
  38 #include "libguile/throw.h"
  39 #include "libguile/validate.h"
  40
  41
  42 \f
  43
  44
  45 SCM scm_exp_vtable_vtable;
  46 static SCM exp_vtables[SCM_NUM_EXPANDED_TYPES];
  47 static size_t exp_nfields[SCM_NUM_EXPANDED_TYPES];
  48 static const char* exp_names[SCM_NUM_EXPANDED_TYPES];
  49 static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
  50
  51
  52 /* The trailing underscores on these first to are to avoid spurious
  53    conflicts with macros defined on MinGW.  */
  54
  55 #define VOID_(src) \
  56   SCM_MAKE_EXPANDED_VOID(src)
  57 #define CONST_(src, exp) \
  58   SCM_MAKE_EXPANDED_CONST(src, exp)
  59 #define PRIMITIVE_REF(src, name) \
  60   SCM_MAKE_EXPANDED_PRIMITIVE_REF(src, name)
  61 #define LEXICAL_REF(src, name, gensym) \
  62   SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym)
  63 #define LEXICAL_SET(src, name, gensym, exp) \
  64   SCM_MAKE_EXPANDED_LEXICAL_SET(src, name, gensym, exp)
  65 #define MODULE_REF(src, mod, name, public) \
  66   SCM_MAKE_EXPANDED_MODULE_REF(src, mod, name, public)
  67 #define MODULE_SET(src, mod, name, public, exp) \
  68   SCM_MAKE_EXPANDED_MODULE_SET(src, mod, name, public, exp)
  69 #define TOPLEVEL_REF(src, name) \
  70   SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, name)
  71 #define TOPLEVEL_SET(src, name, exp) \
  72   SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, name, exp)
  73 #define TOPLEVEL_DEFINE(src, name, exp) \
  74   SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp)
  75 #define CONDITIONAL(src, test, consequent, alternate) \
  76   SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
  77 #define PRIMCALL(src, name, exps) \
  78   SCM_MAKE_EXPANDED_PRIMCALL(src, name, exps)
  79 #define CALL(src, proc, exps) \
  80   SCM_MAKE_EXPANDED_CALL(src, proc, exps)
  81 #define SEQ(src, head, tail) \
  82   SCM_MAKE_EXPANDED_SEQ(src, head, tail)
  83 #define LAMBDA(src, meta, body) \
  84   SCM_MAKE_EXPANDED_LAMBDA(src, meta, body)
  85 #define LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \
  86   SCM_MAKE_EXPANDED_LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate)
  87 #define LET(src, names, gensyms, vals, body) \
  88   SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body)
  89 #define LETREC(src, in_order_p, names, gensyms, vals, body) \
  90   SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body)
  91 #define DYNLET(src, fluids, vals, body) \
  92   SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body)
  93
  94 #define CAR(x)   SCM_CAR(x)
  95 #define CDR(x)   SCM_CDR(x)
  96 #define CAAR(x)  SCM_CAAR(x)
  97 #define CADR(x)  SCM_CADR(x)
  98 #define CDAR(x)  SCM_CDAR(x)
  99 #define CDDR(x)  SCM_CDDR(x)
 100 #define CADDR(x) SCM_CADDR(x)
 101 #define CDDDR(x) SCM_CDDDR(x)
 102 #define CADDDR(x) SCM_CADDDR(x)
 103
 104
 105 static const char s_bad_expression[] = "Bad expression";
 106 static const char s_expression[] = "Missing or extra expression in";
 107 static const char s_missing_expression[] = "Missing expression in";
 108 static const char s_extra_expression[] = "Extra expression in";
 109 static const char s_empty_combination[] = "Illegal empty combination";
 110 static const char s_missing_body_expression[] = "Missing body expression in";
 111 static const char s_mixed_body_forms[] = "Mixed definitions and expressions in";
 112 static const char s_bad_define[] = "Bad define placement";
 113 static const char s_missing_clauses[] = "Missing clauses";
 114 static const char s_misplaced_else_clause[] = "Misplaced else clause";
 115 static const char s_bad_case_clause[] = "Bad case clause";
 116 static const char s_bad_case_labels[] = "Bad case labels";
 117 static const char s_duplicate_case_label[] = "Duplicate case label";
 118 static const char s_bad_cond_clause[] = "Bad cond clause";
 119 static const char s_missing_recipient[] = "Missing recipient in";
 120 static const char s_bad_variable[] = "Bad variable";
 121 static const char s_bad_bindings[] = "Bad bindings";
 122 static const char s_bad_binding[] = "Bad binding";
 123 static const char s_duplicate_binding[] = "Duplicate binding";
 124 static const char s_bad_exit_clause[] = "Bad exit clause";
 125 static const char s_bad_formals[] = "Bad formals";
 126 static const char s_bad_formal[] = "Bad formal";
 127 static const char s_duplicate_formal[] = "Duplicate formal";
 128 static const char s_splicing[] = "Non-list result for unquote-splicing";
 129 static const char s_bad_slot_number[] = "Bad slot number";
 130
 131 static void syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN;
 132
 133 SCM_SYMBOL (syntax_error_key, "syntax-error");
 134
 135 /* Shortcut macros to simplify syntax error handling. */
 136 #define ASSERT_SYNTAX(cond, message, form)              \
 137   { if (SCM_UNLIKELY (!(cond)))                 \
 138       syntax_error (message, form, SCM_UNDEFINED); }
 139 #define ASSERT_SYNTAX_2(cond, message, form, expr)      \
 140   { if (SCM_UNLIKELY (!(cond)))                 \
 141       syntax_error (message, form, expr); }
 142
 143
 144 \f
 145
 146 /* Primitive syntax.  */
 147
 148 #define SCM_SYNTAX(STR, CFN)  \
 149 SCM_SNARF_HERE(static SCM CFN (SCM xorig, SCM env))                     \
 150 SCM_SNARF_INIT(scm_c_define (STR, scm_i_make_primitive_macro (STR, CFN)))
 151
 152
 153 /* True primitive syntax */
 154 SCM_SYNTAX ("@", expand_at);
 155 SCM_SYNTAX ("@@", expand_atat);
 156 SCM_SYNTAX ("begin", expand_begin);
 157 SCM_SYNTAX ("define", expand_define);
 158 SCM_SYNTAX ("with-fluids", expand_with_fluids);
 159 SCM_SYNTAX ("eval-when", expand_eval_when);
 160 SCM_SYNTAX ("if", expand_if);
 161 SCM_SYNTAX ("lambda", expand_lambda);
 162 SCM_SYNTAX ("let", expand_let);
 163 SCM_SYNTAX ("quote", expand_quote);
 164 SCM_SYNTAX ("set!", expand_set_x);
 165
 166 /* Convenient syntax during boot, expands to primitive syntax. Replaced after
 167    psyntax boots. */
 168 SCM_SYNTAX ("and", expand_and);
 169 SCM_SYNTAX ("cond", expand_cond);
 170 SCM_SYNTAX ("letrec", expand_letrec);
 171 SCM_SYNTAX ("letrec*", expand_letrec_star);
 172 SCM_SYNTAX ("let*", expand_letstar);
 173 SCM_SYNTAX ("or", expand_or);
 174 SCM_SYNTAX ("lambda*", expand_lambda_star);
 175 SCM_SYNTAX ("case-lambda", expand_case_lambda);
 176 SCM_SYNTAX ("case-lambda*", expand_case_lambda_star);
 177
 178
 179 SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply");
 180 SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
 181 SCM_GLOBAL_SYMBOL (scm_sym_at, "@");
 182 SCM_GLOBAL_SYMBOL (scm_sym_atat, "@@");
 183 SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
 184 SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
 185 SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
 186 SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
 187 SCM_GLOBAL_SYMBOL (scm_sym_at_dynamic_wind, "@dynamic-wind");
 188 SCM_GLOBAL_SYMBOL (scm_sym_with_fluids, "with-fluids");
 189 SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
 190 SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
 191 SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
 192 SCM_GLOBAL_SYMBOL (scm_sym_lambda, "lambda");
 193 SCM_GLOBAL_SYMBOL (scm_sym_let, "let");
 194 SCM_GLOBAL_SYMBOL (scm_sym_letrec, "letrec");
 195 SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*");
 196 SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
 197 SCM_SYMBOL (sym_call_with_prompt, "call-with-prompt");
 198 SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
 199 SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
 200 SCM_SYMBOL (sym_lambda_star, "lambda*");
 201 SCM_SYMBOL (sym_eval, "eval");
 202 SCM_SYMBOL (sym_load, "load");
 203 SCM_SYMBOL (sym_primitive, "primitive");
 204
 205 SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
 206 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
 207 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
 208
 209 SCM_KEYWORD (kw_allow_other_keys, "allow-other-keys");
 210 SCM_KEYWORD (kw_optional, "optional");
 211 SCM_KEYWORD (kw_key, "key");
 212 SCM_KEYWORD (kw_rest, "rest");
 213
 214
 215 \f
 216
 217
 218 /* Signal a syntax error.  We distinguish between the form that caused the
 219  * error and the enclosing expression.  The error message will print out as
 220  * shown in the following pattern.  The file name and line number are only
 221  * given when they can be determined from the erroneous form or from the
 222  * enclosing expression.
 223  *
 224  * <filename>: In procedure memoization:
 225  * <filename>: In file <name>, line <nr>: <error-message> in <expression>.  */
 226
 227 static void
 228 syntax_error (const char* const msg, const SCM form, const SCM expr)
 229 {
 230   SCM msg_string = scm_from_locale_string (msg);
 231   SCM filename = SCM_BOOL_F;
 232   SCM linenr = SCM_BOOL_F;
 233   const char *format;
 234   SCM args;
 235
 236   if (scm_is_pair (form))
 237     {
 238       filename = scm_source_property (form, scm_sym_filename);
 239       linenr = scm_source_property (form, scm_sym_line);
 240     }
 241
 242   if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
 243     {
 244       filename = scm_source_property (expr, scm_sym_filename);
 245       linenr = scm_source_property (expr, scm_sym_line);
 246     }
 247
 248   if (!SCM_UNBNDP (expr))
 249     {
 250       if (scm_is_true (filename))
 251         {
 252           format = "In file ~S, line ~S: ~A ~S in expression ~S.";
 253           args = scm_list_5 (filename, linenr, msg_string, form, expr);
 254         }
 255       else if (scm_is_true (linenr))
 256         {
 257           format = "In line ~S: ~A ~S in expression ~S.";
 258           args = scm_list_4 (linenr, msg_string, form, expr);
 259         }
 260       else
 261         {
 262           format = "~A ~S in expression ~S.";
 263           args = scm_list_3 (msg_string, form, expr);
 264         }
 265     }
 266   else
 267     {
 268       if (scm_is_true (filename))
 269         {
 270           format = "In file ~S, line ~S: ~A ~S.";
 271           args = scm_list_4 (filename, linenr, msg_string, form);
 272         }
 273       else if (scm_is_true (linenr))
 274         {
 275           format = "In line ~S: ~A ~S.";
 276           args = scm_list_3 (linenr, msg_string, form);
 277         }
 278       else
 279         {
 280           format = "~A ~S.";
 281           args = scm_list_2 (msg_string, form);
 282         }
 283     }
 284
 285   scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
 286 }
 287
 288
 289 \f
 290
 291
 292 static int
 293 expand_env_var_is_free (SCM env, SCM x)
 294 {
 295   for (; scm_is_pair (env); env = CDR (env))
 296     if (scm_is_eq (x, CAAR (env)))
 297       return 0; /* bound */
 298   return 1; /* free */
 299 }
 300
 301 static SCM
 302 expand_env_ref_macro (SCM env, SCM x)
 303 {
 304   SCM var;
 305   if (!expand_env_var_is_free (env, x))
 306     return SCM_BOOL_F; /* lexical */
 307
 308   var = scm_module_variable (scm_current_module (), x);
 309   if (scm_is_true (var) && scm_is_true (scm_variable_bound_p (var))
 310       && scm_is_true (scm_macro_p (scm_variable_ref (var))))
 311     return scm_variable_ref (var);
 312   else
 313     return SCM_BOOL_F; /* anything else */
 314 }
 315
 316 static SCM
 317 expand_env_lexical_gensym (SCM env, SCM name)
 318 {
 319   for (; scm_is_pair (env); env = CDR (env))
 320     if (scm_is_eq (name, CAAR (env)))
 321       return CDAR (env); /* bound */
 322   return SCM_BOOL_F; /* free */
 323 }
 324
 325 static SCM
 326 expand_env_extend (SCM env, SCM names, SCM vars)
 327 {
 328   while (scm_is_pair (names))
 329     {
 330       env = scm_acons (CAR (names), CAR (vars), env);
 331       names = CDR (names);
 332       vars = CDR (vars);
 333     }
 334   return env;
 335 }
 336
 337 static SCM
 338 expand (SCM exp, SCM env)
 339 {
 340   if (scm_is_pair (exp))
 341     {
 342       SCM car;
 343       scm_t_macro_primitive trans = NULL;
 344       SCM macro = SCM_BOOL_F;
 345
 346       car = CAR (exp);
 347       if (scm_is_symbol (car))
 348         macro = expand_env_ref_macro (env, car);
 349
 350       if (scm_is_true (macro))
 351         trans = scm_i_macro_primitive (macro);
 352
 353       if (trans)
 354         return trans (exp, env);
 355       else
 356         {
 357           SCM arg_exps = SCM_EOL;
 358           SCM args = SCM_EOL;
 359           SCM proc = expand (CAR (exp), env);
 360
 361           for (arg_exps = CDR (exp); scm_is_pair (arg_exps);
 362                arg_exps = CDR (arg_exps))
 363             args = scm_cons (expand (CAR (arg_exps), env), args);
 364           args = scm_reverse_x (args, SCM_UNDEFINED);
 365
 366           if (!scm_is_null (arg_exps))
 367             syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
 368
 369           if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_PRIMITIVE_REF)
 370             return PRIMCALL (scm_source_properties (exp),
 371                              SCM_EXPANDED_REF (proc, PRIMITIVE_REF, NAME),
 372                              args);
 373           else
 374             return CALL (scm_source_properties (exp), proc, args);
 375         }
 376     }
 377   else if (scm_is_symbol (exp))
 378     {
 379       SCM gensym = expand_env_lexical_gensym (env, exp);
 380       if (scm_is_true (gensym))
 381         return LEXICAL_REF (SCM_BOOL_F, exp, gensym);
 382       else
 383         return TOPLEVEL_REF (SCM_BOOL_F, exp);
 384     }
 385   else
 386     return CONST_ (SCM_BOOL_F, exp);
 387 }
 388
 389 static SCM
 390 expand_exprs (SCM forms, const SCM env)
 391 {
 392   SCM ret = SCM_EOL;
 393
 394   for (; !scm_is_null (forms); forms = CDR (forms))
 395     ret = scm_cons (expand (CAR (forms), env), ret);
 396   return scm_reverse_x (ret, SCM_UNDEFINED);
 397 }
 398
 399 static SCM
 400 expand_sequence (const SCM forms, const SCM env)
 401 {
 402   ASSERT_SYNTAX (scm_ilength (forms) >= 1, s_bad_expression,
 403                  scm_cons (scm_sym_begin, forms));
 404   if (scm_is_null (CDR (forms)))
 405     return expand (CAR (forms), env);
 406   else
 407     return SEQ (scm_source_properties (forms),
 408                 expand (CAR (forms), env),
 409                 expand_sequence (CDR (forms), env));
 410 }
 411
 412
 413 \f
 414
 415
 416 static SCM
 417 expand_at (SCM expr, SCM env SCM_UNUSED)
 418 {
 419   ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
 420   ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
 421   ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
 422
 423   return MODULE_REF (scm_source_properties (expr),
 424                      CADR (expr), CADDR (expr), SCM_BOOL_T);
 425 }
 426
 427 static SCM
 428 expand_atat (SCM expr, SCM env SCM_UNUSED)
 429 {
 430   ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
 431   ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
 432
 433   if (scm_is_eq (CADR (expr), sym_primitive))
 434     return PRIMITIVE_REF (scm_source_properties (expr), CADDR (expr));
 435
 436   ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
 437   return MODULE_REF (scm_source_properties (expr),
 438                      CADR (expr), CADDR (expr), SCM_BOOL_F);
 439 }
 440
 441 static SCM
 442 expand_and (SCM expr, SCM env)
 443 {
 444   const SCM cdr_expr = CDR (expr);
 445
 446   if (scm_is_null (cdr_expr))
 447     return CONST_ (SCM_BOOL_F, SCM_BOOL_T);
 448
 449   ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);
 450
 451   if (scm_is_null (CDR (cdr_expr)))
 452     return expand (CAR (cdr_expr), env);
 453   else
 454     return CONDITIONAL (scm_source_properties (expr),
 455                         expand (CAR (cdr_expr), env),
 456                         expand_and (cdr_expr, env),
 457                         CONST_ (SCM_BOOL_F, SCM_BOOL_F));
 458 }
 459
 460 static SCM
 461 expand_begin (SCM expr, SCM env)
 462 {
 463   const SCM cdr_expr = CDR (expr);
 464   ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_bad_expression, expr);
 465   return expand_sequence (cdr_expr, env);
 466 }
 467
 468 static SCM
 469 expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env)
 470 {
 471   SCM test;
 472   const long length = scm_ilength (clause);
 473   ASSERT_SYNTAX (length >= 1, s_bad_cond_clause, clause);
 474
 475   test = CAR (clause);
 476   if (scm_is_eq (test, scm_sym_else) && elp)
 477     {
 478       const int last_clause_p = scm_is_null (rest);
 479       ASSERT_SYNTAX (length >= 2, s_bad_cond_clause, clause);
 480       ASSERT_SYNTAX (last_clause_p, s_misplaced_else_clause, clause);
 481       return expand_sequence (CDR (clause), env);
 482     }
 483
 484   if (scm_is_null (rest))
 485     rest = VOID_ (SCM_BOOL_F);
 486   else
 487     rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env);
 488
 489   if (length >= 2
 490       && scm_is_eq (CADR (clause), scm_sym_arrow)
 491       && alp)
 492     {
 493       SCM tmp = scm_gensym (scm_from_locale_string ("cond "));
 494       SCM new_env = scm_acons (tmp, tmp, env);
 495       ASSERT_SYNTAX (length > 2, s_missing_recipient, clause);
 496       ASSERT_SYNTAX (length == 3, s_extra_expression, clause);
 497       return LET (SCM_BOOL_F,
 498                   scm_list_1 (tmp),
 499                   scm_list_1 (tmp),
 500                   scm_list_1 (expand (test, env)),
 501                   CONDITIONAL (SCM_BOOL_F,
 502                                LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
 503                                CALL (SCM_BOOL_F,
 504                                      expand (CADDR (clause), new_env),
 505                                      scm_list_1 (LEXICAL_REF (SCM_BOOL_F,
 506                                                               tmp, tmp))),
 507                                rest));
 508     }
 509   /* FIXME length == 1 case */
 510   else
 511     return CONDITIONAL (SCM_BOOL_F,
 512                         expand (test, env),
 513                         expand_sequence (CDR (clause), env),
 514                         rest);
 515 }
 516
 517 static SCM
 518 expand_cond (SCM expr, SCM env)
 519 {
 520   const int else_literal_p = expand_env_var_is_free (env, scm_sym_else);
 521   const int arrow_literal_p = expand_env_var_is_free (env, scm_sym_arrow);
 522   const SCM clauses = CDR (expr);
 523
 524   ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr);
 525   ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr);
 526
 527   return expand_cond_clauses (CAR (clauses), CDR (clauses),
 528                               else_literal_p, arrow_literal_p, env);
 529 }
 530
 531 /* lone forward decl */
 532 static SCM expand_lambda (SCM expr, SCM env);
 533
 534 /* According to Section 5.2.1 of R5RS we first have to make sure that the
 535    variable is bound, and then perform the `(set! variable expression)'
 536    operation.  However, EXPRESSION _can_ be evaluated before VARIABLE is
 537    bound.  This means that EXPRESSION won't necessarily be able to assign
 538    values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'.  */
 539 static SCM
 540 expand_define (SCM expr, SCM env)
 541 {
 542   const SCM cdr_expr = CDR (expr);
 543   SCM body;
 544   SCM variable;
 545
 546   ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
 547   ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
 548   ASSERT_SYNTAX (!scm_is_pair (env), s_bad_define, expr);
 549
 550   body = CDR (cdr_expr);
 551   variable = CAR (cdr_expr);
 552
 553   if (scm_is_pair (variable))
 554     {
 555       ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr);
 556       return TOPLEVEL_DEFINE
 557         (scm_source_properties (expr),
 558          CAR (variable),
 559          expand_lambda (scm_cons (scm_sym_lambda, scm_cons (CDR (variable), body)),
 560                         env));
 561     }
 562   ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
 563   ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
 564   return TOPLEVEL_DEFINE (scm_source_properties (expr), variable,
 565                           expand (CAR (body), env));
 566 }
 567
 568 static SCM
 569 expand_with_fluids (SCM expr, SCM env)
 570 {
 571   SCM binds, fluids, vals;
 572   ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
 573   binds = CADR (expr);
 574   ASSERT_SYNTAX_2 (scm_ilength (binds) >= 0, s_bad_bindings, binds, expr);
 575   for (fluids = SCM_EOL, vals = SCM_EOL;
 576        scm_is_pair (binds);
 577        binds = CDR (binds))
 578     {
 579       SCM binding = CAR (binds);
 580       ASSERT_SYNTAX_2 (scm_ilength (CAR (binds)) == 2, s_bad_binding,
 581                        binding, expr);
 582       fluids = scm_cons (expand (CAR (binding), env), fluids);
 583       vals = scm_cons (expand (CADR (binding), env), vals);
 584     }
 585
 586   return DYNLET (scm_source_properties (expr),
 587                  scm_reverse_x (fluids, SCM_UNDEFINED),
 588                  scm_reverse_x (vals, SCM_UNDEFINED),
 589                  expand_sequence (CDDR (expr), env));
 590 }
 591
 592 static SCM
 593 expand_eval_when (SCM expr, SCM env)
 594 {
 595   ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
 596   ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
 597
 598   if (scm_is_true (scm_memq (sym_eval, CADR (expr)))
 599       || scm_is_true (scm_memq (sym_load, CADR (expr))))
 600     return expand_sequence (CDDR (expr), env);
 601   else
 602     return VOID_ (scm_source_properties (expr));
 603 }
 604
 605 static SCM
 606 expand_if (SCM expr, SCM env SCM_UNUSED)
 607 {
 608   const SCM cdr_expr = CDR (expr);
 609   const long length = scm_ilength (cdr_expr);
 610   ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
 611   return CONDITIONAL (scm_source_properties (expr),
 612                       expand (CADR (expr), env),
 613                       expand (CADDR (expr), env),
 614                       ((length == 3)
 615                        ? expand (CADDDR (expr), env)
 616                        : VOID_ (SCM_BOOL_F)));
 617 }
 618
 619 /* A helper function for expand_lambda to support checking for duplicate
 620  * formal arguments: Return true if OBJ is `eq?' to one of the elements of
 621  * LIST or to the CDR of the last cons.  Therefore, LIST may have any of the
 622  * forms that a formal argument can have:
 623  *   <rest>, (<arg1> ...), (<arg1> ...  .  <rest>) */
 624 static int
 625 c_improper_memq (SCM obj, SCM list)
 626 {
 627   for (; scm_is_pair (list); list = CDR (list))
 628     {
 629       if (scm_is_eq (CAR (list), obj))
 630         return 1;
 631     }
 632   return scm_is_eq (list, obj);
 633 }
 634
 635 static SCM
 636 expand_lambda_case (SCM clause, SCM alternate, SCM env)
 637 {
 638   SCM formals;
 639   SCM rest;
 640   SCM req = SCM_EOL;
 641   SCM vars = SCM_EOL;
 642   SCM body;
 643   int nreq = 0;
 644
 645   ASSERT_SYNTAX (scm_is_pair (clause) && scm_is_pair (CDR (clause)),
 646                  s_bad_expression, scm_cons (scm_sym_lambda, clause));
 647
 648   /* Before iterating the list of formal arguments, make sure the formals
 649    * actually are given as either a symbol or a non-cyclic list.  */
 650   formals = CAR (clause);
 651   if (scm_is_pair (formals))
 652     {
 653       /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
 654        * detected, report a 'Bad formals' error.  */
 655     }
 656   else
 657     ASSERT_SYNTAX_2 (scm_is_symbol (formals) || scm_is_null (formals),
 658                      s_bad_formals, formals, scm_cons (scm_sym_lambda, clause));
 659
 660   /* Now iterate the list of formal arguments to check if all formals are
 661    * symbols, and that there are no duplicates.  */
 662   while (scm_is_pair (formals))
 663     {
 664       const SCM formal = CAR (formals);
 665       formals = CDR (formals);
 666       ASSERT_SYNTAX_2 (scm_is_symbol (formal), s_bad_formal, formal,
 667                        scm_cons (scm_sym_lambda, clause));
 668       ASSERT_SYNTAX_2 (!c_improper_memq (formal, formals), s_duplicate_formal,
 669                        formal, scm_cons (scm_sym_lambda, clause));
 670       nreq++;
 671       req = scm_cons (formal, req);
 672       vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
 673       env = scm_acons (formal, CAR (vars), env);
 674     }
 675
 676   ASSERT_SYNTAX_2 (scm_is_null (formals) || scm_is_symbol (formals),
 677                    s_bad_formal, formals, scm_cons (scm_sym_lambda, clause));
 678   if (scm_is_symbol (formals))
 679     {
 680       rest = formals;
 681       vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
 682       env = scm_acons (rest, CAR (vars), env);
 683     }
 684   else
 685     rest = SCM_BOOL_F;
 686
 687   body = expand_sequence (CDR (clause), env);
 688   req = scm_reverse_x (req, SCM_UNDEFINED);
 689   vars = scm_reverse_x (vars, SCM_UNDEFINED);
 690
 691   if (scm_is_true (alternate) && !(SCM_EXPANDED_P (alternate) && SCM_EXPANDED_TYPE (alternate) == SCM_EXPANDED_LAMBDA_CASE))
 692     abort ();
 693
 694   return LAMBDA_CASE (SCM_BOOL_F, req, SCM_BOOL_F, rest, SCM_BOOL_F,
 695                       SCM_EOL, vars, body, alternate);
 696 }
 697
 698 static SCM
 699 expand_lambda (SCM expr, SCM env)
 700 {
 701   return LAMBDA (scm_source_properties (expr),
 702                  SCM_EOL,
 703                  expand_lambda_case (CDR (expr), SCM_BOOL_F, env));
 704 }
 705
 706 static SCM
 707 expand_lambda_star_case (SCM clause, SCM alternate, SCM env)
 708 {
 709   SCM req, opt, kw, allow_other_keys, rest, formals, vars, body, tmp;
 710   SCM inits;
 711   int nreq, nopt;
 712
 713   const long length = scm_ilength (clause);
 714   ASSERT_SYNTAX (length >= 1, s_bad_expression,
 715                  scm_cons (sym_lambda_star, clause));
 716   ASSERT_SYNTAX (length >= 2, s_missing_expression,
 717                  scm_cons (sym_lambda_star, clause));
 718
 719   formals = CAR (clause);
 720   body = CDR (clause);
 721
 722   nreq = nopt = 0;
 723   req = opt = kw = SCM_EOL;
 724   rest = allow_other_keys = SCM_BOOL_F;
 725
 726   while (scm_is_pair (formals) && scm_is_symbol (CAR (formals)))
 727     {
 728       nreq++;
 729       req = scm_cons (CAR (formals), req);
 730       formals = scm_cdr (formals);
 731     }
 732
 733   if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_optional))
 734     {
 735       formals = CDR (formals);
 736       while (scm_is_pair (formals)
 737              && (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
 738         {
 739           nopt++;
 740           opt = scm_cons (CAR (formals), opt);
 741           formals = scm_cdr (formals);
 742         }
 743     }
 744
 745   if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_key))
 746     {
 747       formals = CDR (formals);
 748       while (scm_is_pair (formals)
 749              && (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
 750         {
 751           kw = scm_cons (CAR (formals), kw);
 752           formals = scm_cdr (formals);
 753         }
 754     }
 755
 756   if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_allow_other_keys))
 757     {
 758       formals = CDR (formals);
 759       allow_other_keys = SCM_BOOL_T;
 760     }
 761
 762   if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_rest))
 763     {
 764       ASSERT_SYNTAX (scm_ilength (formals) == 2, s_bad_formals,
 765                      CAR (clause));
 766       rest = CADR (formals);
 767     }
 768   else if (scm_is_symbol (formals))
 769     rest = formals;
 770   else
 771     {
 772       ASSERT_SYNTAX (scm_is_null (formals), s_bad_formals, CAR (clause));
 773       rest = SCM_BOOL_F;
 774     }
 775
 776   /* Now, iterate through them a second time, building up an expansion-time
 777      environment, checking, expanding and canonicalizing the opt/kw init forms,
 778      and eventually memoizing the body as well. Note that the rest argument, if
 779      any, is expanded before keyword args, thus necessitating the second
 780      pass.
 781
 782      Also note that the specific environment during expansion of init
 783      expressions here needs to coincide with the environment when psyntax
 784      expands. A lot of effort for something that is only used in the bootstrap
 785      expandr, you say? Yes. Yes it is.
 786   */
 787
 788   vars = SCM_EOL;
 789   req = scm_reverse_x (req, SCM_EOL);
 790   for (tmp = req; scm_is_pair (tmp); tmp = scm_cdr (tmp))
 791     {
 792       vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
 793       env = scm_acons (CAR (tmp), CAR (vars), env);
 794     }
 795
 796   /* Build up opt inits and env */
 797   inits = SCM_EOL;
 798   opt = scm_reverse_x (opt, SCM_EOL);
 799   for (tmp = opt; scm_is_pair (tmp); tmp = scm_cdr (tmp))
 800     {
 801       SCM x = CAR (tmp);
 802       vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
 803       env = scm_acons (x, CAR (vars), env);
 804       if (scm_is_symbol (x))
 805         inits = scm_cons (CONST_ (SCM_BOOL_F, SCM_BOOL_F), inits);
 806       else
 807         {
 808           ASSERT_SYNTAX (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)),
 809                          s_bad_formals, CAR (clause));
 810           inits = scm_cons (expand (CADR (x), env), inits);
 811         }
 812       env = scm_acons (scm_is_symbol (x) ? x : CAR (x), CAR (vars), env);
 813     }
 814   if (scm_is_null (opt))
 815     opt = SCM_BOOL_F;
 816
 817   /* Process rest before keyword args */
 818   if (scm_is_true (rest))
 819     {
 820       vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
 821       env = scm_acons (rest, CAR (vars), env);
 822     }
 823
 824   /* Build up kw inits, env, and kw-canon list */
 825   if (scm_is_null (kw))
 826     kw = SCM_BOOL_F;
 827   else
 828     {
 829       SCM kw_canon = SCM_EOL;
 830       kw = scm_reverse_x (kw, SCM_UNDEFINED);
 831       for (tmp = kw; scm_is_pair (tmp); tmp = scm_cdr (tmp))
 832         {
 833           SCM x, sym, k, init;
 834           x = CAR (tmp);
 835           if (scm_is_symbol (x))
 836             {
 837               sym = x;
 838               init = SCM_BOOL_F;
 839               k = scm_symbol_to_keyword (sym);
 840             }
 841           else if (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)))
 842             {
 843               sym = CAR (x);
 844               init = CADR (x);
 845               k = scm_symbol_to_keyword (sym);
 846             }
 847           else if (scm_ilength (x) == 3 && scm_is_symbol (CAR (x))
 848                    && scm_is_keyword (CADDR (x)))
 849             {
 850               sym = CAR (x);
 851               init = CADR (x);
 852               k = CADDR (x);
 853             }
 854           else
 855             syntax_error (s_bad_formals, CAR (clause), SCM_UNDEFINED);
 856
 857           inits = scm_cons (expand (init, env), inits);
 858           vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
 859           kw_canon = scm_cons (scm_list_3 (k, sym, CAR (vars)), kw_canon);
 860           env = scm_acons (sym, CAR (vars), env);
 861         }
 862       kw_canon = scm_reverse_x (kw_canon, SCM_UNDEFINED);
 863       kw = scm_cons (allow_other_keys, kw_canon);
 864     }
 865
 866   /* We should check for no duplicates, but given that psyntax does this
 867      already, we can punt on it here... */
 868
 869   vars = scm_reverse_x (vars, SCM_UNDEFINED);
 870   inits = scm_reverse_x (inits, SCM_UNDEFINED);
 871   body = expand_sequence (body, env);
 872
 873   return LAMBDA_CASE (SCM_BOOL_F, req, opt, rest, kw, inits, vars, body,
 874                       alternate);
 875 }
 876
 877 static SCM
 878 expand_lambda_star (SCM expr, SCM env)
 879 {
 880   return LAMBDA (scm_source_properties (expr),
 881                  SCM_EOL,
 882                  expand_lambda_star_case (CDR (expr), SCM_BOOL_F, env));
 883 }
 884
 885 static SCM
 886 expand_case_lambda_clauses (SCM expr, SCM rest, SCM env)
 887 {
 888   SCM alt;
 889
 890   if (scm_is_pair (rest))
 891     alt = expand_case_lambda_clauses (CAR (rest), CDR (rest), env);
 892   else
 893     alt = SCM_BOOL_F;
 894
 895   return expand_lambda_case (expr, alt, env);
 896 }
 897
 898 static SCM
 899 expand_case_lambda (SCM expr, SCM env)
 900 {
 901   ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr);
 902
 903   return LAMBDA (scm_source_properties (expr),
 904                  SCM_EOL,
 905                  expand_case_lambda_clauses (CADR (expr), CDDR (expr), env));
 906 }
 907
 908 static SCM
 909 expand_case_lambda_star_clauses (SCM expr, SCM rest, SCM env)
 910 {
 911   SCM alt;
 912
 913   if (scm_is_pair (rest))
 914     alt = expand_case_lambda_star_clauses (CAR (rest), CDR (rest), env);
 915   else
 916     alt = SCM_BOOL_F;
 917
 918   return expand_lambda_star_case (expr, alt, env);
 919 }
 920
 921 static SCM
 922 expand_case_lambda_star (SCM expr, SCM env)
 923 {
 924   ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr);
 925
 926   return LAMBDA (scm_source_properties (expr),
 927                  SCM_EOL,
 928                  expand_case_lambda_star_clauses (CADR (expr), CDDR (expr), env));
 929 }
 930
 931 /* Check if the format of the bindings is ((<symbol> <init-form>) ...).  */
 932 static void
 933 check_bindings (const SCM bindings, const SCM expr)
 934 {
 935   SCM binding_idx;
 936
 937   ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
 938                    s_bad_bindings, bindings, expr);
 939
 940   binding_idx = bindings;
 941   for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
 942     {
 943       SCM name;         /* const */
 944
 945       const SCM binding = CAR (binding_idx);
 946       ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
 947                        s_bad_binding, binding, expr);
 948
 949       name = CAR (binding);
 950       ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
 951     }
 952 }
 953
 954 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
 955  * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
 956  * variable name is detected, an error is signalled. */
 957 static void
 958 transform_bindings (const SCM bindings, const SCM expr,
 959                     SCM *const names, SCM *const vars, SCM *const initptr)
 960 {
 961   SCM rnames = SCM_EOL;
 962   SCM rvars = SCM_EOL;
 963   SCM rinits = SCM_EOL;
 964   SCM binding_idx = bindings;
 965   for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
 966     {
 967       const SCM binding = CAR (binding_idx);
 968       const SCM CDR_binding = CDR (binding);
 969       const SCM name = CAR (binding);
 970       ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rnames)),
 971                        s_duplicate_binding, name, expr);
 972       rnames = scm_cons (name, rnames);
 973       rvars = scm_cons (scm_gensym (SCM_UNDEFINED), rvars);
 974       rinits = scm_cons (CAR (CDR_binding), rinits);
 975     }
 976   *names = scm_reverse_x (rnames, SCM_UNDEFINED);
 977   *vars = scm_reverse_x (rvars, SCM_UNDEFINED);
 978   *initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
 979 }
 980
 981 /* FIXME: Remove named let in this boot expander. */
 982 static SCM
 983 expand_named_let (const SCM expr, SCM env)
 984 {
 985   SCM var_names, var_syms, inits;
 986   SCM inner_env;
 987   SCM name_sym;
 988
 989   const SCM cdr_expr = CDR (expr);
 990   const SCM name = CAR (cdr_expr);
 991   const SCM cddr_expr = CDR (cdr_expr);
 992   const SCM bindings = CAR (cddr_expr);
 993   check_bindings (bindings, expr);
 994
 995   transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
 996   name_sym = scm_gensym (SCM_UNDEFINED);
 997   inner_env = scm_acons (name, name_sym, env);
 998   inner_env = expand_env_extend (inner_env, var_names, var_syms);
 999
1000   return LETREC
1001     (scm_source_properties (expr), SCM_BOOL_F,
1002      scm_list_1 (name), scm_list_1 (name_sym),
1003      scm_list_1 (LAMBDA (SCM_BOOL_F,
1004                          SCM_EOL,
1005                          LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_BOOL_F, SCM_BOOL_F,
1006                                       SCM_BOOL_F, SCM_BOOL_F, var_syms,
1007                                       expand_sequence (CDDDR (expr), inner_env),
1008                                       SCM_BOOL_F))),
1009      CALL (SCM_BOOL_F,
1010            LEXICAL_REF (SCM_BOOL_F, name, name_sym),
1011            expand_exprs (inits, env)));
1012 }
1013
1014 static SCM
1015 expand_let (SCM expr, SCM env)
1016 {
1017   SCM bindings;
1018
1019   const SCM cdr_expr = CDR (expr);
1020   const long length = scm_ilength (cdr_expr);
1021   ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
1022   ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
1023
1024   bindings = CAR (cdr_expr);
1025   if (scm_is_symbol (bindings))
1026     {
1027       ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
1028       return expand_named_let (expr, env);
1029     }
1030
1031   check_bindings (bindings, expr);
1032   if (scm_is_null (bindings))
1033     return expand_sequence (CDDR (expr), env);
1034   else
1035     {
1036       SCM var_names, var_syms, inits;
1037       transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
1038       return LET (SCM_BOOL_F,
1039                   var_names, var_syms, expand_exprs (inits, env),
1040                   expand_sequence (CDDR (expr),
1041                                    expand_env_extend (env, var_names,
1042                                                       var_syms)));
1043     }
1044 }
1045
1046 static SCM
1047 expand_letrec_helper (SCM expr, SCM env, SCM in_order_p)
1048 {
1049   SCM bindings;
1050
1051   const SCM cdr_expr = CDR (expr);
1052   const long length = scm_ilength (cdr_expr);
1053   ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
1054   ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
1055
1056   bindings = CAR (cdr_expr);
1057   check_bindings (bindings, expr);
1058   if (scm_is_null (bindings))
1059     return expand_sequence (CDDR (expr), env);
1060   else
1061     {
1062       SCM var_names, var_syms, inits;
1063       transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
1064       env = expand_env_extend (env, var_names, var_syms);
1065       return LETREC (SCM_BOOL_F, in_order_p,
1066                      var_names, var_syms, expand_exprs (inits, env),
1067                      expand_sequence (CDDR (expr), env));
1068     }
1069 }
1070
1071 static SCM
1072 expand_letrec (SCM expr, SCM env)
1073 {
1074   return expand_letrec_helper (expr, env, SCM_BOOL_F);
1075 }
1076
1077 static SCM
1078 expand_letrec_star (SCM expr, SCM env)
1079 {
1080   return expand_letrec_helper (expr, env, SCM_BOOL_T);
1081 }
1082
1083 static SCM
1084 expand_letstar_clause (SCM bindings, SCM body, SCM env SCM_UNUSED)
1085 {
1086   if (scm_is_null (bindings))
1087     return expand_sequence (body, env);
1088   else
1089     {
1090       SCM bind, name, sym, init;
1091
1092       ASSERT_SYNTAX (scm_is_pair (bindings), s_bad_expression, bindings);
1093       bind = CAR (bindings);
1094       ASSERT_SYNTAX (scm_ilength (bind) == 2, s_bad_binding, bind);
1095       name = CAR (bind);
1096       sym = scm_gensym (SCM_UNDEFINED);
1097       init = CADR (bind);
1098
1099       return LET (SCM_BOOL_F, scm_list_1 (name), scm_list_1 (sym),
1100                   scm_list_1 (expand (init, env)),
1101                   expand_letstar_clause (CDR (bindings), body,
1102                                          scm_acons (name, sym, env)));
1103     }
1104 }
1105
1106 static SCM
1107 expand_letstar (SCM expr, SCM env SCM_UNUSED)
1108 {
1109   const SCM cdr_expr = CDR (expr);
1110   ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1111   ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
1112
1113   return expand_letstar_clause (CADR (expr), CDDR (expr), env);
1114 }
1115
1116 static SCM
1117 expand_or (SCM expr, SCM env SCM_UNUSED)
1118 {
1119   SCM tail = CDR (expr);
1120   const long length = scm_ilength (tail);
1121
1122   ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
1123
1124   if (scm_is_null (CDR (expr)))
1125     return CONST_ (SCM_BOOL_F, SCM_BOOL_F);
1126   else
1127     {
1128       SCM tmp = scm_gensym (SCM_UNDEFINED);
1129       return LET (SCM_BOOL_F,
1130                   scm_list_1 (tmp), scm_list_1 (tmp),
1131                   scm_list_1 (expand (CADR (expr), env)),
1132                   CONDITIONAL (SCM_BOOL_F,
1133                                LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
1134                                LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
1135                                expand_or (CDR (expr),
1136                                           scm_acons (tmp, tmp, env))));
1137     }
1138 }
1139
1140 static SCM
1141 expand_quote (SCM expr, SCM env SCM_UNUSED)
1142 {
1143   SCM quotee;
1144
1145   const SCM cdr_expr = CDR (expr);
1146   ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1147   ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
1148   quotee = CAR (cdr_expr);
1149   return CONST_ (scm_source_properties (expr), quotee);
1150 }
1151
1152 static SCM
1153 expand_set_x (SCM expr, SCM env)
1154 {
1155   SCM variable;
1156   SCM vmem;
1157
1158   const SCM cdr_expr = CDR (expr);
1159   ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1160   ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
1161   variable = CAR (cdr_expr);
1162   vmem = expand (variable, env);
1163
1164   switch (SCM_EXPANDED_TYPE (vmem))
1165     {
1166     case SCM_EXPANDED_LEXICAL_REF:
1167       return LEXICAL_SET (scm_source_properties (expr),
1168                           SCM_EXPANDED_REF (vmem, LEXICAL_REF, NAME),
1169                           SCM_EXPANDED_REF (vmem, LEXICAL_REF, GENSYM),
1170                           expand (CADDR (expr), env));
1171     case SCM_EXPANDED_TOPLEVEL_REF:
1172       return TOPLEVEL_SET (scm_source_properties (expr),
1173                            SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, NAME),
1174                            expand (CADDR (expr), env));
1175     case SCM_EXPANDED_MODULE_REF:
1176       return MODULE_SET (scm_source_properties (expr),
1177                          SCM_EXPANDED_REF (vmem, MODULE_REF, MOD),
1178                          SCM_EXPANDED_REF (vmem, MODULE_REF, NAME),
1179                          SCM_EXPANDED_REF (vmem, MODULE_REF, PUBLIC),
1180                          expand (CADDR (expr), env));
1181     default:
1182       syntax_error (s_bad_variable, variable, expr);
1183     }
1184 }
1185
1186
1187 \f
1188
1189 /* This is the boot expander. It is later replaced with psyntax's sc-expand. */
1190 SCM_DEFINE (scm_macroexpand, "macroexpand", 1, 0, 0,
1191             (SCM exp),
1192             "Expand the expression @var{exp}.")
1193 #define FUNC_NAME s_scm_macroexpand
1194 {
1195   return expand (exp, scm_current_module ());
1196 }
1197 #undef FUNC_NAME
1198
1199 SCM_DEFINE (scm_macroexpanded_p, "macroexpanded?", 1, 0, 0,
1200             (SCM exp),
1201             "Return @code{#t} if @var{exp} is an expanded expression.")
1202 #define FUNC_NAME s_scm_macroexpanded_p
1203 {
1204   return scm_from_bool (SCM_EXPANDED_P (exp));
1205 }
1206 #undef FUNC_NAME
1207
1208
1209  \f
1210
1211 #define DEFINE_NAMES(type)                                              \
1212   {                                                                     \
1213     static const char *fields[] = SCM_EXPANDED_##type##_FIELD_NAMES;    \
1214     exp_field_names[SCM_EXPANDED_##type] = fields;                      \
1215     exp_names[SCM_EXPANDED_##type] = SCM_EXPANDED_##type##_TYPE_NAME;   \
1216     exp_nfields[SCM_EXPANDED_##type] = SCM_NUM_EXPANDED_##type##_FIELDS; \
1217   }
1218
1219 static SCM
1220 make_exp_vtable (size_t n)
1221 {
1222   SCM layout, printer, name, code, fields;
1223
1224   layout = scm_string_to_symbol
1225     (scm_string_append (scm_make_list (scm_from_size_t (exp_nfields[n]),
1226                                        scm_from_locale_string ("pw"))));
1227   printer = SCM_BOOL_F;
1228   name = scm_from_utf8_symbol (exp_names[n]);
1229   code = scm_from_size_t (n);
1230   fields = SCM_EOL;
1231   {
1232     size_t m = exp_nfields[n];
1233     while (m--)
1234       fields = scm_cons (scm_from_utf8_symbol (exp_field_names[n][m]), fields);
1235   }
1236
1237   return scm_c_make_struct (scm_exp_vtable_vtable, 0, 5,
1238                             SCM_UNPACK (layout), SCM_UNPACK (printer), SCM_UNPACK (name),
1239                             SCM_UNPACK (code), SCM_UNPACK (fields));
1240 }
1241
1242 void
1243 scm_init_expand ()
1244 {
1245   size_t n;
1246   SCM exp_vtable_list = SCM_EOL;
1247
1248   DEFINE_NAMES (VOID);
1249   DEFINE_NAMES (CONST);
1250   DEFINE_NAMES (PRIMITIVE_REF);
1251   DEFINE_NAMES (LEXICAL_REF);
1252   DEFINE_NAMES (LEXICAL_SET);
1253   DEFINE_NAMES (MODULE_REF);
1254   DEFINE_NAMES (MODULE_SET);
1255   DEFINE_NAMES (TOPLEVEL_REF);
1256   DEFINE_NAMES (TOPLEVEL_SET);
1257   DEFINE_NAMES (TOPLEVEL_DEFINE);
1258   DEFINE_NAMES (CONDITIONAL);
1259   DEFINE_NAMES (CALL);
1260   DEFINE_NAMES (PRIMCALL);
1261   DEFINE_NAMES (SEQ);
1262   DEFINE_NAMES (LAMBDA);
1263   DEFINE_NAMES (LAMBDA_CASE);
1264   DEFINE_NAMES (LET);
1265   DEFINE_NAMES (LETREC);
1266   DEFINE_NAMES (DYNLET);
1267
1268   scm_exp_vtable_vtable =
1269     scm_make_vtable (scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT "pwuwpw"),
1270                      SCM_BOOL_F);
1271
1272   for (n = 0; n < SCM_NUM_EXPANDED_TYPES; n++)
1273     exp_vtables[n] = make_exp_vtable (n);
1274
1275   /* Now walk back down, consing in reverse. */
1276   while (n--)
1277     exp_vtable_list = scm_cons (exp_vtables[n], exp_vtable_list);
1278
1279   scm_c_define ("%expanded-vtables", scm_vector (exp_vtable_list));
1280
1281 #include "libguile/expand.x"
1282 }
1283
1284 /*
1285   Local Variables:
1286   c-file-style: "gnu"
1287   End:
1288 */