libguile/expand.c

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