artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

closures: mostly supported...

Browse source
This commit is contained in:
Jan Nieuwenhuizen 2016-07-17 22:15:31 +02:00
parent 7eb56a400a
commit 59cdf9632f
6 changed files with 387 additions and 278 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
TODO
View file

@ -3,11 +3,12 @@
** syntax.mes ** syntax.mes
** or psyntax.pp ** or psyntax.pp
** bugs ** bugs
*** c1.mes *** v c0.mes
*** closure.mes *** v closure.mes
*** using (let () ...) in macro.mes/syntax.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 *** <=, => take only 2 arguments
**
** run PEG ** run PEG
** parse C using PEG ** parse C using PEG
http://piumarta.com/software/peg/ http://piumarta.com/software/peg/
@ -28,6 +29,7 @@ v #(v e c t o r)
v assq v assq
v call-with-values v call-with-values
v char? v char?
for-each
v length v length
v list v list
v list->vector v list->vector

7
c0.mes
View file

@ -8,10 +8,11 @@
;; 1 ;; 1
(define b 0) (define b 0)
(define x (lambda () b)) ;;(define x (lambda () b))
(define (x) b)
(display (x)) ;;(display (x))
(newline) ;;(newline)
(define (c b) (define (c b)
(display (x)) (display (x))
(newline) (newline)

37
macro.mes
View file

@ -58,28 +58,23 @@
) )
(d-s s-r (d-s s-r
(;; let () ;; syntax-rules uses (let () ...), (let ()
;; mes doesn't support that yet; use ((lambda () ...)) (define name? symbol?)
(lambda () (lambda (. n-a)
;; 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?)
(display "YEAH:") (display "YEAH:")
(display n-a) (display n-a)
(display (name? n-a)) (display (name? n-a))
(newline) (newline)
'(lambda (. i) ;;(i r c) '(lambda (. i) ;;(i r c)
(display "transformers") (display "transformers")
(newline) (newline)
''tee-hee-hee ''tee-hee-hee
) )
;; (define (foo) (display "Footje") (newline) 'f-f-f) ;; (define (foo) (display "Footje") (newline) 'f-f-f)
;; foo ;; foo
;;"blaat" ;;"blaat"
))) ))
) )
(display "calling s-r") (display "calling s-r")

163
mes.c
View file

@ -160,6 +160,14 @@ eq_p (scm *x, scm *y)
? &scm_t : &scm_f; ? &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 * scm *
null_p (scm *x) 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))); return call (&scm_call_with_values_env, append2 (x, cons (a, &scm_nil)));
if (builtin_p (fn) == &scm_t) if (builtin_p (fn) == &scm_t)
return call (fn, x); 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) else if (car (fn) == &scm_lambda)
return begin_env (cddr (fn), pairlis (cadr (fn), x, a)); 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* #if DEBUG // FIXME: for macro.mes/syntax.mes this feels *wrong*
printf ("APPLY WTF: fn="); printf ("APPLY WTF: fn=");
display (fn); display (fn);
printf (" WTF: x=");
display (x);
puts (""); puts ("");
#endif #endif
//return apply_env_ (eval_ (fn, a), x, a); //return apply_env_ (eval_ (fn, a), x, a);
@ -347,7 +362,7 @@ eval_ (scm *e, scm *a)
scm *y = assq (e, a); scm *y = assq (e, a);
if (y == &scm_f) { if (y == &scm_f) {
printf ("eval: no such symbol: %s\n", e->name); printf ("eval: no such symbol: %s\n", e->name);
exit (1); assert (!"unknown symbol");
} }
return cdr (y); return cdr (y);
} }
@ -360,16 +375,8 @@ eval_ (scm *e, scm *a)
#endif // MACROS #endif // MACROS
if (car (e) == &scm_symbol_quote) if (car (e) == &scm_symbol_quote)
return cadr (e); return cadr (e);
if (car (e) == &scm_lambda) { if (car (e) == &scm_lambda)
scm *p = pairlis (cadr (e), cadr (e), a); return make_lambda (cadr (e), closure_body (cddr (e), 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_symbol_set_x) if (car (e) == &scm_symbol_set_x)
return set_env_x (cadr (e), eval (caddr (e), a), a); return set_env_x (cadr (e), eval (caddr (e), a), a);
#if QUASIQUOTE #if QUASIQUOTE
@ -384,7 +391,7 @@ eval_ (scm *e, scm *a)
display (eval_quasiquote (cadr (e), a)); display (eval_quasiquote (cadr (e), a));
puts (""); puts ("");
#endif // DEBUG #endif // DEBUG
return eval_quasiquote (cadr (e), a); return eval_quasiquote (cadr (e), add_unquoters (a));
} }
#endif // QUASIQUOTE #endif // QUASIQUOTE
else if (car (e) == &scm_symbol_cond) 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); 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 * scm *
evcon_ (scm *c, scm *a) evcon_ (scm *c, scm *a)
{ {
@ -434,6 +523,10 @@ evcon_ (scm *c, scm *a)
return expr; return expr;
if (cddr (clause) == &scm_nil) if (cddr (clause) == &scm_nil)
return eval (cadr (clause), a); return eval (cadr (clause), a);
// printf ("EVALLING: (cadr clause): clause=");
// display (clause);
// printf (" (cadr clause)=");
// display (cadr (clause));
eval (cadr (clause), a); eval (cadr (clause), a);
return evcon_ (cons (cons (&scm_t, cddr (clause)), &scm_nil), 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); else if (atom_p (x) == &scm_t) printf ("%s", x->name);
//return &scm_unspecified; return &scm_unspecified;
return x; // FIXME: eval helper for macros return x; // FIXME: eval helper for macros
} }
@ -1149,6 +1242,15 @@ is_p (scm *a, scm *b)
} }
#if QUASIQUOTE #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 * scm *
eval_quasiquote (scm *e, scm *a) eval_quasiquote (scm *e, scm *a)
{ {
@ -1195,11 +1297,14 @@ mes_environment ()
a = add_environment (a, "*dot*", &scm_dot); a = add_environment (a, "*dot*", &scm_dot);
a = add_environment (a, "current-module", &scm_symbol_current_module); a = add_environment (a, "current-module", &scm_symbol_current_module);
a = add_environment (a, "'", &scm_quote); // builtins, for closure_body
#if QUASIQUOTE a = add_environment (a, "cond", &scm_symbol_cond);
a = add_environment (a, ",", &scm_unquote);
a = add_environment (a, "`", &scm_quasiquote); // a = add_environment (a, "'", &scm_quote);
#endif // #if QUASIQUOTE
// a = add_environment (a, ",", &scm_unquote);
// a = add_environment (a, "`", &scm_quasiquote);
// #endif
#include "environment.i" #include "environment.i"
@ -1216,8 +1321,8 @@ scm *
define (scm *x, scm *a) define (scm *x, scm *a)
{ {
if (atom_p (cadr (x)) != &scm_f) if (atom_p (cadr (x)) != &scm_f)
return cons (cadr (x), eval (caddr (x), a)); return cons (cadr (x), eval (caddr (x), cons (cons (cadr (x), cadr (x)), a)));
#if 1//DEBUG #if DEBUG
scm *name = caadr (x); scm *name = caadr (x);
scm *args = cdadr (x); scm *args = cdadr (x);
scm *body = cddr (x); scm *body = cddr (x);
@ -1232,7 +1337,10 @@ define (scm *x, scm *a)
display (aa); display (aa);
puts (""); puts ("");
#endif #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 * scm *
@ -1258,9 +1366,14 @@ define_macro (scm *x, scm *a)
scm *macros = assq (&scm_macro, a); scm *macros = assq (&scm_macro, a);
scm *macro; scm *macro;
if (atom_p (cadr (x)) != &scm_f) if (atom_p (cadr (x)) != &scm_f)
macro = cons (cadr (x), eval (caddr (x), a)); //macro = cons (cadr (x), eval (caddr (x), a));
else macro = cons (cadr (x), eval (caddr (x), cons (cons (cadr (x), cadr (x)), a)));
macro = cons (caadr(x), make_lambda (cdadr (x), cddr (x))); 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))); set_cdr_x (macros, cons (macro, cdr (macros)));
return a; return a;
} }

5
scm.mes
View file

@ -80,8 +80,9 @@
,@(split-values bindings '()))) ,@(split-values bindings '())))
(define-macro (let-loop label bindings rest) (define-macro (let-loop label bindings rest)
`(let ((,label (lambda ,(split-params bindings '()) ,@rest))) `(let ((,label *unspecified*))
(,label ,@(split-values bindings '())))) (let ((,label (lambda ,(split-params bindings '()) ,@rest)))
(,label ,@(split-values bindings '())))))
(define-macro (let bindings-or-label . rest) (define-macro (let bindings-or-label . rest)
`(if ,(symbol? bindings-or-label) `(if ,(symbol? bindings-or-label)

443
syntax.mes
View file

@ -99,259 +99,256 @@
(newline) (newline)
(mes:define-syntax syntax-rules (mes:define-syntax syntax-rules
(;; let () ;; syntax-rules uses (let () ...), (let ()
;; mes doesn't support that yet; use ((lambda () ...)) ;; syntax-rules uses defines that get closured-in
(lambda () ;; mes still has a bug here; move down
;; (define name? symbol?)
;; syntax-rules uses defines that get closured-in ;; (define (segment-pattern? pattern)
;; mes doesn't support that yet; move down ;; (and (segment-template? pattern)
;; (define name? symbol?) ;; (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) ;; (define (segment-template? pattern)
;; (and (pair? pattern) ;; (and (pair? pattern)
;; (pair? (cdr pattern)) ;; (pair? (cdr pattern))
;; (memq (cadr pattern) indicators-for-zero-or-more))) ;; (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 ;; FIXME: mes, moved down
(define name? symbol?) (define name? symbol?)
(define (segment-pattern? pattern) (define (segment-pattern? pattern)
(display "segment-pattern?: ") (display "segment-pattern?: ")
(display pattern) (display pattern)
(newline) (newline)
(display "segment-template?: ") (display "segment-template?: ")
(display (segment-template? pattern)) (display (segment-template? pattern))
(newline) (newline)
(and (segment-template? pattern) (and (segment-template? pattern)
(or (null? (cddr pattern)) (or (null? (cddr pattern))
(syntax-error "segment matching not implemented" 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) (define (segment-template? pattern)
(and (pair? pattern) (and (pair? pattern)
(display "pair?: ") (display "pair?: ")
(display (pair? pattern)) (display (pair? pattern))
(newline) (newline)
(pair? (cdr pattern)) (pair? (cdr pattern))
(display "pair? cdr: ") (display "pair? cdr: ")
(display (pair? (cdr pattern))) (display (pair? (cdr pattern)))
(newline) (newline)
;; (display "indicators: ") ;; (display "indicators: ")
;; (display indicators-for-zero-or-more) ;; (display indicators-for-zero-or-more)
;; (newline) ;; (newline)
(display "cadr pattern: ") (display "cadr pattern: ")
(display (cadr pattern)) (display (cadr pattern))
(newline) (newline)
(display "memq?: ") (display "memq?: ")
;;(memq (cadr pattern) indicators-for-zero-or-more) ;;(memq (cadr pattern) indicators-for-zero-or-more)
(memq (cadr pattern) (list (string->symbol "...") '---)) (memq (cadr pattern) (list (string->symbol "...") '---))
;;(member (cadr pattern) indicators-for-zero-or-more) ;;(member (cadr pattern) indicators-for-zero-or-more)
)) ))
;; end FIXME ;; end FIXME
(define %input (r '%input)) ;Gensym these, if you like. (define %input (r '%input)) ;Gensym these, if you like.
(define %compare (r '%compare)) (define %compare (r '%compare))
(define %rename (r '%rename)) (define %rename (r '%rename))
(define %tail (r '%tail)) (define %tail (r '%tail))
(define %temp (r '%temp)) (define %temp (r '%temp))
(define rules (cddr exp)) (define rules (cddr exp))
(define subkeywords (cadr exp)) (define subkeywords (cadr exp))
(define (make-transformer rules) (define (make-transformer rules)
(display "make-transformer") (newline) (display "make-transformer") (newline)
`(lambda (,%input ,%rename ,%compare) `(lambda (,%input ,%rename ,%compare)
(let ((,%tail (cdr ,%input))) (let ((,%tail (cdr ,%input)))
(cond ,@(map process-rule rules) (cond ,@(map process-rule rules)
(#t ;;else (#t ;;else
(syntax-error (syntax-error
"use of macro doesn't match definition" "use of macro doesn't match definition"
,%input)))))) ,%input))))))
(define (process-rule rule) (define (process-rule rule)
(display "process-rule") (newline) (display "process-rule") (newline)
(cond ((and (pair? rule) (cond ((and (pair? rule)
(pair? (cdr rule)) (pair? (cdr rule))
(null? (cddr rule))) (null? (cddr rule)))
(let ((pattern (cdar rule)) (let ((pattern (cdar rule))
(template (cadr rule))) (template (cadr rule)))
`((and ,@(process-match %tail pattern)) `((and ,@(process-match %tail pattern))
(let* ,(process-pattern pattern (let* ,(process-pattern pattern
%tail %tail
(lambda (x) x)) (lambda (x) x))
,(process-template template ,(process-template template
0 0
(meta-variables pattern 0 '())))))) (meta-variables pattern 0 '()))))))
(syntax-error "ill-formed syntax rule" rule))) (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) (define (process-match input pattern)
(display "process-match") (newline) (display "process-match") (newline)
(cond ((name? pattern) (cond ((name? pattern)
(cond ((member pattern subkeywords) (cond ((member pattern subkeywords)
`((,%compare ,input (,%rename ',pattern)))) `((,%compare ,input (,%rename ',pattern))))
(#t `()))) (#t `())))
((segment-pattern? pattern) ((segment-pattern? pattern)
(process-segment-match input (car pattern))) (process-segment-match input (car pattern)))
((pair? pattern) ((pair? pattern)
`((let ((,%temp ,input)) `((let ((,%temp ,input))
(and (pair? ,%temp) (and (pair? ,%temp)
,@(process-match `(car ,%temp) (car pattern)) ,@(process-match `(car ,%temp) (car pattern))
,@(process-match `(cdr ,%temp) (cdr pattern)))))) ,@(process-match `(cdr ,%temp) (cdr pattern))))))
((or (null? pattern) (boolean? pattern) (char? pattern)) ((or (null? pattern) (boolean? pattern) (char? pattern))
`((eq? ,input ',pattern))) `((eq? ,input ',pattern)))
(#t ;;else (#t ;;else
`((equal? ,input ',pattern))))) `((equal? ,input ',pattern)))))
(define (process-segment-match input pattern) (define (process-segment-match input pattern)
(display "process-segment-match") (newline) (display "process-segment-match") (newline)
(let ((conjuncts (process-match '(car l) pattern))) (let ((conjuncts (process-match '(car l) pattern)))
(cond ((null? conjuncts) (cond ((null? conjuncts)
`((list? ,input))) ;+++ `((list? ,input))) ;+++
(#t `((let loop ((l ,input)) (#t `((let loop ((l ,input))
(display "loop") (newline) (display "loop") (newline)
(or (null? l) (or (null? l)
(and (pair? l) (and (pair? l)
,@conjuncts ,@conjuncts
(loop (cdr l)))))))))) (loop (cdr l))))))))))
;; Generate code to take apart the input expression ;; Generate code to take apart the input expression
;; This is pretty bad, but it seems to work (can't say why). ;; This is pretty bad, but it seems to work (can't say why).
(define (process-pattern pattern path mapit) (define (process-pattern pattern path mapit)
(display "process-pattern pattern=") (display pattern) (newline) (display "process-pattern pattern=") (display pattern) (newline)
(cond ((name? pattern) (cond ((name? pattern)
(display "name!") (newline) (display "name!") (newline)
(display "subkeywords: ") (display subkeywords) (newline) (display "subkeywords: ") (display subkeywords) (newline)
(cond ((memq pattern subkeywords) (cond ((memq pattern subkeywords)
;;;;(member pattern subkeywords) ;;;;(member pattern subkeywords)
'()) '())
(#t (#t
(display "hiero mapit=") (display mapit) (display "hiero mapit=") (display mapit)
(display " path=") (display path) (display " path=") (display path)
(newline) (newline)
(list (list pattern (mapit path)))))) (list (list pattern (mapit path))))))
((segment-pattern? pattern) ((segment-pattern? pattern)
(display "segment!") (newline) (display "segment!") (newline)
(process-pattern (car pattern) (process-pattern (car pattern)
%temp %temp
(lambda (x) ;temp is free in x (lambda (x) ;temp is free in x
(display "mapit x=") (display x) (newline) (display "mapit x=") (display x) (newline)
(mapit (cond ((eq? %temp x) (mapit (cond ((eq? %temp x)
;; guile: x=%temp ==> mapit==> (cdr %tail) ;; guile: x=%temp ==> mapit==> (cdr %tail)
;; mes: x=%temp ==> mapit==> %temp ;; mes: x=%temp ==> mapit==> %temp
(display " x=%temp ==> mapit==> ") (display path) (newline) (display " x=%temp ==> mapit==> ") (display path) (newline)
path) ;+++ path) ;+++
(#t (#t
(display "not!") (display "not!")
`(map (lambda (,%temp) ,x) `(map (lambda (,%temp) ,x)
,path))))))) ,path)))))))
((pair? pattern) ((pair? pattern)
(display "pair!") (newline) (display "pair!") (newline)
(append (process-pattern (car pattern) `(car ,path) mapit) (append (process-pattern (car pattern) `(car ,path) mapit)
(process-pattern (cdr pattern) `(cdr ,path) mapit))) (process-pattern (cdr pattern) `(cdr ,path) mapit)))
(#t ;;else (#t ;;else
(display "else!") (newline) (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) (define (process-template template rank env)
(display "process-template") (newline) (display "process-template") (newline)
(cond ((name? template) (cond ((name? template)
(let ((probe (assq template env))) (let ((probe (assq template env)))
(cond (probe (cond (probe
(cond ((<= (cdr probe) rank) (cond ((<= (cdr probe) rank)
template) template)
(#t (syntax-error "template rank error (too few ...'s?)" (#t (syntax-error "template rank error (too few ...'s?)"
template)))) template))))
(#t `(,%rename ',template))))) (#t `(,%rename ',template)))))
((segment-template? template) ((segment-template? template)
(let ((vars (let ((vars
(free-meta-variables (car template) (+ rank 1) env '()))) (free-meta-variables (car template) (+ rank 1) env '())))
(cond ((null? vars) (cond ((null? vars)
(syntax-error "too many ...'s" template)) (syntax-error "too many ...'s" template))
(#t (let* ((x (process-template (car template) (#t (let* ((x (process-template (car template)
(+ rank 1) (+ rank 1)
env)) env))
(gen (cond ((equal? (list x) vars) (gen (cond ((equal? (list x) vars)
x) ;+++ x) ;+++
(#t `(map (lambda ,vars ,x) (#t `(map (lambda ,vars ,x)
,@vars))))) ,@vars)))))
(cond ((null? (cddr template)) (cond ((null? (cddr template))
gen) ;+++ gen) ;+++
(#t `(append ,gen ,(process-template (cddr template) (#t `(append ,gen ,(process-template (cddr template)
rank env))))))))) rank env)))))))))
((pair? template) ((pair? template)
`(cons ,(process-template (car template) rank env) `(cons ,(process-template (car template) rank env)
,(process-template (cdr template) rank env))) ,(process-template (cdr template) rank env)))
(#t ;;else (#t ;;else
`(quote ,template)))) `(quote ,template))))
;; Return an association list of (var . rank) ;; Return an association list of (var . rank)
(define (meta-variables pattern rank vars) (define (meta-variables pattern rank vars)
(display "meta-variables") (newline) (display "meta-variables") (newline)
(cond ((name? pattern) (cond ((name? pattern)
(cond ((memq pattern subkeywords) (cond ((memq pattern subkeywords)
vars) vars)
(#t (cons (cons pattern rank) vars)))) (#t (cons (cons pattern rank) vars))))
((segment-pattern? pattern) ((segment-pattern? pattern)
(meta-variables (car pattern) (+ rank 1) vars)) (meta-variables (car pattern) (+ rank 1) vars))
((pair? pattern) ((pair? pattern)
(meta-variables (car pattern) rank (meta-variables (car pattern) rank
(meta-variables (cdr pattern) rank vars))) (meta-variables (cdr pattern) rank vars)))
(#t ;;else (#t ;;else
vars))) 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) (define (free-meta-variables template rank env free)
(display "free-meta-variables") (newline) (display "free-meta-variables") (newline)
(cond ((name? template) (cond ((name? template)
(cond ((and (not (memq template free)) (cond ((and (not (memq template free))
(let ((probe (assq template env))) (let ((probe (assq template env)))
(and probe (>= (cdr probe) rank)))) (and probe (>= (cdr probe) rank))))
(cons template free)) (cons template free))
(#t free))) (#t free)))
((segment-template? template) ((segment-template? template)
(free-meta-variables (car template) (free-meta-variables (car template)
rank env rank env
(free-meta-variables (cddr template) (free-meta-variables (cddr template)
rank env free))) rank env free)))
((pair? template) ((pair? template)
(free-meta-variables (car template) (free-meta-variables (car template)
rank env rank env
(free-meta-variables (cdr template) (free-meta-variables (cdr template)
rank env free))) rank env free)))
(#t ;;else (#t ;;else
free))) free)))
c ;ignored c ;ignored
(display "HELLO") (display "HELLO")
(newline) (newline)
;; Kludge for Scheme48 linker. ;; Kludge for Scheme48 linker.
;; `(cons ,(make-transformer rules) ;; `(cons ,(make-transformer rules)
;; ',(find-free-names-in-syntax-rules subkeywords rules)) ;; ',(find-free-names-in-syntax-rules subkeywords rules))
(make-transformer rules))))) (make-transformer rules))))
(mes:define-syntax mes:or (mes:define-syntax mes:or