mes.c: store actual environment with closures.

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

View File

@ -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
View File

@ -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
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)

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)
;; (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
View File

@ -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
View File

@ -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))))))

View File

@ -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)

View File

@ -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
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))