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