closures: mostly supported...
This commit is contained in:
Jan Nieuwenhuizen
parent
7eb56a400a
commit
59cdf9632f
10
TODO
10
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
|
||||
|
|
|
|||
7
c0.mes
7
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)
|
||||
|
|
|
|||
37
macro.mes
37
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")
|
||||
|
|
|
|||
163
mes.c
163
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;
|
||||
}
|
||||
|
|
|
|||
5
scm.mes
5
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)
|
||||
|
|
|
|||
443
syntax.mes
443
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue