1 /*===========================================================================
2 * Filename : macro.c
3 * About : R5RS hygienic macros
4 *
5 * Copyright (C) 2006 Jun Inoue <jun.lambda@gmail.com>
6 * Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
7 *
8 * All rights reserved.
9 *
10 * Redistribution and use in source and binary forms, with or without
11 * modification, are permitted provided that the following conditions
12 * are met:
13 *
14 * 1. Redistributions of source code must retain the above copyright
15 * notice, this list of conditions and the following disclaimer.
16 * 2. Redistributions in binary form must reproduce the above copyright
17 * notice, this list of conditions and the following disclaimer in the
18 * documentation and/or other materials provided with the distribution.
19 * 3. Neither the name of authors nor the names of its contributors
20 * may be used to endorse or promote products derived from this software
21 * without specific prior written permission.
22 *
23 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
24 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
25 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
26 * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
27 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
28 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
29 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
30 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
31 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
32 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
33 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34 ===========================================================================*/
35
36 #include "sigscheme.h"
37 #include "sigschemeinternal.h"
38 #include <stdlib.h>
39
40 #include "functable-r5rs-macro.c"
41
42 /* ------------------------------
43 * Definitions
44 * ------------------------------
45 *
46 * There doesn't seem to be a set of terminologies that is widely
47 * agreed upon in the Scheme community regarding hygienic macros.
48 * Here's a list of definitions and clarifications of the terms used
49 * in SigScheme's macro facility.
50 *
51 * far symbol (farsym, wrapped identifier, wrapper):
52 * An object that wraps an identifier with environment information.
53 *
54 * identifier (ident, variable):
55 * A symbol or a far symbol.
56 *
57 * level:
58 * A number associated with every subpattern, namely the number of
59 * ellipses that affect the subpattern. e.g. the pvar x in the
60 * template ((x ...) ... y ...) is at level 2.
61 *
62 * <literals>:
63 * The cadr of a valid syntax-rules form. Note the <>.
64 *
65 * pattern variable (pvar, pv[prefix]):
66 * An identifier that appears in a pattern which is not in <literals>.
67 * Also, any identifier in a template that is eq? to a pattern
68 * variable found in the corresponding pattern. The latter may be
69 * referred to as a pattern variable reference (pref).
70 *
71 * pattern variable marker (pvar marker, marker):
72 * Objects found in a compiled pattern or template that mark where
73 * pattern variables were.
74 *
75 * repeatable subpattern (reppat):
76 * A subpattern *or subtemplate* designated as repeatable, i.e.
77 * followed by an ellipsis.
78 *
79 * repeatable sublist (replist):
80 * A repeatable subpattern that matches a list.
81 *
82 * repeatable subvector (repvector):
83 * A repeatable subpattern that matches a vector.
84 *
85 * rule:
86 * A pattern-template pair in a syntax-rules form. Or, a pattern-body
87 * pair in a case-lambda or match-case expression.
88 *
89 * sub:
90 * A subform which is matched to a pattern variable, or a list of such
91 * objects. It derives, surprisingly perhaps, from `subform', only
92 * contracted for disambiguation. FIXME: Any better name?
93 */
94
95 #if SCM_DEBUG_MACRO
96 enum dbg_flag {
97 DBG_COMPILER = 1 << 0,
98 DBG_MATCHER = 1 << 1,
99 DBG_TRANSCRIPTOR = 1 << 2,
100 DBG_FUNCALL = 1 << 3,
101 DBG_PVAR = 1 << 4,
102 DBG_RETURN = 1 << 5,
103 DBG_UNWRAP = 1 << 6,
104 DBG_EXPANDER = 1 << 7
105 };
106 #endif
107
108 SCM_GLOBAL_VARS_BEGIN(static_macro);
109 #define static
110 #if SCM_DEBUG_MACRO
111 static enum dbg_flag l_debug_mode;
112 #endif
113 static int l_dummy;
114 #undef static
115 SCM_GLOBAL_VARS_END(static_macro);
116 #define l_debug_mode SCM_GLOBAL_VAR(static_macro, l_debug_mode)
117 SCM_DEFINE_STATIC_VARS(static_macro);
118
119 #define SYM_SYNTAX_RULES scm_intern("syntax-rules")
120
121 #define ELLIPSISP(o) EQ((o), SYM_ELLIPSIS)
122
123 #define MAKE_PVAR SCM_SUBPAT_MAKE_PVAR
124 #define PVAR_INDEX SCM_SUBPAT_PVAR_INDEX
125 #define PVARP SCM_SUBPAT_PVARP
126
127 #define MAKE_REPPAT SCM_SUBPAT_MAKE_REPPAT
128 #define REPPAT_PAT SCM_SUBPAT_REPPAT_PAT
129 #define REPPAT_PVCOUNT SCM_SUBPAT_REPPAT_PVCOUNT
130 #define REPPATP SCM_SUBPAT_REPPATP
131
132
133 #if SCM_DEBUG_MACRO
134 #define DBG_PRINT(args) (dbg_print args)
135 #define INIT_DBG() init_dbg()
136 #define DEFINE(name, init) (SCM_SYMBOL_SET_VCELL(scm_intern((name)), (init)))
137 #include <stdarg.h>
138
139 static void
dbg_print(enum dbg_flag mask,const char * fmt,...)140 dbg_print(enum dbg_flag mask, const char *fmt, ...)
141 {
142 va_list va;
143
144 if (mask & l_debug_mode) {
145 va_start(va, fmt);
146 scm_vformat(scm_err, SCM_FMT_INTERNAL, fmt, va);
147 va_end(va);
148 }
149 }
150
151 static ScmObj
scm_p_set_macro_debug_flagsx(ScmObj new_mode)152 scm_p_set_macro_debug_flagsx(ScmObj new_mode)
153 {
154 SCM_ASSERT(INTP(new_mode));
155
156 l_debug_mode = SCM_INT_VALUE(new_mode);
157 return SCM_UNDEF;
158 }
159
160 static const struct scm_func_registration_info dbg_funcs[] = {
161 { "set-macro-debug-flags!", scm_p_set_macro_debug_flagsx,
162 SCM_PROCEDURE_FIXED_1 },
163 { NULL, NULL, SCM_FUNCTYPE_INVALID }
164 };
165
166 static void
init_dbg(void)167 init_dbg(void)
168 {
169 l_debug_mode = 0;
170
171 DEFINE("%debug-macro-compiler", MAKE_INT(DBG_COMPILER));
172 DEFINE("%debug-macro-matcher", MAKE_INT(DBG_MATCHER));
173 DEFINE("%debug-macro-transcriptor", MAKE_INT(DBG_TRANSCRIPTOR));
174 DEFINE("%debug-macro-funcall", MAKE_INT(DBG_FUNCALL));
175 DEFINE("%debug-macro-pvar", MAKE_INT(DBG_PVAR));
176 DEFINE("%debug-macro-return", MAKE_INT(DBG_RETURN));
177 DEFINE("%debug-macro-unwrap", MAKE_INT(DBG_UNWRAP));
178 DEFINE("%debug-macro-expander", MAKE_INT(DBG_EXPANDER));
179 scm_register_funcs(dbg_funcs);
180 }
181
182 #else /* not SCM_DEBUG_MACRO */
183 #define DBG_PRINT(args) SCM_EMPTY_EXPR
184 #define INIT_DBG() SCM_EMPTY_EXPR
185 #endif /* not SCM_DEBUG_MACRO */
186
187
188 typedef struct {
189 ScmObj syms;
190 ScmObj vals;
191 } var_map;
192
193 typedef struct {
194 ScmObj pvmark; /** Pvar marker in patterns. */
195 var_map pvars; /** Pvar -> level/marker. */
196 scm_int_t pvlen; /** Length of pvars.syms */
197 ScmObj literals;
198 struct {
199 scm_bool pattern; /* False if compiling template. */
200 } mode;
201 } compilation_context;
202
203 static ScmObj compile(compilation_context *ctx, ScmObj form);
204 static ScmObj match(ScmObj pattern, ScmObj form, ScmPackedEnv def_penv, ScmPackedEnv use_penv, ScmObj env);
205 static ScmObj transcribe(ScmObj template, ScmObj sub, ScmPackedEnv def_penv, ScmObj use_env);
206
207 static ScmObj expand_hygienic_macro(ScmObj macro, ScmObj args, ScmObj env);
208
209 static scm_int_t list_find_index(ScmObj x, ScmObj ls);
210
211
212 SCM_EXPORT void
scm_init_macro(void)213 scm_init_macro(void)
214 {
215 SCM_GLOBAL_VARS_INIT(static_macro);
216
217 scm_register_funcs(scm_functable_r5rs_macro);
218
219 INIT_DBG();
220 }
221
222 SCM_EXPORT void SCM_NORETURN
scm_macro_bad_scope(ScmObj id)223 scm_macro_bad_scope(ScmObj id)
224 {
225 PLAIN_ERR("Identifier ~s found in wrong context. "
226 "Possibly, a macro was passed around like an object "
227 "or a syntax didn't syntax-unwrap its arguments properly.",
228 id);
229 }
230
231 static ScmObj
expand_hygienic_macro(ScmObj macro,ScmObj args,ScmObj env)232 expand_hygienic_macro(ScmObj macro, ScmObj args, ScmObj env)
233 {
234 ScmObj sub, rule, rules;
235 ScmPackedEnv use_penv, def_penv;
236 DECLARE_INTERNAL_FUNCTION("(expand_hygienic_macro)");
237
238 rules = SCM_HMACRO_RULES(macro);
239 def_penv = SCM_HMACRO_ENV(macro);
240 use_penv = scm_pack_env(env);
241
242 FOR_EACH (rule, rules) {
243 sub = match(CAR(rule), args, def_penv, use_penv, env);
244 if (VALIDP(sub))
245 return transcribe(CDR(rule), sub, SCM_HMACRO_ENV(macro),
246 env);
247 }
248 ERR_OBJ("no matching pattern for", args);
249 /* Not reached. */
250 }
251
252 SCM_EXPORT ScmObj
scm_expand_macro(ScmObj macro,ScmObj args,ScmEvalState * eval_state)253 scm_expand_macro(ScmObj macro, ScmObj args, ScmEvalState *eval_state)
254 {
255 ScmObj ret;
256 DECLARE_INTERNAL_FUNCTION("scm_expand_macro");
257
258 eval_state->ret_type = SCM_VALTYPE_NEED_EVAL;
259 #if SCM_STRICT_R5RS
260 if (!SCM_LISTLEN_PROPERP(scm_length(args)))
261 ERR_OBJ("bad argument list", args);
262 #endif
263 ret = expand_hygienic_macro(macro, args, eval_state->env);
264 DBG_PRINT((DBG_EXPANDER, "expanded to ~s\n", ret));
265 return ret;
266 }
267
268 SCM_EXPORT ScmObj
scm_s_expand_macro(ScmObj macro,ScmObj args,ScmEvalState * eval_state)269 scm_s_expand_macro(ScmObj macro, ScmObj args, ScmEvalState *eval_state)
270 {
271 ScmObj ret;
272 DECLARE_FUNCTION("expand-macro", syntax_variadic_tailrec_1);
273
274 ret = scm_expand_macro(EVAL(macro, eval_state->env), args, eval_state);
275 eval_state->ret_type = SCM_VALTYPE_AS_IS;
276 return ret;
277 }
278
279 SCM_EXPORT ScmObj
scm_s_syntax_rules(ScmObj args,ScmObj env)280 scm_s_syntax_rules(ScmObj args, ScmObj env)
281 {
282 ScmObj rule, compiled_rules;
283 ScmQueue q;
284 compilation_context ctx;
285 DECLARE_FUNCTION("syntax-rules", syntax_variadic_0);
286
287 if (NULLP(args) || NULLP(CDR(args)))
288 ERR_OBJ("missing rules", args);
289
290 ctx.literals = CAR(args);
291 args = CDR(args);
292 #if SCM_STRICT_ARGCHECK
293 /* Check literals. */
294 {
295 ScmObj pair;
296 FOR_EACH_PAIR (pair, ctx.literals)
297 ENSURE_IDENTIFIER(CAR(pair));
298 if (!NULLP(pair))
299 ERR_OBJ("bad <literals>", ctx.literals);
300 }
301 #endif
302
303 ctx.pvmark = MAKE_PVAR(SCM_NULL, 0);
304 SCM_QUEUE_POINT_TO(q, compiled_rules);
305
306 FOR_EACH (rule, args) {
307 ScmObj pat, tmpl;
308 /* ((_ . pattern) template) */
309 if (!LIST_2_P(rule) || !CONSP(CAR(rule)))
310 ERR_OBJ("malformed syntax rule", rule);
311 #if SCM_STRICT_ARGCHECK
312 if (!IDENTIFIERP(CAAR(rule)))
313 ERR_OBJ("pattern must start with an identifier", rule);
314 #endif
315 ctx.pvars.syms = SCM_NULL;
316 ctx.pvars.vals = SCM_NULL;
317 ctx.pvlen = 0;
318 ctx.mode.pattern = scm_true;
319 pat = compile(&ctx, CDAR(rule));
320 ctx.mode.pattern = scm_false;
321 /* ctx.pvlen = 0; Not necessary because we just need its
322 * change, not the absolute value. */
323 tmpl = compile(&ctx, CADR(rule));
324 SCM_QUEUE_ADD(q, CONS(pat, tmpl));
325 }
326
327 return MAKE_HMACRO(compiled_rules, env);
328 }
329
330 SCM_EXPORT ScmObj
scm_s_match(ScmObj form,ScmObj clauses,ScmEvalState * state)331 scm_s_match(ScmObj form, ScmObj clauses, ScmEvalState *state)
332 {
333 ScmObj clause;
334 compilation_context ctx;
335 DECLARE_FUNCTION("match", syntax_variadic_tailrec_1);
336
337 form = EVAL(form, state->env);
338 ctx.pvmark = MAKE_PVAR(SCM_NULL, 0);
339 ctx.literals = SCM_NULL;
340 ctx.mode.pattern = scm_true;
341 /* (match <datum>
342 * (<pattern>)
343 * (<pattern>))
344 */
345 FOR_EACH (clause, clauses) {
346 ScmObj pat, sub;
347 if (!CONSP(clause))
348 ERR_OBJ("malformed match clause", clause);
349 ctx.pvars.syms = SCM_NULL;
350 ctx.pvars.vals = SCM_NULL;
351 ctx.pvlen = 0;
352
353 pat = compile(&ctx, SCM_UNWRAP_SYNTAX(CAR(clause)));
354
355 /* match should never invoke scm_identifierequalp() since at
356 * the moment no construct to literalize an identifier is
357 * provided. */
358 sub = match(pat, form,
359 0, 0, SCM_INVALID);
360 if (VALIDP(sub)) {
361 /* FIXME: directly manipulates environment. */
362 state->env = CONS(CONS(ctx.pvars.syms, sub), state->env);
363
364 /* FIXME: enforce proper tail recursion (but don't let
365 * code that does no matching pay for it!). */
366 return scm_s_begin(CDR(clause), state);
367 }
368 }
369 return SCM_UNDEF;
370 }
371
372 /* TODO: parameterize EVAL in scm_s_let(), scm_s_letrec() and scm_s_define(),
373 * and call them with EVAL set to eval_syntax_rules(). We might want to
374 * separate macros namespace from that of objects since macros aren't
375 * first-class objects. */
376 SCM_EXPORT ScmObj
scm_s_let_syntax(ScmObj bindings,ScmObj body,ScmEvalState * eval_state)377 scm_s_let_syntax(ScmObj bindings, ScmObj body, ScmEvalState *eval_state)
378 {
379 DECLARE_FUNCTION("let-syntax", syntax_variadic_tailrec_1);
380
381 return scm_s_let_internal(ScmMacro, bindings, body, eval_state);
382 }
383
384 SCM_EXPORT ScmObj
scm_s_letrec_syntax(ScmObj bindings,ScmObj body,ScmEvalState * eval_state)385 scm_s_letrec_syntax(ScmObj bindings, ScmObj body, ScmEvalState *eval_state)
386 {
387 DECLARE_FUNCTION("letrec-syntax", syntax_variadic_tailrec_1);
388
389 return scm_s_letrec_internal(ScmMacro, bindings, body, eval_state);
390 }
391
392 SCM_EXPORT ScmObj
scm_s_define_syntax(ScmObj var,ScmObj macro,ScmObj env)393 scm_s_define_syntax(ScmObj var, ScmObj macro, ScmObj env)
394 {
395 DECLARE_FUNCTION("define-syntax", syntax_fixed_2);
396
397 ENSURE_IDENTIFIER(var);
398
399 scm_s_define_internal(ScmMacro, var, macro, env);
400
401 return SCM_UNDEF;
402 }
403
404 /* ==============================
405 * Pattern Compiler
406 * ==============================*/
407
408
409 static ScmObj compile_rec(compilation_context *ctx, ScmObj form,
410 scm_int_t level);
411
412 static ScmObj
compile(compilation_context * ctx,ScmObj form)413 compile(compilation_context *ctx, ScmObj form)
414 {
415 DECLARE_INTERNAL_FUNCTION("compile (pattern or template)");
416
417 if (ELLIPSISP(form))
418 ERR("misplaced ellipsis");
419 return compile_rec(ctx, form, 0);
420 }
421
422 static ScmObj
compile_rec(compilation_context * ctx,ScmObj form,scm_int_t level)423 compile_rec(compilation_context *ctx, ScmObj form, scm_int_t level)
424 {
425 DECLARE_INTERNAL_FUNCTION("compile (pattern or template)");
426
427 DBG_PRINT((DBG_COMPILER | DBG_FUNCALL, "compiling ~s [~S lv ~MD]\n",
428 form, ctx->mode.pattern ? "pattern" : "template", level));
429 /* TODO: maybe rewrite it using translators? Not sure how much
430 * advantage that would provide, though... */
431 if (CONSP(form)) {
432 ScmObj out, obj, rest;
433 ScmQueue q;
434
435 rest = out = form;
436 SCM_QUEUE_POINT_TO(q, out);
437
438 restart:
439 if (ELLIPSISP(CAR(rest)))
440 ERR_OBJ("misplaced ellipsis", form);
441 FOR_EACH_BUTLAST (obj, rest) {
442 if (ELLIPSISP(CAR(rest))) {
443 ScmObj subpat;
444 scm_int_t pvlen_before;
445
446 pvlen_before = ctx->pvlen;
447 rest = CDR(rest);
448 subpat = compile_rec(ctx, obj, level + 1);
449 subpat = MAKE_REPPAT(subpat, ctx->pvlen - pvlen_before);
450 SCM_QUEUE_ADD(q, subpat);
451
452 if (ctx->mode.pattern) {
453 if (!NULLP(rest))
454 ERR_OBJ("misplaced ellipsis", form);
455 return out;
456 }
457 if (ctx->pvlen == pvlen_before)
458 ERR_OBJ("constant repeatable subtemplate", form);
459 if (CONSP(rest))
460 goto restart;
461 return out;
462 } else {
463 SCM_QUEUE_ADD(q, compile_rec(ctx, obj, level));
464 }
465 }
466 SCM_ASSERT(!ELLIPSISP(obj));
467 SCM_QUEUE_ADD(q, compile_rec(ctx, obj, level));
468 if (!NULLP(rest)) {
469 if (ELLIPSISP(rest))
470 ERR_OBJ("misplaced ellipsis", form);
471 SCM_QUEUE_SLOPPY_APPEND(q, compile_rec(ctx, rest, level));
472 }
473 return out;
474 } else if (VECTORP(form)) {
475 scm_int_t i, j, ellipses, len;
476 scm_bool ellipsis_ok, constantp;
477 ScmObj *invec, *outvec;
478 ScmObj out;
479
480 len = SCM_VECTOR_LEN(form);
481 if (!len) return form;
482 invec = SCM_VECTOR_VEC(form);
483
484 /* Count ellipses. */
485 ellipsis_ok = scm_false;
486 constantp = scm_true;
487 ellipses = 0;
488 for (i = 0; i < len; i++) {
489 if (constantp && (CONSP(invec[i]) || IDENTIFIERP(invec[i])
490 || VECTORP(invec[i])))
491 constantp = scm_false;
492 if (ELLIPSISP(invec[i])) {
493 if (!ellipsis_ok)
494 ERR_OBJ("misplaced ellipsis", form);
495 ++ellipses;
496 ellipsis_ok = scm_false;
497 } else {
498 ellipsis_ok = scm_true;
499 }
500 }
501 if (constantp) return form;
502 if (ctx->mode.pattern) {
503 /* At most one ellipsis at the end. */
504 if (1 < ellipses || (ellipses && !ELLIPSISP(invec[len - 1])))
505 ERR_OBJ("misplaced ellipsis", form);
506 }
507
508 outvec = scm_malloc((len - ellipses) * sizeof(ScmObj));
509 /* Fill with something recognized by GC. */
510 for (i = 0; i < len - ellipses; i++)
511 outvec[i] = SCM_NULL;
512 out = MAKE_VECTOR(outvec, len - ellipses);
513
514 /* i = input index, j = output index. */
515 for (i = 1, j = 0; i < len; i++, j++) {
516 SCM_ASSERT(j < len - ellipses);
517 if (ELLIPSISP(invec[i])) {
518 ScmObj subpat;
519 scm_int_t pvlen_before;
520
521 pvlen_before = ctx->pvlen;
522 subpat = compile_rec(ctx, invec[i - 1], level + 1);
523 if (!ctx->mode.pattern && ctx->pvlen == pvlen_before)
524 ERR_OBJ("constant repeatable subtemplate", form);
525 outvec[j] = MAKE_REPPAT(subpat, ctx->pvlen - pvlen_before);
526 if (++i == len)
527 return out;
528 } else {
529 outvec[j] = compile_rec(ctx, invec[i - 1], level);
530 }
531 }
532 SCM_ASSERT(i == len);
533 outvec[j] = compile_rec(ctx, invec[i - 1], level);
534 return out;
535 } else if (IDENTIFIERP(form)) {
536 /* ctx->pvars.vals initially contains a list of levels. Then
537 * during template compilation, pvar markers are cached as
538 * they are created by consing them to the vals list, like so:
539 *
540 * syntax rule: ((_ (a ...) b c) '(a b))
541 * syms: (c b a)
542 * compile pattern -> vals = (0 0 1)
543 * compile template -> vals = (0
544 * (#<pvar index=1> . 0)
545 * (#<pvar index=2> . 1))
546 */
547 if (ctx->mode.pattern) {
548 if (FALSEP(scm_p_memq(form, ctx->literals))) {
549 if (TRUEP(scm_p_memq(form, ctx->pvars.syms)))
550 ERR_OBJ("duplicate pattern variable", form);
551 ctx->pvars.syms = CONS(form, ctx->pvars.syms);
552 ctx->pvars.vals = CONS(MAKE_INT(level), ctx->pvars.vals);
553 ++ctx->pvlen;
554 #if SCM_DEBUG_MACRO
555 return MAKE_PVAR(form, 0);
556 #else
557 return ctx->pvmark;
558 #endif
559 }
560 return form;
561 } else {
562 scm_int_t index;
563
564 index = list_find_index(form, ctx->pvars.syms);
565 if (index < 0) {
566 /* Not found; FORM is a free variable. */
567 return form;
568 } else {
569 ScmObj tail, ret;
570 scm_int_t pvlevel;
571
572 ++ctx->pvlen;
573 tail = scm_list_tail(ctx->pvars.vals, index);
574 SCM_ASSERT(CONSP(tail));
575 if (CONSP(CAR(tail))) {
576 SCM_ASSERT(PVARP(CAAR(tail)) && INTP(CDAR(tail)));
577 pvlevel = SCM_INT_VALUE(CDAR(tail));
578 ret = CAAR(tail);
579 } else {
580 SCM_ASSERT(INTP(CAR(tail)));
581 pvlevel = SCM_INT_VALUE(CAR(tail));
582 ret = MAKE_PVAR(form, index);
583 SET_CAR(tail, CONS(ret, CAR(tail)));
584 }
585 if (level != pvlevel) {
586 ERR_OBJ("pattern variable used at wrong level", form);
587 }
588 return ret;
589 }
590 }
591 }
592 return form;
593 }
594
595
596 /* ==============================
597 * Pattern Matcher
598 * ==============================*/
599
600 typedef struct {
601 ScmPackedEnv def_penv;
602 ScmPackedEnv use_penv;
603 ScmObj use_env;
604 ScmObj sub; /** Objects that matched a pvar.
605 * Populated only if it's VALIDP(). */
606 } match_context;
607
608 static void merge_subs(ScmObj to, ScmObj from, ScmObj end);
609 static scm_bool match_rec(match_context *ctx, ScmObj pat, ScmObj form);
610 static scm_bool match_reppat(match_context *ctx, ScmObj arg, ScmObj form);
611
612 /**
613 * Matches FORM against RULES.
614 *
615 * @param env Environment of the macro use.
616 */
617 static ScmObj
match(ScmObj pattern,ScmObj form,ScmPackedEnv def_penv,ScmPackedEnv use_penv,ScmObj use_env)618 match(ScmObj pattern, ScmObj form, ScmPackedEnv def_penv,
619 ScmPackedEnv use_penv, ScmObj use_env)
620 {
621 match_context ctx;
622 DECLARE_INTERNAL_FUNCTION("(match)");
623
624 DBG_PRINT((DBG_MATCHER | DBG_FUNCALL, "match: ~s =~~ ~s\n",
625 form, pattern));
626
627 ctx.def_penv = def_penv;
628 ctx.use_penv = use_penv;
629 ctx.use_env = use_env;
630 ctx.sub = SCM_INVALID; /* Not investing storage yet. */
631
632 if (match_rec(&ctx, pattern, form)) {
633 /* Matched. */
634 ctx.sub = SCM_NULL;
635 match_rec(&ctx, pattern, form);
636 }
637 DBG_PRINT((DBG_MATCHER | DBG_RETURN, "match done, returning ~s\n",
638 VALIDP(ctx.sub) ? ctx.sub : SCM_UNDEF));
639 return ctx.sub;
640 }
641
642 #define MATCH_REC(c, p, f) \
643 do { \
644 if (!match_rec((c), (p), (f))) \
645 return scm_false; \
646 } while (0)
647
648 #define MISMATCH(reason, pat, form) \
649 do { \
650 DBG_PRINT((DBG_MATCHER, "~s !~~ ~s ~S\n", (form), (pat), (reason))); \
651 return scm_false; \
652 } while (0)
653
654 static scm_bool
match_rec(match_context * ctx,ScmObj pat,ScmObj form)655 match_rec(match_context *ctx, ScmObj pat, ScmObj form)
656 {
657 #if SCM_DEBUG_MACRO
658 ScmObj pat_save = pat;
659 ScmObj form_save = form;
660 #endif
661 DECLARE_INTERNAL_FUNCTION("(<pattern>)");
662
663 DBG_PRINT((DBG_MATCHER | DBG_FUNCALL, "match_rec: ~s =~~ ~s\n",
664 form, pat));
665
666 SCM_ASSERT(!(SUBPATP(pat) && REPPATP(pat)));
667
668 FOR_EACH_PAIR (pat, pat) {
669 ScmObj subpat = CAR(pat);
670 if (SUBPATP(subpat) && REPPATP(subpat))
671 return match_reppat(ctx, pat, form);
672 if (!CONSP(form))
673 MISMATCH("form too short", pat_save, form_save);
674 MATCH_REC(ctx, subpat, CAR(form));
675 form = CDR(form);
676 }
677
678 if (SUBPATP(pat)) {
679 SCM_ASSERT(PVARP(pat));
680 if (VALIDP(ctx->sub))
681 ctx->sub = CONS(form, ctx->sub);
682 return scm_true;
683 }
684
685 if (VECTORP(pat)) {
686 scm_int_t plen, flen, len, i;
687 ScmObj *pvec, *fvec;
688 if (!VECTORP(form))
689 return scm_false;
690 plen = SCM_VECTOR_LEN(pat);
691 flen = SCM_VECTOR_LEN(form);
692 if (!plen)
693 return !flen;
694 pvec = SCM_VECTOR_VEC(pat);
695 fvec = SCM_VECTOR_VEC(form);
696 if (SUBPATP(pvec[plen - 1]) && REPPATP(pvec[plen - 1])) {
697 len = plen - 1;
698 if (SCM_VECTOR_LEN(form) < len)
699 MISMATCH("form too short", pat_save, form_save);
700 } else {
701 if (plen != flen)
702 MISMATCH("length mismatch", pat_save, form_save);
703 len = plen;
704 }
705
706 for (i = 0; i < len; i++)
707 MATCH_REC(ctx, pvec[i], fvec[i]);
708 if (plen != len)
709 return match_reppat(ctx, pat, form);
710 return scm_true;
711 } else if (IDENTIFIERP(pat)) {
712 if (!IDENTIFIERP(form))
713 MISMATCH("wrong atom", pat_save, form_save);
714 if (!scm_identifierequalp(pat, ctx->def_penv, form,
715 ctx->use_penv, ctx->use_env))
716 MISMATCH("wrong name or binding", pat_save, form_save);
717 return scm_true;
718 }
719
720 if (TRUEP(scm_p_equalp(pat, form)))
721 return scm_true;
722 MISMATCH("wrong atom", pat_save, form_save);
723 /* Not reached. */
724 }
725
726
727 /* FIXME: give arg a better name. */
728 static scm_bool
match_reppat(match_context * ctx,ScmObj arg,ScmObj form)729 match_reppat(match_context *ctx, ScmObj arg, ScmObj form)
730 {
731 ScmObj pat, sub_save, accum, reppat;
732 scm_int_t i = 0; /* the value is needed only to suppress warning */
733
734 DBG_PRINT((DBG_MATCHER | DBG_FUNCALL, "match_reppat: ~s =~~ ~s\n",
735 form, arg));
736
737 if (CONSP(arg)) {
738 reppat = CAR(arg);
739 pat = REPPAT_PAT(reppat);
740
741 if (SUBPATP(pat)) {
742 /* (pvar ...) */
743 SCM_ASSERT(PVARP(pat));
744 if (!SCM_LISTLEN_PROPERP(scm_length(form)))
745 MISMATCH("repeatable subpattern matched against "
746 "improper list, vector, or atom",
747 pat, form);
748 if (VALIDP(ctx->sub))
749 ctx->sub = CONS(form, ctx->sub);
750 return scm_true;
751 }
752 } else {
753 SCM_ASSERT(VECTORP(arg));
754 i = SCM_VECTOR_LEN(arg) - 1;
755 SCM_ASSERT(i >= 0);
756 SCM_ASSERT(i <= SCM_VECTOR_LEN(form));
757 reppat = SCM_VECTOR_VEC(arg)[i];
758 pat = REPPAT_PAT(reppat);
759 }
760 SCM_ASSERT(SUBPATP(reppat) && REPPATP(reppat));
761
762 accum = sub_save = ctx->sub;
763 /* Populate with empty subs. */
764 if (VALIDP(ctx->sub)) {
765 scm_int_t pvcount;
766 for (pvcount = REPPAT_PVCOUNT(reppat); pvcount--;)
767 accum = CONS(SCM_NULL, accum);
768 }
769
770 if (CONSP(arg)) {
771 ScmObj subform;
772 FOR_EACH (subform, form) {
773 ctx->sub = sub_save;
774 MATCH_REC(ctx, pat, subform);
775 merge_subs(accum, ctx->sub, sub_save);
776 }
777 if (!NULLP(form))
778 MISMATCH("repeatable subpattern matched against "
779 "improper list, vector, or atom",
780 pat, form);
781 } else { /* VECTORP(arg) */
782 scm_int_t len;
783 ScmObj *vec;
784
785 SCM_ASSERT(VECTORP(form));
786 len = SCM_VECTOR_LEN(form);
787 vec = SCM_VECTOR_VEC(form);
788 /* i = SCM_VECTOR_LEN(pat) - 1; */
789 for (; i < len; i++) {
790 ctx->sub = sub_save;
791 MATCH_REC(ctx, pat, vec[i]);
792 merge_subs(accum, ctx->sub, sub_save);
793 }
794 }
795
796 for (ctx->sub = accum; !EQ(accum, sub_save); accum = CDR(accum))
797 SET_CAR(accum, scm_p_reversex(CAR(accum)));
798
799 return scm_true;
800 }
801
802 /* ;; Push new bindings at the front.
803 * (map!
804 * (cut cons <> <>)
805 * ctx->sub
806 * (take-until (cut eq? <> end) from))
807 *
808 * If you're hacking on this code, beware that the arguments can be
809 * all SCM_INVALID.
810 */
811 static void
merge_subs(ScmObj to,ScmObj from,ScmObj end)812 merge_subs(ScmObj to, ScmObj from, ScmObj end)
813 {
814 DBG_PRINT((DBG_MATCHER | DBG_FUNCALL, "merging ~s ++ ~s\n",
815 VALIDP(to) ? to : SCM_UNDEF,
816 VALIDP(from) ? from : SCM_UNDEF));
817 while (!EQ(from, end)) {
818 ScmObj next;
819 next = CDR(from);
820 SET_CDR(from, CAR(to));
821 SET_CAR(to, from);
822 to = CDR(to);
823 from = next;
824 }
825 }
826
827
828 /* ==============================
829 * Template Transcription
830 * ============================== */
831
832 #define DEFAULT_INDEX_BUF_SIZE 16
833
834 typedef struct {
835 ScmObj fvars; /* Alist; free variables -> wrapped ident. */
836 scm_int_t index_buf[DEFAULT_INDEX_BUF_SIZE];
837 scm_int_t *indices;
838 scm_int_t index_buf_size;
839 ScmPackedEnv def_penv;
840 ScmObj def_env;
841 ScmObj use_env;
842 } transcription_context;
843
844 typedef struct {
845 enum {
846 MSG_REPLACE,
847 MSG_SPLICE,
848 MSG_PVAR_EXHAUSTED
849 } msg;
850 union {
851 ScmObj obj;
852 scm_int_t exhausted_level;
853 } u;
854 } transcribe_ret;
855
856 static transcribe_ret transcribe_rec(transcription_context *ctx,
857 ScmObj template, ScmObj sub,
858 scm_int_t level);
859 static transcribe_ret transcribe_reppat(transcription_context *ctx,
860 ScmObj template, ScmObj sub,
861 scm_int_t level);
862
863 static ScmObj
transcribe(ScmObj template,ScmObj sub,ScmPackedEnv def_penv,ScmObj use_env)864 transcribe(ScmObj template, ScmObj sub, ScmPackedEnv def_penv, ScmObj use_env)
865 {
866 transcribe_ret ret;
867 transcription_context ctx;
868
869 DBG_PRINT((DBG_TRANSCRIPTOR | DBG_FUNCALL, "transcribe\n"));
870 ctx.fvars = SCM_NULL;
871 ctx.indices = ctx.index_buf;
872 ctx.index_buf_size = DEFAULT_INDEX_BUF_SIZE;
873 ctx.def_penv = def_penv;
874 ctx.def_env = scm_unpack_env(def_penv, use_env);
875 ctx.use_env = use_env;
876 ret = transcribe_rec(&ctx, template, sub, 0);
877 SCM_ASSERT(ret.msg == MSG_REPLACE);
878 if (ctx.indices != ctx.index_buf) {
879 free(ctx.indices);
880 DBG_PRINT((DBG_TRANSCRIPTOR, "freed dynamic buffer\n"));
881 }
882 DBG_PRINT((DBG_TRANSCRIPTOR | DBG_RETURN, "transcribe: returning ~s\n",
883 ret.u.obj));
884 return ret.u.obj;
885 }
886
887 static transcribe_ret
transcribe_rec(transcription_context * ctx,ScmObj template,ScmObj sub,scm_int_t level)888 transcribe_rec(transcription_context *ctx, ScmObj template, ScmObj sub,
889 scm_int_t level)
890 {
891 transcribe_ret ret;
892
893 DBG_PRINT((DBG_TRANSCRIPTOR | DBG_FUNCALL,
894 "transcribe_rec [lv ~MD] ~s | ~s\n",
895 level, template, sub));
896
897 #define RECURSE(_q, _obj) \
898 do { \
899 transcribe_ret r; \
900 r = transcribe_rec(ctx, (_obj), sub, level); \
901 switch (r.msg) { \
902 case MSG_PVAR_EXHAUSTED: \
903 return r; \
904 case MSG_REPLACE: \
905 SCM_QUEUE_ADD((_q), r.u.obj); break; \
906 case MSG_SPLICE: \
907 SCM_QUEUE_APPEND((_q), r.u.obj); break; \
908 default: \
909 SCM_NOTREACHED; \
910 } \
911 } while (0)
912
913 #define RECURSE_ALWAYS_APPEND(_q, _obj) \
914 do { \
915 transcribe_ret r; \
916 r = transcribe_rec(ctx, (_obj), sub, level); \
917 if (r.msg == MSG_PVAR_EXHAUSTED) \
918 return r; \
919 SCM_ASSERT(r.msg == MSG_REPLACE); \
920 SCM_QUEUE_SLOPPY_APPEND((_q), r.u.obj); \
921 } while (0)
922
923 if (CONSP(template)) {
924 ScmObj tmp;
925 ScmQueue q;
926 ret.msg = MSG_REPLACE;
927 ret.u.obj = SCM_NULL;
928 SCM_QUEUE_POINT_TO(q, ret.u.obj);
929 FOR_EACH (tmp, template)
930 RECURSE(q, tmp);
931 SCM_ASSERT(!(SUBPATP(template) && REPPATP(template)));
932 if (!NULLP(template))
933 RECURSE_ALWAYS_APPEND(q, template);
934 return ret;
935 } else if (VECTORP(template)) {
936 scm_int_t i, len;
937 ScmObj *vec;
938 ScmQueue q;
939
940 ret.msg = MSG_REPLACE;
941 ret.u.obj = SCM_NULL;
942 SCM_QUEUE_POINT_TO(q, ret.u.obj);
943 vec = SCM_VECTOR_VEC(template);
944 len = SCM_VECTOR_LEN(template);
945 for (i = 0; i < len; i++)
946 RECURSE(q, vec[i]);
947 ret.u.obj = scm_p_list2vector(ret.u.obj);
948 return ret;
949 } else if (SUBPATP(template)) {
950 if (PVARP(template)) {
951 scm_int_t i;
952 sub = scm_list_tail(sub, PVAR_INDEX(template));
953 SCM_ASSERT(CONSP(sub));
954 sub = CAR(sub);
955 for (i = 0; i < level; i++) {
956 DBG_PRINT((DBG_TRANSCRIPTOR, "ref (~MD) ; ~s\n",
957 ctx->indices[i], sub));
958 sub = scm_list_tail(sub, ctx->indices[i]);
959 SCM_ASSERT(VALIDP(sub));
960 if (NULLP(sub)) {
961 ret.msg = MSG_PVAR_EXHAUSTED;
962 ret.u.exhausted_level = i;
963 return ret;
964 }
965 sub = CAR(sub);
966 }
967 ret.msg = MSG_REPLACE;
968 ret.u.obj = sub;
969 return ret;
970 }
971 /* REPPATP(template) */
972 return transcribe_reppat(ctx, template, sub, level);
973 } else if (IDENTIFIERP(template)) {
974 ScmObj wrapped;
975
976 wrapped = scm_p_assq(template, ctx->fvars);
977 if (FALSEP(wrapped)) {
978 wrapped = scm_wrap_identifier(template, ctx->def_penv,
979 ctx->def_env);
980 ctx->fvars = CONS(CONS(template, wrapped), ctx->fvars);
981 } else {
982 wrapped = CDR(wrapped);
983 }
984 ret.msg = MSG_REPLACE;
985 ret.u.obj = wrapped;
986 return ret;
987 } else {
988 ret.msg = MSG_REPLACE;
989 ret.u.obj = template;
990 return ret;
991 }
992 return ret;
993 #undef RECURSE
994 }
995
996 static transcribe_ret
transcribe_reppat(transcription_context * ctx,ScmObj template,ScmObj sub,scm_int_t level)997 transcribe_reppat(transcription_context *ctx, ScmObj template, ScmObj sub,
998 scm_int_t level)
999 {
1000 ScmObj form;
1001 transcribe_ret ret;
1002 ScmQueue q;
1003
1004 SCM_ASSERT(SUBPATP(template) && REPPATP(template));
1005 SCM_ASSERT(level <= ctx->index_buf_size);
1006
1007 DBG_PRINT((DBG_TRANSCRIPTOR | DBG_FUNCALL, "transcribe_reppat\n"));
1008 if (level == ctx->index_buf_size) {
1009 DBG_PRINT((DBG_TRANSCRIPTOR, "growing buffer from size ~MD\n",
1010 ctx->index_buf_size));
1011 ctx->index_buf_size = level * 2;
1012 if (ctx->indices == ctx->index_buf) {
1013 SCM_ASSERT(level == DEFAULT_INDEX_BUF_SIZE);
1014 ctx->indices = scm_malloc(ctx->index_buf_size
1015 * sizeof(scm_int_t));
1016 memcpy(ctx->indices, ctx->index_buf,
1017 level * sizeof(scm_int_t));
1018 } else {
1019 ctx->indices = scm_realloc(ctx->indices,
1020 ctx->index_buf_size
1021 * sizeof(scm_int_t));
1022 }
1023 }
1024
1025 form = REPPAT_PAT(template);
1026 ret.u.obj = SCM_NULL;
1027 SCM_QUEUE_POINT_TO(q, ret.u.obj);
1028 ctx->indices[level] = 0;
1029
1030 for (;;) {
1031 transcribe_ret subret;
1032 subret = transcribe_rec(ctx, form, sub, level + 1);
1033 if (subret.msg == MSG_PVAR_EXHAUSTED) {
1034 if (subret.u.exhausted_level == level)
1035 break;
1036 SCM_ASSERT(subret.u.exhausted_level < level);
1037 return subret;
1038 }
1039 SCM_ASSERT(subret.msg == MSG_REPLACE);
1040 SCM_QUEUE_ADD(q, subret.u.obj);
1041 ++ctx->indices[level];
1042 }
1043 ret.msg = MSG_SPLICE;
1044 return ret;
1045 }
1046
1047 /* ==============================
1048 * Syntax unwrapping
1049 * ==============================*/
1050
1051 static ScmObj unwrap_farsymbol(ScmObj obj);
1052 static void unwrap_dispatch(ScmObj obj);
1053 static void unwrap_listx(ScmObj ls);
1054 static void unwrap_vectorx(ScmObj obj);
1055
1056 /* Like FOR_EACH(), but leaves the argument at the last cons cell. */
1057 #define UPTO_LAST_PAIR(ls) while (CONSP(CDR(ls)) && ((ls) = CDR(ls), 1))
1058
1059 static ScmObj
unwrap_farsymbol(ScmObj obj)1060 unwrap_farsymbol(ScmObj obj)
1061 {
1062 SCM_ASSERT(FARSYMBOLP(obj));
1063 do
1064 obj = SCM_FARSYMBOL_SYM(obj);
1065 while (FARSYMBOLP(obj));
1066 return obj;
1067 }
1068
1069 static void
unwrap_dispatch(ScmObj obj)1070 unwrap_dispatch(ScmObj obj)
1071 {
1072 if (CONSP(obj))
1073 unwrap_listx(obj);
1074 else if (VECTORP(obj))
1075 unwrap_vectorx(obj);
1076 }
1077
1078 static void
unwrap_listx(ScmObj ls)1079 unwrap_listx(ScmObj ls)
1080 {
1081 do {
1082 if (FARSYMBOLP(CAR(ls)))
1083 SET_CAR(ls, unwrap_farsymbol(CAR(ls)));
1084 else
1085 unwrap_dispatch(CAR(ls));
1086 } UPTO_LAST_PAIR (ls);
1087 SET_CDR(ls, scm_unwrap_syntaxx(CDR(ls)));
1088 }
1089
1090 static void
unwrap_vectorx(ScmObj obj)1091 unwrap_vectorx(ScmObj obj)
1092 {
1093 ScmObj *vec;
1094 scm_int_t i;
1095
1096 i = SCM_VECTOR_LEN(obj);
1097 vec = SCM_VECTOR_VEC(obj);
1098 while (i--) {
1099 if (FARSYMBOLP(vec[i]))
1100 vec[i] = unwrap_farsymbol(vec[i]);
1101 else
1102 unwrap_dispatch(vec[i]);
1103 }
1104 }
1105
1106 SCM_EXPORT ScmObj
scm_unwrap_syntaxx(ScmObj arg)1107 scm_unwrap_syntaxx(ScmObj arg)
1108 {
1109 DBG_PRINT((DBG_UNWRAP, "unwrap-syntax!: ~s\n", arg));
1110 if (FARSYMBOLP(arg))
1111 return unwrap_farsymbol(arg);
1112 unwrap_dispatch(arg);
1113 return arg;
1114 }
1115
1116 SCM_EXPORT ScmObj
scm_unwrap_keyword(ScmObj obj)1117 scm_unwrap_keyword(ScmObj obj)
1118 {
1119 DBG_PRINT((DBG_UNWRAP, "unwrap-keyword: ~s\n", obj));
1120 return FARSYMBOLP(obj) ? unwrap_farsymbol(obj) : obj;
1121 }
1122
1123 #if 0
1124 /* Alternative implementation. */
1125 SCM_EXPORT ScmObj
1126 scm_unwrap_syntaxx(ScmObj arg)
1127 {
1128 if (CONSP(arg)) {
1129 ScmObj ls = arg;
1130 do {
1131 SET_CAR(ls, scm_unwrap_syntaxx(CAR(ls)));
1132 tail = ls;
1133 } UPTO_LAST_PAIR(ls);
1134 SET_CDR(ls, scm_unwrap_syntaxx(CDR(ls)));
1135 return arg;
1136 }
1137
1138 if (FARSYMBOLP(arg))
1139 return unwrap_farsymbol(arg);
1140
1141 if (VECTORP(arg)) {
1142 scm_int_t i;
1143 ScmObj *vec;
1144 i = SCM_VECTOR_LEN(arg);
1145 vec = SCM_VECTOR_VEC(arg);
1146 while (i--)
1147 vec[i] = scm_unwrap_syntaxx(vec[i]);
1148 return arg;
1149 }
1150 return arg;
1151 }
1152 #endif /* 0 */
1153 #undef UPTO_LAST_PAIR
1154
1155 /* ==============================
1156 * Auxiliary Utilities
1157 * ==============================*/
1158
1159 /* TODO: move to somewhere appropriate. */
1160 SCM_EXPORT ScmObj
scm_p_reversex(ScmObj in)1161 scm_p_reversex(ScmObj in)
1162 {
1163 ScmObj out, next;
1164 DECLARE_FUNCTION("reverse!", procedure_fixed_1);
1165
1166 out = SCM_NULL;
1167 while (CONSP(in)) {
1168 next = CDR(in);
1169 SET_CDR(in, out);
1170 out = in;
1171 in = next;
1172 }
1173 SCM_ENSURE_PROPER_LIST_TERMINATION(in, out);
1174 return out;
1175 }
1176
1177 static scm_int_t
list_find_index(ScmObj x,ScmObj ls)1178 list_find_index(ScmObj x, ScmObj ls)
1179 {
1180 ScmObj kar;
1181 scm_int_t index;
1182
1183 index = 0;
1184 FOR_EACH (kar, ls) {
1185 if (EQ(x, kar))
1186 return index;
1187 ++index;
1188 }
1189 return -1;
1190 }
1191
1192