| 1 | /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012,2013,2014 |
| 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 SCM const_unbound; |
| 49 | static const char* exp_names[SCM_NUM_EXPANDED_TYPES]; |
| 50 | static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES]; |
| 51 | |
| 52 | |
| 53 | /* The trailing underscores on these first to are to avoid spurious |
| 54 | conflicts with macros defined on MinGW. */ |
| 55 | |
| 56 | #define VOID_(src) \ |
| 57 | SCM_MAKE_EXPANDED_VOID(src) |
| 58 | #define CONST_(src, exp) \ |
| 59 | SCM_MAKE_EXPANDED_CONST(src, exp) |
| 60 | #define PRIMITIVE_REF(src, name) \ |
| 61 | SCM_MAKE_EXPANDED_PRIMITIVE_REF(src, name) |
| 62 | #define LEXICAL_REF(src, name, gensym) \ |
| 63 | SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym) |
| 64 | #define LEXICAL_SET(src, name, gensym, exp) \ |
| 65 | SCM_MAKE_EXPANDED_LEXICAL_SET(src, name, gensym, exp) |
| 66 | #define MODULE_REF(src, mod, name, public) \ |
| 67 | SCM_MAKE_EXPANDED_MODULE_REF(src, mod, name, public) |
| 68 | #define MODULE_SET(src, mod, name, public, exp) \ |
| 69 | SCM_MAKE_EXPANDED_MODULE_SET(src, mod, name, public, exp) |
| 70 | #define TOPLEVEL_REF(src, name) \ |
| 71 | SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, name) |
| 72 | #define TOPLEVEL_SET(src, name, exp) \ |
| 73 | SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, name, exp) |
| 74 | #define TOPLEVEL_DEFINE(src, name, exp) \ |
| 75 | SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp) |
| 76 | #define CONDITIONAL(src, test, consequent, alternate) \ |
| 77 | SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate) |
| 78 | #define PRIMCALL(src, name, exps) \ |
| 79 | SCM_MAKE_EXPANDED_PRIMCALL(src, name, exps) |
| 80 | #define CALL(src, proc, exps) \ |
| 81 | SCM_MAKE_EXPANDED_CALL(src, proc, exps) |
| 82 | #define SEQ(src, head, tail) \ |
| 83 | SCM_MAKE_EXPANDED_SEQ(src, head, tail) |
| 84 | #define LAMBDA(src, meta, body) \ |
| 85 | SCM_MAKE_EXPANDED_LAMBDA(src, meta, body) |
| 86 | #define LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \ |
| 87 | SCM_MAKE_EXPANDED_LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) |
| 88 | #define LET(src, names, gensyms, vals, body) \ |
| 89 | SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body) |
| 90 | #define LETREC(src, in_order_p, names, gensyms, vals, body) \ |
| 91 | SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body) |
| 92 | |
| 93 | #define CAR(x) SCM_CAR(x) |
| 94 | #define CDR(x) SCM_CDR(x) |
| 95 | #define CAAR(x) SCM_CAAR(x) |
| 96 | #define CADR(x) SCM_CADR(x) |
| 97 | #define CDAR(x) SCM_CDAR(x) |
| 98 | #define CDDR(x) SCM_CDDR(x) |
| 99 | #define CADDR(x) SCM_CADDR(x) |
| 100 | #define CDDDR(x) SCM_CDDDR(x) |
| 101 | #define CADDDR(x) SCM_CADDDR(x) |
| 102 | |
| 103 | /* Abbreviate SCM_EXPANDED_REF. */ |
| 104 | #define REF(x,type,field) \ |
| 105 | (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field))) |
| 106 | |
| 107 | |
| 108 | static const char s_bad_expression[] = "Bad expression"; |
| 109 | static const char s_expression[] = "Missing or extra expression in"; |
| 110 | static const char s_missing_expression[] = "Missing expression in"; |
| 111 | static const char s_extra_expression[] = "Extra expression in"; |
| 112 | static const char s_empty_combination[] = "Illegal empty combination"; |
| 113 | static const char s_missing_body_expression[] = "Missing body expression in"; |
| 114 | static const char s_mixed_body_forms[] = "Mixed definitions and expressions in"; |
| 115 | static const char s_bad_define[] = "Bad define placement"; |
| 116 | static const char s_missing_clauses[] = "Missing clauses"; |
| 117 | static const char s_misplaced_else_clause[] = "Misplaced else clause"; |
| 118 | static const char s_bad_case_clause[] = "Bad case clause"; |
| 119 | static const char s_bad_case_labels[] = "Bad case labels"; |
| 120 | static const char s_duplicate_case_label[] = "Duplicate case label"; |
| 121 | static const char s_bad_cond_clause[] = "Bad cond clause"; |
| 122 | static const char s_missing_recipient[] = "Missing recipient in"; |
| 123 | static const char s_bad_variable[] = "Bad variable"; |
| 124 | static const char s_bad_bindings[] = "Bad bindings"; |
| 125 | static const char s_bad_binding[] = "Bad binding"; |
| 126 | static const char s_duplicate_binding[] = "Duplicate binding"; |
| 127 | static const char s_bad_exit_clause[] = "Bad exit clause"; |
| 128 | static const char s_bad_formals[] = "Bad formals"; |
| 129 | static const char s_bad_formal[] = "Bad formal"; |
| 130 | static const char s_duplicate_formal[] = "Duplicate formal"; |
| 131 | static const char s_splicing[] = "Non-list result for unquote-splicing"; |
| 132 | static const char s_bad_slot_number[] = "Bad slot number"; |
| 133 | |
| 134 | static void syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN; |
| 135 | |
| 136 | SCM_SYMBOL (syntax_error_key, "syntax-error"); |
| 137 | |
| 138 | /* Shortcut macros to simplify syntax error handling. */ |
| 139 | #define ASSERT_SYNTAX(cond, message, form) \ |
| 140 | { if (SCM_UNLIKELY (!(cond))) \ |
| 141 | syntax_error (message, form, SCM_UNDEFINED); } |
| 142 | #define ASSERT_SYNTAX_2(cond, message, form, expr) \ |
| 143 | { if (SCM_UNLIKELY (!(cond))) \ |
| 144 | syntax_error (message, form, expr); } |
| 145 | |
| 146 | |
| 147 | \f |
| 148 | |
| 149 | /* Primitive syntax. */ |
| 150 | |
| 151 | #define SCM_SYNTAX(STR, CFN) \ |
| 152 | SCM_SNARF_HERE(static SCM CFN (SCM xorig, SCM env)) \ |
| 153 | SCM_SNARF_INIT(scm_c_define (STR, scm_i_make_primitive_macro (STR, CFN))) |
| 154 | |
| 155 | |
| 156 | /* True primitive syntax */ |
| 157 | SCM_SYNTAX ("@", expand_at); |
| 158 | SCM_SYNTAX ("@@", expand_atat); |
| 159 | SCM_SYNTAX ("begin", expand_begin); |
| 160 | SCM_SYNTAX ("define", expand_define); |
| 161 | SCM_SYNTAX ("eval-when", expand_eval_when); |
| 162 | SCM_SYNTAX ("if", expand_if); |
| 163 | SCM_SYNTAX ("lambda", expand_lambda); |
| 164 | SCM_SYNTAX ("let", expand_let); |
| 165 | SCM_SYNTAX ("quote", expand_quote); |
| 166 | SCM_SYNTAX ("set!", expand_set_x); |
| 167 | |
| 168 | /* Convenient syntax during boot, expands to primitive syntax. Replaced after |
| 169 | psyntax boots. */ |
| 170 | SCM_SYNTAX ("and", expand_and); |
| 171 | SCM_SYNTAX ("cond", expand_cond); |
| 172 | SCM_SYNTAX ("letrec", expand_letrec); |
| 173 | SCM_SYNTAX ("letrec*", expand_letrec_star); |
| 174 | SCM_SYNTAX ("let*", expand_letstar); |
| 175 | SCM_SYNTAX ("or", expand_or); |
| 176 | SCM_SYNTAX ("lambda*", expand_lambda_star); |
| 177 | SCM_SYNTAX ("case-lambda", expand_case_lambda); |
| 178 | SCM_SYNTAX ("case-lambda*", expand_case_lambda_star); |
| 179 | |
| 180 | |
| 181 | SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>"); |
| 182 | SCM_GLOBAL_SYMBOL (scm_sym_at, "@"); |
| 183 | SCM_GLOBAL_SYMBOL (scm_sym_atat, "@@"); |
| 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_else, "else"); |
| 189 | SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when"); |
| 190 | SCM_GLOBAL_SYMBOL (scm_sym_if, "if"); |
| 191 | SCM_GLOBAL_SYMBOL (scm_sym_lambda, "lambda"); |
| 192 | SCM_GLOBAL_SYMBOL (scm_sym_let, "let"); |
| 193 | SCM_GLOBAL_SYMBOL (scm_sym_letrec, "letrec"); |
| 194 | SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*"); |
| 195 | SCM_GLOBAL_SYMBOL (scm_sym_or, "or"); |
| 196 | SCM_SYMBOL (sym_call_with_prompt, "call-with-prompt"); |
| 197 | SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote"); |
| 198 | SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!"); |
| 199 | SCM_SYMBOL (sym_lambda_star, "lambda*"); |
| 200 | SCM_SYMBOL (sym_eval, "eval"); |
| 201 | SCM_SYMBOL (sym_load, "load"); |
| 202 | SCM_SYMBOL (sym_primitive, "primitive"); |
| 203 | |
| 204 | SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote"); |
| 205 | SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote"); |
| 206 | SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing"); |
| 207 | |
| 208 | SCM_KEYWORD (kw_allow_other_keys, "allow-other-keys"); |
| 209 | SCM_KEYWORD (kw_optional, "optional"); |
| 210 | SCM_KEYWORD (kw_key, "key"); |
| 211 | SCM_KEYWORD (kw_rest, "rest"); |
| 212 | |
| 213 | |
| 214 | \f |
| 215 | |
| 216 | |
| 217 | /* Signal a syntax error. We distinguish between the form that caused the |
| 218 | * error and the enclosing expression. The error message will print out as |
| 219 | * shown in the following pattern. The file name and line number are only |
| 220 | * given when they can be determined from the erroneous form or from the |
| 221 | * enclosing expression. |
| 222 | * |
| 223 | * <filename>: In procedure memoization: |
| 224 | * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */ |
| 225 | |
| 226 | static void |
| 227 | syntax_error (const char* const msg, const SCM form, const SCM expr) |
| 228 | { |
| 229 | SCM msg_string = scm_from_locale_string (msg); |
| 230 | SCM filename = SCM_BOOL_F; |
| 231 | SCM linenr = SCM_BOOL_F; |
| 232 | const char *format; |
| 233 | SCM args; |
| 234 | |
| 235 | if (scm_is_pair (form)) |
| 236 | { |
| 237 | filename = scm_source_property (form, scm_sym_filename); |
| 238 | linenr = scm_source_property (form, scm_sym_line); |
| 239 | } |
| 240 | |
| 241 | if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr)) |
| 242 | { |
| 243 | filename = scm_source_property (expr, scm_sym_filename); |
| 244 | linenr = scm_source_property (expr, scm_sym_line); |
| 245 | } |
| 246 | |
| 247 | if (!SCM_UNBNDP (expr)) |
| 248 | { |
| 249 | if (scm_is_true (filename)) |
| 250 | { |
| 251 | format = "In file ~S, line ~S: ~A ~S in expression ~S."; |
| 252 | args = scm_list_5 (filename, linenr, msg_string, form, expr); |
| 253 | } |
| 254 | else if (scm_is_true (linenr)) |
| 255 | { |
| 256 | format = "In line ~S: ~A ~S in expression ~S."; |
| 257 | args = scm_list_4 (linenr, msg_string, form, expr); |
| 258 | } |
| 259 | else |
| 260 | { |
| 261 | format = "~A ~S in expression ~S."; |
| 262 | args = scm_list_3 (msg_string, form, expr); |
| 263 | } |
| 264 | } |
| 265 | else |
| 266 | { |
| 267 | if (scm_is_true (filename)) |
| 268 | { |
| 269 | format = "In file ~S, line ~S: ~A ~S."; |
| 270 | args = scm_list_4 (filename, linenr, msg_string, form); |
| 271 | } |
| 272 | else if (scm_is_true (linenr)) |
| 273 | { |
| 274 | format = "In line ~S: ~A ~S."; |
| 275 | args = scm_list_3 (linenr, msg_string, form); |
| 276 | } |
| 277 | else |
| 278 | { |
| 279 | format = "~A ~S."; |
| 280 | args = scm_list_2 (msg_string, form); |
| 281 | } |
| 282 | } |
| 283 | |
| 284 | scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F); |
| 285 | } |
| 286 | |
| 287 | |
| 288 | \f |
| 289 | |
| 290 | |
| 291 | static int |
| 292 | expand_env_var_is_free (SCM env, SCM x) |
| 293 | { |
| 294 | for (; scm_is_pair (env); env = CDR (env)) |
| 295 | if (scm_is_eq (x, CAAR (env))) |
| 296 | return 0; /* bound */ |
| 297 | return 1; /* free */ |
| 298 | } |
| 299 | |
| 300 | static SCM |
| 301 | expand_env_ref_macro (SCM env, SCM x) |
| 302 | { |
| 303 | SCM var; |
| 304 | if (!expand_env_var_is_free (env, x)) |
| 305 | return SCM_BOOL_F; /* lexical */ |
| 306 | |
| 307 | var = scm_module_variable (scm_current_module (), x); |
| 308 | if (scm_is_true (var) && scm_is_true (scm_variable_bound_p (var)) |
| 309 | && scm_is_true (scm_macro_p (scm_variable_ref (var)))) |
| 310 | return scm_variable_ref (var); |
| 311 | else |
| 312 | return SCM_BOOL_F; /* anything else */ |
| 313 | } |
| 314 | |
| 315 | static SCM |
| 316 | expand_env_lexical_gensym (SCM env, SCM name) |
| 317 | { |
| 318 | for (; scm_is_pair (env); env = CDR (env)) |
| 319 | if (scm_is_eq (name, CAAR (env))) |
| 320 | return CDAR (env); /* bound */ |
| 321 | return SCM_BOOL_F; /* free */ |
| 322 | } |
| 323 | |
| 324 | static SCM |
| 325 | expand_env_extend (SCM env, SCM names, SCM vars) |
| 326 | { |
| 327 | while (scm_is_pair (names)) |
| 328 | { |
| 329 | env = scm_acons (CAR (names), CAR (vars), env); |
| 330 | names = CDR (names); |
| 331 | vars = CDR (vars); |
| 332 | } |
| 333 | return env; |
| 334 | } |
| 335 | |
| 336 | static SCM |
| 337 | expand (SCM exp, SCM env) |
| 338 | { |
| 339 | if (scm_is_pair (exp)) |
| 340 | { |
| 341 | SCM car; |
| 342 | scm_t_macro_primitive trans = NULL; |
| 343 | SCM macro = SCM_BOOL_F; |
| 344 | |
| 345 | car = CAR (exp); |
| 346 | if (scm_is_symbol (car)) |
| 347 | macro = expand_env_ref_macro (env, car); |
| 348 | |
| 349 | if (scm_is_true (macro)) |
| 350 | trans = scm_i_macro_primitive (macro); |
| 351 | |
| 352 | if (trans) |
| 353 | return trans (exp, env); |
| 354 | else |
| 355 | { |
| 356 | SCM arg_exps = SCM_EOL; |
| 357 | SCM args = SCM_EOL; |
| 358 | SCM proc = expand (CAR (exp), env); |
| 359 | |
| 360 | for (arg_exps = CDR (exp); scm_is_pair (arg_exps); |
| 361 | arg_exps = CDR (arg_exps)) |
| 362 | args = scm_cons (expand (CAR (arg_exps), env), args); |
| 363 | args = scm_reverse_x (args, SCM_UNDEFINED); |
| 364 | |
| 365 | if (!scm_is_null (arg_exps)) |
| 366 | syntax_error ("expected a proper list", exp, SCM_UNDEFINED); |
| 367 | |
| 368 | if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_PRIMITIVE_REF) |
| 369 | return PRIMCALL (scm_source_properties (exp), |
| 370 | SCM_EXPANDED_REF (proc, PRIMITIVE_REF, NAME), |
| 371 | args); |
| 372 | else |
| 373 | return CALL (scm_source_properties (exp), proc, args); |
| 374 | } |
| 375 | } |
| 376 | else if (scm_is_symbol (exp)) |
| 377 | { |
| 378 | SCM gensym = expand_env_lexical_gensym (env, exp); |
| 379 | if (scm_is_true (gensym)) |
| 380 | return LEXICAL_REF (SCM_BOOL_F, exp, gensym); |
| 381 | else |
| 382 | return TOPLEVEL_REF (SCM_BOOL_F, exp); |
| 383 | } |
| 384 | else |
| 385 | return CONST_ (SCM_BOOL_F, exp); |
| 386 | } |
| 387 | |
| 388 | static SCM |
| 389 | expand_exprs (SCM forms, const SCM env) |
| 390 | { |
| 391 | SCM ret = SCM_EOL; |
| 392 | |
| 393 | for (; !scm_is_null (forms); forms = CDR (forms)) |
| 394 | ret = scm_cons (expand (CAR (forms), env), ret); |
| 395 | return scm_reverse_x (ret, SCM_UNDEFINED); |
| 396 | } |
| 397 | |
| 398 | static SCM |
| 399 | expand_sequence (const SCM forms, const SCM env) |
| 400 | { |
| 401 | ASSERT_SYNTAX (scm_ilength (forms) >= 1, s_bad_expression, |
| 402 | scm_cons (scm_sym_begin, forms)); |
| 403 | if (scm_is_null (CDR (forms))) |
| 404 | return expand (CAR (forms), env); |
| 405 | else |
| 406 | return SEQ (scm_source_properties (forms), |
| 407 | expand (CAR (forms), env), |
| 408 | expand_sequence (CDR (forms), env)); |
| 409 | } |
| 410 | |
| 411 | |
| 412 | \f |
| 413 | |
| 414 | |
| 415 | static SCM |
| 416 | expand_at (SCM expr, SCM env SCM_UNUSED) |
| 417 | { |
| 418 | ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr); |
| 419 | ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr); |
| 420 | ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr); |
| 421 | |
| 422 | return MODULE_REF (scm_source_properties (expr), |
| 423 | CADR (expr), CADDR (expr), SCM_BOOL_T); |
| 424 | } |
| 425 | |
| 426 | static SCM |
| 427 | expand_atat (SCM expr, SCM env SCM_UNUSED) |
| 428 | { |
| 429 | ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr); |
| 430 | ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr); |
| 431 | |
| 432 | if (scm_is_eq (CADR (expr), sym_primitive)) |
| 433 | return PRIMITIVE_REF (scm_source_properties (expr), CADDR (expr)); |
| 434 | |
| 435 | ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr); |
| 436 | return MODULE_REF (scm_source_properties (expr), |
| 437 | CADR (expr), CADDR (expr), SCM_BOOL_F); |
| 438 | } |
| 439 | |
| 440 | static SCM |
| 441 | expand_and (SCM expr, SCM env) |
| 442 | { |
| 443 | const SCM cdr_expr = CDR (expr); |
| 444 | |
| 445 | if (scm_is_null (cdr_expr)) |
| 446 | return CONST_ (SCM_BOOL_F, SCM_BOOL_T); |
| 447 | |
| 448 | ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr); |
| 449 | |
| 450 | if (scm_is_null (CDR (cdr_expr))) |
| 451 | return expand (CAR (cdr_expr), env); |
| 452 | else |
| 453 | return CONDITIONAL (scm_source_properties (expr), |
| 454 | expand (CAR (cdr_expr), env), |
| 455 | expand_and (cdr_expr, env), |
| 456 | CONST_ (SCM_BOOL_F, SCM_BOOL_F)); |
| 457 | } |
| 458 | |
| 459 | static SCM |
| 460 | expand_begin (SCM expr, SCM env) |
| 461 | { |
| 462 | const SCM cdr_expr = CDR (expr); |
| 463 | ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_bad_expression, expr); |
| 464 | return expand_sequence (cdr_expr, env); |
| 465 | } |
| 466 | |
| 467 | static SCM |
| 468 | expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env) |
| 469 | { |
| 470 | SCM test; |
| 471 | const long length = scm_ilength (clause); |
| 472 | ASSERT_SYNTAX (length >= 1, s_bad_cond_clause, clause); |
| 473 | |
| 474 | test = CAR (clause); |
| 475 | if (scm_is_eq (test, scm_sym_else) && elp) |
| 476 | { |
| 477 | const int last_clause_p = scm_is_null (rest); |
| 478 | ASSERT_SYNTAX (length >= 2, s_bad_cond_clause, clause); |
| 479 | ASSERT_SYNTAX (last_clause_p, s_misplaced_else_clause, clause); |
| 480 | return expand_sequence (CDR (clause), env); |
| 481 | } |
| 482 | |
| 483 | if (scm_is_null (rest)) |
| 484 | rest = VOID_ (SCM_BOOL_F); |
| 485 | else |
| 486 | rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env); |
| 487 | |
| 488 | if (length >= 2 |
| 489 | && scm_is_eq (CADR (clause), scm_sym_arrow) |
| 490 | && alp) |
| 491 | { |
| 492 | SCM tmp = scm_gensym (scm_from_locale_string ("cond ")); |
| 493 | SCM new_env = scm_acons (tmp, tmp, env); |
| 494 | ASSERT_SYNTAX (length > 2, s_missing_recipient, clause); |
| 495 | ASSERT_SYNTAX (length == 3, s_extra_expression, clause); |
| 496 | return LET (SCM_BOOL_F, |
| 497 | scm_list_1 (tmp), |
| 498 | scm_list_1 (tmp), |
| 499 | scm_list_1 (expand (test, env)), |
| 500 | CONDITIONAL (SCM_BOOL_F, |
| 501 | LEXICAL_REF (SCM_BOOL_F, tmp, tmp), |
| 502 | CALL (SCM_BOOL_F, |
| 503 | expand (CADDR (clause), new_env), |
| 504 | scm_list_1 (LEXICAL_REF (SCM_BOOL_F, |
| 505 | tmp, tmp))), |
| 506 | rest)); |
| 507 | } |
| 508 | /* FIXME length == 1 case */ |
| 509 | else |
| 510 | return CONDITIONAL (SCM_BOOL_F, |
| 511 | expand (test, env), |
| 512 | expand_sequence (CDR (clause), env), |
| 513 | rest); |
| 514 | } |
| 515 | |
| 516 | static SCM |
| 517 | expand_cond (SCM expr, SCM env) |
| 518 | { |
| 519 | const int else_literal_p = expand_env_var_is_free (env, scm_sym_else); |
| 520 | const int arrow_literal_p = expand_env_var_is_free (env, scm_sym_arrow); |
| 521 | const SCM clauses = CDR (expr); |
| 522 | |
| 523 | ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr); |
| 524 | ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr); |
| 525 | |
| 526 | return expand_cond_clauses (CAR (clauses), CDR (clauses), |
| 527 | else_literal_p, arrow_literal_p, env); |
| 528 | } |
| 529 | |
| 530 | /* lone forward decl */ |
| 531 | static SCM expand_lambda (SCM expr, SCM env); |
| 532 | |
| 533 | /* According to Section 5.2.1 of R5RS we first have to make sure that the |
| 534 | variable is bound, and then perform the `(set! variable expression)' |
| 535 | operation. However, EXPRESSION _can_ be evaluated before VARIABLE is |
| 536 | bound. This means that EXPRESSION won't necessarily be able to assign |
| 537 | values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */ |
| 538 | static SCM |
| 539 | expand_define (SCM expr, SCM env) |
| 540 | { |
| 541 | const SCM cdr_expr = CDR (expr); |
| 542 | SCM body; |
| 543 | SCM variable; |
| 544 | |
| 545 | ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); |
| 546 | ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr); |
| 547 | ASSERT_SYNTAX (!scm_is_pair (env), s_bad_define, expr); |
| 548 | |
| 549 | body = CDR (cdr_expr); |
| 550 | variable = CAR (cdr_expr); |
| 551 | |
| 552 | if (scm_is_pair (variable)) |
| 553 | { |
| 554 | ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr); |
| 555 | return TOPLEVEL_DEFINE |
| 556 | (scm_source_properties (expr), |
| 557 | CAR (variable), |
| 558 | expand_lambda (scm_cons (scm_sym_lambda, scm_cons (CDR (variable), body)), |
| 559 | env)); |
| 560 | } |
| 561 | ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr); |
| 562 | ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr); |
| 563 | return TOPLEVEL_DEFINE (scm_source_properties (expr), variable, |
| 564 | expand (CAR (body), env)); |
| 565 | } |
| 566 | |
| 567 | static SCM |
| 568 | expand_eval_when (SCM expr, SCM env) |
| 569 | { |
| 570 | ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr); |
| 571 | ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr); |
| 572 | |
| 573 | if (scm_is_true (scm_memq (sym_eval, CADR (expr))) |
| 574 | || scm_is_true (scm_memq (sym_load, CADR (expr)))) |
| 575 | return expand_sequence (CDDR (expr), env); |
| 576 | else |
| 577 | return VOID_ (scm_source_properties (expr)); |
| 578 | } |
| 579 | |
| 580 | static SCM |
| 581 | expand_if (SCM expr, SCM env SCM_UNUSED) |
| 582 | { |
| 583 | const SCM cdr_expr = CDR (expr); |
| 584 | const long length = scm_ilength (cdr_expr); |
| 585 | ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr); |
| 586 | return CONDITIONAL (scm_source_properties (expr), |
| 587 | expand (CADR (expr), env), |
| 588 | expand (CADDR (expr), env), |
| 589 | ((length == 3) |
| 590 | ? expand (CADDDR (expr), env) |
| 591 | : VOID_ (SCM_BOOL_F))); |
| 592 | } |
| 593 | |
| 594 | /* A helper function for expand_lambda to support checking for duplicate |
| 595 | * formal arguments: Return true if OBJ is `eq?' to one of the elements of |
| 596 | * LIST or to the CDR of the last cons. Therefore, LIST may have any of the |
| 597 | * forms that a formal argument can have: |
| 598 | * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */ |
| 599 | static int |
| 600 | c_improper_memq (SCM obj, SCM list) |
| 601 | { |
| 602 | for (; scm_is_pair (list); list = CDR (list)) |
| 603 | { |
| 604 | if (scm_is_eq (CAR (list), obj)) |
| 605 | return 1; |
| 606 | } |
| 607 | return scm_is_eq (list, obj); |
| 608 | } |
| 609 | |
| 610 | static SCM |
| 611 | expand_lambda_case (SCM clause, SCM alternate, SCM env) |
| 612 | { |
| 613 | SCM formals; |
| 614 | SCM rest; |
| 615 | SCM req = SCM_EOL; |
| 616 | SCM vars = SCM_EOL; |
| 617 | SCM body; |
| 618 | int nreq = 0; |
| 619 | |
| 620 | ASSERT_SYNTAX (scm_is_pair (clause) && scm_is_pair (CDR (clause)), |
| 621 | s_bad_expression, scm_cons (scm_sym_lambda, clause)); |
| 622 | |
| 623 | /* Before iterating the list of formal arguments, make sure the formals |
| 624 | * actually are given as either a symbol or a non-cyclic list. */ |
| 625 | formals = CAR (clause); |
| 626 | if (scm_is_pair (formals)) |
| 627 | { |
| 628 | /* Dirk:FIXME:: We should check for a cyclic list of formals, and if |
| 629 | * detected, report a 'Bad formals' error. */ |
| 630 | } |
| 631 | else |
| 632 | ASSERT_SYNTAX_2 (scm_is_symbol (formals) || scm_is_null (formals), |
| 633 | s_bad_formals, formals, scm_cons (scm_sym_lambda, clause)); |
| 634 | |
| 635 | /* Now iterate the list of formal arguments to check if all formals are |
| 636 | * symbols, and that there are no duplicates. */ |
| 637 | while (scm_is_pair (formals)) |
| 638 | { |
| 639 | const SCM formal = CAR (formals); |
| 640 | formals = CDR (formals); |
| 641 | ASSERT_SYNTAX_2 (scm_is_symbol (formal), s_bad_formal, formal, |
| 642 | scm_cons (scm_sym_lambda, clause)); |
| 643 | ASSERT_SYNTAX_2 (!c_improper_memq (formal, formals), s_duplicate_formal, |
| 644 | formal, scm_cons (scm_sym_lambda, clause)); |
| 645 | nreq++; |
| 646 | req = scm_cons (formal, req); |
| 647 | vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars); |
| 648 | env = scm_acons (formal, CAR (vars), env); |
| 649 | } |
| 650 | |
| 651 | ASSERT_SYNTAX_2 (scm_is_null (formals) || scm_is_symbol (formals), |
| 652 | s_bad_formal, formals, scm_cons (scm_sym_lambda, clause)); |
| 653 | if (scm_is_symbol (formals)) |
| 654 | { |
| 655 | rest = formals; |
| 656 | vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars); |
| 657 | env = scm_acons (rest, CAR (vars), env); |
| 658 | } |
| 659 | else |
| 660 | rest = SCM_BOOL_F; |
| 661 | |
| 662 | body = expand_sequence (CDR (clause), env); |
| 663 | req = scm_reverse_x (req, SCM_UNDEFINED); |
| 664 | vars = scm_reverse_x (vars, SCM_UNDEFINED); |
| 665 | |
| 666 | if (scm_is_true (alternate) && !(SCM_EXPANDED_P (alternate) && SCM_EXPANDED_TYPE (alternate) == SCM_EXPANDED_LAMBDA_CASE)) |
| 667 | abort (); |
| 668 | |
| 669 | return LAMBDA_CASE (SCM_BOOL_F, req, SCM_BOOL_F, rest, SCM_BOOL_F, |
| 670 | SCM_EOL, vars, body, alternate); |
| 671 | } |
| 672 | |
| 673 | static SCM |
| 674 | expand_lambda (SCM expr, SCM env) |
| 675 | { |
| 676 | return LAMBDA (scm_source_properties (expr), |
| 677 | SCM_EOL, |
| 678 | expand_lambda_case (CDR (expr), SCM_BOOL_F, env)); |
| 679 | } |
| 680 | |
| 681 | static SCM |
| 682 | expand_lambda_star_case (SCM clause, SCM alternate, SCM env) |
| 683 | { |
| 684 | SCM req, opt, kw, allow_other_keys, rest, formals, vars, body, tmp; |
| 685 | SCM inits; |
| 686 | int nreq, nopt; |
| 687 | |
| 688 | const long length = scm_ilength (clause); |
| 689 | ASSERT_SYNTAX (length >= 1, s_bad_expression, |
| 690 | scm_cons (sym_lambda_star, clause)); |
| 691 | ASSERT_SYNTAX (length >= 2, s_missing_expression, |
| 692 | scm_cons (sym_lambda_star, clause)); |
| 693 | |
| 694 | formals = CAR (clause); |
| 695 | body = CDR (clause); |
| 696 | |
| 697 | nreq = nopt = 0; |
| 698 | req = opt = kw = SCM_EOL; |
| 699 | rest = allow_other_keys = SCM_BOOL_F; |
| 700 | |
| 701 | while (scm_is_pair (formals) && scm_is_symbol (CAR (formals))) |
| 702 | { |
| 703 | nreq++; |
| 704 | req = scm_cons (CAR (formals), req); |
| 705 | formals = scm_cdr (formals); |
| 706 | } |
| 707 | |
| 708 | if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_optional)) |
| 709 | { |
| 710 | formals = CDR (formals); |
| 711 | while (scm_is_pair (formals) |
| 712 | && (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals)))) |
| 713 | { |
| 714 | nopt++; |
| 715 | opt = scm_cons (CAR (formals), opt); |
| 716 | formals = scm_cdr (formals); |
| 717 | } |
| 718 | } |
| 719 | |
| 720 | if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_key)) |
| 721 | { |
| 722 | formals = CDR (formals); |
| 723 | while (scm_is_pair (formals) |
| 724 | && (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals)))) |
| 725 | { |
| 726 | kw = scm_cons (CAR (formals), kw); |
| 727 | formals = scm_cdr (formals); |
| 728 | } |
| 729 | } |
| 730 | |
| 731 | if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_allow_other_keys)) |
| 732 | { |
| 733 | formals = CDR (formals); |
| 734 | allow_other_keys = SCM_BOOL_T; |
| 735 | } |
| 736 | |
| 737 | if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_rest)) |
| 738 | { |
| 739 | ASSERT_SYNTAX (scm_ilength (formals) == 2, s_bad_formals, |
| 740 | CAR (clause)); |
| 741 | rest = CADR (formals); |
| 742 | } |
| 743 | else if (scm_is_symbol (formals)) |
| 744 | rest = formals; |
| 745 | else |
| 746 | { |
| 747 | ASSERT_SYNTAX (scm_is_null (formals), s_bad_formals, CAR (clause)); |
| 748 | rest = SCM_BOOL_F; |
| 749 | } |
| 750 | |
| 751 | /* Now, iterate through them a second time, building up an expansion-time |
| 752 | environment, checking, expanding and canonicalizing the opt/kw init forms, |
| 753 | and eventually memoizing the body as well. Note that the rest argument, if |
| 754 | any, is expanded before keyword args, thus necessitating the second |
| 755 | pass. |
| 756 | |
| 757 | Also note that the specific environment during expansion of init |
| 758 | expressions here needs to coincide with the environment when psyntax |
| 759 | expands. A lot of effort for something that is only used in the bootstrap |
| 760 | expandr, you say? Yes. Yes it is. |
| 761 | */ |
| 762 | |
| 763 | vars = SCM_EOL; |
| 764 | req = scm_reverse_x (req, SCM_EOL); |
| 765 | for (tmp = req; scm_is_pair (tmp); tmp = scm_cdr (tmp)) |
| 766 | { |
| 767 | vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars); |
| 768 | env = scm_acons (CAR (tmp), CAR (vars), env); |
| 769 | } |
| 770 | |
| 771 | /* Build up opt inits and env */ |
| 772 | inits = SCM_EOL; |
| 773 | opt = scm_reverse_x (opt, SCM_EOL); |
| 774 | for (tmp = opt; scm_is_pair (tmp); tmp = scm_cdr (tmp)) |
| 775 | { |
| 776 | SCM x = CAR (tmp); |
| 777 | vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars); |
| 778 | env = scm_acons (x, CAR (vars), env); |
| 779 | if (scm_is_symbol (x)) |
| 780 | inits = scm_cons (CONST_ (SCM_BOOL_F, SCM_BOOL_F), inits); |
| 781 | else |
| 782 | { |
| 783 | ASSERT_SYNTAX (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)), |
| 784 | s_bad_formals, CAR (clause)); |
| 785 | inits = scm_cons (expand (CADR (x), env), inits); |
| 786 | } |
| 787 | env = scm_acons (scm_is_symbol (x) ? x : CAR (x), CAR (vars), env); |
| 788 | } |
| 789 | if (scm_is_null (opt)) |
| 790 | opt = SCM_BOOL_F; |
| 791 | |
| 792 | /* Process rest before keyword args */ |
| 793 | if (scm_is_true (rest)) |
| 794 | { |
| 795 | vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars); |
| 796 | env = scm_acons (rest, CAR (vars), env); |
| 797 | } |
| 798 | |
| 799 | /* Build up kw inits, env, and kw-canon list */ |
| 800 | if (scm_is_null (kw)) |
| 801 | kw = SCM_BOOL_F; |
| 802 | else |
| 803 | { |
| 804 | SCM kw_canon = SCM_EOL; |
| 805 | kw = scm_reverse_x (kw, SCM_UNDEFINED); |
| 806 | for (tmp = kw; scm_is_pair (tmp); tmp = scm_cdr (tmp)) |
| 807 | { |
| 808 | SCM x, sym, k, init; |
| 809 | x = CAR (tmp); |
| 810 | if (scm_is_symbol (x)) |
| 811 | { |
| 812 | sym = x; |
| 813 | init = SCM_BOOL_F; |
| 814 | k = scm_symbol_to_keyword (sym); |
| 815 | } |
| 816 | else if (scm_ilength (x) == 2 && scm_is_symbol (CAR (x))) |
| 817 | { |
| 818 | sym = CAR (x); |
| 819 | init = CADR (x); |
| 820 | k = scm_symbol_to_keyword (sym); |
| 821 | } |
| 822 | else if (scm_ilength (x) == 3 && scm_is_symbol (CAR (x)) |
| 823 | && scm_is_keyword (CADDR (x))) |
| 824 | { |
| 825 | sym = CAR (x); |
| 826 | init = CADR (x); |
| 827 | k = CADDR (x); |
| 828 | } |
| 829 | else |
| 830 | syntax_error (s_bad_formals, CAR (clause), SCM_UNDEFINED); |
| 831 | |
| 832 | inits = scm_cons (expand (init, env), inits); |
| 833 | vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars); |
| 834 | kw_canon = scm_cons (scm_list_3 (k, sym, CAR (vars)), kw_canon); |
| 835 | env = scm_acons (sym, CAR (vars), env); |
| 836 | } |
| 837 | kw_canon = scm_reverse_x (kw_canon, SCM_UNDEFINED); |
| 838 | kw = scm_cons (allow_other_keys, kw_canon); |
| 839 | } |
| 840 | |
| 841 | /* We should check for no duplicates, but given that psyntax does this |
| 842 | already, we can punt on it here... */ |
| 843 | |
| 844 | vars = scm_reverse_x (vars, SCM_UNDEFINED); |
| 845 | inits = scm_reverse_x (inits, SCM_UNDEFINED); |
| 846 | body = expand_sequence (body, env); |
| 847 | |
| 848 | return LAMBDA_CASE (SCM_BOOL_F, req, opt, rest, kw, inits, vars, body, |
| 849 | alternate); |
| 850 | } |
| 851 | |
| 852 | static SCM |
| 853 | expand_lambda_star (SCM expr, SCM env) |
| 854 | { |
| 855 | return LAMBDA (scm_source_properties (expr), |
| 856 | SCM_EOL, |
| 857 | expand_lambda_star_case (CDR (expr), SCM_BOOL_F, env)); |
| 858 | } |
| 859 | |
| 860 | static SCM |
| 861 | expand_case_lambda_clauses (SCM expr, SCM rest, SCM env) |
| 862 | { |
| 863 | SCM alt; |
| 864 | |
| 865 | if (scm_is_pair (rest)) |
| 866 | alt = expand_case_lambda_clauses (CAR (rest), CDR (rest), env); |
| 867 | else |
| 868 | alt = SCM_BOOL_F; |
| 869 | |
| 870 | return expand_lambda_case (expr, alt, env); |
| 871 | } |
| 872 | |
| 873 | static SCM |
| 874 | expand_case_lambda (SCM expr, SCM env) |
| 875 | { |
| 876 | ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr); |
| 877 | |
| 878 | return LAMBDA (scm_source_properties (expr), |
| 879 | SCM_EOL, |
| 880 | expand_case_lambda_clauses (CADR (expr), CDDR (expr), env)); |
| 881 | } |
| 882 | |
| 883 | static SCM |
| 884 | expand_case_lambda_star_clauses (SCM expr, SCM rest, SCM env) |
| 885 | { |
| 886 | SCM alt; |
| 887 | |
| 888 | if (scm_is_pair (rest)) |
| 889 | alt = expand_case_lambda_star_clauses (CAR (rest), CDR (rest), env); |
| 890 | else |
| 891 | alt = SCM_BOOL_F; |
| 892 | |
| 893 | return expand_lambda_star_case (expr, alt, env); |
| 894 | } |
| 895 | |
| 896 | static SCM |
| 897 | expand_case_lambda_star (SCM expr, SCM env) |
| 898 | { |
| 899 | ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr); |
| 900 | |
| 901 | return LAMBDA (scm_source_properties (expr), |
| 902 | SCM_EOL, |
| 903 | expand_case_lambda_star_clauses (CADR (expr), CDDR (expr), env)); |
| 904 | } |
| 905 | |
| 906 | /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */ |
| 907 | static void |
| 908 | check_bindings (const SCM bindings, const SCM expr) |
| 909 | { |
| 910 | SCM binding_idx; |
| 911 | |
| 912 | ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0, |
| 913 | s_bad_bindings, bindings, expr); |
| 914 | |
| 915 | binding_idx = bindings; |
| 916 | for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx)) |
| 917 | { |
| 918 | SCM name; /* const */ |
| 919 | |
| 920 | const SCM binding = CAR (binding_idx); |
| 921 | ASSERT_SYNTAX_2 (scm_ilength (binding) == 2, |
| 922 | s_bad_binding, binding, expr); |
| 923 | |
| 924 | name = CAR (binding); |
| 925 | ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr); |
| 926 | } |
| 927 | } |
| 928 | |
| 929 | /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are |
| 930 | * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate |
| 931 | * variable name is detected, an error is signalled. */ |
| 932 | static void |
| 933 | transform_bindings (const SCM bindings, const SCM expr, |
| 934 | SCM *const names, SCM *const vars, SCM *const initptr) |
| 935 | { |
| 936 | SCM rnames = SCM_EOL; |
| 937 | SCM rvars = SCM_EOL; |
| 938 | SCM rinits = SCM_EOL; |
| 939 | SCM binding_idx = bindings; |
| 940 | for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx)) |
| 941 | { |
| 942 | const SCM binding = CAR (binding_idx); |
| 943 | const SCM CDR_binding = CDR (binding); |
| 944 | const SCM name = CAR (binding); |
| 945 | ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rnames)), |
| 946 | s_duplicate_binding, name, expr); |
| 947 | rnames = scm_cons (name, rnames); |
| 948 | rvars = scm_cons (scm_gensym (SCM_UNDEFINED), rvars); |
| 949 | rinits = scm_cons (CAR (CDR_binding), rinits); |
| 950 | } |
| 951 | *names = scm_reverse_x (rnames, SCM_UNDEFINED); |
| 952 | *vars = scm_reverse_x (rvars, SCM_UNDEFINED); |
| 953 | *initptr = scm_reverse_x (rinits, SCM_UNDEFINED); |
| 954 | } |
| 955 | |
| 956 | /* FIXME: Remove named let in this boot expander. */ |
| 957 | static SCM |
| 958 | expand_named_let (const SCM expr, SCM env) |
| 959 | { |
| 960 | SCM var_names, var_syms, inits; |
| 961 | SCM inner_env; |
| 962 | SCM name_sym; |
| 963 | |
| 964 | const SCM cdr_expr = CDR (expr); |
| 965 | const SCM name = CAR (cdr_expr); |
| 966 | const SCM cddr_expr = CDR (cdr_expr); |
| 967 | const SCM bindings = CAR (cddr_expr); |
| 968 | check_bindings (bindings, expr); |
| 969 | |
| 970 | transform_bindings (bindings, expr, &var_names, &var_syms, &inits); |
| 971 | name_sym = scm_gensym (SCM_UNDEFINED); |
| 972 | inner_env = scm_acons (name, name_sym, env); |
| 973 | inner_env = expand_env_extend (inner_env, var_names, var_syms); |
| 974 | |
| 975 | return LETREC |
| 976 | (scm_source_properties (expr), SCM_BOOL_F, |
| 977 | scm_list_1 (name), scm_list_1 (name_sym), |
| 978 | scm_list_1 (LAMBDA (SCM_BOOL_F, |
| 979 | SCM_EOL, |
| 980 | LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_EOL, SCM_BOOL_F, |
| 981 | SCM_BOOL_F, SCM_EOL, var_syms, |
| 982 | expand_sequence (CDDDR (expr), inner_env), |
| 983 | SCM_BOOL_F))), |
| 984 | CALL (SCM_BOOL_F, |
| 985 | LEXICAL_REF (SCM_BOOL_F, name, name_sym), |
| 986 | expand_exprs (inits, env))); |
| 987 | } |
| 988 | |
| 989 | static SCM |
| 990 | expand_let (SCM expr, SCM env) |
| 991 | { |
| 992 | SCM bindings; |
| 993 | |
| 994 | const SCM cdr_expr = CDR (expr); |
| 995 | const long length = scm_ilength (cdr_expr); |
| 996 | ASSERT_SYNTAX (length >= 0, s_bad_expression, expr); |
| 997 | ASSERT_SYNTAX (length >= 2, s_missing_expression, expr); |
| 998 | |
| 999 | bindings = CAR (cdr_expr); |
| 1000 | if (scm_is_symbol (bindings)) |
| 1001 | { |
| 1002 | ASSERT_SYNTAX (length >= 3, s_missing_expression, expr); |
| 1003 | return expand_named_let (expr, env); |
| 1004 | } |
| 1005 | |
| 1006 | check_bindings (bindings, expr); |
| 1007 | if (scm_is_null (bindings)) |
| 1008 | return expand_sequence (CDDR (expr), env); |
| 1009 | else |
| 1010 | { |
| 1011 | SCM var_names, var_syms, inits; |
| 1012 | transform_bindings (bindings, expr, &var_names, &var_syms, &inits); |
| 1013 | return LET (SCM_BOOL_F, |
| 1014 | var_names, var_syms, expand_exprs (inits, env), |
| 1015 | expand_sequence (CDDR (expr), |
| 1016 | expand_env_extend (env, var_names, |
| 1017 | var_syms))); |
| 1018 | } |
| 1019 | } |
| 1020 | |
| 1021 | static SCM |
| 1022 | expand_letrec_helper (SCM expr, SCM env, SCM in_order_p) |
| 1023 | { |
| 1024 | SCM bindings; |
| 1025 | |
| 1026 | const SCM cdr_expr = CDR (expr); |
| 1027 | const long length = scm_ilength (cdr_expr); |
| 1028 | ASSERT_SYNTAX (length >= 0, s_bad_expression, expr); |
| 1029 | ASSERT_SYNTAX (length >= 2, s_missing_expression, expr); |
| 1030 | |
| 1031 | bindings = CAR (cdr_expr); |
| 1032 | check_bindings (bindings, expr); |
| 1033 | if (scm_is_null (bindings)) |
| 1034 | return expand_sequence (CDDR (expr), env); |
| 1035 | else |
| 1036 | { |
| 1037 | SCM var_names, var_syms, inits; |
| 1038 | transform_bindings (bindings, expr, &var_names, &var_syms, &inits); |
| 1039 | env = expand_env_extend (env, var_names, var_syms); |
| 1040 | return LETREC (SCM_BOOL_F, in_order_p, |
| 1041 | var_names, var_syms, expand_exprs (inits, env), |
| 1042 | expand_sequence (CDDR (expr), env)); |
| 1043 | } |
| 1044 | } |
| 1045 | |
| 1046 | static SCM |
| 1047 | expand_letrec (SCM expr, SCM env) |
| 1048 | { |
| 1049 | return expand_letrec_helper (expr, env, SCM_BOOL_F); |
| 1050 | } |
| 1051 | |
| 1052 | static SCM |
| 1053 | expand_letrec_star (SCM expr, SCM env) |
| 1054 | { |
| 1055 | return expand_letrec_helper (expr, env, SCM_BOOL_T); |
| 1056 | } |
| 1057 | |
| 1058 | static SCM |
| 1059 | expand_letstar_clause (SCM bindings, SCM body, SCM env SCM_UNUSED) |
| 1060 | { |
| 1061 | if (scm_is_null (bindings)) |
| 1062 | return expand_sequence (body, env); |
| 1063 | else |
| 1064 | { |
| 1065 | SCM bind, name, sym, init; |
| 1066 | |
| 1067 | ASSERT_SYNTAX (scm_is_pair (bindings), s_bad_expression, bindings); |
| 1068 | bind = CAR (bindings); |
| 1069 | ASSERT_SYNTAX (scm_ilength (bind) == 2, s_bad_binding, bind); |
| 1070 | name = CAR (bind); |
| 1071 | sym = scm_gensym (SCM_UNDEFINED); |
| 1072 | init = CADR (bind); |
| 1073 | |
| 1074 | return LET (SCM_BOOL_F, scm_list_1 (name), scm_list_1 (sym), |
| 1075 | scm_list_1 (expand (init, env)), |
| 1076 | expand_letstar_clause (CDR (bindings), body, |
| 1077 | scm_acons (name, sym, env))); |
| 1078 | } |
| 1079 | } |
| 1080 | |
| 1081 | static SCM |
| 1082 | expand_letstar (SCM expr, SCM env SCM_UNUSED) |
| 1083 | { |
| 1084 | const SCM cdr_expr = CDR (expr); |
| 1085 | ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); |
| 1086 | ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr); |
| 1087 | |
| 1088 | return expand_letstar_clause (CADR (expr), CDDR (expr), env); |
| 1089 | } |
| 1090 | |
| 1091 | static SCM |
| 1092 | expand_or (SCM expr, SCM env SCM_UNUSED) |
| 1093 | { |
| 1094 | SCM tail = CDR (expr); |
| 1095 | const long length = scm_ilength (tail); |
| 1096 | |
| 1097 | ASSERT_SYNTAX (length >= 0, s_bad_expression, expr); |
| 1098 | |
| 1099 | if (scm_is_null (CDR (expr))) |
| 1100 | return CONST_ (SCM_BOOL_F, SCM_BOOL_F); |
| 1101 | else |
| 1102 | { |
| 1103 | SCM tmp = scm_gensym (SCM_UNDEFINED); |
| 1104 | return LET (SCM_BOOL_F, |
| 1105 | scm_list_1 (tmp), scm_list_1 (tmp), |
| 1106 | scm_list_1 (expand (CADR (expr), env)), |
| 1107 | CONDITIONAL (SCM_BOOL_F, |
| 1108 | LEXICAL_REF (SCM_BOOL_F, tmp, tmp), |
| 1109 | LEXICAL_REF (SCM_BOOL_F, tmp, tmp), |
| 1110 | expand_or (CDR (expr), |
| 1111 | scm_acons (tmp, tmp, env)))); |
| 1112 | } |
| 1113 | } |
| 1114 | |
| 1115 | static SCM |
| 1116 | expand_quote (SCM expr, SCM env SCM_UNUSED) |
| 1117 | { |
| 1118 | SCM quotee; |
| 1119 | |
| 1120 | const SCM cdr_expr = CDR (expr); |
| 1121 | ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); |
| 1122 | ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr); |
| 1123 | quotee = CAR (cdr_expr); |
| 1124 | return CONST_ (scm_source_properties (expr), quotee); |
| 1125 | } |
| 1126 | |
| 1127 | static SCM |
| 1128 | expand_set_x (SCM expr, SCM env) |
| 1129 | { |
| 1130 | SCM variable; |
| 1131 | SCM vmem; |
| 1132 | |
| 1133 | const SCM cdr_expr = CDR (expr); |
| 1134 | ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); |
| 1135 | ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr); |
| 1136 | variable = CAR (cdr_expr); |
| 1137 | vmem = expand (variable, env); |
| 1138 | |
| 1139 | switch (SCM_EXPANDED_TYPE (vmem)) |
| 1140 | { |
| 1141 | case SCM_EXPANDED_LEXICAL_REF: |
| 1142 | return LEXICAL_SET (scm_source_properties (expr), |
| 1143 | SCM_EXPANDED_REF (vmem, LEXICAL_REF, NAME), |
| 1144 | SCM_EXPANDED_REF (vmem, LEXICAL_REF, GENSYM), |
| 1145 | expand (CADDR (expr), env)); |
| 1146 | case SCM_EXPANDED_TOPLEVEL_REF: |
| 1147 | return TOPLEVEL_SET (scm_source_properties (expr), |
| 1148 | SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, NAME), |
| 1149 | expand (CADDR (expr), env)); |
| 1150 | case SCM_EXPANDED_MODULE_REF: |
| 1151 | return MODULE_SET (scm_source_properties (expr), |
| 1152 | SCM_EXPANDED_REF (vmem, MODULE_REF, MOD), |
| 1153 | SCM_EXPANDED_REF (vmem, MODULE_REF, NAME), |
| 1154 | SCM_EXPANDED_REF (vmem, MODULE_REF, PUBLIC), |
| 1155 | expand (CADDR (expr), env)); |
| 1156 | default: |
| 1157 | syntax_error (s_bad_variable, variable, expr); |
| 1158 | } |
| 1159 | } |
| 1160 | |
| 1161 | |
| 1162 | \f |
| 1163 | |
| 1164 | /* This is the boot expander. It is later replaced with psyntax's sc-expand. */ |
| 1165 | SCM_DEFINE (scm_macroexpand, "macroexpand", 1, 0, 0, |
| 1166 | (SCM exp), |
| 1167 | "Expand the expression @var{exp}.") |
| 1168 | #define FUNC_NAME s_scm_macroexpand |
| 1169 | { |
| 1170 | return expand (exp, scm_current_module ()); |
| 1171 | } |
| 1172 | #undef FUNC_NAME |
| 1173 | |
| 1174 | SCM_DEFINE (scm_macroexpanded_p, "macroexpanded?", 1, 0, 0, |
| 1175 | (SCM exp), |
| 1176 | "Return @code{#t} if @var{exp} is an expanded expression.") |
| 1177 | #define FUNC_NAME s_scm_macroexpanded_p |
| 1178 | { |
| 1179 | return scm_from_bool (SCM_EXPANDED_P (exp)); |
| 1180 | } |
| 1181 | #undef FUNC_NAME |
| 1182 | |
| 1183 | |
| 1184 | \f |
| 1185 | |
| 1186 | static void |
| 1187 | compute_assigned (SCM exp, SCM assigned) |
| 1188 | { |
| 1189 | if (scm_is_null (exp) || scm_is_false (exp)) |
| 1190 | return; |
| 1191 | |
| 1192 | if (scm_is_pair (exp)) |
| 1193 | { |
| 1194 | compute_assigned (CAR (exp), assigned); |
| 1195 | compute_assigned (CDR (exp), assigned); |
| 1196 | return; |
| 1197 | } |
| 1198 | |
| 1199 | if (!SCM_EXPANDED_P (exp)) |
| 1200 | abort (); |
| 1201 | |
| 1202 | switch (SCM_EXPANDED_TYPE (exp)) |
| 1203 | { |
| 1204 | case SCM_EXPANDED_VOID: |
| 1205 | case SCM_EXPANDED_CONST: |
| 1206 | case SCM_EXPANDED_PRIMITIVE_REF: |
| 1207 | case SCM_EXPANDED_LEXICAL_REF: |
| 1208 | case SCM_EXPANDED_MODULE_REF: |
| 1209 | case SCM_EXPANDED_TOPLEVEL_REF: |
| 1210 | return; |
| 1211 | |
| 1212 | case SCM_EXPANDED_LEXICAL_SET: |
| 1213 | scm_hashq_set_x (assigned, REF (exp, LEXICAL_SET, GENSYM), SCM_BOOL_T); |
| 1214 | compute_assigned (REF (exp, LEXICAL_SET, EXP), assigned); |
| 1215 | return; |
| 1216 | |
| 1217 | case SCM_EXPANDED_MODULE_SET: |
| 1218 | compute_assigned (REF (exp, MODULE_SET, EXP), assigned); |
| 1219 | return; |
| 1220 | |
| 1221 | case SCM_EXPANDED_TOPLEVEL_SET: |
| 1222 | compute_assigned (REF (exp, TOPLEVEL_SET, EXP), assigned); |
| 1223 | return; |
| 1224 | |
| 1225 | case SCM_EXPANDED_TOPLEVEL_DEFINE: |
| 1226 | compute_assigned (REF (exp, TOPLEVEL_DEFINE, EXP), assigned); |
| 1227 | return; |
| 1228 | |
| 1229 | case SCM_EXPANDED_CONDITIONAL: |
| 1230 | compute_assigned (REF (exp, CONDITIONAL, TEST), assigned); |
| 1231 | compute_assigned (REF (exp, CONDITIONAL, CONSEQUENT), assigned); |
| 1232 | compute_assigned (REF (exp, CONDITIONAL, ALTERNATE), assigned); |
| 1233 | return; |
| 1234 | |
| 1235 | case SCM_EXPANDED_CALL: |
| 1236 | compute_assigned (REF (exp, CALL, PROC), assigned); |
| 1237 | compute_assigned (REF (exp, CALL, ARGS), assigned); |
| 1238 | return; |
| 1239 | |
| 1240 | case SCM_EXPANDED_PRIMCALL: |
| 1241 | compute_assigned (REF (exp, PRIMCALL, ARGS), assigned); |
| 1242 | return; |
| 1243 | |
| 1244 | case SCM_EXPANDED_SEQ: |
| 1245 | compute_assigned (REF (exp, SEQ, HEAD), assigned); |
| 1246 | compute_assigned (REF (exp, SEQ, TAIL), assigned); |
| 1247 | return; |
| 1248 | |
| 1249 | case SCM_EXPANDED_LAMBDA: |
| 1250 | compute_assigned (REF (exp, LAMBDA, BODY), assigned); |
| 1251 | return; |
| 1252 | |
| 1253 | case SCM_EXPANDED_LAMBDA_CASE: |
| 1254 | compute_assigned (REF (exp, LAMBDA_CASE, INITS), assigned); |
| 1255 | compute_assigned (REF (exp, LAMBDA_CASE, BODY), assigned); |
| 1256 | compute_assigned (REF (exp, LAMBDA_CASE, ALTERNATE), assigned); |
| 1257 | return; |
| 1258 | |
| 1259 | case SCM_EXPANDED_LET: |
| 1260 | compute_assigned (REF (exp, LET, VALS), assigned); |
| 1261 | compute_assigned (REF (exp, LET, BODY), assigned); |
| 1262 | return; |
| 1263 | |
| 1264 | case SCM_EXPANDED_LETREC: |
| 1265 | { |
| 1266 | SCM syms = REF (exp, LETREC, GENSYMS); |
| 1267 | /* We lower letrec in this same pass, so mark these variables as |
| 1268 | assigned. */ |
| 1269 | for (; scm_is_pair (syms); syms = CDR (syms)) |
| 1270 | scm_hashq_set_x (assigned, CAR (syms), SCM_BOOL_T); |
| 1271 | } |
| 1272 | compute_assigned (REF (exp, LETREC, VALS), assigned); |
| 1273 | compute_assigned (REF (exp, LETREC, BODY), assigned); |
| 1274 | return; |
| 1275 | |
| 1276 | default: |
| 1277 | abort (); |
| 1278 | } |
| 1279 | } |
| 1280 | |
| 1281 | static SCM |
| 1282 | box_value (SCM exp) |
| 1283 | { |
| 1284 | return PRIMCALL (SCM_BOOL_F, scm_from_latin1_symbol ("make-variable"), |
| 1285 | scm_list_1 (exp)); |
| 1286 | } |
| 1287 | |
| 1288 | static SCM |
| 1289 | box_lexical (SCM name, SCM sym) |
| 1290 | { |
| 1291 | return LEXICAL_SET (SCM_BOOL_F, name, sym, |
| 1292 | box_value (LEXICAL_REF (SCM_BOOL_F, name, sym))); |
| 1293 | } |
| 1294 | |
| 1295 | static SCM |
| 1296 | init_if_unbound (SCM src, SCM name, SCM sym, SCM init) |
| 1297 | { |
| 1298 | return CONDITIONAL (src, |
| 1299 | PRIMCALL (src, |
| 1300 | scm_from_latin1_symbol ("eq?"), |
| 1301 | scm_list_2 (LEXICAL_REF (src, name, sym), |
| 1302 | const_unbound)), |
| 1303 | LEXICAL_SET (src, name, sym, init), |
| 1304 | VOID_ (src)); |
| 1305 | } |
| 1306 | |
| 1307 | static SCM |
| 1308 | init_boxes (SCM names, SCM syms, SCM vals, SCM body) |
| 1309 | { |
| 1310 | if (scm_is_null (names)) return body; |
| 1311 | |
| 1312 | return SEQ (SCM_BOOL_F, |
| 1313 | PRIMCALL |
| 1314 | (SCM_BOOL_F, |
| 1315 | scm_from_latin1_symbol ("variable-set!"), |
| 1316 | scm_list_2 (LEXICAL_REF (SCM_BOOL_F, CAR (names), CAR (syms)), |
| 1317 | CAR (vals))), |
| 1318 | init_boxes (CDR (names), CDR (syms), CDR (vals), body)); |
| 1319 | } |
| 1320 | |
| 1321 | static SCM |
| 1322 | convert_assignment (SCM exp, SCM assigned) |
| 1323 | { |
| 1324 | if (scm_is_null (exp) || scm_is_false (exp)) |
| 1325 | return exp; |
| 1326 | |
| 1327 | if (scm_is_pair (exp)) |
| 1328 | return scm_cons (convert_assignment (CAR (exp), assigned), |
| 1329 | convert_assignment (CDR (exp), assigned)); |
| 1330 | |
| 1331 | if (!SCM_EXPANDED_P (exp)) |
| 1332 | abort (); |
| 1333 | |
| 1334 | switch (SCM_EXPANDED_TYPE (exp)) |
| 1335 | { |
| 1336 | case SCM_EXPANDED_VOID: |
| 1337 | case SCM_EXPANDED_CONST: |
| 1338 | case SCM_EXPANDED_PRIMITIVE_REF: |
| 1339 | case SCM_EXPANDED_MODULE_REF: |
| 1340 | case SCM_EXPANDED_TOPLEVEL_REF: |
| 1341 | return exp; |
| 1342 | |
| 1343 | case SCM_EXPANDED_LEXICAL_REF: |
| 1344 | { |
| 1345 | SCM sym = REF (exp, LEXICAL_REF, GENSYM); |
| 1346 | |
| 1347 | if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F))) |
| 1348 | return PRIMCALL |
| 1349 | (REF (exp, LEXICAL_REF, SRC), |
| 1350 | scm_from_latin1_symbol ("variable-ref"), |
| 1351 | scm_list_1 (exp)); |
| 1352 | return exp; |
| 1353 | } |
| 1354 | |
| 1355 | case SCM_EXPANDED_LEXICAL_SET: |
| 1356 | return PRIMCALL |
| 1357 | (REF (exp, LEXICAL_SET, SRC), |
| 1358 | scm_from_latin1_symbol ("variable-set!"), |
| 1359 | scm_list_2 (LEXICAL_REF (REF (exp, LEXICAL_SET, SRC), |
| 1360 | REF (exp, LEXICAL_SET, NAME), |
| 1361 | REF (exp, LEXICAL_SET, GENSYM)), |
| 1362 | convert_assignment (REF (exp, LEXICAL_SET, EXP), |
| 1363 | assigned))); |
| 1364 | |
| 1365 | case SCM_EXPANDED_MODULE_SET: |
| 1366 | return MODULE_SET |
| 1367 | (REF (exp, MODULE_SET, SRC), |
| 1368 | REF (exp, MODULE_SET, MOD), |
| 1369 | REF (exp, MODULE_SET, NAME), |
| 1370 | REF (exp, MODULE_SET, PUBLIC), |
| 1371 | convert_assignment (REF (exp, MODULE_SET, EXP), assigned)); |
| 1372 | |
| 1373 | case SCM_EXPANDED_TOPLEVEL_SET: |
| 1374 | return TOPLEVEL_SET |
| 1375 | (REF (exp, TOPLEVEL_SET, SRC), |
| 1376 | REF (exp, TOPLEVEL_SET, NAME), |
| 1377 | convert_assignment (REF (exp, TOPLEVEL_SET, EXP), assigned)); |
| 1378 | |
| 1379 | case SCM_EXPANDED_TOPLEVEL_DEFINE: |
| 1380 | return TOPLEVEL_DEFINE |
| 1381 | (REF (exp, TOPLEVEL_DEFINE, SRC), |
| 1382 | REF (exp, TOPLEVEL_DEFINE, NAME), |
| 1383 | convert_assignment (REF (exp, TOPLEVEL_DEFINE, EXP), |
| 1384 | assigned)); |
| 1385 | |
| 1386 | case SCM_EXPANDED_CONDITIONAL: |
| 1387 | return CONDITIONAL |
| 1388 | (REF (exp, CONDITIONAL, SRC), |
| 1389 | convert_assignment (REF (exp, CONDITIONAL, TEST), assigned), |
| 1390 | convert_assignment (REF (exp, CONDITIONAL, CONSEQUENT), assigned), |
| 1391 | convert_assignment (REF (exp, CONDITIONAL, ALTERNATE), assigned)); |
| 1392 | |
| 1393 | case SCM_EXPANDED_CALL: |
| 1394 | return CALL |
| 1395 | (REF (exp, CALL, SRC), |
| 1396 | convert_assignment (REF (exp, CALL, PROC), assigned), |
| 1397 | convert_assignment (REF (exp, CALL, ARGS), assigned)); |
| 1398 | |
| 1399 | case SCM_EXPANDED_PRIMCALL: |
| 1400 | return PRIMCALL |
| 1401 | (REF (exp, PRIMCALL, SRC), |
| 1402 | REF (exp, PRIMCALL, NAME), |
| 1403 | convert_assignment (REF (exp, PRIMCALL, ARGS), assigned)); |
| 1404 | |
| 1405 | case SCM_EXPANDED_SEQ: |
| 1406 | return SEQ |
| 1407 | (REF (exp, SEQ, SRC), |
| 1408 | convert_assignment (REF (exp, SEQ, HEAD), assigned), |
| 1409 | convert_assignment (REF (exp, SEQ, TAIL), assigned)); |
| 1410 | |
| 1411 | case SCM_EXPANDED_LAMBDA: |
| 1412 | return LAMBDA |
| 1413 | (REF (exp, LAMBDA, SRC), |
| 1414 | REF (exp, LAMBDA, META), |
| 1415 | scm_is_false (REF (exp, LAMBDA, BODY)) |
| 1416 | /* Give a body to case-lambda with no clauses. */ |
| 1417 | ? LAMBDA_CASE (SCM_BOOL_F, SCM_EOL, SCM_EOL, SCM_BOOL_F, SCM_BOOL_F, |
| 1418 | SCM_EOL, SCM_EOL, |
| 1419 | PRIMCALL |
| 1420 | (SCM_BOOL_F, |
| 1421 | scm_from_latin1_symbol ("throw"), |
| 1422 | scm_list_5 (CONST_ (SCM_BOOL_F, scm_args_number_key), |
| 1423 | CONST_ (SCM_BOOL_F, SCM_BOOL_F), |
| 1424 | CONST_ (SCM_BOOL_F, scm_from_latin1_string |
| 1425 | ("Wrong number of arguments")), |
| 1426 | CONST_ (SCM_BOOL_F, SCM_EOL), |
| 1427 | CONST_ (SCM_BOOL_F, SCM_BOOL_F))), |
| 1428 | SCM_BOOL_F) |
| 1429 | : convert_assignment (REF (exp, LAMBDA, BODY), assigned)); |
| 1430 | |
| 1431 | case SCM_EXPANDED_LAMBDA_CASE: |
| 1432 | { |
| 1433 | SCM src, req, opt, rest, kw, inits, syms, body, alt; |
| 1434 | SCM namewalk, symwalk, new_inits, seq; |
| 1435 | |
| 1436 | /* Box assigned formals. Since initializers can capture |
| 1437 | previous formals, we convert initializers to be in the body |
| 1438 | instead of in the "header". */ |
| 1439 | |
| 1440 | src = REF (exp, LAMBDA_CASE, SRC); |
| 1441 | req = REF (exp, LAMBDA_CASE, REQ); |
| 1442 | opt = REF (exp, LAMBDA_CASE, OPT); |
| 1443 | rest = REF (exp, LAMBDA_CASE, REST); |
| 1444 | kw = REF (exp, LAMBDA_CASE, KW); |
| 1445 | inits = convert_assignment (REF (exp, LAMBDA_CASE, INITS), assigned); |
| 1446 | syms = REF (exp, LAMBDA_CASE, GENSYMS); |
| 1447 | body = convert_assignment (REF (exp, LAMBDA_CASE, BODY), assigned); |
| 1448 | alt = convert_assignment (REF (exp, LAMBDA_CASE, ALTERNATE), assigned); |
| 1449 | |
| 1450 | new_inits = scm_make_list (scm_length (inits), const_unbound); |
| 1451 | |
| 1452 | seq = SCM_EOL, symwalk = syms; |
| 1453 | |
| 1454 | /* Required arguments may need boxing. */ |
| 1455 | for (namewalk = req; |
| 1456 | scm_is_pair (namewalk); |
| 1457 | namewalk = CDR (namewalk), symwalk = CDR (symwalk)) |
| 1458 | { |
| 1459 | SCM name = CAR (namewalk), sym = CAR (symwalk); |
| 1460 | if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F))) |
| 1461 | seq = scm_cons (box_lexical (name, sym), seq); |
| 1462 | } |
| 1463 | /* Optional arguments may need initialization and/or boxing. */ |
| 1464 | for (namewalk = opt; |
| 1465 | scm_is_pair (namewalk); |
| 1466 | namewalk = CDR (namewalk), symwalk = CDR (symwalk), |
| 1467 | inits = CDR (inits)) |
| 1468 | { |
| 1469 | SCM name = CAR (namewalk), sym = CAR (symwalk), init = CAR (inits); |
| 1470 | seq = scm_cons (init_if_unbound (src, name, sym, init), seq); |
| 1471 | if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F))) |
| 1472 | seq = scm_cons (box_lexical (name, sym), seq); |
| 1473 | } |
| 1474 | /* Rest arguments may need boxing. */ |
| 1475 | if (scm_is_true (rest)) |
| 1476 | { |
| 1477 | SCM sym = CAR (symwalk); |
| 1478 | symwalk = CDR (symwalk); |
| 1479 | if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F))) |
| 1480 | seq = scm_cons (box_lexical (rest, sym), seq); |
| 1481 | } |
| 1482 | /* The rest of the arguments, if any, are keyword arguments, |
| 1483 | which may need initialization and/or boxing. */ |
| 1484 | for (; |
| 1485 | scm_is_pair (symwalk); |
| 1486 | symwalk = CDR (symwalk), inits = CDR (inits)) |
| 1487 | { |
| 1488 | SCM sym = CAR (symwalk), init = CAR (inits); |
| 1489 | seq = scm_cons (init_if_unbound (src, SCM_BOOL_F, sym, init), seq); |
| 1490 | if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F))) |
| 1491 | seq = scm_cons (box_lexical (SCM_BOOL_F, sym), seq); |
| 1492 | } |
| 1493 | |
| 1494 | for (; scm_is_pair (seq); seq = CDR (seq)) |
| 1495 | body = SEQ (src, CAR (seq), body); |
| 1496 | |
| 1497 | return LAMBDA_CASE |
| 1498 | (src, req, opt, rest, kw, new_inits, syms, body, alt); |
| 1499 | } |
| 1500 | |
| 1501 | case SCM_EXPANDED_LET: |
| 1502 | { |
| 1503 | SCM src, names, syms, vals, body, new_vals, walk; |
| 1504 | |
| 1505 | src = REF (exp, LET, SRC); |
| 1506 | names = REF (exp, LET, NAMES); |
| 1507 | syms = REF (exp, LET, GENSYMS); |
| 1508 | vals = convert_assignment (REF (exp, LET, VALS), assigned); |
| 1509 | body = convert_assignment (REF (exp, LET, BODY), assigned); |
| 1510 | |
| 1511 | for (new_vals = SCM_EOL, walk = syms; |
| 1512 | scm_is_pair (vals); |
| 1513 | vals = CDR (vals), walk = CDR (walk)) |
| 1514 | { |
| 1515 | SCM sym = CAR (walk), val = CAR (vals); |
| 1516 | if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F))) |
| 1517 | new_vals = scm_cons (box_value (val), new_vals); |
| 1518 | else |
| 1519 | new_vals = scm_cons (val, new_vals); |
| 1520 | } |
| 1521 | new_vals = scm_reverse (new_vals); |
| 1522 | |
| 1523 | return LET (src, names, syms, new_vals, body); |
| 1524 | } |
| 1525 | |
| 1526 | case SCM_EXPANDED_LETREC: |
| 1527 | { |
| 1528 | SCM src, names, syms, vals, empty_box, boxes, body; |
| 1529 | |
| 1530 | src = REF (exp, LETREC, SRC); |
| 1531 | names = REF (exp, LETREC, NAMES); |
| 1532 | syms = REF (exp, LETREC, GENSYMS); |
| 1533 | vals = convert_assignment (REF (exp, LETREC, VALS), assigned); |
| 1534 | body = convert_assignment (REF (exp, LETREC, BODY), assigned); |
| 1535 | |
| 1536 | empty_box = |
| 1537 | PRIMCALL (SCM_BOOL_F, |
| 1538 | scm_from_latin1_symbol ("make-undefined-variable"), |
| 1539 | SCM_EOL); |
| 1540 | boxes = scm_make_list (scm_length (names), empty_box); |
| 1541 | |
| 1542 | if (scm_is_true (REF (exp, LETREC, IN_ORDER_P))) |
| 1543 | return LET |
| 1544 | (src, names, syms, boxes, |
| 1545 | init_boxes (names, syms, vals, body)); |
| 1546 | else |
| 1547 | { |
| 1548 | SCM walk, tmps = SCM_EOL, inits = SCM_EOL; |
| 1549 | |
| 1550 | for (walk = syms; scm_is_pair (walk); walk = CDR (walk)) |
| 1551 | { |
| 1552 | SCM tmp = scm_gensym (SCM_UNDEFINED); |
| 1553 | tmps = scm_cons (tmp, tmps); |
| 1554 | inits = scm_cons (LEXICAL_REF (SCM_BOOL_F, SCM_BOOL_F, tmp), |
| 1555 | inits); |
| 1556 | } |
| 1557 | tmps = scm_reverse (tmps); |
| 1558 | inits = scm_reverse (inits); |
| 1559 | |
| 1560 | return LET |
| 1561 | (src, names, syms, boxes, |
| 1562 | SEQ (src, |
| 1563 | LET (src, names, tmps, vals, |
| 1564 | init_boxes (names, syms, inits, VOID_ (src))), |
| 1565 | body)); |
| 1566 | } |
| 1567 | } |
| 1568 | |
| 1569 | default: |
| 1570 | abort (); |
| 1571 | } |
| 1572 | } |
| 1573 | |
| 1574 | SCM |
| 1575 | scm_convert_assignment (SCM exp) |
| 1576 | { |
| 1577 | SCM assigned = scm_c_make_hash_table (0); |
| 1578 | |
| 1579 | compute_assigned (exp, assigned); |
| 1580 | return convert_assignment (exp, assigned); |
| 1581 | } |
| 1582 | |
| 1583 | |
| 1584 | \f |
| 1585 | |
| 1586 | #define DEFINE_NAMES(type) \ |
| 1587 | { \ |
| 1588 | static const char *fields[] = SCM_EXPANDED_##type##_FIELD_NAMES; \ |
| 1589 | exp_field_names[SCM_EXPANDED_##type] = fields; \ |
| 1590 | exp_names[SCM_EXPANDED_##type] = SCM_EXPANDED_##type##_TYPE_NAME; \ |
| 1591 | exp_nfields[SCM_EXPANDED_##type] = SCM_NUM_EXPANDED_##type##_FIELDS; \ |
| 1592 | } |
| 1593 | |
| 1594 | static SCM |
| 1595 | make_exp_vtable (size_t n) |
| 1596 | { |
| 1597 | SCM layout, printer, name, code, fields; |
| 1598 | |
| 1599 | layout = scm_string_to_symbol |
| 1600 | (scm_string_append (scm_make_list (scm_from_size_t (exp_nfields[n]), |
| 1601 | scm_from_locale_string ("pw")))); |
| 1602 | printer = SCM_BOOL_F; |
| 1603 | name = scm_from_utf8_symbol (exp_names[n]); |
| 1604 | code = scm_from_size_t (n); |
| 1605 | fields = SCM_EOL; |
| 1606 | { |
| 1607 | size_t m = exp_nfields[n]; |
| 1608 | while (m--) |
| 1609 | fields = scm_cons (scm_from_utf8_symbol (exp_field_names[n][m]), fields); |
| 1610 | } |
| 1611 | |
| 1612 | return scm_c_make_struct (scm_exp_vtable_vtable, 0, 5, |
| 1613 | SCM_UNPACK (layout), SCM_UNPACK (printer), SCM_UNPACK (name), |
| 1614 | SCM_UNPACK (code), SCM_UNPACK (fields)); |
| 1615 | } |
| 1616 | |
| 1617 | void |
| 1618 | scm_init_expand () |
| 1619 | { |
| 1620 | size_t n; |
| 1621 | SCM exp_vtable_list = SCM_EOL; |
| 1622 | |
| 1623 | DEFINE_NAMES (VOID); |
| 1624 | DEFINE_NAMES (CONST); |
| 1625 | DEFINE_NAMES (PRIMITIVE_REF); |
| 1626 | DEFINE_NAMES (LEXICAL_REF); |
| 1627 | DEFINE_NAMES (LEXICAL_SET); |
| 1628 | DEFINE_NAMES (MODULE_REF); |
| 1629 | DEFINE_NAMES (MODULE_SET); |
| 1630 | DEFINE_NAMES (TOPLEVEL_REF); |
| 1631 | DEFINE_NAMES (TOPLEVEL_SET); |
| 1632 | DEFINE_NAMES (TOPLEVEL_DEFINE); |
| 1633 | DEFINE_NAMES (CONDITIONAL); |
| 1634 | DEFINE_NAMES (CALL); |
| 1635 | DEFINE_NAMES (PRIMCALL); |
| 1636 | DEFINE_NAMES (SEQ); |
| 1637 | DEFINE_NAMES (LAMBDA); |
| 1638 | DEFINE_NAMES (LAMBDA_CASE); |
| 1639 | DEFINE_NAMES (LET); |
| 1640 | DEFINE_NAMES (LETREC); |
| 1641 | |
| 1642 | scm_exp_vtable_vtable = |
| 1643 | scm_make_vtable (scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT "pwuwpw"), |
| 1644 | SCM_BOOL_F); |
| 1645 | |
| 1646 | for (n = 0; n < SCM_NUM_EXPANDED_TYPES; n++) |
| 1647 | exp_vtables[n] = make_exp_vtable (n); |
| 1648 | |
| 1649 | /* Now walk back down, consing in reverse. */ |
| 1650 | while (n--) |
| 1651 | exp_vtable_list = scm_cons (exp_vtables[n], exp_vtable_list); |
| 1652 | |
| 1653 | const_unbound = |
| 1654 | CONST_ (SCM_BOOL_F, scm_list_1 (scm_from_latin1_symbol ("unbound"))); |
| 1655 | |
| 1656 | scm_c_define_gsubr ("convert-assignment", 1, 0, 0, scm_convert_assignment); |
| 1657 | |
| 1658 | scm_c_define ("%expanded-vtables", scm_vector (exp_vtable_list)); |
| 1659 | |
| 1660 | #include "libguile/expand.x" |
| 1661 | } |
| 1662 | |
| 1663 | /* |
| 1664 | Local Variables: |
| 1665 | c-file-style: "gnu" |
| 1666 | End: |
| 1667 | */ |