root/src/macro.c

/* [<][>][^][v][top][bottom][index][help] */

DEFINITIONS

This source file includes following definitions.
  1. syntax_print
  2. Scm_MakeSyntax
  3. macro_print
  4. Scm_MakeMacro
  5. pattern_print
  6. make_syntax_pattern
  7. synrule_print
  8. make_syntax_rules
  9. macro_transform
  10. Scm_MakeMacroTransformer
  11. macro_transform_old
  12. Scm_MakeMacroTransformerOld
  13. resolve_macro_autoload
  14. macro_autoload
  15. Scm_MakeMacroAutoload
  16. PatternContext
  17. add_pvar
  18. pvar_to_pvref
  19. pvref_to_pvar
  20. id_memq
  21. preprocess_literals
  22. compile_rule1
  23. compile_rules
  24. MatchVar
  25. alloc_matchvec
  26. init_matchvec
  27. get_pvref_value
  28. print_matchvec
  29. grow_branch
  30. enter_subpattern
  31. exit_subpattern
  32. match_insert
  33. match_identifier
  34. match_subpattern
  35. match_synrule
  36. realize_template_rec
  37. realize_template
  38. synrule_expand
  39. synrule_transform
  40. Scm_CompileSyntaxRules
  41. macro_expand_cc
  42. Scm_VMMacroExpand
  43. Scm_CallMacroExpander
  44. 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 }

/* [<][>][^][v][top][bottom][index][help] */