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