mes.c: add new macro type, junk *macro* hack.
This commit is contained in:
Jan Nieuwenhuizen
parent
04f3323f10
commit
efdd84b4c4
|
|
@ -1,6 +1,6 @@
|
|||
.PHONY: all check default
|
||||
#CFLAGS=-std=c99 -O3 -finline-functions
|
||||
CFLAGS=-std=c99 -g
|
||||
CFLAGS=-std=c99 -O3 -finline-functions
|
||||
#CFLAGS=-std=c99 -g
|
||||
|
||||
default: all
|
||||
|
||||
|
|
|
|||
8
TODO
8
TODO
|
|
@ -1,7 +1,9 @@
|
|||
-*-mode:org-*-
|
||||
* define-syntax and syntax-rules
|
||||
** syntax.mes
|
||||
** or psyntax.pp
|
||||
Using define-macro-based version.
|
||||
** psyntax.pp
|
||||
Find out how to hook-up sc-expand in eval/apply.
|
||||
** bugs
|
||||
*** c2.mes
|
||||
*** c4.mes
|
||||
|
|
@ -11,8 +13,8 @@
|
|||
*** v c1.mes
|
||||
*** v c3.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: ---
|
||||
*** v syntax.mes: closuring name? etc in syntax.mes
|
||||
*** v syntax.mes: closuring: indicators: eval: no such symbol: ---
|
||||
*** <=, => take only 2 arguments
|
||||
** run PEG
|
||||
** parse C using PEG
|
||||
|
|
|
|||
194
mes.c
194
mes.c
|
|
@ -34,10 +34,9 @@
|
|||
#include <stdbool.h>
|
||||
|
||||
#define DEBUG 0
|
||||
#define XDEBUG 0
|
||||
#define MES_FULL 1
|
||||
|
||||
enum type {CHAR, NUMBER, PAIR, STRING, SYMBOL, VALUES, VECTOR,
|
||||
enum type {CHAR, MACRO, NUMBER, PAIR, STRING, SYMBOL, VALUES, VECTOR,
|
||||
FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn};
|
||||
struct scm_t;
|
||||
typedef struct scm_t* (*function0_t) (void);
|
||||
|
|
@ -61,6 +60,7 @@ typedef struct scm_t {
|
|||
function3_t function3;
|
||||
functionn_t functionn;
|
||||
struct scm_t* cdr;
|
||||
struct scm_t* macro;
|
||||
struct scm_t** vector;
|
||||
};
|
||||
} scm;
|
||||
|
|
@ -91,7 +91,6 @@ scm symbol_quote = {SYMBOL, "quote"};
|
|||
scm symbol_quasiquote = {SYMBOL, "quasiquote"};
|
||||
scm symbol_unquote = {SYMBOL, "unquote"};
|
||||
scm symbol_unquote_splicing = {SYMBOL, "unquote-splicing"};
|
||||
scm symbol_macro = {SYMBOL, "*macro*"};
|
||||
|
||||
scm symbol_call_with_values = {SYMBOL, "call-with-values"};
|
||||
scm symbol_current_module = {SYMBOL, "current-module"};
|
||||
|
|
@ -155,9 +154,9 @@ eq_p (scm *x, scm *y)
|
|||
}
|
||||
|
||||
scm *
|
||||
macro_p (scm *x, scm *a)
|
||||
macro_p (scm *x)
|
||||
{
|
||||
return assq (x, cdr (assq (&symbol_macro, a))) != &scm_f ? &scm_t : &scm_f;
|
||||
return x->type == MACRO ? &scm_t : &scm_f;
|
||||
}
|
||||
|
||||
scm *
|
||||
|
|
@ -286,8 +285,8 @@ apply_env (scm *fn, scm *x, scm *a)
|
|||
a = cdadr (fn);
|
||||
return eval (cons (&symbol_begin, body), pairlis (args, x, a));
|
||||
}
|
||||
else if ((macro = assq (car (fn), cdr (assq (&symbol_macro, a)))) != &scm_f) {
|
||||
scm *r = apply_env (eval (cdr (macro), a), cdr (fn), a);
|
||||
else if ((macro = lookup_macro (car (fn), a)) != &scm_f) {
|
||||
scm *r = apply_env (eval (macro, a), cdr (fn), a);
|
||||
scm *e = eval (r, a);
|
||||
return apply_env (e, x, a);
|
||||
}
|
||||
|
|
@ -296,6 +295,8 @@ apply_env (scm *fn, scm *x, scm *a)
|
|||
return apply_env (efn, x, a);
|
||||
}
|
||||
|
||||
scm *make_symbol (char const *s);
|
||||
|
||||
scm *
|
||||
eval (scm *e, scm *a)
|
||||
{
|
||||
|
|
@ -318,84 +319,35 @@ eval (scm *e, scm *a)
|
|||
return e;
|
||||
else if (atom_p (car (e)) == &scm_t)
|
||||
{
|
||||
//scm *macro;
|
||||
if (car (e) == &symbol_quote)
|
||||
return cadr (e);
|
||||
if (car (e) == &symbol_begin)
|
||||
{
|
||||
|
||||
scm *orig_a = a;
|
||||
|
||||
scm *body = cdr (e);
|
||||
if (body == &scm_nil) return &scm_nil;
|
||||
e = car (body);
|
||||
body = cdr (body);
|
||||
scm *r = &scm_unspecified;
|
||||
|
||||
#if DEBUG
|
||||
printf ("BEGIN eval e=");
|
||||
display (e);
|
||||
puts ("");
|
||||
#endif
|
||||
|
||||
// closure defines in one go
|
||||
|
||||
#define WHILE while
|
||||
#define BREAK break
|
||||
|
||||
scm *defines = &scm_nil;
|
||||
scm *macros = &scm_nil;
|
||||
WHILE (e->type == PAIR
|
||||
&& (eq_p (car (e), &symbol_define) == &scm_t
|
||||
|| eq_p (car (e), &symbol_define_macro) == &scm_t)) {
|
||||
if (eq_p (car (e), &symbol_define) == &scm_t)
|
||||
while (body != &scm_nil) {
|
||||
e = car (body);
|
||||
body = cdr (body);
|
||||
if (e->type == PAIR
|
||||
&& (eq_p (car (e), &symbol_define) == &scm_t
|
||||
|| eq_p (car (e), &symbol_define_macro) == &scm_t)) {
|
||||
defines = append2 (defines, cons (def (e), &scm_nil));
|
||||
else if (eq_p (car (e), &symbol_define_macro) == &scm_t)
|
||||
macros = append2 (macros, cons (def (e), &scm_nil));
|
||||
if (body == &scm_nil) e = &scm_unspecified;
|
||||
if (body == &scm_nil) BREAK;
|
||||
if (body != &scm_nil) {
|
||||
e = car (body);
|
||||
body = cdr (body);
|
||||
e = &scm_unspecified;
|
||||
}
|
||||
else break;
|
||||
}
|
||||
breek:;
|
||||
|
||||
scm* xmacros = cons (&symbol_macro,
|
||||
append2 (macros, cdr (assq (&symbol_macro, a))));
|
||||
|
||||
scm *aa = a;
|
||||
if (macros != &scm_nil) aa = cons (xmacros, aa);
|
||||
aa = append2 (defines, aa);
|
||||
a = aa;
|
||||
scm *names = &scm_nil;
|
||||
scm *values = &scm_nil;
|
||||
WHILE (defines != &scm_nil) {
|
||||
a = append2 (defines, a);
|
||||
while (defines != &scm_nil) {
|
||||
scm *name = caar (defines);
|
||||
scm *d = cdar (defines);
|
||||
scm *x = define (d, a);
|
||||
scm *entry = assq (name, a);
|
||||
set_cdr_x (entry, cdr (x));
|
||||
scm *x = cdar (defines);
|
||||
set_cdr_x (entry, cdr (define (x, a)));
|
||||
defines = cdr (defines);
|
||||
|
||||
names = cons (name, names);
|
||||
values = cons (cdr (x), values);
|
||||
}
|
||||
|
||||
WHILE (macros != &scm_nil) {
|
||||
scm *name = caar (macros);
|
||||
scm *d = cdar (macros);
|
||||
scm *x = define (d, a);
|
||||
scm *entry = assq (name, cdr (assq (&symbol_macro, a)));
|
||||
set_cdr_x (entry, cdr (x));
|
||||
macros = cdr (macros);
|
||||
|
||||
names = cons (name, names);
|
||||
values = cons (cdr (x), values);
|
||||
}
|
||||
|
||||
scm *foo = cons (&scm_dot, &scm_dot);
|
||||
r = eval (e, cons (foo, a));
|
||||
scm *fubar = cons (&scm_dot, &scm_dot);
|
||||
scm *r = eval (e, cons (fubar, a));
|
||||
if (r->type == PAIR && macro_p (cdr (r)))
|
||||
a = cons (r, a); // macros defining macros...
|
||||
if (body == &scm_nil) return r;
|
||||
return eval (cons (&symbol_begin, body), a);
|
||||
}
|
||||
|
|
@ -410,9 +362,9 @@ eval (scm *e, scm *a)
|
|||
if (car (e) == &symbol_cond)
|
||||
return evcon (cdr (e), a);
|
||||
if (eq_p (car (e), &symbol_define_macro) == &scm_t)
|
||||
return define_macro (e, a);
|
||||
if ((macro = assq (car (e), cdr (assq (&symbol_macro, a)))) != &scm_f)
|
||||
return eval (apply_env (cdr (macro), cdr (e), a), a);
|
||||
return define (e, a);
|
||||
if ((macro = lookup_macro (car (e), a)) != &scm_f)
|
||||
return eval (apply_env (macro, cdr (e), a), a);
|
||||
if (car (e) == &symbol_set_x)
|
||||
return set_env_x (cadr (e), eval (caddr (e), a), a);
|
||||
}
|
||||
|
|
@ -558,6 +510,15 @@ make_char (int x)
|
|||
return p;
|
||||
}
|
||||
|
||||
scm *
|
||||
make_macro (scm *x) //int
|
||||
{
|
||||
scm *p = malloc (sizeof (scm));
|
||||
p->type = MACRO;
|
||||
p->macro = x;
|
||||
return p;
|
||||
}
|
||||
|
||||
scm *
|
||||
make_number (int x)
|
||||
{
|
||||
|
|
@ -697,37 +658,33 @@ lookup (char *x, scm *a)
|
|||
{
|
||||
if (isdigit (*x) || (*x == '-' && isdigit (*(x+1))))
|
||||
return make_number (atoi (x));
|
||||
if (*x == '\'') return &symbol_quote;
|
||||
|
||||
// Hmmm
|
||||
if (!strcmp (x, scm_unspecified.name)) return &scm_unspecified;
|
||||
if (!strcmp (x, scm_nil.name)) return &scm_nil;
|
||||
if (!strcmp (x, scm_t.name)) return &scm_t;
|
||||
if (!strcmp (x, scm_f.name)) return &scm_f;
|
||||
|
||||
if (!strcmp (x, scm_dot.name)) return &scm_dot;
|
||||
|
||||
if (!strcmp (x, scm_f.name)) return &scm_f;
|
||||
if (!strcmp (x, scm_nil.name)) return &scm_nil;
|
||||
if (!strcmp (x, scm_t.name)) return &scm_t;
|
||||
if (!strcmp (x, scm_unspecified.name)) return &scm_unspecified;
|
||||
|
||||
if (!strcmp (x, symbol_begin.name)) return &symbol_begin;
|
||||
if (!strcmp (x, symbol_cond.name)) return &symbol_cond;
|
||||
if (!strcmp (x, symbol_closure.name)) return &symbol_closure;
|
||||
if (!strcmp (x, symbol_cond.name)) return &symbol_cond;
|
||||
if (!strcmp (x, symbol_current_module.name)) return &symbol_current_module;
|
||||
if (!strcmp (x, symbol_lambda.name)) return &symbol_lambda;
|
||||
if (!strcmp (x, symbol_set_x.name)) return &symbol_set_x;
|
||||
if (!strcmp (x, symbol_quasiquote.name)) return &symbol_quasiquote;
|
||||
if (!strcmp (x, symbol_quote.name)) return &symbol_quote;
|
||||
|
||||
if (!strcmp (x, symbol_set_x.name)) return &symbol_set_x;
|
||||
if (!strcmp (x, symbol_unquote.name)) return &symbol_unquote;
|
||||
if (!strcmp (x, symbol_unquote_splicing.name)) return &symbol_unquote_splicing;
|
||||
|
||||
if (!strcmp (x, scm_car.name)) return &scm_car;
|
||||
if (!strcmp (x, scm_cdr.name)) return &scm_cdr;
|
||||
if (!strcmp (x, scm_display.name)) return &scm_display;
|
||||
if (!strcmp (x, scm_builtin_list.name)) return &scm_builtin_list;
|
||||
|
||||
|
||||
if (*x == '\'') return &symbol_quote;
|
||||
if (*x == '`') return &symbol_quasiquote;
|
||||
if (*x == ',' && *(x+1) == '@') return &symbol_unquote_splicing;
|
||||
if (*x == ',') return &symbol_unquote;
|
||||
if (!strcmp (x, symbol_quasiquote.name)) return &symbol_quasiquote;
|
||||
if (!strcmp (x, symbol_unquote.name)) return &symbol_unquote;
|
||||
if (!strcmp (x, symbol_unquote_splicing.name)) return &symbol_unquote_splicing;
|
||||
|
||||
return make_symbol (x);
|
||||
}
|
||||
|
|
@ -838,6 +795,11 @@ display_helper (scm *x, bool cont, char *sep, bool quote)
|
|||
if (x->type == CHAR && x->value == 10) printf ("#\\%s", "newline");
|
||||
else if (x->type == CHAR && x->value == 32) printf ("#\\%s", "space");
|
||||
else if (x->type == CHAR) printf ("#\\%c", x->value);
|
||||
else if (x->type == MACRO) {
|
||||
printf ("(*macro* ");
|
||||
display_helper (x->macro, cont, sep, quote);
|
||||
printf (")");
|
||||
}
|
||||
else if (x->type == NUMBER) printf ("%d", x->value);
|
||||
else if (x->type == PAIR) {
|
||||
if (car (x) == &symbol_circ) {
|
||||
|
|
@ -1146,25 +1108,7 @@ mes_environment ()
|
|||
{
|
||||
scm *a = &scm_nil;
|
||||
|
||||
a = add_environment (a, "*macro*", &scm_nil);
|
||||
|
||||
|
||||
#if MES_FULL
|
||||
|
||||
a = add_environment (a, "()", &scm_nil);
|
||||
a = add_environment (a, "#t", &scm_t);
|
||||
a = add_environment (a, "#f", &scm_f);
|
||||
a = add_environment (a, "*unspecified*", &scm_unspecified);
|
||||
a = add_environment (a, "lambda", &symbol_lambda);
|
||||
a = add_environment (a, "*dot*", &scm_dot);
|
||||
a = add_environment (a, "current-module", &symbol_current_module);
|
||||
|
||||
a = add_environment (a, "begin", &symbol_begin);
|
||||
a = add_environment (a, "cond", &symbol_cond);
|
||||
a = add_environment (a, "list", &symbol_list);
|
||||
|
||||
#include "environment.i"
|
||||
#endif
|
||||
|
||||
return a;
|
||||
}
|
||||
|
|
@ -1192,25 +1136,27 @@ def (scm *x)
|
|||
scm *
|
||||
define (scm *x, scm *a)
|
||||
{
|
||||
if (atom_p (cadr (x)) != &scm_f)
|
||||
return cons (cadr (x), eval (caddr (x), cons (cons (cadr (x), cadr (x)), a)));
|
||||
scm *p = pairlis (cadr (x), cadr (x), a);
|
||||
return cons (caadr (x), eval (make_lambda (cdadr (x), cddr (x)), p));
|
||||
}
|
||||
|
||||
scm *
|
||||
define_macro (scm *x, scm *a)
|
||||
{
|
||||
scm *macros = assq (&symbol_macro, a);
|
||||
scm *macro;
|
||||
if (atom_p (cadr (x)) != &scm_f)
|
||||
macro = cons (cadr (x), eval (caddr (x), cons (cons (cadr (x), cadr (x)), a)));
|
||||
scm *e;
|
||||
scm *name = cadr (x);
|
||||
if (name->type != PAIR)
|
||||
e = eval (caddr (x), cons (cons (cadr (x), cadr (x)), a));
|
||||
else {
|
||||
name = car (name);
|
||||
scm *p = pairlis (cadr (x), cadr (x), a);
|
||||
macro = cons (caadr(x), eval (make_lambda (cdadr (x), cddr (x)), p));
|
||||
e = eval (make_lambda (cdadr (x), cddr (x)), p);
|
||||
}
|
||||
set_cdr_x (macros, cons (macro, cdr (macros)));
|
||||
return a;
|
||||
if (eq_p (car (x), &symbol_define_macro) == &scm_t)
|
||||
e = make_macro (e);
|
||||
return cons (name, e);
|
||||
}
|
||||
|
||||
scm *
|
||||
lookup_macro (scm *x, scm *a)
|
||||
{
|
||||
scm *m = assq (x, a);
|
||||
if (m != &scm_f && macro_p (cdr (m)) != &scm_f)
|
||||
return cdr (m)->macro;
|
||||
return &scm_f;
|
||||
}
|
||||
|
||||
scm *
|
||||
|
|
|
|||
8
mes.test
8
mes.test
|
|
@ -1,21 +1,17 @@
|
|||
#! /bin/sh
|
||||
set -x
|
||||
#set -x
|
||||
mes=${1-./mes.scm}
|
||||
echo 0 | $mes
|
||||
echo 1 | $mes
|
||||
#echo car | $mes "((0 1))"
|
||||
echo "(car '(0 1))" | $mes
|
||||
echo "(car (quote (0 1)))" | $mes
|
||||
echo "(car '(0 1))" | $mes
|
||||
#echo cdr | $mes "((0 1))"
|
||||
echo "(cdr '(0 1))" | $mes
|
||||
#echo cons | $mes "(0 1)"
|
||||
echo "(cons 0 1)" | $mes
|
||||
#echo "(lambda (x y) (cons x y))" | $mes "(0 1)"
|
||||
echo "((lambda (x y) (cons x y)) 0 1)" | $mes
|
||||
## echo "((label fun (lambda (x) x)) 2 2)" | $mes
|
||||
echo "(< 0 0)" | $mes
|
||||
echo "(< 0 1)" | $mes
|
||||
# LISP-1.5 label dropped for now
|
||||
# echo "((label fun\
|
||||
# (lambda (x) (cons x\
|
||||
# (cond ((< 0 x) (fun (- x 1)))\
|
||||
|
|
|
|||
1
scm.mes
1
scm.mes
|
|
@ -44,7 +44,6 @@
|
|||
|
||||
(define-macro (let-loop label bindings rest)
|
||||
`((lambda (,label)
|
||||
(display "loop") (newline)
|
||||
(set! ,label (lambda ,(split-params bindings '()) ,@rest))
|
||||
(,label ,@(split-values bindings '())))
|
||||
*unspecified*))
|
||||
|
|
|
|||
142
syntax.mes
142
syntax.mes
|
|
@ -1,5 +1,4 @@
|
|||
;; -*-scheme-*-
|
||||
;;(define else #t)
|
||||
(define (syntax-error message thing)
|
||||
(display "syntax-error:")
|
||||
(display message)
|
||||
|
|
@ -9,75 +8,25 @@
|
|||
|
||||
(display "mes:define-syntax...")
|
||||
|
||||
;;(define (caddr x) (car (cdr (cdr x))))
|
||||
;; (define (caddr x)
|
||||
;; (display "wanna caddr:")
|
||||
;; (display x)
|
||||
;; (newline))
|
||||
|
||||
;; (define-macro mes:define-syntax
|
||||
;; (lambda (form expander)
|
||||
;; (expander `(define-macro ,(cadr form)
|
||||
;; (let ((transformer ,(caddr form)))
|
||||
;; (lambda (form expander)
|
||||
;; (expander (transformer form
|
||||
;; (lambda (x) x)
|
||||
;; eq?)
|
||||
;; expander))))
|
||||
;; expander)))
|
||||
|
||||
;; (define (dinges form expander)
|
||||
;; (display "dinges form:")
|
||||
;; (display form)
|
||||
;; (newline)
|
||||
;; `(define-macro BOO ;;;,(cadr form)
|
||||
;; (let ((transformer ,(caddr form)))
|
||||
;; (lambda (form expander)
|
||||
;; (expander (transformer form
|
||||
;; (lambda (x) x)
|
||||
;; eq?)
|
||||
;; expander)))))
|
||||
|
||||
;; (define-macro (mes:define-syntax form expander)
|
||||
;; `(expander (dinges form expander)
|
||||
;; expander))
|
||||
|
||||
(define-macro (mes:define-syntax macro-name transformer . stuff)
|
||||
;; (display "mes:define-syntax:")
|
||||
;; (newline)
|
||||
;; (display `(define-macro (,macro-name . args)
|
||||
;; (,transformer (cons ',macro-name args)
|
||||
;; (lambda (x) x)
|
||||
;; eq?)))
|
||||
;; (newline)
|
||||
`(define-macro (,macro-name . args)
|
||||
(,transformer (cons ',macro-name args)
|
||||
(lambda (x) x)
|
||||
eq?)
|
||||
))
|
||||
eq?)))
|
||||
|
||||
;; (define-macro (mes:define-syntax form expander)
|
||||
;; (expander `(define-macro ,(cadr form)
|
||||
;; (let ((transformer ,(caddr form)))
|
||||
;; (lambda (form expander)
|
||||
;; (expander (transformer form
|
||||
;; (lambda (x) x)
|
||||
;; eq?)
|
||||
;; expander))))
|
||||
;; expander))
|
||||
;; Rewrite-rule compiler (a.k.a. "extend-syntax")
|
||||
|
||||
;; (define-macro (mes:define-syntax form expander)
|
||||
;; (expander `(define-macro ((cadr form) form expander)
|
||||
;; (let ((transformer (caddr form)))
|
||||
;; (expander (transformer form
|
||||
;; (lambda (x) x)
|
||||
;; eq?)
|
||||
;; expander)))
|
||||
;; expander))
|
||||
;; Example:
|
||||
;;
|
||||
;; (define-syntax or
|
||||
;; (syntax-rules ()
|
||||
;; ((or) #f)
|
||||
;; ((or e) e)
|
||||
;; ((or e1 e ...) (let ((temp e1))
|
||||
;; (if temp temp (or e ...))))))
|
||||
|
||||
(newline)
|
||||
|
||||
|
||||
(display "mes:define-syntax syntax-rules...")
|
||||
(newline)
|
||||
|
||||
|
|
@ -96,9 +45,7 @@
|
|||
(memq (cadr pattern) indicators-for-zero-or-more)))
|
||||
|
||||
(define indicators-for-zero-or-more (list (string->symbol "...") '---))
|
||||
|
||||
;;(display "BOOO")
|
||||
|
||||
|
||||
(lambda (exp r c)
|
||||
|
||||
(define %input (r '%input)) ;Gensym these, if you like.
|
||||
|
|
@ -111,19 +58,16 @@
|
|||
(define subkeywords (cadr exp))
|
||||
|
||||
(define (make-transformer rules)
|
||||
;;x;;(display "make-transformer") (newline)
|
||||
`(lambda (,%input ,%rename ,%compare)
|
||||
`(lambda (,%input ,%rename ,%compare)
|
||||
(let ((,%tail (cdr ,%input)))
|
||||
;;x;;(display "TEEL:") (display ,%tail) (newline)
|
||||
(cond ,@(map process-rule rules)
|
||||
(#t ;;else
|
||||
(cond ,@(map process-rule rules)
|
||||
(else
|
||||
(syntax-error
|
||||
"use of macro doesn't match definition"
|
||||
,%input))))))
|
||||
|
||||
(define (process-rule rule)
|
||||
;;x;;(display "process-rule") (newline)
|
||||
(cond ((and (pair? rule)
|
||||
(cond ((and (pair? rule)
|
||||
(pair? (cdr rule))
|
||||
(null? (cddr rule)))
|
||||
(let ((pattern (cdar rule))
|
||||
|
|
@ -140,8 +84,7 @@
|
|||
;; Generate code to test whether input expression matches pattern
|
||||
|
||||
(define (process-match input pattern)
|
||||
;;x;;(display "process-match") (newline)
|
||||
(cond ((name? pattern)
|
||||
(cond ((name? pattern)
|
||||
(cond ((member pattern subkeywords)
|
||||
`((,%compare ,input (,%rename ',pattern))))
|
||||
(#t `())))
|
||||
|
|
@ -154,16 +97,14 @@
|
|||
,@(process-match `(cdr ,%temp) (cdr pattern))))))
|
||||
((or (null? pattern) (boolean? pattern) (char? pattern))
|
||||
`((eq? ,input ',pattern)))
|
||||
(#t ;;else
|
||||
(else
|
||||
`((equal? ,input ',pattern)))))
|
||||
|
||||
(define (process-segment-match input pattern)
|
||||
;;x;;(display "process-segment-match") (newline)
|
||||
(let ((conjuncts (process-match '(car l) pattern)))
|
||||
(cond ((null? conjuncts)
|
||||
`((list? ,input))) ;+++
|
||||
(#t `((let loop ((l ,input))
|
||||
;;x;;(display "loop") (newline)
|
||||
(or (null? l)
|
||||
(and (pair? l)
|
||||
,@conjuncts
|
||||
|
|
@ -173,44 +114,28 @@
|
|||
;; This is pretty bad, but it seems to work (can't say why).
|
||||
|
||||
(define (process-pattern pattern path mapit)
|
||||
;;x;;(display "process-pattern pattern=") (display pattern) (newline)
|
||||
(cond ((name? pattern)
|
||||
;;x;;(display "name!") (newline)
|
||||
;;x;;(display "subkeywords: ") (display subkeywords) (newline)
|
||||
(cond ((memq pattern subkeywords)
|
||||
;;;;(member pattern subkeywords)
|
||||
'())
|
||||
(#t
|
||||
;;x;;(display "hiero mapit=") (display mapit)
|
||||
;;x;;(display " path=") (display path) (newline)
|
||||
(list (list pattern (mapit path))))))
|
||||
((segment-pattern? pattern)
|
||||
;;x;;(display "segment!") (newline)
|
||||
(process-pattern (car pattern)
|
||||
%temp
|
||||
(lambda (x) ;temp is free in x
|
||||
;;x;;(display "mapit x=") (display x) (newline)
|
||||
(mapit (cond ((eq? %temp x)
|
||||
;; guile: x=%temp ==> mapit==> (cdr %tail)
|
||||
;; mes: x=%temp ==> mapit==> %temp
|
||||
;;x;;(display " x=%temp ==> mapit==> ") (display path) (newline)
|
||||
path) ;+++
|
||||
(#t
|
||||
;;x;;(display "not!")
|
||||
`(map (lambda (,%temp) ,x)
|
||||
,path)))))))
|
||||
((pair? pattern)
|
||||
;;x;;(display "pair!") (newline)
|
||||
(append (process-pattern (car pattern) `(car ,path) mapit)
|
||||
(process-pattern (cdr pattern) `(cdr ,path) mapit)))
|
||||
(#t ;;else
|
||||
;;x;;(display "else!") (newline)
|
||||
'())))
|
||||
(else '())))
|
||||
|
||||
;; Generate code to compose the output expression according to template
|
||||
|
||||
(define (process-template template rank env)
|
||||
;;x;;(display "process-template") (newline)
|
||||
(cond ((name? template)
|
||||
(let ((probe (assq template env)))
|
||||
(cond (probe
|
||||
|
|
@ -233,40 +158,37 @@
|
|||
,@vars)))))
|
||||
(cond ((null? (cddr template))
|
||||
gen) ;+++
|
||||
(#t `(append ,gen ,(process-template (cddr template)
|
||||
rank env)))))))))
|
||||
(else
|
||||
`(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))))
|
||||
(else `(quote ,template))))
|
||||
|
||||
;; Return an association list of (var . rank)
|
||||
|
||||
(define (meta-variables pattern rank vars)
|
||||
;;x;;(display "meta-variables") (newline)
|
||||
(cond ((name? pattern)
|
||||
(cond ((memq pattern subkeywords)
|
||||
vars)
|
||||
(#t (cons (cons pattern rank) vars))))
|
||||
(else (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)))
|
||||
(else vars)))
|
||||
|
||||
;; Return a list of meta-variables of given higher rank
|
||||
|
||||
(define (free-meta-variables template rank env free)
|
||||
;;x;;(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)))
|
||||
(else free)))
|
||||
((segment-template? template)
|
||||
(free-meta-variables (car template)
|
||||
rank env
|
||||
|
|
@ -277,14 +199,10 @@
|
|||
rank env
|
||||
(free-meta-variables (cdr template)
|
||||
rank env free)))
|
||||
(#t ;;else
|
||||
free)))
|
||||
(else free)))
|
||||
|
||||
c ;ignored
|
||||
|
||||
;; (display "HELLO")
|
||||
;; (newline)
|
||||
|
||||
;; Kludge for Scheme48 linker.
|
||||
;; `(cons ,(make-transformer rules)
|
||||
;; ',(find-free-names-in-syntax-rules subkeywords rules))
|
||||
|
|
@ -311,13 +229,5 @@
|
|||
(begin exp ...)))))
|
||||
|
||||
(display (mes:when #t "when:hello syntax world"))
|
||||
|
||||
;; (define-macro (when cond exp . rest)
|
||||
;; `(if ,cond
|
||||
;; (begin ,exp . ,rest)))
|
||||
|
||||
|
||||
;; (define-macro (when clause . rest)
|
||||
;; (list 'cond (list clause (list 'let '() rest))))
|
||||
(newline)
|
||||
'syntax-dun
|
||||
|
|
|
|||
Loading…
Reference in a new issue