From 59cdf9632f7432f4bfb76818a29d77ec98a9100c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 17 Jul 2016 22:15:31 +0200 Subject: [PATCH] closures: mostly supported... --- TODO | 10 +- c0.mes | 7 +- macro.mes | 37 ++--- mes.c | 163 +++++++++++++++++--- scm.mes | 5 +- syntax.mes | 443 ++++++++++++++++++++++++++--------------------------- 6 files changed, 387 insertions(+), 278 deletions(-) diff --git a/TODO b/TODO index 5ae1abd2..d0cfd1f6 100644 --- a/TODO +++ b/TODO @@ -3,11 +3,12 @@ ** syntax.mes ** or psyntax.pp ** bugs -*** c1.mes -*** closure.mes -*** using (let () ...) in macro.mes/syntax.mes +*** v c0.mes +*** v closure.mes +*** v using (let () ...) in macro.mes/syntax.mes +*** syntax.mes: closuring name? etc in syntax.mes +*** syntax.mes: closuring: indicators: eval: no such symbol: --- *** <=, => take only 2 arguments -** ** run PEG ** parse C using PEG http://piumarta.com/software/peg/ @@ -28,6 +29,7 @@ v #(v e c t o r) v assq v call-with-values v char? +for-each v length v list v list->vector diff --git a/c0.mes b/c0.mes index 6614dcfb..29df12fa 100644 --- a/c0.mes +++ b/c0.mes @@ -8,10 +8,11 @@ ;; 1 (define b 0) -(define x (lambda () b)) +;;(define x (lambda () b)) +(define (x) b) -(display (x)) -(newline) +;;(display (x)) +;;(newline) (define (c b) (display (x)) (newline) diff --git a/macro.mes b/macro.mes index d43a3fd4..309f3e67 100644 --- a/macro.mes +++ b/macro.mes @@ -58,28 +58,23 @@ ) (d-s s-r - (;; let () ;; syntax-rules uses (let () ...), - ;; mes doesn't support that yet; use ((lambda () ...)) - (lambda () - ;; syntax-rules uses defines that get closured-in - ;; mes doesn't support that yet; move down - ;; (define name? symbol?) - (lambda (. n-a) - (define name? symbol?) + (let () + (define name? symbol?) + (lambda (. n-a) - (display "YEAH:") - (display n-a) - (display (name? n-a)) - (newline) - '(lambda (. i) ;;(i r c) - (display "transformers") - (newline) - ''tee-hee-hee - ) - ;; (define (foo) (display "Footje") (newline) 'f-f-f) - ;; foo - ;;"blaat" - ))) + (display "YEAH:") + (display n-a) + (display (name? n-a)) + (newline) + '(lambda (. i) ;;(i r c) + (display "transformers") + (newline) + ''tee-hee-hee + ) + ;; (define (foo) (display "Footje") (newline) 'f-f-f) + ;; foo + ;;"blaat" + )) ) (display "calling s-r") diff --git a/mes.c b/mes.c index 381afad6..cc296409 100644 --- a/mes.c +++ b/mes.c @@ -160,6 +160,14 @@ eq_p (scm *x, scm *y) ? &scm_t : &scm_f; } +#if MACROS +scm * +macro_p (scm *x, scm *a) +{ + return assq (x, cdr (assq (&scm_macro, a))) != &scm_f ? &scm_t : &scm_f; +} +#endif + scm * null_p (scm *x) { @@ -285,7 +293,12 @@ apply_env_ (scm *fn, scm *x, scm *a) return call (&scm_call_with_values_env, append2 (x, cons (a, &scm_nil))); if (builtin_p (fn) == &scm_t) return call (fn, x); - return apply_env (eval (fn, a), x, a); + scm *efn = eval (fn, a); + if (efn == &scm_unspecified) assert (!"apply unspecified"); + // FIXME: closure.scm is calling: (3 2 1) + if (efn->type == NUMBER) return cons (efn, x); + if (efn->type == NUMBER) assert (!"apply number"); + return apply_env (efn, x, a); } else if (car (fn) == &scm_lambda) return begin_env (cddr (fn), pairlis (cadr (fn), x, a)); @@ -295,6 +308,8 @@ apply_env_ (scm *fn, scm *x, scm *a) #if DEBUG // FIXME: for macro.mes/syntax.mes this feels *wrong* printf ("APPLY WTF: fn="); display (fn); + printf (" WTF: x="); + display (x); puts (""); #endif //return apply_env_ (eval_ (fn, a), x, a); @@ -347,7 +362,7 @@ eval_ (scm *e, scm *a) scm *y = assq (e, a); if (y == &scm_f) { printf ("eval: no such symbol: %s\n", e->name); - exit (1); + assert (!"unknown symbol"); } return cdr (y); } @@ -360,16 +375,8 @@ eval_ (scm *e, scm *a) #endif // MACROS if (car (e) == &scm_symbol_quote) return cadr (e); - if (car (e) == &scm_lambda) { - scm *p = pairlis (cadr (e), cadr (e), a); - printf ("CLOSURE pairlis="); - display (p); - puts (""); - ///return e; - //return make_lambda (cadr (e), eval (cddr (e), evlis (cadr (e), a))); - // FIXME: CLOSURE...caddr: body of ONE: cons with '() - return make_lambda (cadr (e), cons (eval_ (caddr (e), pairlis (cadr (e), cadr (e), a)), &scm_nil)); - } + if (car (e) == &scm_lambda) + return make_lambda (cadr (e), closure_body (cddr (e), pairlis (cadr (e), cadr (e), a))); if (car (e) == &scm_symbol_set_x) return set_env_x (cadr (e), eval (caddr (e), a), a); #if QUASIQUOTE @@ -384,7 +391,7 @@ eval_ (scm *e, scm *a) display (eval_quasiquote (cadr (e), a)); puts (""); #endif // DEBUG - return eval_quasiquote (cadr (e), a); + return eval_quasiquote (cadr (e), add_unquoters (a)); } #endif // QUASIQUOTE else if (car (e) == &scm_symbol_cond) @@ -410,6 +417,88 @@ eval_ (scm *e, scm *a) return apply_env (car (e), evlis (cdr (e), a), a); } +// FIXME: add values to closures. what is this step called, and when +// should it be run: read/eval/apply? +scm * +closure_body (scm *body, scm *a) +{ + if (body == &scm_nil) return &scm_nil; + scm *e = car (body); +#if DEBUG + printf ("\nclosure_body e="); + display (e); + puts (""); +#endif + if (e->type == PAIR) { // FIXME: c&p from begin_env + if (eq_p (car (e), &scm_lambda) == &scm_t) { + scm *p = pairlis (cadr (e), cadr (e), a); + return cons (make_lambda (cadr (e), cddr (e)), closure_body (cdr (body), p)); + } + else if (eq_p (car (e), &scm_quote) == &scm_t + || eq_p (car (e), &scm_quasiquote) == &scm_t + || eq_p (car (e), &scm_unquote) == &scm_t + || eq_p (car (e), &scm_unquote_splicing) == &scm_t) { + bool have_unquote = assq (&scm_unquote, a) != &scm_f; +#if DEBUG + printf ("quote[%d] ==> ", have_unquote); + display (e); + puts (""); +#endif + scm *x = e; + if (!have_unquote && eq_p (car (e), &scm_quote) == &scm_t) + ; + else if (!have_unquote && eq_p (car (e), &scm_quasiquote) == &scm_t) + a = add_unquoters (a); + else + x = cons (car (x), closure_body (cdr (x), a)); + return cons (x, closure_body (cdr (body), a)); + } + if (eq_p (car (e), &scm_symbol_define) == &scm_t + // FIXME: closure inside macros? + || eq_p (car (e), &scm_symbol_define_macro) == &scm_t + || eq_p (car (e), &scm_symbol_set_x) == &scm_t) { + if (cadr (e)->type == PAIR && cadr (e) == &scm_nil) { + scm *p = pairlis (cdadr (e), cdadr (e), cons (cons (caar (e), caar (e)), a)); + return cons (cons (car (e), cons (cadr (e), closure_body (cddr (e), p))), cdr (body)); + } + return cons (cons (car (e), cons (cadr (e), closure_body (cddr (e), a))), cdr (body)); + } + } + if (builtin_p (e) == &scm_t) { + return cons (e, closure_body (cdr (body), a)); + } + + else if (atom_p (e) == &scm_t) { +#if DEBUG + printf ("e="); + display (e); +#endif + scm *x = e; + if (builtin_p (e) != &scm_t + && e->type != CHAR + && e->type != NUMBER + && e->type != STRING + && e->type != VECTOR +#if MACROS + && macro_p (e, a) != &scm_t +#endif + ) { + scm *s = assq (e, a); + if (s == &scm_f) fprintf (stderr, "warning: %s possibly undefined symbol\n", e->name); + else if (eq_p (s->cdr, &scm_unspecified) == &scm_t) + ; // FIXME: letrec bindings use *unspecified* ... + else x = cdr (s); + } +#if DEBUG + printf (" => x="); + display (x); + puts (""); +#endif + return cons (x, closure_body (cdr (body), a)); + } + return cons (closure_body (e, a), closure_body (cdr (body), a)); +} + scm * evcon_ (scm *c, scm *a) { @@ -434,6 +523,10 @@ evcon_ (scm *c, scm *a) return expr; if (cddr (clause) == &scm_nil) return eval (cadr (clause), a); + // printf ("EVALLING: (cadr clause): clause="); + // display (clause); + // printf (" (cadr clause)="); + // display (cadr (clause)); eval (cadr (clause), a); return evcon_ (cons (cons (&scm_t, cddr (clause)), &scm_nil), a); } @@ -885,7 +978,7 @@ display_helper (scm *x, bool cont, char *sep, bool quote) } else if (atom_p (x) == &scm_t) printf ("%s", x->name); - //return &scm_unspecified; + return &scm_unspecified; return x; // FIXME: eval helper for macros } @@ -1149,6 +1242,15 @@ is_p (scm *a, scm *b) } #if QUASIQUOTE +scm *add_environment (scm *a, char *name, scm *x); + +scm * +add_unquoters (scm *a) +{ + a = add_environment (a, "unquote", &scm_unquote); + a = add_environment (a, "unquote-splicing", &scm_unquote_splicing); + return a; +} scm * eval_quasiquote (scm *e, scm *a) { @@ -1195,11 +1297,14 @@ mes_environment () a = add_environment (a, "*dot*", &scm_dot); a = add_environment (a, "current-module", &scm_symbol_current_module); - a = add_environment (a, "'", &scm_quote); -#if QUASIQUOTE - a = add_environment (a, ",", &scm_unquote); - a = add_environment (a, "`", &scm_quasiquote); -#endif + // builtins, for closure_body + a = add_environment (a, "cond", &scm_symbol_cond); + +// a = add_environment (a, "'", &scm_quote); +// #if QUASIQUOTE +// a = add_environment (a, ",", &scm_unquote); +// a = add_environment (a, "`", &scm_quasiquote); +// #endif #include "environment.i" @@ -1216,8 +1321,8 @@ scm * define (scm *x, scm *a) { if (atom_p (cadr (x)) != &scm_f) - return cons (cadr (x), eval (caddr (x), a)); -#if 1//DEBUG + return cons (cadr (x), eval (caddr (x), cons (cons (cadr (x), cadr (x)), a))); +#if DEBUG scm *name = caadr (x); scm *args = cdadr (x); scm *body = cddr (x); @@ -1232,7 +1337,10 @@ define (scm *x, scm *a) display (aa); puts (""); #endif - return cons (caadr (x), eval (make_lambda (cdadr (x), cddr (x)), a)); + scm *e = cdr (x); + scm *p = pairlis (cadr (x), cadr (x), a); + // eval for closure_body + return cons (caadr (x), eval (make_lambda (cdadr (x), cddr (x)), p)); } scm * @@ -1258,9 +1366,14 @@ define_macro (scm *x, scm *a) scm *macros = assq (&scm_macro, a); scm *macro; if (atom_p (cadr (x)) != &scm_f) - macro = cons (cadr (x), eval (caddr (x), a)); - else - macro = cons (caadr(x), make_lambda (cdadr (x), cddr (x))); + //macro = cons (cadr (x), eval (caddr (x), a)); + macro = cons (cadr (x), eval (caddr (x), cons (cons (cadr (x), cadr (x)), a))); + else { + scm *p = pairlis (cadr (x), cadr (x), a); + //macro = cons (caadr(x), make_lambda (cdadr (x), cddr (x))); + // FIXME: closure inside macros? + macro = cons (caadr(x), eval (make_lambda (cdadr (x), cddr (x)), p)); + } set_cdr_x (macros, cons (macro, cdr (macros))); return a; } diff --git a/scm.mes b/scm.mes index ad0dd531..32e11d0c 100755 --- a/scm.mes +++ b/scm.mes @@ -80,8 +80,9 @@ ,@(split-values bindings '()))) (define-macro (let-loop label bindings rest) - `(let ((,label (lambda ,(split-params bindings '()) ,@rest))) - (,label ,@(split-values bindings '())))) + `(let ((,label *unspecified*)) + (let ((,label (lambda ,(split-params bindings '()) ,@rest))) + (,label ,@(split-values bindings '()))))) (define-macro (let bindings-or-label . rest) `(if ,(symbol? bindings-or-label) diff --git a/syntax.mes b/syntax.mes index 7b7a30f8..1b33cd26 100644 --- a/syntax.mes +++ b/syntax.mes @@ -99,259 +99,256 @@ (newline) (mes:define-syntax syntax-rules - (;; let () ;; syntax-rules uses (let () ...), - ;; mes doesn't support that yet; use ((lambda () ...)) - (lambda () + (let () + ;; syntax-rules uses defines that get closured-in + ;; mes still has a bug here; move down + ;; (define name? symbol?) - ;; syntax-rules uses defines that get closured-in - ;; mes doesn't support that yet; move down - ;; (define name? symbol?) - - ;; (define (segment-pattern? pattern) - ;; (and (segment-template? pattern) - ;; (or (null? (cddr pattern)) - ;; (syntax-error "segment matching not implemented" pattern)))) + ;; (define (segment-pattern? pattern) + ;; (and (segment-template? pattern) + ;; (or (null? (cddr pattern)) + ;; (syntax-error "segment matching not implemented" pattern)))) - ;; (define (segment-template? pattern) - ;; (and (pair? pattern) - ;; (pair? (cdr pattern)) - ;; (memq (cadr pattern) indicators-for-zero-or-more))) + ;; (define (segment-template? pattern) + ;; (and (pair? pattern) + ;; (pair? (cdr pattern)) + ;; (memq (cadr pattern) indicators-for-zero-or-more))) - ;;(define indicators-for-zero-or-more (list (string->symbol "...") '---)) + ;;(define indicators-for-zero-or-more (list (string->symbol "...") '---)) - (display "BOOO") + (display "BOOO") - (lambda (exp r c) + (lambda (exp r c) - ;; FIXME: mes, moved down - (define name? symbol?) + ;; FIXME: mes, moved down + (define name? symbol?) - (define (segment-pattern? pattern) - (display "segment-pattern?: ") - (display pattern) - (newline) - (display "segment-template?: ") - (display (segment-template? pattern)) - (newline) - (and (segment-template? pattern) - (or (null? (cddr pattern)) - (syntax-error "segment matching not implemented" pattern)))) + (define (segment-pattern? pattern) + (display "segment-pattern?: ") + (display pattern) + (newline) + (display "segment-template?: ") + (display (segment-template? pattern)) + (newline) + (and (segment-template? pattern) + (or (null? (cddr pattern)) + (syntax-error "segment matching not implemented" pattern)))) - (define indicators-for-zero-or-more (list (string->symbol "...") '---)) + (define indicators-for-zero-or-more (list (string->symbol "...") '---)) - (define (segment-template? pattern) - (and (pair? pattern) - (display "pair?: ") - (display (pair? pattern)) - (newline) - (pair? (cdr pattern)) - (display "pair? cdr: ") - (display (pair? (cdr pattern))) - (newline) - ;; (display "indicators: ") - ;; (display indicators-for-zero-or-more) - ;; (newline) - (display "cadr pattern: ") - (display (cadr pattern)) - (newline) - (display "memq?: ") - ;;(memq (cadr pattern) indicators-for-zero-or-more) - (memq (cadr pattern) (list (string->symbol "...") '---)) - ;;(member (cadr pattern) indicators-for-zero-or-more) - )) + (define (segment-template? pattern) + (and (pair? pattern) + (display "pair?: ") + (display (pair? pattern)) + (newline) + (pair? (cdr pattern)) + (display "pair? cdr: ") + (display (pair? (cdr pattern))) + (newline) + ;; (display "indicators: ") + ;; (display indicators-for-zero-or-more) + ;; (newline) + (display "cadr pattern: ") + (display (cadr pattern)) + (newline) + (display "memq?: ") + ;;(memq (cadr pattern) indicators-for-zero-or-more) + (memq (cadr pattern) (list (string->symbol "...") '---)) + ;;(member (cadr pattern) indicators-for-zero-or-more) + )) - ;; end FIXME + ;; end FIXME - (define %input (r '%input)) ;Gensym these, if you like. - (define %compare (r '%compare)) - (define %rename (r '%rename)) - (define %tail (r '%tail)) - (define %temp (r '%temp)) + (define %input (r '%input)) ;Gensym these, if you like. + (define %compare (r '%compare)) + (define %rename (r '%rename)) + (define %tail (r '%tail)) + (define %temp (r '%temp)) - (define rules (cddr exp)) - (define subkeywords (cadr exp)) + (define rules (cddr exp)) + (define subkeywords (cadr exp)) - (define (make-transformer rules) - (display "make-transformer") (newline) - `(lambda (,%input ,%rename ,%compare) - (let ((,%tail (cdr ,%input))) - (cond ,@(map process-rule rules) - (#t ;;else - (syntax-error - "use of macro doesn't match definition" - ,%input)))))) + (define (make-transformer rules) + (display "make-transformer") (newline) + `(lambda (,%input ,%rename ,%compare) + (let ((,%tail (cdr ,%input))) + (cond ,@(map process-rule rules) + (#t ;;else + (syntax-error + "use of macro doesn't match definition" + ,%input)))))) - (define (process-rule rule) - (display "process-rule") (newline) - (cond ((and (pair? rule) - (pair? (cdr rule)) - (null? (cddr rule))) - (let ((pattern (cdar rule)) - (template (cadr rule))) - `((and ,@(process-match %tail pattern)) - (let* ,(process-pattern pattern - %tail - (lambda (x) x)) - ,(process-template template - 0 - (meta-variables pattern 0 '())))))) - (syntax-error "ill-formed syntax rule" rule))) + (define (process-rule rule) + (display "process-rule") (newline) + (cond ((and (pair? rule) + (pair? (cdr rule)) + (null? (cddr rule))) + (let ((pattern (cdar rule)) + (template (cadr rule))) + `((and ,@(process-match %tail pattern)) + (let* ,(process-pattern pattern + %tail + (lambda (x) x)) + ,(process-template template + 0 + (meta-variables pattern 0 '())))))) + (syntax-error "ill-formed syntax rule" rule))) - ;; Generate code to test whether input expression matches pattern + ;; Generate code to test whether input expression matches pattern - (define (process-match input pattern) - (display "process-match") (newline) - (cond ((name? pattern) - (cond ((member pattern subkeywords) - `((,%compare ,input (,%rename ',pattern)))) - (#t `()))) - ((segment-pattern? pattern) - (process-segment-match input (car pattern))) - ((pair? pattern) - `((let ((,%temp ,input)) - (and (pair? ,%temp) - ,@(process-match `(car ,%temp) (car pattern)) - ,@(process-match `(cdr ,%temp) (cdr pattern)))))) - ((or (null? pattern) (boolean? pattern) (char? pattern)) - `((eq? ,input ',pattern))) - (#t ;;else - `((equal? ,input ',pattern))))) + (define (process-match input pattern) + (display "process-match") (newline) + (cond ((name? pattern) + (cond ((member pattern subkeywords) + `((,%compare ,input (,%rename ',pattern)))) + (#t `()))) + ((segment-pattern? pattern) + (process-segment-match input (car pattern))) + ((pair? pattern) + `((let ((,%temp ,input)) + (and (pair? ,%temp) + ,@(process-match `(car ,%temp) (car pattern)) + ,@(process-match `(cdr ,%temp) (cdr pattern)))))) + ((or (null? pattern) (boolean? pattern) (char? pattern)) + `((eq? ,input ',pattern))) + (#t ;;else + `((equal? ,input ',pattern))))) - (define (process-segment-match input pattern) - (display "process-segment-match") (newline) - (let ((conjuncts (process-match '(car l) pattern))) - (cond ((null? conjuncts) - `((list? ,input))) ;+++ - (#t `((let loop ((l ,input)) - (display "loop") (newline) - (or (null? l) - (and (pair? l) - ,@conjuncts - (loop (cdr l)))))))))) + (define (process-segment-match input pattern) + (display "process-segment-match") (newline) + (let ((conjuncts (process-match '(car l) pattern))) + (cond ((null? conjuncts) + `((list? ,input))) ;+++ + (#t `((let loop ((l ,input)) + (display "loop") (newline) + (or (null? l) + (and (pair? l) + ,@conjuncts + (loop (cdr l)))))))))) - ;; Generate code to take apart the input expression - ;; This is pretty bad, but it seems to work (can't say why). + ;; Generate code to take apart the input expression + ;; This is pretty bad, but it seems to work (can't say why). - (define (process-pattern pattern path mapit) - (display "process-pattern pattern=") (display pattern) (newline) - (cond ((name? pattern) - (display "name!") (newline) - (display "subkeywords: ") (display subkeywords) (newline) - (cond ((memq pattern subkeywords) - ;;;;(member pattern subkeywords) - '()) - (#t - (display "hiero mapit=") (display mapit) - (display " path=") (display path) - (newline) - (list (list pattern (mapit path)))))) - ((segment-pattern? pattern) - (display "segment!") (newline) - (process-pattern (car pattern) - %temp - (lambda (x) ;temp is free in x - (display "mapit x=") (display x) (newline) - (mapit (cond ((eq? %temp x) - ;; guile: x=%temp ==> mapit==> (cdr %tail) - ;; mes: x=%temp ==> mapit==> %temp - (display " x=%temp ==> mapit==> ") (display path) (newline) - path) ;+++ - (#t - (display "not!") - `(map (lambda (,%temp) ,x) - ,path))))))) - ((pair? pattern) - (display "pair!") (newline) - (append (process-pattern (car pattern) `(car ,path) mapit) - (process-pattern (cdr pattern) `(cdr ,path) mapit))) - (#t ;;else - (display "else!") (newline) - '()))) + (define (process-pattern pattern path mapit) + (display "process-pattern pattern=") (display pattern) (newline) + (cond ((name? pattern) + (display "name!") (newline) + (display "subkeywords: ") (display subkeywords) (newline) + (cond ((memq pattern subkeywords) +;;;;(member pattern subkeywords) + '()) + (#t + (display "hiero mapit=") (display mapit) + (display " path=") (display path) + (newline) + (list (list pattern (mapit path)))))) + ((segment-pattern? pattern) + (display "segment!") (newline) + (process-pattern (car pattern) + %temp + (lambda (x) ;temp is free in x + (display "mapit x=") (display x) (newline) + (mapit (cond ((eq? %temp x) + ;; guile: x=%temp ==> mapit==> (cdr %tail) + ;; mes: x=%temp ==> mapit==> %temp + (display " x=%temp ==> mapit==> ") (display path) (newline) + path) ;+++ + (#t + (display "not!") + `(map (lambda (,%temp) ,x) + ,path))))))) + ((pair? pattern) + (display "pair!") (newline) + (append (process-pattern (car pattern) `(car ,path) mapit) + (process-pattern (cdr pattern) `(cdr ,path) mapit))) + (#t ;;else + (display "else!") (newline) + '()))) - ;; Generate code to compose the output expression according to template + ;; Generate code to compose the output expression according to template - (define (process-template template rank env) - (display "process-template") (newline) - (cond ((name? template) - (let ((probe (assq template env))) - (cond (probe - (cond ((<= (cdr probe) rank) - template) - (#t (syntax-error "template rank error (too few ...'s?)" - template)))) - (#t `(,%rename ',template))))) - ((segment-template? template) - (let ((vars - (free-meta-variables (car template) (+ rank 1) env '()))) - (cond ((null? vars) - (syntax-error "too many ...'s" template)) - (#t (let* ((x (process-template (car template) - (+ rank 1) - env)) - (gen (cond ((equal? (list x) vars) - x) ;+++ - (#t `(map (lambda ,vars ,x) - ,@vars))))) - (cond ((null? (cddr template)) - gen) ;+++ - (#t `(append ,gen ,(process-template (cddr template) - rank env))))))))) - ((pair? template) - `(cons ,(process-template (car template) rank env) - ,(process-template (cdr template) rank env))) - (#t ;;else - `(quote ,template)))) + (define (process-template template rank env) + (display "process-template") (newline) + (cond ((name? template) + (let ((probe (assq template env))) + (cond (probe + (cond ((<= (cdr probe) rank) + template) + (#t (syntax-error "template rank error (too few ...'s?)" + template)))) + (#t `(,%rename ',template))))) + ((segment-template? template) + (let ((vars + (free-meta-variables (car template) (+ rank 1) env '()))) + (cond ((null? vars) + (syntax-error "too many ...'s" template)) + (#t (let* ((x (process-template (car template) + (+ rank 1) + env)) + (gen (cond ((equal? (list x) vars) + x) ;+++ + (#t `(map (lambda ,vars ,x) + ,@vars))))) + (cond ((null? (cddr template)) + gen) ;+++ + (#t `(append ,gen ,(process-template (cddr template) + rank env))))))))) + ((pair? template) + `(cons ,(process-template (car template) rank env) + ,(process-template (cdr template) rank env))) + (#t ;;else + `(quote ,template)))) - ;; Return an association list of (var . rank) + ;; Return an association list of (var . rank) - (define (meta-variables pattern rank vars) - (display "meta-variables") (newline) - (cond ((name? pattern) - (cond ((memq pattern subkeywords) - vars) - (#t (cons (cons pattern rank) vars)))) - ((segment-pattern? pattern) - (meta-variables (car pattern) (+ rank 1) vars)) - ((pair? pattern) - (meta-variables (car pattern) rank - (meta-variables (cdr pattern) rank vars))) - (#t ;;else - vars))) + (define (meta-variables pattern rank vars) + (display "meta-variables") (newline) + (cond ((name? pattern) + (cond ((memq pattern subkeywords) + vars) + (#t (cons (cons pattern rank) vars)))) + ((segment-pattern? pattern) + (meta-variables (car pattern) (+ rank 1) vars)) + ((pair? pattern) + (meta-variables (car pattern) rank + (meta-variables (cdr pattern) rank vars))) + (#t ;;else + vars))) - ;; Return a list of meta-variables of given higher rank + ;; Return a list of meta-variables of given higher rank - (define (free-meta-variables template rank env free) - (display "free-meta-variables") (newline) - (cond ((name? template) - (cond ((and (not (memq template free)) - (let ((probe (assq template env))) - (and probe (>= (cdr probe) rank)))) - (cons template free)) - (#t free))) - ((segment-template? template) - (free-meta-variables (car template) - rank env - (free-meta-variables (cddr template) - rank env free))) - ((pair? template) - (free-meta-variables (car template) - rank env - (free-meta-variables (cdr template) - rank env free))) - (#t ;;else - free))) + (define (free-meta-variables template rank env free) + (display "free-meta-variables") (newline) + (cond ((name? template) + (cond ((and (not (memq template free)) + (let ((probe (assq template env))) + (and probe (>= (cdr probe) rank)))) + (cons template free)) + (#t free))) + ((segment-template? template) + (free-meta-variables (car template) + rank env + (free-meta-variables (cddr template) + rank env free))) + ((pair? template) + (free-meta-variables (car template) + rank env + (free-meta-variables (cdr template) + rank env free))) + (#t ;;else + free))) - c ;ignored + c ;ignored - (display "HELLO") - (newline) + (display "HELLO") + (newline) - ;; Kludge for Scheme48 linker. - ;; `(cons ,(make-transformer rules) - ;; ',(find-free-names-in-syntax-rules subkeywords rules)) + ;; Kludge for Scheme48 linker. + ;; `(cons ,(make-transformer rules) + ;; ',(find-free-names-in-syntax-rules subkeywords rules)) - (make-transformer rules))))) + (make-transformer rules)))) (mes:define-syntax mes:or