/* [<][>][^][v][top][bottom][index][help] */
DEFINITIONS
This source file includes following definitions.
- syntax_print
- Scm_MakeSyntax
- macro_print
- Scm_MakeMacro
- pattern_print
- make_syntax_pattern
- synrule_print
- make_syntax_rules
- macro_transform
- Scm_MakeMacroTransformer
- macro_transform_old
- Scm_MakeMacroTransformerOld
- resolve_macro_autoload
- macro_autoload
- Scm_MakeMacroAutoload
- PatternContext
- add_pvar
- pvar_to_pvref
- pvref_to_pvar
- id_memq
- preprocess_literals
- compile_rule1
- compile_rules
- MatchVar
- alloc_matchvec
- init_matchvec
- get_pvref_value
- print_matchvec
- grow_branch
- enter_subpattern
- exit_subpattern
- match_insert
- match_identifier
- match_subpattern
- match_synrule
- realize_template_rec
- realize_template
- synrule_expand
- synrule_transform
- Scm_CompileSyntaxRules
- macro_expand_cc
- Scm_VMMacroExpand
- Scm_CallMacroExpander
- Scm__InitMacro
1 /*
2 * macro.c - macro implementation
3 *
4 * Copyright (c) 2000-2005 Shiro Kawai, All rights reserved.
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * 1. Redistributions of source code must retain the above copyright
11 * notice, this list of conditions and the following disclaimer.
12 *
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 *
17 * 3. Neither the name of the authors nor the names of its contributors
18 * may be used to endorse or promote products derived from this
19 * software without specific prior written permission.
20 *
21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 *
33 * $Id: macro.c,v 1.59 2005/10/03 20:57:45 shirok Exp $
34 */
35
36 #define LIBGAUCHE_BODY
37 #include "gauche.h"
38 #include "gauche/macro.h"
39 #include "gauche/code.h"
40 #include "gauche/vminsn.h"
41 #include "gauche/builtin-syms.h"
42
43 /* avoid C++ reserved name conflict.
44 (I hate languages that takes away names from programmers!) */
45 #define template templat
46
47 /* define if you want to debug syntax-rule expander */
48 /*#define DEBUG_SYNRULE*/
49
50 /*===================================================================
51 * Syntax object
52 */
53
54 static void syntax_print(ScmObj obj, ScmPort *port, ScmWriteContext *mode)
55 {
56 Scm_Printf(port, "#<syntax %A>", SCM_SYNTAX(obj)->name);
57 }
58
59 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_SyntaxClass, syntax_print);
60
61 ScmObj Scm_MakeSyntax(ScmSymbol *name, ScmObj handler)
62 {
63 ScmSyntax *s = SCM_NEW(ScmSyntax);
64 SCM_SET_CLASS(s, SCM_CLASS_SYNTAX);
65 s->name = name;
66 s->handler = handler;
67 return SCM_OBJ(s);
68 }
69
70 /*===================================================================
71 * Macro object
72 */
73
74 static void macro_print(ScmObj obj, ScmPort *port, ScmWriteContext *mode)
75 {
76 Scm_Printf(port, "#<macro %A>", SCM_MACRO(obj)->name);
77 }
78
79 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_MacroClass, macro_print);
80
81 ScmObj Scm_MakeMacro(ScmSymbol *name, ScmTransformerProc transformer,
82 void *data)
83 {
84 ScmMacro *s = SCM_NEW(ScmMacro);
85 SCM_SET_CLASS(s, SCM_CLASS_MACRO);
86 s->name = name;
87 s->transformer = transformer;
88 s->data = data;
89 return SCM_OBJ(s);
90 }
91
92 /*===================================================================
93 * SyntaxPattern object
94 * Internal object to construct pattern matcher
95 */
96
97 static void pattern_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
98 {
99 Scm_Printf(port, "#<pattern:%d%S %S%s>",
100 SCM_SYNTAX_PATTERN(obj)->level,
101 SCM_SYNTAX_PATTERN(obj)->vars,
102 SCM_SYNTAX_PATTERN(obj)->pattern,
103 SCM_SYNTAX_PATTERN(obj)->repeat? " ..." : "");
104 }
105
106 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_SyntaxPatternClass, pattern_print);
107
108 ScmSyntaxPattern *make_syntax_pattern(int level, int repeat)
109 {
110 ScmSyntaxPattern *p = SCM_NEW(ScmSyntaxPattern);
111 SCM_SET_CLASS(p, SCM_CLASS_SYNTAX_PATTERN);
112 p->pattern = SCM_NIL;
113 p->vars = SCM_NIL;
114 p->level = level;
115 p->repeat = repeat;
116 return p;
117 }
118
119 /*===================================================================
120 * SyntaxRules object
121 * Internal object to construct pattern matcher
122 */
123
124 static void synrule_print(ScmObj obj, ScmPort *port, ScmWriteContext *mode)
125 {
126 int i;
127 ScmSyntaxRules *r = SCM_SYNTAX_RULES(obj);
128
129 Scm_Printf(port, "#<syntax-rules(%d)\n", r->numRules);
130 for (i = 0; i < r->numRules; i++) {
131 Scm_Printf(port, "%2d: (numPvars=%d, maxLevel=%d)\n",
132 i, r->rules[i].numPvars, r->rules[i].maxLevel);
133 Scm_Printf(port, " pattern = %S\n", r->rules[i].pattern);
134 Scm_Printf(port, " template = %S\n", r->rules[i].template);
135 }
136 Scm_Printf(port, ">");
137 }
138
139 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_SyntaxRulesClass, synrule_print);
140
141 ScmSyntaxRules *make_syntax_rules(int nr)
142 {
143 ScmSyntaxRules *r = SCM_NEW2(ScmSyntaxRules *,
144 sizeof(ScmSyntaxRules)+(nr-1)*sizeof(ScmSyntaxRuleBranch));
145 SCM_SET_CLASS(r, SCM_CLASS_SYNTAX_RULES);
146 r->numRules = nr;
147 return r;
148 }
149
150 /*===================================================================
151 * Macro for the new compiler
152 */
153
154 /* In the new compiler, macro transformers for hygienic and traditional
155 * macros are integrated.
156 * The lowest-level macro transformer can be introduced by define-syntax,
157 * let-syntax and letrec-syntax (but not syntax-case or syntax-rules; they
158 * are built on top of it).
159 *
160 * (define-syntax foo <transformer>)
161 *
162 * Where <transformer> is a procedure that takes one argument, a syntactic
163 * closure. It must return a syntactic closure as the result of trans
164 * formation.
165 *
166 * From the point of the compiler, define-syntax triggers the following
167 * actions.
168 *
169 * - evaluate <transformer> in the compiler environment.
170 * - encapsulate it into <macro> object, and insert it to the compiler
171 * environment.
172 * - insert the binding to foo in the runtime toplevel environment.
173 *
174 * Define-macro is also built on top of define-syntax. Concepturally,
175 * it is transformed as follows.
176 *
177 * (define-macro foo procedure)
178 * => (define-syntax foo
179 * (lambda (x)
180 * (let ((env (slot-ref x 'env))
181 * (form (slot-ref x 'expr)))
182 * (make-syntactic-closure
183 * env () (apply procedure form)))))
184 */
185
186 static ScmObj macro_transform(ScmObj self, ScmObj form, ScmObj env,
187 void *data)
188 {
189 ScmObj proc = SCM_OBJ(data);
190 SCM_ASSERT(SCM_SYNTACTIC_CLOSURE_P(form));
191 return Scm_Apply(proc, SCM_LIST1(form));
192 }
193
194 ScmObj Scm_MakeMacroTransformer(ScmSymbol *name, ScmObj proc)
195 {
196 return Scm_MakeMacro(name, macro_transform, (void*)proc);
197 }
198
199 /*===================================================================
200 * Traditional Macro
201 */
202
203 /* TODO: how to retain debug info? */
204 /* TODO: better error message on syntax error (macro invocation with
205 bad number of arguments) */
206
207 static ScmObj macro_transform_old(ScmObj self, ScmObj form,
208 ScmObj env, void *data)
209 {
210 ScmObj proc = SCM_OBJ(data);
211 SCM_ASSERT(SCM_PAIRP(form));
212 return Scm_VMApply(proc, SCM_CDR(form));
213 }
214
215 ScmObj Scm_MakeMacroTransformerOld(ScmSymbol *name, ScmProcedure *proc)
216 {
217 return Scm_MakeMacro(name, macro_transform_old, (void*)proc);
218 }
219
220 static ScmMacro *resolve_macro_autoload(ScmAutoload *adata)
221 {
222 ScmObj mac = Scm_LoadAutoload(adata);
223 if (!SCM_MACROP(mac)) {
224 Scm_Error("tried to autoload macro %S, but it yields non-macro object: %S", adata->name, mac);
225 }
226 return SCM_MACRO(mac);
227 }
228
229 static ScmObj macro_autoload(ScmObj self, ScmObj form, ScmObj env, void *data)
230 {
231 ScmMacro *mac = resolve_macro_autoload(SCM_AUTOLOAD(data));
232 return mac->transformer(SCM_OBJ(mac), form, env, mac->data);
233 }
234
235 ScmObj Scm_MakeMacroAutoload(ScmSymbol *name, ScmAutoload *adata)
236 {
237 return Scm_MakeMacro(name, macro_autoload, (void*)adata);
238 }
239
240 /*===================================================================
241 * R5RS Macro
242 */
243
244 /* Keeping hygienic reference
245 *
246 * - symbols which a template inserts into the expanded form are
247 * converted to identifiers at the macro definition time, encapsulating
248 * the defining environment of the macro. So it doesn't interfere
249 * with the macro call environment.
250 *
251 * - literal symbols provided to the syntax-rules are also converted
252 * to identifiers encapsulating the defining environment, and the
253 * environment information is used when comparing with the symbols
254 * in the macro call.
255 *
256 * - symbols in the macro call is treated as they are. Since the result
257 * of macro expansion is immediately compiled in the macro call
258 * environment, those symbols can refer proper bindings.
259 */
260
261 /*-------------------------------------------------------------------
262 * pattern language compiler
263 * - convert literals into identifiers
264 * - recognize repeatable subpatterns and replace it to SyntaxPattern node.
265 * - convert free symbols in the template into identifiers
266 * - convert pattern variables into LREF object.
267 */
268 /* TODO: avoid unnecessary consing as much as possible */
269
270 /* context of pattern traversal */
271 typedef struct {
272 ScmObj name; /* name of this macro (for error msg)*/
273 ScmObj form; /* form being compiled (for error msg) */
274 ScmObj literals; /* list of literal identifiers */
275 ScmObj pvars; /* list of (pvar . pvref) */
276 int pvcnt; /* counter of pattern variables */
277 int maxlev; /* maximum level */
278 ScmObj tvars; /* list of identifies inserted in template */
279 ScmModule *mod; /* module where this macro is defined */
280 ScmObj env; /* compiler env of this macro definition */
281 } PatternContext;
282
283 #define PVREF_P(pvref) SCM_PVREF_P(pvref)
284 #define PVREF_LEVEL(pvref) SCM_PVREF_LEVEL(pvref)
285 #define PVREF_COUNT(pvref) SCM_PVREF_COUNT(pvref)
286
287 /* add pattern variable pvar. called when compiling a pattern */
288 static inline ScmObj add_pvar(PatternContext *ctx,
289 ScmSyntaxPattern *pat,
290 ScmObj pvar)
291 {
292 ScmObj pvref = SCM_MAKE_PVREF(pat->level, ctx->pvcnt);
293 if (!SCM_FALSEP(Scm_Assq(pvar, ctx->pvars))) {
294 Scm_Error("pattern variable %S appears more than once in the macro definition of %S: %S",
295 pvar, ctx->name, ctx->form);
296 }
297 ctx->pvcnt++;
298 ctx->pvars = Scm_Acons(pvar, pvref, ctx->pvars);
299 pat->vars = Scm_Cons(pvref, pat->vars);
300 return pvref;
301 }
302
303 /* returns pvref corresponds to the given pvar in template compilation.
304 if pvar is not a valid pvar, returns pvar itself. */
305 static inline ScmObj pvar_to_pvref(PatternContext *ctx,
306 ScmSyntaxPattern *pat,
307 ScmObj pvar)
308 {
309 ScmObj q = Scm_Assq(pvar, ctx->pvars), pvref;
310 if (!SCM_PAIRP(q)) return pvar;
311 pvref = SCM_CDR(q);
312 if (PVREF_LEVEL(pvref) > pat->level) {
313 Scm_Error("%S: Pattern variable %S is used in wrong level: %S",
314 ctx->name, pvar, ctx->form);
315 }
316 return pvref;
317 }
318
319 static inline ScmObj pvref_to_pvar(PatternContext *ctx, ScmObj pvref)
320 {
321 int count = PVREF_COUNT(pvref);
322 ScmObj q = Scm_ListRef(ctx->pvars, count, SCM_UNBOUND);
323 SCM_ASSERT(SCM_PAIRP(q));
324 return SCM_CAR(q);
325 }
326
327 /* search an identifier with name NAME from a list of identifiers */
328 static ScmObj id_memq(ScmObj name, ScmObj list)
329 {
330 ScmObj lp;
331 ScmObj n;
332 if (SCM_IDENTIFIERP(name)) {
333 n = SCM_OBJ(SCM_IDENTIFIER(name)->name);
334 } else {
335 n = name;
336 }
337 SCM_FOR_EACH(lp, list) {
338 if (SCM_OBJ(SCM_IDENTIFIER(SCM_CAR(lp))->name) == name)
339 return SCM_CAR(lp);
340 }
341 return SCM_FALSE;
342 }
343
344 #define ELLIPSIS_FOLLOWING(Pat) \
345 (SCM_PAIRP(SCM_CDR(Pat)) && SCM_CADR(Pat)==SCM_SYM_ELLIPSIS)
346
347 #define BAD_ELLIPSIS(Ctx) \
348 Scm_Error("Bad ellipsis usage in macro definition of %S: %S", \
349 Ctx->name, Ctx->form)
350
351 /* convert literal symbols into identifiers */
352 static ScmObj preprocess_literals(ScmObj literals, ScmModule *mod, ScmObj env)
353 {
354 ScmObj lp, h = SCM_NIL, t = SCM_NIL;
355 SCM_FOR_EACH(lp, literals) {
356 ScmObj lit = SCM_CAR(lp);
357 if (SCM_IDENTIFIERP(lit))
358 SCM_APPEND1(h, t, lit);
359 else if (SCM_SYMBOLP(lit))
360 SCM_APPEND1(h, t, Scm_MakeIdentifier(SCM_SYMBOL(lit), mod, env));
361 else
362 Scm_Error("literal list contains non-symbol: %S", literals);
363 }
364 if (!SCM_NULLP(lp))
365 Scm_Error("bad literal list in syntax-rules: %S", literals);
366 return h;
367 }
368
369 /* compile a pattern or a template.
370 In a pattern, replace literal symbols for identifiers; leave
371 non-literal symbols (i.e. pattern variables) as they are, but
372 records it's presence in the context. Also, when encounters
373 a repeatable subpattern, replace it with SyntaxPattern node.
374 In a template, replace symbols for identifiers except pattern variables.
375 */
376
377 static ScmObj compile_rule1(ScmObj form,
378 ScmSyntaxPattern *spat,
379 PatternContext *ctx,
380 int patternp)
381 {
382 if (SCM_PAIRP(form)) {
383 ScmObj pp, h = SCM_NIL, t = SCM_NIL;
384 SCM_FOR_EACH(pp, form) {
385 if (ELLIPSIS_FOLLOWING(pp)) {
386 ScmSyntaxPattern *nspat;
387 if (patternp && !SCM_NULLP(SCM_CDDR(pp))) BAD_ELLIPSIS(ctx);
388 nspat = make_syntax_pattern(spat->level+1, TRUE);
389 if (ctx->maxlev <= spat->level) ctx->maxlev++;
390 nspat->pattern = compile_rule1(SCM_CAR(pp), nspat, ctx,
391 patternp);
392 SCM_APPEND1(h, t, SCM_OBJ(nspat));
393 if (!patternp) {
394 ScmObj vp;
395 if (SCM_NULLP(nspat->vars)) {
396 Scm_Error("in definition of macro %S: "
397 "a template contains repetition "
398 "of constant form: %S",
399 ctx->name, form);
400 }
401 SCM_FOR_EACH(vp, nspat->vars) {
402 if (PVREF_LEVEL(SCM_CAR(vp)) >= nspat->level) break;
403 }
404 if (SCM_NULLP(vp)) {
405 Scm_Error("in definition of macro %S: "
406 "template's ellipsis nesting"
407 " is deeper than pattern's: %S",
408 ctx->name, form);
409 }
410 }
411 spat->vars = Scm_Append2(spat->vars, nspat->vars);
412 pp = SCM_CDR(pp);
413 } else {
414 SCM_APPEND1(h, t,
415 compile_rule1(SCM_CAR(pp), spat, ctx, patternp));
416 }
417 }
418 if (!SCM_NULLP(pp))
419 SCM_APPEND(h, t, compile_rule1(pp, spat, ctx, patternp));
420 return h;
421 }
422 else if (SCM_VECTORP(form)) {
423 /* TODO: this is a sloppy implementation.
424 Eliminate intermediate list structure! */
425 ScmObj l = Scm_VectorToList(SCM_VECTOR(form), 0, -1);
426 return Scm_ListToVector(compile_rule1(l, spat, ctx, patternp), 0, -1);
427 }
428 #if 0
429 else if (patternp && SCM_IDENTIFIERP(form)) {
430 /* this happens in a macro produced by another macro */
431 form = SCM_OBJ(SCM_IDENTIFIER(form)->name);
432 }
433 #endif
434 if (SCM_SYMBOLP(form)||SCM_IDENTIFIERP(form)) {
435 ScmObj q;
436 if (form == SCM_SYM_ELLIPSIS) BAD_ELLIPSIS(ctx);
437 if (!SCM_FALSEP(q = id_memq(form, ctx->literals))) return q;
438
439 if (patternp) {
440 return add_pvar(ctx, spat, form);
441 } else {
442 ScmObj id, pvref = pvar_to_pvref(ctx, spat, form);
443 if (pvref == form) {
444 /* form is not a pattern variable. make it an identifier. */
445 if (!SCM_FALSEP(q = id_memq(form, ctx->tvars))) return q;
446 if (SCM_IDENTIFIERP(form)) {
447 id = form;
448 } else {
449 id = Scm_MakeIdentifier(SCM_SYMBOL(form),
450 ctx->mod, ctx->env);
451 }
452 ctx->tvars = Scm_Cons(id, ctx->tvars);
453 return id;
454 } else {
455 spat->vars = Scm_Cons(pvref, spat->vars);
456 }
457 return pvref;
458 }
459 }
460 return form;
461 }
462
463 /* compile rules into ScmSyntaxRules structure */
464 static ScmSyntaxRules *compile_rules(ScmObj name,
465 ScmObj literals,
466 ScmObj rules,
467 ScmModule *mod,
468 ScmObj env) /* compiler env */
469 {
470 PatternContext ctx;
471 ScmSyntaxPattern *pat, *tmpl;
472 ScmSyntaxRules *sr;
473 ScmObj rp;
474 int numRules = Scm_Length(rules), i;
475
476 if (numRules < 1) goto badform;
477 if (Scm_Length(literals) < 0) goto badform;
478
479 ctx.name = name;
480 ctx.literals = preprocess_literals(literals, mod, env);
481 ctx.mod = mod;
482 ctx.env = env;
483
484 sr = make_syntax_rules(numRules);
485 sr->name = name;
486 sr->numRules = numRules;
487 sr->maxNumPvars = 0;
488 for (i=0, rp = rules; i < numRules; i++, rp = SCM_CDR(rp)) {
489 ScmObj rule = SCM_CAR(rp);
490 if (Scm_Length(rule) != 2) goto badform;
491
492 pat = make_syntax_pattern(0, FALSE);
493 tmpl = make_syntax_pattern(0, FALSE);
494 ctx.pvars = SCM_NIL;
495 ctx.tvars = SCM_NIL;
496 ctx.pvcnt = 0;
497 ctx.maxlev = 0;
498
499 ctx.form = SCM_CAR(rule);
500 if (!SCM_PAIRP(ctx.form)) goto badform;
501 pat->pattern = compile_rule1(SCM_CDR(ctx.form), pat, &ctx, TRUE);
502
503 ctx.form = SCM_CADR(rule);
504 tmpl->pattern = compile_rule1(ctx.form, tmpl, &ctx, FALSE);
505
506 sr->rules[i].pattern = SCM_OBJ(pat->pattern);
507 sr->rules[i].template = SCM_OBJ(tmpl->pattern);
508 sr->rules[i].numPvars = ctx.pvcnt;
509 sr->rules[i].maxLevel = ctx.maxlev;
510 if (ctx.pvcnt > sr->maxNumPvars) sr->maxNumPvars = ctx.pvcnt;
511 }
512 return sr;
513
514 badform:
515 Scm_Error("malformed macro %S: %S", name,
516 Scm_Cons(SCM_SYM_SYNTAX_RULES, Scm_Cons(literals, rules)));
517 return NULL; /* dummy */
518 }
519
520 /*-------------------------------------------------------------------
521 * pattern language matcher
522 */
523
524 /* Matchvec
525 * A sort of shallow binding technique is used to bind pattern
526 * variables with matched patterns.
527 *
528 * Matchlist itself is an assoc list whose key is a pattern variable.
529 * It's value is a tree of the same depth of the pattern variable.
530 *
531 * Suppose you have a pattern
532 * (?a (?b (?c ?d ...) ...) ...)
533 * In it, pattern variable ?a is level 0, ?b is 1, ?c is 2 and ?d is 3.
534 * When the pattern matches the following form:
535 * (1 (2 (3 4 5) (6)) (7 (8 9) (10 11 12)))
536 * trees bound to each pattern variables are like this:
537 *
538 * ?a => 1
539 * ?b => (2 7)
540 * ?c => ((3 6) (8 10))
541 * ?d => (((4 5) ()) ((9) (11 12)))
542 */
543
544 typedef struct {
545 ScmObj branch; /* current level match */
546 ScmObj sprout; /* current sprout */
547 ScmObj root; /* root of the tree */
548 } MatchVar;
549
550 static MatchVar *alloc_matchvec(int numPvars)
551 {
552 return SCM_NEW_ARRAY(MatchVar, numPvars);
553 }
554
555 static void init_matchvec(MatchVar *mvec, int numPvars)
556 {
557 int i;
558 for (i=0; i<numPvars; i++) {
559 mvec[i].branch = mvec[i].sprout = mvec[i].root = SCM_NIL;
560 }
561 }
562
563 /* get value associated to the pvref. if exhausted, return SCM_UNBOUND
564 and set exhaust level in *exlev. */
565 static ScmObj get_pvref_value(ScmObj pvref, MatchVar *mvec,
566 int *indices, int *exlev)
567 {
568 int level = PVREF_LEVEL(pvref), count = PVREF_COUNT(pvref);
569 int i, j;
570 ScmObj tree = mvec[count].root;
571 for (i=1; i<=level; i++) {
572 for (j=0; j<indices[i]; j++) {
573 if (!SCM_PAIRP(tree)) {
574 *exlev = i;
575 return SCM_UNBOUND;
576 }
577 tree = SCM_CDR(tree);
578 }
579 if (!SCM_PAIRP(tree)) {
580 *exlev = i;
581 return SCM_UNBOUND;
582 }
583 tree = SCM_CAR(tree);
584 }
585 return tree;
586 }
587
588 /* for debug */
589 #ifdef DEBUG_SYNRULE
590 static void print_matchvec(MatchVar *mvec, int numPvars, ScmPort *port)
591 {
592 int i;
593 for (i=0; i<numPvars; i++) {
594 Scm_Printf(port, "[%S %S %S]\n",
595 mvec[i].branch, mvec[i].sprout, mvec[i].root);
596 }
597 }
598 #endif
599
600 static int match_synrule(ScmObj form, ScmObj pattern, ScmObj env,
601 MatchVar *mvec);
602
603 #define SPROUT Scm_Cons(SCM_NIL, SCM_NIL)
604
605 /* add a new "sprout" to the given tree at the given level. */
606 static void grow_branch(MatchVar *rec, int level)
607 {
608 ScmObj trunc;
609 int i;
610 if (level <= 1) return;
611 if (rec->root == SCM_NIL) {
612 rec->sprout = rec->root = SPROUT;
613 if (level == 2) return;
614 }
615
616 trunc = rec->root;
617 for (i=1; i<level-1; i++, trunc = SCM_CAR(trunc)) {
618 SCM_FOR_EACH(trunc, trunc) {
619 if (SCM_NULLP(SCM_CDR(trunc))) break;
620 }
621 if (SCM_NULLP(SCM_CAR(trunc))) {
622 for (i++; i<level-1; i++, trunc = SCM_CAR(trunc)) {
623 SCM_SET_CAR(trunc, SPROUT);
624 }
625 rec->sprout = SPROUT;
626 SCM_SET_CAR(trunc, rec->sprout);
627 return;
628 }
629 }
630 SCM_FOR_EACH(trunc, trunc) {
631 if (SCM_NULLP(SCM_CDR(trunc))) {
632 rec->sprout = SPROUT;
633 SCM_SET_CDR(trunc, rec->sprout);
634 break;
635 }
636 }
637 }
638
639 static void enter_subpattern(ScmSyntaxPattern *subpat, MatchVar *mvec)
640 {
641 ScmObj pp;
642 SCM_FOR_EACH(pp, subpat->vars) {
643 ScmObj pvref = SCM_CAR(pp);
644 int count = PVREF_COUNT(pvref);
645 grow_branch(mvec+count, subpat->level);
646 }
647 }
648
649 static void exit_subpattern(ScmSyntaxPattern *subpat, MatchVar *mvec)
650 {
651 ScmObj pp;
652 SCM_FOR_EACH(pp, subpat->vars) {
653 ScmObj pvref = SCM_CAR(pp);
654 int count = PVREF_COUNT(pvref);
655 if (PVREF_LEVEL(pvref) == subpat->level) {
656 if (subpat->level == 1) {
657 mvec[count].root = Scm_ReverseX(mvec[count].branch);
658 } else {
659 SCM_SET_CAR(mvec[count].sprout,
660 Scm_ReverseX(mvec[count].branch));
661 mvec[count].branch = SCM_NIL;
662 }
663 }
664 }
665 }
666
667 /* add pattern variable PVREF and its matched object MATCHED into MVEC */
668 static inline void match_insert(ScmObj pvref, ScmObj matched, MatchVar *mvec)
669 {
670 int count = PVREF_COUNT(pvref);
671 if (PVREF_LEVEL(pvref) == 0) {
672 mvec[count].root = matched;
673 } else {
674 mvec[count].branch = Scm_Cons(matched, mvec[count].branch);
675 }
676 }
677
678 /* see if literal identifier ID in the pattern matches the given object */
679 static inline int match_identifier(ScmIdentifier *id, ScmObj obj, ScmObj env)
680 {
681 if (SCM_SYMBOLP(obj)) {
682 return (id->name == SCM_SYMBOL(obj)
683 && Scm_IdentifierBindingEqv(id, SCM_SYMBOL(obj), env));
684 }
685 if (SCM_IDENTIFIERP(obj)) {
686 /*TODO: module?*/
687 return (id->name == SCM_IDENTIFIER(obj)->name
688 && id->env == SCM_IDENTIFIER(obj)->env);
689 }
690 return FALSE;
691 }
692
693 static inline int match_subpattern(ScmObj form, ScmSyntaxPattern *pat,
694 ScmObj env, MatchVar *mvec)
695 {
696 enter_subpattern(pat, mvec);
697 while (SCM_PAIRP(form)) {
698 if (!match_synrule(SCM_CAR(form), pat->pattern, env, mvec))
699 return FALSE;
700 form = SCM_CDR(form);
701 }
702 if (!SCM_NULLP(form)) return FALSE;
703 exit_subpattern(pat, mvec);
704 return TRUE;
705 }
706
707 /* See if form matches pattern. If match, add matched syntax variable
708 bindings to match vector and return TRUE; otherwise, return FALSE
709 */
710 static int match_synrule(ScmObj form, ScmObj pattern, ScmObj env,
711 MatchVar *mvec)
712 {
713 if (PVREF_P(pattern)) {
714 match_insert(pattern, form, mvec);
715 return TRUE;
716 }
717 if (SCM_IDENTIFIERP(pattern)) {
718 return match_identifier(SCM_IDENTIFIER(pattern), form, env);
719 }
720 if (SCM_SYNTAX_PATTERN_P(pattern)) {
721 return match_subpattern(form, SCM_SYNTAX_PATTERN(pattern), env, mvec);
722 }
723 if (SCM_PAIRP(pattern)) {
724 while (SCM_PAIRP(pattern)) {
725 ScmObj elt = SCM_CAR(pattern);
726 if (SCM_SYNTAX_PATTERN_P(elt)) {
727 return match_subpattern(form, SCM_SYNTAX_PATTERN(elt),
728 env, mvec);
729 } else if (!SCM_PAIRP(form)) {
730 return FALSE;
731 } else {
732 if (!match_synrule(SCM_CAR(form), elt, env, mvec))
733 return FALSE;
734 pattern = SCM_CDR(pattern);
735 form = SCM_CDR(form);
736 }
737 }
738 if (!SCM_NULLP(pattern))
739 return match_synrule(form, pattern, env, mvec);
740 else
741 return SCM_NULLP(form);
742 }
743 if (SCM_VECTORP(pattern)) {
744 int i, plen, flen, elli;
745 if (!SCM_VECTORP(form)) return FALSE;
746 plen = SCM_VECTOR_SIZE(pattern);
747 flen = SCM_VECTOR_SIZE(form);
748 if (plen == 0) return (flen == 0);
749 elli = SCM_SYNTAX_PATTERN_P(SCM_VECTOR_ELEMENT(pattern, plen-1));
750 if ((!elli && plen!=flen) || (elli && plen-1>flen)) return FALSE;
751 for (i=0; i < plen-elli; i++) {
752 if (!match_synrule(SCM_VECTOR_ELEMENT(form, i),
753 SCM_VECTOR_ELEMENT(pattern, i),
754 env, mvec))
755 return FALSE;
756 }
757 if (elli) {
758 ScmObj h = SCM_NIL, t = SCM_NIL;
759 ScmObj pat = SCM_VECTOR_ELEMENT(pattern, plen-1);
760 for (i=plen-1; i<flen; i++) {
761 SCM_APPEND1(h, t, SCM_VECTOR_ELEMENT(form, i));
762 }
763 return match_subpattern(h, SCM_SYNTAX_PATTERN(pat), env, mvec);
764 }
765 return TRUE;
766 }
767
768 /* literal */
769 return Scm_EqualP(pattern, form);
770 }
771
772 /*-------------------------------------------------------------------
773 * pattern language transformer
774 */
775
776 /* If a pattern variable is exhausted, SCM_UNDEFINED is returned. */
777 static ScmObj realize_template_rec(ScmObj template,
778 MatchVar *mvec,
779 int level,
780 int *indices,
781 ScmObj *idlist,
782 int *exlev)
783 {
784 if (SCM_PAIRP(template)) {
785 ScmObj h = SCM_NIL, t = SCM_NIL, r, e;
786 while (SCM_PAIRP(template)) {
787 e = SCM_CAR(template);
788 if (SCM_SYNTAX_PATTERN_P(e)) {
789 r = realize_template_rec(e, mvec, level, indices, idlist, exlev);
790 if (SCM_UNBOUNDP(r)) return r;
791 SCM_APPEND(h, t, r);
792 } else {
793 r = realize_template_rec(e, mvec, level, indices, idlist, exlev);
794 if (SCM_UNBOUNDP(r)) return r;
795 SCM_APPEND1(h, t, r);
796 }
797 template = SCM_CDR(template);
798 }
799 if (!SCM_NULLP(template)) {
800 r = realize_template_rec(template, mvec, level, indices, idlist, exlev);
801 if (SCM_UNBOUNDP(r)) return r;
802 if (SCM_NULLP(h)) return r; /* (a ... . b) and a ... is empty */
803 SCM_APPEND(h, t, r);
804 }
805 return h;
806 }
807 if (PVREF_P(template)) {
808 return get_pvref_value(template, mvec, indices, exlev);
809 }
810 if (SCM_SYNTAX_PATTERN_P(template)) {
811 ScmSyntaxPattern *pat = SCM_SYNTAX_PATTERN(template);
812 ScmObj h = SCM_NIL, t = SCM_NIL, r;
813 indices[level+1] = 0;
814 for (;;) {
815 r = realize_template_rec(pat->pattern, mvec, level+1, indices, idlist, exlev);
816 if (SCM_UNBOUNDP(r)) return (*exlev < pat->level)? r : h;
817 SCM_APPEND1(h, t, r);
818 indices[level+1]++;
819 }
820 }
821 if (SCM_VECTORP(template)) {
822 ScmObj h = SCM_NIL, t = SCM_NIL, r, *pe;
823 int len = SCM_VECTOR_SIZE(template), i;
824 pe = SCM_VECTOR_ELEMENTS(template);
825
826 for (i=0; i<len; i++, pe++) {
827 if (SCM_SYNTAX_PATTERN_P(*pe)) {
828 r = realize_template_rec(*pe, mvec, level, indices, idlist, exlev);
829 if (SCM_UNBOUNDP(r)) return r;
830 SCM_APPEND(h, t, r);
831 } else {
832 r = realize_template_rec(*pe, mvec, level, indices, idlist, exlev);
833 if (SCM_UNBOUNDP(r)) return r;
834 SCM_APPEND1(h, t, r);
835 }
836 }
837 return Scm_ListToVector(h, 0, -1);
838 }
839 if (SCM_IDENTIFIERP(template)) {
840 /* we copy the identifier, so that the symbol bindings introduced
841 by recursive macro call won't interfere each other.
842 (e.g. the macro definitions of "letrec" and "do" shown in R5RS
843 use the fact that the symbol "newtemp" introduced in each
844 iteration of macro expansion are distinct. */
845 ScmObj p = Scm_Assq(template, *idlist);
846 if (SCM_PAIRP(p)) return SCM_CDR(p);
847 else {
848 ScmObj id = Scm_CopyIdentifier(SCM_IDENTIFIER(template));
849 *idlist = Scm_Acons(template, id, *idlist);
850 return id;
851 }
852 }
853 return template;
854 }
855
856 #define DEFAULT_MAX_LEVEL 10
857
858 static ScmObj realize_template(ScmSyntaxRuleBranch *branch,
859 MatchVar *mvec)
860 {
861 int index[DEFAULT_MAX_LEVEL], *indices = index, i;
862 int exlev = 0;
863 ScmObj idlist = SCM_NIL;
864
865 if (branch->maxLevel > DEFAULT_MAX_LEVEL)
866 indices = SCM_NEW_ATOMIC2(int*, (branch->maxLevel+1) * sizeof(int));
867 for (i=0; i<=branch->maxLevel; i++) indices[i] = 0;
868 return realize_template_rec(branch->template, mvec, 0, indices, &idlist, &exlev);
869 }
870
871 static ScmObj synrule_expand(ScmObj form, ScmObj env, ScmSyntaxRules *sr)
872 {
873 MatchVar *mvec = alloc_matchvec(sr->maxNumPvars);
874 ScmObj expanded;
875 int i;
876
877 #ifdef DEBUG_SYNRULE
878 Scm_Printf(SCM_CUROUT, "**** synrule_transform: %S\n", form);
879 #endif
880 for (i=0; i<sr->numRules; i++) {
881 #ifdef DEBUG_SYNRULE
882 Scm_Printf(SCM_CUROUT, "pattern #%d: %S\n", i, sr->rules[i].pattern);
883 #endif
884 init_matchvec(mvec, sr->rules[i].numPvars);
885 if (match_synrule(SCM_CDR(form), sr->rules[i].pattern, env, mvec)) {
886 #ifdef DEBUG_SYNRULE
887 Scm_Printf(SCM_CUROUT, "success #%d:\n", i);
888 print_matchvec(mvec, sr->rules[i].numPvars, SCM_CUROUT);
889 #endif
890 expanded = realize_template(&sr->rules[i], mvec);
891 #ifdef DEBUG_SYNRULE
892 Scm_Printf(SCM_CUROUT, "result: %S\n", expanded);
893 #endif
894 return expanded;
895 }
896 }
897 Scm_Error("malformed %S: %S", SCM_CAR(form), form);
898 return SCM_NIL;
899 }
900
901 static ScmObj synrule_transform(ScmObj self, ScmObj form, ScmObj env,
902 void *data)
903 {
904 ScmSyntaxRules *sr = (ScmSyntaxRules *)data;
905 return synrule_expand(form, env, sr);
906 }
907
908 /* NB: a stub for the new compiler (TEMPORARY) */
909 ScmObj Scm_CompileSyntaxRules(ScmObj name, ScmObj literals, ScmObj rules,
910 ScmObj mod, ScmObj env)
911 {
912 ScmSyntaxRules *sr;
913
914 if (SCM_IDENTIFIERP(name)) name = SCM_OBJ(SCM_IDENTIFIER(name)->name);
915 else if (!SCM_SYMBOLP(name)) {
916 Scm_Error("symbol required, but got %S", name);
917 }
918 if (!SCM_MODULEP(mod)) Scm_Error("module required, but got %S", mod);
919 sr = compile_rules(name, literals, rules, SCM_MODULE(mod), env);
920 return Scm_MakeMacro(SCM_SYMBOL(name), synrule_transform, (void*)sr);
921 }
922
923 /*===================================================================
924 * macro-expand
925 */
926
927 ScmObj macro_expand_cc(ScmObj result, void **data)
928 {
929 ScmObj env = SCM_OBJ(data[0]);
930 return Scm_VMMacroExpand(result, env, FALSE);
931 }
932
933 ScmObj Scm_VMMacroExpand(ScmObj expr, ScmObj env, int oncep)
934 {
935 ScmObj sym, op;
936 ScmMacro *mac;
937
938 if (!SCM_PAIRP(expr)) return expr;
939 op = SCM_CAR(expr);
940 if (SCM_MACROP(op)) {
941 mac = SCM_MACRO(op);
942 } else if (!SCM_SYMBOLP(op) && !SCM_IDENTIFIERP(op)) {
943 return expr;
944 } else {
945 mac = NULL;
946 sym = op;
947 if (SCM_MACROP(sym)) {
948 /* local syntactic binding */
949 mac = SCM_MACRO(sym);
950 } else {
951 if (SCM_IDENTIFIERP(sym)) {
952 sym = SCM_OBJ(SCM_IDENTIFIER(sym)->name);
953 }
954 if (SCM_SYMBOLP(sym)) {
955 ScmGloc *g = Scm_FindBinding(Scm_VM()->module,
956 SCM_SYMBOL(sym), FALSE);
957 if (g) {
958 ScmObj gv = SCM_GLOC_GET(g);
959 if (SCM_MACROP(gv)) mac = SCM_MACRO(gv);
960 }
961 }
962 }
963 }
964 if (mac) {
965 if (!oncep) {
966 void *data[1];
967 data[0] = env;
968 Scm_VMPushCC(macro_expand_cc, data, 1);
969 }
970 expr = Scm_CallMacroExpander(mac, expr, env);
971 }
972 return expr;
973 }
974
975 ScmObj Scm_CallMacroExpander(ScmMacro *mac, ScmObj expr, ScmObj env)
976 {
977 return mac->transformer(SCM_OBJ(mac), expr, env, mac->data);
978 }
979
980 /*===================================================================
981 * Initializer
982 */
983
984 void Scm__InitMacro(void)
985 {
986 }