libguile/expand.c

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