mes.c: store actual environment with closures.
This commit is contained in:
Jan Nieuwenhuizen
parent
dbbfcb5899
commit
04f3323f10
|
|
@ -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
|
||||
|
||||
|
|
@ -9,7 +9,7 @@ all: mes
|
|||
mes: mes.c mes.h
|
||||
|
||||
mes.h: mes.c GNUmakefile
|
||||
( echo '#if MES'; echo '#if MES' 1>&2;\
|
||||
( echo '#if MES_C'; echo '#if MES_FULL' 1>&2;\
|
||||
grep -E '^(scm [*])*[a-z0-9_]+ \(.*\)( {|$$)' $< | grep -Ev '\(.*(char |bool |int )' | sed -e 's,^scm [*],,' | sort |\
|
||||
while read f; do\
|
||||
fun=$$(echo $$f | sed -e 's,^scm [*],,' -e 's,{.*,,');\
|
||||
|
|
|
|||
1
TODO
1
TODO
|
|
@ -5,6 +5,7 @@
|
|||
** bugs
|
||||
*** c2.mes
|
||||
*** c4.mes
|
||||
*** v c5.mes
|
||||
*** v c0.mes
|
||||
*** v closure.mes
|
||||
*** v c1.mes
|
||||
|
|
|
|||
16
c5.mes
Normal file
16
c5.mes
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
;; guile: 00
|
||||
;; mes: segfault
|
||||
;; (display
|
||||
;; (let ((count (let ((counter 0))
|
||||
;; (lambda ()
|
||||
;; counter))))
|
||||
;; (count)))
|
||||
|
||||
(display
|
||||
((lambda (count)
|
||||
(count))
|
||||
((lambda (counter)
|
||||
(lambda ()
|
||||
counter))
|
||||
0)))
|
||||
(newline)
|
||||
40
let.mes
Normal file
40
let.mes
Normal file
|
|
@ -0,0 +1,40 @@
|
|||
(define (split-params bindings params)
|
||||
(cond ((null? bindings) params)
|
||||
(#t (split-params (cdr bindings)
|
||||
(append params (cons (caar bindings) '()))))))
|
||||
|
||||
(define (split-values bindings values)
|
||||
(cond ((null? bindings) values)
|
||||
(#t (split-values (cdr bindings)
|
||||
(append values (cdar bindings) '())))))
|
||||
|
||||
(define-macro (simple-let bindings rest)
|
||||
`((lambda ,(split-params bindings '()) ,@rest)
|
||||
,@(split-values bindings '())))
|
||||
|
||||
(define-macro (let-loop label bindings . rest)
|
||||
`(let ((,label *unspecified*))
|
||||
(let ((,label (lambda ,(split-params bindings '()) ,@rest)))
|
||||
(,label ,@(split-values bindings '())))))
|
||||
|
||||
(define-macro (let-loop label bindings rest)
|
||||
`((lambda (,label)
|
||||
(display "loop") (newline)
|
||||
(set! ,label (lambda ,(split-params bindings '()) ,@rest))
|
||||
(,label ,@(split-values bindings '())))
|
||||
*unspecified*))
|
||||
|
||||
(define-macro (let bindings-or-label . rest)
|
||||
`(cond (,(symbol? bindings-or-label)
|
||||
(let-loop ,bindings-or-label ,(car rest) ,(cdr rest)))
|
||||
(#t (simple-let ,bindings-or-label ,rest))))
|
||||
|
||||
(display (let ((a "b"))
|
||||
(display "A: ") (display a) (newline) a))
|
||||
|
||||
(display (let loop ((lst '(1 2 3)))
|
||||
(display "LOOP")
|
||||
(newline)
|
||||
(cond ((null? lst) '(dun))
|
||||
(#t (cons (car lst) (loop (cdr lst)))))))
|
||||
(newline)
|
||||
43
macro.mes
43
macro.mes
|
|
@ -1,42 +1,3 @@
|
|||
|
||||
;; (define (run x)
|
||||
;; (define (test? y) (display "testing:") (display y) (newline) (eq? x y))
|
||||
;; (test? 3)
|
||||
;; )
|
||||
|
||||
;; (display "(run 3):")
|
||||
;; (display (run 3))
|
||||
;; (newline)
|
||||
;; (display "(run 4):")
|
||||
;; (display (run 4))
|
||||
;; (newline)
|
||||
|
||||
(define (fm a)
|
||||
(define-macro (a b)
|
||||
(display b)
|
||||
(newline)
|
||||
"boo"))
|
||||
|
||||
(display "f-define-macro: ")
|
||||
(fm 'dinges)
|
||||
(a c)
|
||||
(newline)
|
||||
|
||||
|
||||
;; (define-macro (m a)
|
||||
;; `(define-macro (,a b)
|
||||
;; (display "b")
|
||||
;; (display b)
|
||||
;; (newline)))
|
||||
|
||||
;; (display "define-macro: ")
|
||||
;; (m dinges)
|
||||
;; (newline)
|
||||
;; (display "running dinges: ")
|
||||
;; (dinges c)
|
||||
;; (newline)
|
||||
|
||||
|
||||
(define-macro (d-s n t)
|
||||
;; (display "D-S: ")
|
||||
;; (display `(define-macro (,n . a)
|
||||
|
|
@ -59,9 +20,9 @@
|
|||
|
||||
(d-s s-r
|
||||
(let ()
|
||||
;;(define name? symbol?)
|
||||
(define name? symbol?)
|
||||
(lambda (. n-a)
|
||||
(define name? symbol?)
|
||||
;;(define name? symbol?)
|
||||
(display "YEAH:")
|
||||
(display n-a)
|
||||
(display (name? n-a))
|
||||
|
|
|
|||
152
mes.c
152
mes.c
|
|
@ -35,6 +35,7 @@
|
|||
|
||||
#define DEBUG 0
|
||||
#define XDEBUG 0
|
||||
#define MES_FULL 1
|
||||
|
||||
enum type {CHAR, NUMBER, PAIR, STRING, SYMBOL, VALUES, VECTOR,
|
||||
FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn};
|
||||
|
|
@ -64,7 +65,7 @@ typedef struct scm_t {
|
|||
};
|
||||
} scm;
|
||||
|
||||
#define MES 1
|
||||
#define MES_C 1
|
||||
#include "mes.h"
|
||||
|
||||
scm *display_helper (scm*, bool, char*, bool);
|
||||
|
|
@ -81,6 +82,7 @@ scm scm_f = {SYMBOL, "#f"};
|
|||
scm scm_unspecified = {SYMBOL, "*unspecified*"};
|
||||
|
||||
scm symbol_closure = {SYMBOL, "*lambda*"};
|
||||
scm symbol_circ = {SYMBOL, "*circ*"};
|
||||
scm symbol_lambda = {SYMBOL, "lambda"};
|
||||
scm symbol_begin = {SYMBOL, "begin"};
|
||||
scm symbol_list = {SYMBOL, "list"};
|
||||
|
|
@ -139,13 +141,15 @@ eq_p (scm *x, scm *y)
|
|||
&& x->value == y->value)
|
||||
// FIXME: alist lookup symbols
|
||||
|| (atom_p (x) == &scm_t
|
||||
&& atom_p (y) == &scm_t
|
||||
&& x->type != CHAR
|
||||
&& y->type != CHAR
|
||||
&& x->type != NUMBER
|
||||
&& y->type != NUMBER
|
||||
&& x->type != STRING
|
||||
&& y->type != STRING
|
||||
&& x->type != VECTOR
|
||||
&& y->type != VECTOR
|
||||
&& atom_p (y) == &scm_t
|
||||
&& !strcmp (x->name, y->name)))
|
||||
? &scm_t : &scm_f;
|
||||
}
|
||||
|
|
@ -259,7 +263,7 @@ scm *
|
|||
apply_env (scm *fn, scm *x, scm *a)
|
||||
{
|
||||
#if DEBUG
|
||||
printf ("apply_env fn=");
|
||||
printf ("\napply_env fn=");
|
||||
display (fn);
|
||||
printf (" x=");
|
||||
display (x);
|
||||
|
|
@ -277,13 +281,9 @@ apply_env (scm *fn, scm *x, scm *a)
|
|||
else if (car (fn) == &symbol_lambda)
|
||||
return eval (cons (&symbol_begin, cddr (fn)), pairlis (cadr (fn), x, a));
|
||||
else if (car (fn) == &symbol_closure) {
|
||||
int depth = length (a)->value - cadr (fn)->value - 1;
|
||||
scm *args = caddr (fn);
|
||||
scm *body = cdddr (fn);
|
||||
for (int i=0; i < depth; i++) a = a->cdr;
|
||||
// printf ("closure+pl a=");
|
||||
// display (pairlis (args, x, a));
|
||||
// puts ("");
|
||||
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) {
|
||||
|
|
@ -300,7 +300,7 @@ scm *
|
|||
eval (scm *e, scm *a)
|
||||
{
|
||||
#if DEBUG
|
||||
printf ("eval e=");
|
||||
printf ("\neval e=");
|
||||
display (e);
|
||||
puts ("");
|
||||
#endif
|
||||
|
|
@ -323,16 +323,29 @@ eval (scm *e, scm *a)
|
|||
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
|
||||
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)
|
||||
|
|
@ -340,106 +353,53 @@ eval (scm *e, scm *a)
|
|||
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;
|
||||
e = car (body);
|
||||
body = cdr (body);
|
||||
if (body == &scm_nil) BREAK;
|
||||
if (body != &scm_nil) {
|
||||
e = car (body);
|
||||
body = cdr (body);
|
||||
}
|
||||
}
|
||||
|
||||
#if XDEBUG
|
||||
printf ("DEFINES: ");
|
||||
display (defines);
|
||||
puts ("");
|
||||
|
||||
|
||||
printf ("MACROS: ");
|
||||
display (macros);
|
||||
puts ("");
|
||||
#endif
|
||||
|
||||
breek:;
|
||||
|
||||
scm* xmacros = cons (&symbol_macro,
|
||||
append2 (macros, cdr (assq (&symbol_macro, a))));
|
||||
|
||||
#if XDEBUG
|
||||
printf ("MACROS+: ");
|
||||
display (xmacros);
|
||||
puts ("");
|
||||
#endif
|
||||
scm *aa = cons (xmacros, a);
|
||||
scm *aa = a;
|
||||
if (macros != &scm_nil) aa = cons (xmacros, aa);
|
||||
aa = append2 (defines, aa);
|
||||
a = aa;
|
||||
while (defines != &scm_nil) {
|
||||
scm *names = &scm_nil;
|
||||
scm *values = &scm_nil;
|
||||
WHILE (defines != &scm_nil) {
|
||||
scm *name = caar (defines);
|
||||
#if XDEBUG
|
||||
printf ("name: ");
|
||||
display (name);
|
||||
puts ("");
|
||||
#endif
|
||||
scm *d = cdar (defines);
|
||||
#if XDEBUG
|
||||
printf ("define: ");
|
||||
display (d);
|
||||
puts ("");
|
||||
#endif
|
||||
scm *x = define (d, a);
|
||||
|
||||
#if DEBUG
|
||||
printf ("closure: ");
|
||||
display (x);
|
||||
puts ("");
|
||||
#endif
|
||||
scm *entry = assq (name, a);
|
||||
set_cdr_x (entry, cdr (x));
|
||||
defines = cdr (defines);
|
||||
|
||||
names = cons (name, names);
|
||||
values = cons (cdr (x), values);
|
||||
}
|
||||
|
||||
while (macros != &scm_nil) {
|
||||
WHILE (macros != &scm_nil) {
|
||||
scm *name = caar (macros);
|
||||
#if XDEBUG
|
||||
printf ("name: ");
|
||||
display (name);
|
||||
puts ("");
|
||||
#endif
|
||||
scm *d = cdar (macros);
|
||||
#if XDEBUG
|
||||
printf ("macro: ");
|
||||
display (macro);
|
||||
puts ("");
|
||||
#endif
|
||||
//scm *x = define (d, a);
|
||||
scm *x = define (d, a);
|
||||
#if DEBUG
|
||||
printf ("mcclosure: ");
|
||||
display (x);
|
||||
puts ("");
|
||||
#endif
|
||||
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);
|
||||
}
|
||||
|
||||
#if XDEBUG
|
||||
printf ("a: ");
|
||||
display (a);
|
||||
puts ("");
|
||||
|
||||
printf ("E: ");
|
||||
display (e);
|
||||
puts ("");
|
||||
#endif
|
||||
|
||||
// if (e->type == PAIR && eq_p (car (e), &symbol_define) == &scm_t)
|
||||
// a = cons (define (e, a), a);
|
||||
// else if (e->type == PAIR && eq_p (car (e), &symbol_define_macro) == &scm_t)
|
||||
// a = cons (define_macro (e, a), a);
|
||||
//else
|
||||
if (e->type == PAIR && car (e) == &symbol_set_x)
|
||||
r = set_env_x (cadr (e), eval (caddr (e), a), a);
|
||||
else r = eval (e, a);
|
||||
scm *foo = cons (&scm_dot, &scm_dot);
|
||||
r = eval (e, cons (foo, a));
|
||||
if (body == &scm_nil) return r;
|
||||
return eval (cons (&symbol_begin, body), a);
|
||||
}
|
||||
if (car (e) == &symbol_lambda)
|
||||
//return make_closure (cadr (e), cddr (e), pairlis (cadr (e), cadr (e), a));
|
||||
return make_closure (cadr (e), cddr (e), a);
|
||||
if (car (e) == &symbol_closure)
|
||||
return e;
|
||||
|
|
@ -742,6 +702,11 @@ lookup (char *x, scm *a)
|
|||
// 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, symbol_begin.name)) return &symbol_begin;
|
||||
if (!strcmp (x, symbol_cond.name)) return &symbol_cond;
|
||||
|
|
@ -751,6 +716,12 @@ lookup (char *x, scm *a)
|
|||
if (!strcmp (x, symbol_quote.name)) return &symbol_quote;
|
||||
|
||||
|
||||
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_quasiquote;
|
||||
if (*x == ',' && *(x+1) == '@') return &symbol_unquote_splicing;
|
||||
if (*x == ',') return &symbol_unquote;
|
||||
|
|
@ -869,6 +840,10 @@ display_helper (scm *x, bool cont, char *sep, bool quote)
|
|||
else if (x->type == CHAR) printf ("#\\%c", x->value);
|
||||
else if (x->type == NUMBER) printf ("%d", x->value);
|
||||
else if (x->type == PAIR) {
|
||||
if (car (x) == &symbol_circ) {
|
||||
printf ("(*circ* . #-1#)");
|
||||
return &scm_unspecified;
|
||||
}
|
||||
if (car (x) == &scm_quote) {
|
||||
printf ("'");
|
||||
return display_helper (car (cdr (x)), cont, "", true);
|
||||
|
|
@ -1171,12 +1146,16 @@ 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, "*macro*", &scm_nil);
|
||||
a = add_environment (a, "*dot*", &scm_dot);
|
||||
a = add_environment (a, "current-module", &symbol_current_module);
|
||||
|
||||
|
|
@ -1185,6 +1164,7 @@ mes_environment ()
|
|||
a = add_environment (a, "list", &symbol_list);
|
||||
|
||||
#include "environment.i"
|
||||
#endif
|
||||
|
||||
return a;
|
||||
}
|
||||
|
|
@ -1198,7 +1178,7 @@ make_lambda (scm *args, scm *body)
|
|||
scm *
|
||||
make_closure (scm *args, scm *body, scm *a)
|
||||
{
|
||||
return cons (&symbol_closure, cons (length (a), cons (args, body)));
|
||||
return cons (&symbol_closure, cons (cons (&symbol_circ, cdr (a)), cons (args, body)));
|
||||
}
|
||||
|
||||
scm *
|
||||
|
|
|
|||
28
scm.mes
28
scm.mes
|
|
@ -37,15 +37,22 @@
|
|||
`((lambda ,(split-params bindings '()) ,@rest)
|
||||
,@(split-values bindings '())))
|
||||
|
||||
(define-macro (let-loop label bindings rest)
|
||||
(define-macro (let-loop label bindings . rest)
|
||||
`(let ((,label *unspecified*))
|
||||
(let ((,label (lambda ,(split-params bindings '()) ,@rest)))
|
||||
(,label ,@(split-values bindings '())))))
|
||||
|
||||
(define-macro (let-loop label bindings rest)
|
||||
`((lambda (,label)
|
||||
(display "loop") (newline)
|
||||
(set! ,label (lambda ,(split-params bindings '()) ,@rest))
|
||||
(,label ,@(split-values bindings '())))
|
||||
*unspecified*))
|
||||
|
||||
(define-macro (let bindings-or-label . rest)
|
||||
`(if ,(symbol? bindings-or-label)
|
||||
(let-loop ,bindings-or-label ,(car rest) ,(cdr rest))
|
||||
(simple-let ,bindings-or-label ,rest)))
|
||||
`(cond (,(symbol? bindings-or-label)
|
||||
(let-loop ,bindings-or-label ,(car rest) ,(cdr rest)))
|
||||
(#t (simple-let ,bindings-or-label ,rest))))
|
||||
|
||||
(define-macro (or2 x y)
|
||||
`(cond (,x ,x) (#t ,y)))
|
||||
|
|
@ -81,6 +88,8 @@
|
|||
((and (pair? a) (pair? b))
|
||||
(and (equal? (car a) (car b))
|
||||
(equal? (cdr a) (cdr b))))
|
||||
((and (string? a) (string? b))
|
||||
(eq? (string->symbol a) (string->symbol b)))
|
||||
((and (vector? a) (vector? b))
|
||||
(equal? (vector->list a) (vector->list b)))
|
||||
(#t (eq? a b))))
|
||||
|
|
@ -171,7 +180,10 @@
|
|||
;; (let ((value (number->string counter)))
|
||||
;; (set! counter (+ counter 1))
|
||||
;; (string->symbol (string-append "g" value))))))
|
||||
(define *gensym* -1)
|
||||
(define (gensym)
|
||||
(set! *gensym* (+ *gensym* 1))
|
||||
(string->symbol (string-append "g" (number->string *gensym*))))
|
||||
(define gensym #f)
|
||||
(let ((counter 0))
|
||||
(set! gensym
|
||||
(lambda (. rest)
|
||||
(let ((value (number->string counter)))
|
||||
(set! counter (+ counter 1))
|
||||
(string->symbol (string-append "g" value))))))
|
||||
|
|
|
|||
127
syntax.mes
127
syntax.mes
|
|
@ -83,66 +83,24 @@
|
|||
|
||||
(mes:define-syntax syntax-rules
|
||||
(let ()
|
||||
;; syntax-rules uses defines that get closured-in
|
||||
;; mes still has a bug here; move down
|
||||
;; (define name? symbol?)
|
||||
(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)
|
||||
|
||||
;; 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 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)
|
||||
))
|
||||
|
||||
;; end FIXME
|
||||
|
||||
|
||||
(define %input (r '%input)) ;Gensym these, if you like.
|
||||
(define %compare (r '%compare))
|
||||
(define %rename (r '%rename))
|
||||
|
|
@ -153,10 +111,10 @@
|
|||
(define subkeywords (cadr exp))
|
||||
|
||||
(define (make-transformer rules)
|
||||
(display "make-transformer") (newline)
|
||||
;;x;;(display "make-transformer") (newline)
|
||||
`(lambda (,%input ,%rename ,%compare)
|
||||
(let ((,%tail (cdr ,%input)))
|
||||
(display "TEEL:") (display ,%tail) (newline)
|
||||
;;x;;(display "TEEL:") (display ,%tail) (newline)
|
||||
(cond ,@(map process-rule rules)
|
||||
(#t ;;else
|
||||
(syntax-error
|
||||
|
|
@ -164,30 +122,12 @@
|
|||
,%input))))))
|
||||
|
||||
(define (process-rule rule)
|
||||
(display "process-rule") (newline)
|
||||
;;x;;(display "process-rule") (newline)
|
||||
(cond ((and (pair? rule)
|
||||
(pair? (cdr rule))
|
||||
(null? (cddr rule)))
|
||||
(let ((pattern (cdar rule))
|
||||
(template (cadr rule)))
|
||||
(let ((xx `,(process-pattern pattern
|
||||
%tail
|
||||
(lambda (x) x)))
|
||||
(tt `,%tail)
|
||||
(yy (process-match %tail pattern)))
|
||||
(display "METS>>>") (newline)
|
||||
(display yy)
|
||||
(newline)
|
||||
(display "TEEL>>>") (newline)
|
||||
(display tt)
|
||||
(newline)
|
||||
(display "<<<METS") (newline)
|
||||
(display "PETTERN>>>") (newline)
|
||||
(display xx)
|
||||
(newline)
|
||||
(display "<<<PETTERN") (newline)
|
||||
)
|
||||
|
||||
`((and ,@(process-match %tail pattern))
|
||||
(let* ,(process-pattern pattern
|
||||
%tail
|
||||
|
|
@ -200,7 +140,7 @@
|
|||
;; Generate code to test whether input expression matches pattern
|
||||
|
||||
(define (process-match input pattern)
|
||||
(display "process-match") (newline)
|
||||
;;x;;(display "process-match") (newline)
|
||||
(cond ((name? pattern)
|
||||
(cond ((member pattern subkeywords)
|
||||
`((,%compare ,input (,%rename ',pattern))))
|
||||
|
|
@ -218,12 +158,12 @@
|
|||
`((equal? ,input ',pattern)))))
|
||||
|
||||
(define (process-segment-match input pattern)
|
||||
(display "process-segment-match") (newline)
|
||||
;;x;;(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)
|
||||
;;x;;(display "loop") (newline)
|
||||
(or (null? l)
|
||||
(and (pair? l)
|
||||
,@conjuncts
|
||||
|
|
@ -233,45 +173,44 @@
|
|||
;; 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)
|
||||
;;x;;(display "process-pattern pattern=") (display pattern) (newline)
|
||||
(cond ((name? pattern)
|
||||
(display "name!") (newline)
|
||||
(display "subkeywords: ") (display subkeywords) (newline)
|
||||
;;x;;(display "name!") (newline)
|
||||
;;x;;(display "subkeywords: ") (display subkeywords) (newline)
|
||||
(cond ((memq pattern subkeywords)
|
||||
;;;;(member pattern subkeywords)
|
||||
'())
|
||||
(#t
|
||||
(display "hiero mapit=") (display mapit)
|
||||
(display " path=") (display path)
|
||||
(newline)
|
||||
;;x;;(display "hiero mapit=") (display mapit)
|
||||
;;x;;(display " path=") (display path) (newline)
|
||||
(list (list pattern (mapit path))))))
|
||||
((segment-pattern? pattern)
|
||||
(display "segment!") (newline)
|
||||
;;x;;(display "segment!") (newline)
|
||||
(process-pattern (car pattern)
|
||||
%temp
|
||||
(lambda (x) ;temp is free in x
|
||||
(display "mapit x=") (display x) (newline)
|
||||
;;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)
|
||||
;;x;;(display " x=%temp ==> mapit==> ") (display path) (newline)
|
||||
path) ;+++
|
||||
(#t
|
||||
(display "not!")
|
||||
;;x;;(display "not!")
|
||||
`(map (lambda (,%temp) ,x)
|
||||
,path)))))))
|
||||
((pair? pattern)
|
||||
(display "pair!") (newline)
|
||||
;;x;;(display "pair!") (newline)
|
||||
(append (process-pattern (car pattern) `(car ,path) mapit)
|
||||
(process-pattern (cdr pattern) `(cdr ,path) mapit)))
|
||||
(#t ;;else
|
||||
(display "else!") (newline)
|
||||
;;x;;(display "else!") (newline)
|
||||
'())))
|
||||
|
||||
;; Generate code to compose the output expression according to template
|
||||
|
||||
(define (process-template template rank env)
|
||||
(display "process-template") (newline)
|
||||
;;x;;(display "process-template") (newline)
|
||||
(cond ((name? template)
|
||||
(let ((probe (assq template env)))
|
||||
(cond (probe
|
||||
|
|
@ -305,7 +244,7 @@
|
|||
;; Return an association list of (var . rank)
|
||||
|
||||
(define (meta-variables pattern rank vars)
|
||||
(display "meta-variables") (newline)
|
||||
;;x;;(display "meta-variables") (newline)
|
||||
(cond ((name? pattern)
|
||||
(cond ((memq pattern subkeywords)
|
||||
vars)
|
||||
|
|
@ -321,7 +260,7 @@
|
|||
;; Return a list of meta-variables of given higher rank
|
||||
|
||||
(define (free-meta-variables template rank env free)
|
||||
(display "free-meta-variables") (newline)
|
||||
;;x;;(display "free-meta-variables") (newline)
|
||||
(cond ((name? template)
|
||||
(cond ((and (not (memq template free))
|
||||
(let ((probe (assq template env)))
|
||||
|
|
@ -343,8 +282,8 @@
|
|||
|
||||
c ;ignored
|
||||
|
||||
(display "HELLO")
|
||||
(newline)
|
||||
;; (display "HELLO")
|
||||
;; (newline)
|
||||
|
||||
;; Kludge for Scheme48 linker.
|
||||
;; `(cons ,(make-transformer rules)
|
||||
|
|
|
|||
30
test.mes
30
test.mes
|
|
@ -22,11 +22,10 @@
|
|||
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
|
||||
|
||||
;; haha, broken. lat0r
|
||||
(define pass 0)
|
||||
(define fail 0)
|
||||
(define result #f)
|
||||
(let ((pass 0)
|
||||
(fail 0))
|
||||
(fail 0)
|
||||
(xresult #f))
|
||||
(set! result
|
||||
(lambda (. t)
|
||||
(cond ((null? t) (list pass fail))
|
||||
|
|
@ -200,14 +199,25 @@
|
|||
0))
|
||||
|
||||
(pass-if "closure 5 "
|
||||
(seq? (begin
|
||||
(define foo
|
||||
(lambda ()
|
||||
(define name? symbol?)
|
||||
(seq?
|
||||
(begin
|
||||
(define name? 2)
|
||||
(define (foo)
|
||||
(define name? 0)
|
||||
(lambda () name?))
|
||||
((foo)))
|
||||
0))
|
||||
|
||||
(pass-if "closure 6 "
|
||||
(seq?
|
||||
(begin
|
||||
(define foo
|
||||
(lambda ()
|
||||
(name? 'boo))))
|
||||
((foo)))
|
||||
#t))
|
||||
(define name? symbol?)
|
||||
(lambda ()
|
||||
(name? 'boo))))
|
||||
((foo)))
|
||||
#t))
|
||||
|
||||
(newline)
|
||||
(display "passed: ") (display (car (result))) (newline)
|
||||
|
|
|
|||
13
x2.mes
Normal file
13
x2.mes
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
|
||||
(define foo
|
||||
(lambda ()
|
||||
(define name? symbol?)
|
||||
(lambda ()
|
||||
(display "boo: ")
|
||||
(display (name? 'boo))
|
||||
(newline))))
|
||||
|
||||
;;; ((foo)) ==>
|
||||
;;; (lambda () (display boo: ) (display (name? (quote boo))) (newline))
|
||||
;;; apply_env fn=(*lambda* 97 () (display boo: ) (display (name? (quote boo))) (newline)) x=()
|
||||
((foo))
|
||||
12
x3.mes
Normal file
12
x3.mes
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
(define name? 2)
|
||||
(define (foo)
|
||||
(define name? 0)
|
||||
(lambda ()
|
||||
name?))
|
||||
|
||||
;;; ((foo)) ==>
|
||||
;;; (lambda () (display boo: ) (display (name? (quote boo))) (newline))
|
||||
;;; apply_env fn=(*lambda* 97 () (display boo: ) (display (name? (quote boo))) (newline)) x=()
|
||||
(display ((foo)))
|
||||
;;(display (foo))
|
||||
|
||||
Loading…
Reference in a new issue