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

mes.c: store actual environment with closures.

Browse source
This commit is contained in:
Jan Nieuwenhuizen 2016-07-22 12:23:23 +02:00
parent dbbfcb5899
commit 04f3323f10
11 changed files with 226 additions and 242 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
GNUmakefile
View file

@ -1,6 +1,6 @@
.PHONY: all check default .PHONY: all check default
CFLAGS=-std=c99 -O3 -finline-functions #CFLAGS=-std=c99 -O3 -finline-functions
#CFLAGS=-std=c99 -g CFLAGS=-std=c99 -g
default: all default: all
@ -9,7 +9,7 @@ all: mes
mes: mes.c mes.h mes: mes.c mes.h
mes.h: mes.c GNUmakefile 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 |\ grep -E '^(scm [*])*[a-z0-9_]+ \(.*\)( {|$$)' $< | grep -Ev '\(.*(char |bool |int )' | sed -e 's,^scm [*],,' | sort |\
while read f; do\ while read f; do\
fun=$$(echo $$f | sed -e 's,^scm [*],,' -e 's,{.*,,');\ fun=$$(echo $$f | sed -e 's,^scm [*],,' -e 's,{.*,,');\

1
TODO
View file

@ -5,6 +5,7 @@
** bugs ** bugs
*** c2.mes *** c2.mes
*** c4.mes *** c4.mes
*** v c5.mes
*** v c0.mes *** v c0.mes
*** v closure.mes *** v closure.mes
*** v c1.mes *** v c1.mes

16
c5.mes Normal file
View 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
View 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
View file

@ -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) (define-macro (d-s n t)
;; (display "D-S: ") ;; (display "D-S: ")
;; (display `(define-macro (,n . a) ;; (display `(define-macro (,n . a)
@ -59,9 +20,9 @@
(d-s s-r (d-s s-r
(let () (let ()
;;(define name? symbol?) (define name? symbol?)
(lambda (. n-a) (lambda (. n-a)
(define name? symbol?) ;;(define name? symbol?)
(display "YEAH:") (display "YEAH:")
(display n-a) (display n-a)
(display (name? n-a)) (display (name? n-a))

150
mes.c
View file

@ -35,6 +35,7 @@
#define DEBUG 0 #define DEBUG 0
#define XDEBUG 0 #define XDEBUG 0
#define MES_FULL 1
enum type {CHAR, NUMBER, PAIR, STRING, SYMBOL, VALUES, VECTOR, enum type {CHAR, NUMBER, PAIR, STRING, SYMBOL, VALUES, VECTOR,
FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn}; FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn};
@ -64,7 +65,7 @@ typedef struct scm_t {
}; };
} scm; } scm;
#define MES 1 #define MES_C 1
#include "mes.h" #include "mes.h"
scm *display_helper (scm*, bool, char*, bool); scm *display_helper (scm*, bool, char*, bool);
@ -81,6 +82,7 @@ scm scm_f = {SYMBOL, "#f"};
scm scm_unspecified = {SYMBOL, "*unspecified*"}; scm scm_unspecified = {SYMBOL, "*unspecified*"};
scm symbol_closure = {SYMBOL, "*lambda*"}; scm symbol_closure = {SYMBOL, "*lambda*"};
scm symbol_circ = {SYMBOL, "*circ*"};
scm symbol_lambda = {SYMBOL, "lambda"}; scm symbol_lambda = {SYMBOL, "lambda"};
scm symbol_begin = {SYMBOL, "begin"}; scm symbol_begin = {SYMBOL, "begin"};
scm symbol_list = {SYMBOL, "list"}; scm symbol_list = {SYMBOL, "list"};
@ -139,13 +141,15 @@ eq_p (scm *x, scm *y)
&& x->value == y->value) && x->value == y->value)
// FIXME: alist lookup symbols // FIXME: alist lookup symbols
|| (atom_p (x) == &scm_t || (atom_p (x) == &scm_t
&& atom_p (y) == &scm_t
&& x->type != CHAR && x->type != CHAR
&& y->type != CHAR && y->type != CHAR
&& x->type != NUMBER && x->type != NUMBER
&& y->type != NUMBER && y->type != NUMBER
&& x->type != STRING
&& y->type != STRING
&& x->type != VECTOR && x->type != VECTOR
&& y->type != VECTOR && y->type != VECTOR
&& atom_p (y) == &scm_t
&& !strcmp (x->name, y->name))) && !strcmp (x->name, y->name)))
? &scm_t : &scm_f; ? &scm_t : &scm_f;
} }
@ -259,7 +263,7 @@ scm *
apply_env (scm *fn, scm *x, scm *a) apply_env (scm *fn, scm *x, scm *a)
{ {
#if DEBUG #if DEBUG
printf ("apply_env fn="); printf ("\napply_env fn=");
display (fn); display (fn);
printf (" x="); printf (" x=");
display (x); display (x);
@ -277,13 +281,9 @@ apply_env (scm *fn, scm *x, scm *a)
else if (car (fn) == &symbol_lambda) else if (car (fn) == &symbol_lambda)
return eval (cons (&symbol_begin, cddr (fn)), pairlis (cadr (fn), x, a)); return eval (cons (&symbol_begin, cddr (fn)), pairlis (cadr (fn), x, a));
else if (car (fn) == &symbol_closure) { else if (car (fn) == &symbol_closure) {
int depth = length (a)->value - cadr (fn)->value - 1;
scm *args = caddr (fn); scm *args = caddr (fn);
scm *body = cdddr (fn); scm *body = cdddr (fn);
for (int i=0; i < depth; i++) a = a->cdr; a = cdadr (fn);
// printf ("closure+pl a=");
// display (pairlis (args, x, a));
// puts ("");
return eval (cons (&symbol_begin, body), pairlis (args, x, a)); return eval (cons (&symbol_begin, body), pairlis (args, x, a));
} }
else if ((macro = assq (car (fn), cdr (assq (&symbol_macro, a)))) != &scm_f) { else if ((macro = assq (car (fn), cdr (assq (&symbol_macro, a)))) != &scm_f) {
@ -300,7 +300,7 @@ scm *
eval (scm *e, scm *a) eval (scm *e, scm *a)
{ {
#if DEBUG #if DEBUG
printf ("eval e="); printf ("\neval e=");
display (e); display (e);
puts (""); puts ("");
#endif #endif
@ -323,16 +323,29 @@ eval (scm *e, scm *a)
return cadr (e); return cadr (e);
if (car (e) == &symbol_begin) if (car (e) == &symbol_begin)
{ {
scm *orig_a = a;
scm *body = cdr (e); scm *body = cdr (e);
if (body == &scm_nil) return &scm_nil; if (body == &scm_nil) return &scm_nil;
e = car (body); e = car (body);
body = cdr (body); body = cdr (body);
scm *r = &scm_unspecified; scm *r = &scm_unspecified;
#if DEBUG
printf ("BEGIN eval e=");
display (e);
puts ("");
#endif
// closure defines in one go // closure defines in one go
#define WHILE while
#define BREAK break
scm *defines = &scm_nil; scm *defines = &scm_nil;
scm *macros = &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) == &scm_t
|| eq_p (car (e), &symbol_define_macro) == &scm_t)) { || eq_p (car (e), &symbol_define_macro) == &scm_t)) {
if (eq_p (car (e), &symbol_define) == &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) else if (eq_p (car (e), &symbol_define_macro) == &scm_t)
macros = append2 (macros, cons (def (e), &scm_nil)); macros = append2 (macros, cons (def (e), &scm_nil));
if (body == &scm_nil) e = &scm_unspecified; if (body == &scm_nil) e = &scm_unspecified;
if (body == &scm_nil) break; if (body == &scm_nil) BREAK;
e = car (body); if (body != &scm_nil) {
body = cdr (body); e = car (body);
body = cdr (body);
}
} }
breek:;
#if XDEBUG
printf ("DEFINES: ");
display (defines);
puts ("");
printf ("MACROS: ");
display (macros);
puts ("");
#endif
scm* xmacros = cons (&symbol_macro, scm* xmacros = cons (&symbol_macro,
append2 (macros, cdr (assq (&symbol_macro, a)))); append2 (macros, cdr (assq (&symbol_macro, a))));
#if XDEBUG scm *aa = a;
printf ("MACROS+: "); if (macros != &scm_nil) aa = cons (xmacros, aa);
display (xmacros);
puts ("");
#endif
scm *aa = cons (xmacros, a);
aa = append2 (defines, aa); aa = append2 (defines, aa);
a = aa; a = aa;
while (defines != &scm_nil) { scm *names = &scm_nil;
scm *values = &scm_nil;
WHILE (defines != &scm_nil) {
scm *name = caar (defines); scm *name = caar (defines);
#if XDEBUG
printf ("name: ");
display (name);
puts ("");
#endif
scm *d = cdar (defines); scm *d = cdar (defines);
#if XDEBUG
printf ("define: ");
display (d);
puts ("");
#endif
scm *x = define (d, a); scm *x = define (d, a);
#if DEBUG
printf ("closure: ");
display (x);
puts ("");
#endif
scm *entry = assq (name, a); scm *entry = assq (name, a);
set_cdr_x (entry, cdr (x)); set_cdr_x (entry, cdr (x));
defines = cdr (defines); defines = cdr (defines);
names = cons (name, names);
values = cons (cdr (x), values);
} }
while (macros != &scm_nil) { WHILE (macros != &scm_nil) {
scm *name = caar (macros); scm *name = caar (macros);
#if XDEBUG
printf ("name: ");
display (name);
puts ("");
#endif
scm *d = cdar (macros); scm *d = cdar (macros);
#if XDEBUG
printf ("macro: ");
display (macro);
puts ("");
#endif
//scm *x = define (d, a);
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))); scm *entry = assq (name, cdr (assq (&symbol_macro, a)));
set_cdr_x (entry, cdr (x)); set_cdr_x (entry, cdr (x));
macros = cdr (macros); macros = cdr (macros);
names = cons (name, names);
values = cons (cdr (x), values);
} }
#if XDEBUG scm *foo = cons (&scm_dot, &scm_dot);
printf ("a: "); r = eval (e, cons (foo, 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);
if (body == &scm_nil) return r; if (body == &scm_nil) return r;
return eval (cons (&symbol_begin, body), a); return eval (cons (&symbol_begin, body), a);
} }
if (car (e) == &symbol_lambda) 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); return make_closure (cadr (e), cddr (e), a);
if (car (e) == &symbol_closure) if (car (e) == &symbol_closure)
return e; return e;
@ -742,6 +702,11 @@ lookup (char *x, scm *a)
// Hmmm // Hmmm
if (!strcmp (x, scm_unspecified.name)) return &scm_unspecified; if (!strcmp (x, scm_unspecified.name)) return &scm_unspecified;
if (!strcmp (x, scm_nil.name)) return &scm_nil; 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_begin.name)) return &symbol_begin;
if (!strcmp (x, symbol_cond.name)) return &symbol_cond; 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, 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 == '`') return &symbol_quasiquote;
if (*x == ',' && *(x+1) == '@') return &symbol_unquote_splicing; if (*x == ',' && *(x+1) == '@') return &symbol_unquote_splicing;
if (*x == ',') return &symbol_unquote; 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 == CHAR) printf ("#\\%c", x->value);
else if (x->type == NUMBER) printf ("%d", x->value); else if (x->type == NUMBER) printf ("%d", x->value);
else if (x->type == PAIR) { else if (x->type == PAIR) {
if (car (x) == &symbol_circ) {
printf ("(*circ* . #-1#)");
return &scm_unspecified;
}
if (car (x) == &scm_quote) { if (car (x) == &scm_quote) {
printf ("'"); printf ("'");
return display_helper (car (cdr (x)), cont, "", true); return display_helper (car (cdr (x)), cont, "", true);
@ -1171,12 +1146,16 @@ mes_environment ()
{ {
scm *a = &scm_nil; scm *a = &scm_nil;
a = add_environment (a, "*macro*", &scm_nil);
#if MES_FULL
a = add_environment (a, "()", &scm_nil); a = add_environment (a, "()", &scm_nil);
a = add_environment (a, "#t", &scm_t); a = add_environment (a, "#t", &scm_t);
a = add_environment (a, "#f", &scm_f); a = add_environment (a, "#f", &scm_f);
a = add_environment (a, "*unspecified*", &scm_unspecified); a = add_environment (a, "*unspecified*", &scm_unspecified);
a = add_environment (a, "lambda", &symbol_lambda); 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, "*dot*", &scm_dot);
a = add_environment (a, "current-module", &symbol_current_module); a = add_environment (a, "current-module", &symbol_current_module);
@ -1185,6 +1164,7 @@ mes_environment ()
a = add_environment (a, "list", &symbol_list); a = add_environment (a, "list", &symbol_list);
#include "environment.i" #include "environment.i"
#endif
return a; return a;
} }
@ -1198,7 +1178,7 @@ make_lambda (scm *args, scm *body)
scm * scm *
make_closure (scm *args, scm *body, scm *a) 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 * scm *

28
scm.mes
View file

@ -37,15 +37,22 @@
`((lambda ,(split-params bindings '()) ,@rest) `((lambda ,(split-params bindings '()) ,@rest)
,@(split-values bindings '()))) ,@(split-values bindings '())))
(define-macro (let-loop label bindings rest) (define-macro (let-loop label bindings . rest)
`(let ((,label *unspecified*)) `(let ((,label *unspecified*))
(let ((,label (lambda ,(split-params bindings '()) ,@rest))) (let ((,label (lambda ,(split-params bindings '()) ,@rest)))
(,label ,@(split-values bindings '()))))) (,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) (define-macro (let bindings-or-label . rest)
`(if ,(symbol? bindings-or-label) `(cond (,(symbol? bindings-or-label)
(let-loop ,bindings-or-label ,(car rest) ,(cdr rest)) (let-loop ,bindings-or-label ,(car rest) ,(cdr rest)))
(simple-let ,bindings-or-label ,rest))) (#t (simple-let ,bindings-or-label ,rest))))
(define-macro (or2 x y) (define-macro (or2 x y)
`(cond (,x ,x) (#t ,y))) `(cond (,x ,x) (#t ,y)))
@ -81,6 +88,8 @@
((and (pair? a) (pair? b)) ((and (pair? a) (pair? b))
(and (equal? (car a) (car b)) (and (equal? (car a) (car b))
(equal? (cdr a) (cdr b)))) (equal? (cdr a) (cdr b))))
((and (string? a) (string? b))
(eq? (string->symbol a) (string->symbol b)))
((and (vector? a) (vector? b)) ((and (vector? a) (vector? b))
(equal? (vector->list a) (vector->list b))) (equal? (vector->list a) (vector->list b)))
(#t (eq? a b)))) (#t (eq? a b))))
@ -171,7 +180,10 @@
;; (let ((value (number->string counter))) ;; (let ((value (number->string counter)))
;; (set! counter (+ counter 1)) ;; (set! counter (+ counter 1))
;; (string->symbol (string-append "g" value)))))) ;; (string->symbol (string-append "g" value))))))
(define *gensym* -1) (define gensym #f)
(define (gensym) (let ((counter 0))
(set! *gensym* (+ *gensym* 1)) (set! gensym
(string->symbol (string-append "g" (number->string *gensym*)))) (lambda (. rest)
(let ((value (number->string counter)))
(set! counter (+ counter 1))
(string->symbol (string-append "g" value))))))

127
syntax.mes
View file

@ -83,66 +83,24 @@
(mes:define-syntax syntax-rules (mes:define-syntax syntax-rules
(let () (let ()
;; syntax-rules uses defines that get closured-in (define name? symbol?)
;; mes still has a bug here; move down
;; (define name? symbol?)
;; (define (segment-pattern? pattern) (define (segment-pattern? pattern)
;; (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 (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
(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 %input (r '%input)) ;Gensym these, if you like.
(define %compare (r '%compare)) (define %compare (r '%compare))
(define %rename (r '%rename)) (define %rename (r '%rename))
@ -153,10 +111,10 @@
(define subkeywords (cadr exp)) (define subkeywords (cadr exp))
(define (make-transformer rules) (define (make-transformer rules)
(display "make-transformer") (newline) ;;x;;(display "make-transformer") (newline)
`(lambda (,%input ,%rename ,%compare) `(lambda (,%input ,%rename ,%compare)
(let ((,%tail (cdr ,%input))) (let ((,%tail (cdr ,%input)))
(display "TEEL:") (display ,%tail) (newline) ;;x;;(display "TEEL:") (display ,%tail) (newline)
(cond ,@(map process-rule rules) (cond ,@(map process-rule rules)
(#t ;;else (#t ;;else
(syntax-error (syntax-error
@ -164,30 +122,12 @@
,%input)))))) ,%input))))))
(define (process-rule rule) (define (process-rule rule)
(display "process-rule") (newline) ;;x;;(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)))
(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)) `((and ,@(process-match %tail pattern))
(let* ,(process-pattern pattern (let* ,(process-pattern pattern
%tail %tail
@ -200,7 +140,7 @@
;; 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) ;;x;;(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))))
@ -218,12 +158,12 @@
`((equal? ,input ',pattern))))) `((equal? ,input ',pattern)))))
(define (process-segment-match 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))) (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) ;;x;;(display "loop") (newline)
(or (null? l) (or (null? l)
(and (pair? l) (and (pair? l)
,@conjuncts ,@conjuncts
@ -233,45 +173,44 @@
;; 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) ;;x;;(display "process-pattern pattern=") (display pattern) (newline)
(cond ((name? pattern) (cond ((name? pattern)
(display "name!") (newline) ;;x;;(display "name!") (newline)
(display "subkeywords: ") (display subkeywords) (newline) ;;x;;(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) ;;x;;(display "hiero mapit=") (display mapit)
(display " path=") (display path) ;;x;;(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) ;;x;;(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) ;;x;;(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) ;;x;;(display " x=%temp ==> mapit==> ") (display path) (newline)
path) ;+++ path) ;+++
(#t (#t
(display "not!") ;;x;;(display "not!")
`(map (lambda (,%temp) ,x) `(map (lambda (,%temp) ,x)
,path))))))) ,path)))))))
((pair? pattern) ((pair? pattern)
(display "pair!") (newline) ;;x;;(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) ;;x;;(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) ;;x;;(display "process-template") (newline)
(cond ((name? template) (cond ((name? template)
(let ((probe (assq template env))) (let ((probe (assq template env)))
(cond (probe (cond (probe
@ -305,7 +244,7 @@
;; 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) ;;x;;(display "meta-variables") (newline)
(cond ((name? pattern) (cond ((name? pattern)
(cond ((memq pattern subkeywords) (cond ((memq pattern subkeywords)
vars) vars)
@ -321,7 +260,7 @@
;; 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) ;;x;;(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)))
@ -343,8 +282,8 @@
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)

30
test.mes
View file

@ -22,11 +22,10 @@
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
;; haha, broken. lat0r ;; haha, broken. lat0r
(define pass 0)
(define fail 0)
(define result #f) (define result #f)
(let ((pass 0) (let ((pass 0)
(fail 0)) (fail 0)
(xresult #f))
(set! result (set! result
(lambda (. t) (lambda (. t)
(cond ((null? t) (list pass fail)) (cond ((null? t) (list pass fail))
@ -200,14 +199,25 @@
0)) 0))
(pass-if "closure 5 " (pass-if "closure 5 "
(seq? (begin (seq?
(define foo (begin
(lambda () (define name? 2)
(define name? symbol?) (define (foo)
(define name? 0)
(lambda () name?))
((foo)))
0))
(pass-if "closure 6 "
(seq?
(begin
(define foo
(lambda () (lambda ()
(name? 'boo)))) (define name? symbol?)
((foo))) (lambda ()
#t)) (name? 'boo))))
((foo)))
#t))
(newline) (newline)
(display "passed: ") (display (car (result))) (newline) (display "passed: ") (display (car (result))) (newline)

13
x2.mes Normal file
View 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
View 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))