From 24be64787b4eb9f084283cec99b4ff029bc5c0c3 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 19 Jul 2016 21:37:39 +0200 Subject: [PATCH] mes.c: store enviroment depth in closures. Fixes c1, c3 and more. --- TODO | 5 +- c1.mes | 35 +++++++- c2.mes | 32 +++++++ c3.mes | 13 +++ c4.mes | 11 +++ macro.mes | 22 ++--- mes.c | 254 +++++++++++++++++++++++++++++++----------------------- mes.test | 14 +-- scm.mes | 115 ++++++++++++------------ test.mes | 8 ++ 10 files changed, 322 insertions(+), 187 deletions(-) create mode 100644 c2.mes create mode 100644 c3.mes create mode 100644 c4.mes diff --git a/TODO b/TODO index 7d0c7c7a..fba09e0b 100644 --- a/TODO +++ b/TODO @@ -3,9 +3,12 @@ ** syntax.mes ** or psyntax.pp ** bugs +*** c2.mes +*** c4.mes *** v c0.mes *** v closure.mes -*** c1.mes +*** 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: --- diff --git a/c1.mes b/c1.mes index 8f3de4a7..e5cf0123 100644 --- a/c1.mes +++ b/c1.mes @@ -1,13 +1,42 @@ -;; guile: 00 -;; mes: 01 +;; guile: 10 +;; (0 0) +;; mes: 10 +;; (0 2) (define (x) (define b 1) (define (y) b) + + (display b) (set! b 0) + (display b) + (newline) + (list b - (let ((b 2)) + (let ((b 2)) ;; b shadows previous b in mes + (y)))) ;; guile: y captures shadowed b, mes: y runs in context new b + +(display (x)) +(newline) +"" + +;; guile: 10 +;; (0 3) +;; mes: 10 +;; (0 3) +(define (x) + (define b 1) + (define (y) b) ;; var b is captured + + (display b) + (set! b 0) + (display b) + (newline) + + (list b + (let ((d 4)) + (set! b 3) ;; value b is changed (y)))) (display (x)) diff --git a/c2.mes b/c2.mes new file mode 100644 index 00000000..ee9f374b --- /dev/null +++ b/c2.mes @@ -0,0 +1,32 @@ +;; guile +#! +;;; compiling /home/janneke/src/mes/c2.mes +joepie-complie +;;; compiled /home/janneke/.cache/guile/ccache/2.2-LE-8-3.7/home/janneke/src/mes/c2.mes.go +joepie +jippie +!# + +;;mes + + +(define-macro (bla naam de-lambda) + `(define-macro (,naam . rest) + (,de-lambda))) + +(bla joepie + (let () + (lambda () + (list 'begin + (list 'display "joepie") + (list 'newline) + (and + (display "joepie-complie") + (newline) + "jippie"))))) + +(display "compiled") +(newline) +(display (joepie 'x)) +(newline) + diff --git a/c3.mes b/c3.mes new file mode 100644 index 00000000..0c1d8afb --- /dev/null +++ b/c3.mes @@ -0,0 +1,13 @@ +;; guile: 01 +;; mes: 00 +(define free 0) + +(define bla #f) +(let () + (set! bla (lambda () free)) + #t) + +(display (bla)) +(set! free 1) +(display (bla)) +(newline) diff --git a/c4.mes b/c4.mes new file mode 100644 index 00000000..c77dd210 --- /dev/null +++ b/c4.mes @@ -0,0 +1,11 @@ +;; guile: g0 +;; mes: crash +(define gensym + (let ((counter 0)) + (lambda (. rest) + (let ((value (number->string counter))) + (set! counter (+ counter 1)) + (string->symbol (string-append "g" value)))))) + +(display (gensym)) +(newline) diff --git a/macro.mes b/macro.mes index 309f3e67..e172c070 100644 --- a/macro.mes +++ b/macro.mes @@ -11,16 +11,16 @@ ;; (display (run 4)) ;; (newline) -;; (define (fm a) -;; (define-macro (a b) -;; (display b) -;; (newline) -;; "boo")) +(define (fm a) + (define-macro (a b) + (display b) + (newline) + "boo")) -;; (display "f-define-macro: ") -;; (fm 'dinges) -;; (a c) -;; (newline) +(display "f-define-macro: ") +(fm 'dinges) +(a c) +(newline) ;; (define-macro (m a) @@ -59,9 +59,9 @@ (d-s s-r (let () - (define name? symbol?) + ;;(define name? symbol?) (lambda (. n-a) - + (define name? symbol?) (display "YEAH:") (display n-a) (display (name? n-a)) diff --git a/mes.c b/mes.c index d59bb67d..09b6f038 100644 --- a/mes.c +++ b/mes.c @@ -34,6 +34,7 @@ #include #define DEBUG 0 +#define XDEBUG 0 enum type {CHAR, NUMBER, PAIR, STRING, SYMBOL, VALUES, VECTOR, FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn}; @@ -79,6 +80,7 @@ scm scm_t = {SYMBOL, "#t"}; scm scm_f = {SYMBOL, "#f"}; scm scm_unspecified = {SYMBOL, "*unspecified*"}; +scm symbol_closure = {SYMBOL, "*lambda*"}; scm symbol_lambda = {SYMBOL, "lambda"}; scm symbol_begin = {SYMBOL, "begin"}; scm symbol_list = {SYMBOL, "list"}; @@ -266,21 +268,32 @@ apply_env (scm *fn, scm *x, scm *a) scm *macro; if (atom_p (fn) != &scm_f) { - if (fn == &symbol_current_module) // FIXME - return a; + if (fn == &symbol_current_module) return a; if (eq_p (fn, &symbol_call_with_values) == &scm_t) return call (&scm_call_with_values_env, append2 (x, cons (a, &scm_nil))); if (builtin_p (fn) == &scm_t) return call (fn, x); scm *efn = eval (fn, a); - if (efn == &scm_unspecified) assert (!"apply unspecified"); - // FIXME: closure.scm is calling: (3 2 1) - if (efn->type == NUMBER) return cons (efn, x); - if (efn->type == NUMBER) assert (!"apply number"); + if (efn->type == NUMBER || efn == &scm_f || efn == &scm_t) assert (!"apply bool"); return apply_env (efn, x, 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 (""); + 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); + scm *e = eval (r, a); + return apply_env (e, x, a); + } return &scm_unspecified; } @@ -292,6 +305,7 @@ eval (scm *e, scm *a) display (e); puts (""); #endif + scm *macro; if (e->type == SYMBOL) { scm *y = assq (e, a); if (y == &scm_f) { @@ -305,7 +319,7 @@ eval (scm *e, scm *a) return e; else if (atom_p (car (e)) == &scm_t) { - scm *macro; + //scm *macro; if (car (e) == &symbol_quote) return cadr (e); if (car (e) == &symbol_begin) @@ -315,17 +329,121 @@ eval (scm *e, scm *a) e = car (body); body = cdr (body); scm *r = &scm_unspecified; - 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); + + // closure defines in one go + 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) + 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; + e = car (body); + body = cdr (body); + } + +#if XDEBUG + printf ("DEFINES: "); + display (defines); + puts (""); + + + printf ("MACROS: "); + display (macros); + puts (""); +#endif + + 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); + aa = append2 (defines, aa); + a = aa; + 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); + } + + 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); + } + +#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); if (body == &scm_nil) return r; return eval (cons (&symbol_begin, body), a); } - if (car (e) == &symbol_lambda) { - return make_lambda (cadr (e), closure_body (cddr (e), pairlis (cadr (e), cadr (e), 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; if (car (e) == &symbol_unquote) return eval (cadr (e), a); if (car (e) == &symbol_quasiquote) @@ -342,67 +460,6 @@ eval (scm *e, scm *a) return apply_env (car (e), evlis (cdr (e), a), a); } -// FIXME: add values to closures. what is this step called, and when -// should it be run: read/eval/apply? -scm * -closure_body (scm *body, scm *a) -{ - if (body == &scm_nil) return &scm_nil; - scm *e = car (body); -#if DEBUG - printf ("\nclosure_body e="); - display (e); - puts (""); -#endif - if (e->type == PAIR) { - if (eq_p (car (e), &symbol_lambda) == &scm_t) { - scm *p = pairlis (cadr (e), cadr (e), a); - return cons (make_lambda (cadr (e), cddr (e)), closure_body (cdr (body), p)); - } - - if (eq_p (car (e), &scm_quote) == &scm_t - || eq_p (car (e), &scm_quasiquote) == &scm_t - || eq_p (car (e), &scm_unquote) == &scm_t - || eq_p (car (e), &scm_unquote_splicing) == &scm_t) { - bool have_unquote = assq (&scm_unquote, a) != &scm_f; - scm *x = e; - if (!have_unquote && eq_p (car (e), &scm_quote) == &scm_t) - ; - else if (!have_unquote && eq_p (car (e), &scm_quasiquote) == &scm_t) - a = add_unquoters (a); - else - x = cons (car (x), closure_body (cdr (x), a)); - return cons (x, closure_body (cdr (body), a)); - } - if (eq_p (car (e), &symbol_define) == &scm_t - || eq_p (car (e), &symbol_define_macro) == &scm_t - || eq_p (car (e), &symbol_set_x) == &scm_t) { - if (cadr (e)->type == PAIR && cadr (e) == &scm_nil) { - scm *p = pairlis (cdadr (e), cdadr (e), cons (cons (caar (e), caar (e)), a)); - return cons (cons (car (e), cons (cadr (e), closure_body (cddr (e), p))), cdr (body)); - } - if (eq_p (car (e), &symbol_set_x) == &scm_t) - return cons (e, closure_body (cdr (body), a)); - return cons (e, closure_body (cdr (body), a)); - } - } - if (builtin_p (e) == &scm_t) - return cons (e, closure_body (cdr (body), a)); - else if (atom_p (e) == &scm_t) { - if (symbol_p (e) == &scm_t - && macro_p (e, a) != &scm_t) - { - scm *s = assq (e, a); - if (s == &scm_f) fprintf (stderr, "warning: %s possibly undefined symbol\n", e->name); - else if (eq_p (s->cdr, &scm_unspecified) == &scm_t) - ; // FIXME: letrec bindings use *unspecified* ... - else e = cdr (s); - } - return cons (e, closure_body (cdr (body), a)); - } - return cons (closure_body (e, a), closure_body (cdr (body), a)); -} - scm * evcon (scm *c, scm *a) { @@ -635,14 +692,6 @@ builtin_list (scm *x/*...*/) return x; } -#if 0 -scm * -vector (scm *x/*...*/) // int -{ - return list_to_vector (x); -} -#endif - scm * values (scm *x/*...*/) { @@ -697,6 +746,7 @@ lookup (char *x, scm *a) 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_lambda.name)) return &symbol_lambda; if (!strcmp (x, symbol_set_x.name)) return &symbol_set_x; if (!strcmp (x, symbol_quote.name)) return &symbol_quote; @@ -803,21 +853,6 @@ vector_to_list (scm *v) return x; } -scm * -builtin_lookup (scm *l, scm *a) -{ - return lookup (list2str (l), a); -} - -scm * -cossa (scm *x, scm *a) -{ - if (a == &scm_nil) return &scm_f; - if (eq_p (cdar (a), x) == &scm_t) - return car (a); - return cossa (x, cdr (a)); -} - scm * newline () { @@ -870,7 +905,6 @@ display_helper (scm *x, bool cont, char *sep, bool quote) else if (atom_p (x) == &scm_t) printf ("%s", x->name); return &scm_unspecified; - return x; // FIXME: eval helper for macros } // READ @@ -1028,15 +1062,7 @@ readlist (scm *a) scm * readenv (scm *a) { -#if DEBUG - scm *e = readword (getchar (), 0, a); - printf ("readenv: "); - display (e); - puts (""); - return e; -#else return readword (getchar (), 0, a); -#endif } scm * @@ -1170,6 +1196,20 @@ make_lambda (scm *args, scm *body) return cons (&symbol_lambda, cons (args, body)); } +scm * +make_closure (scm *args, scm *body, scm *a) +{ + return cons (&symbol_closure, cons (length (a), cons (args, body))); +} + +scm * +def (scm *x) +{ + if (atom_p (cadr (x)) != &scm_f) + return cons (cadr (x), x); + return cons (caadr (x), x); +} + scm * define (scm *x, scm *a) { diff --git a/mes.test b/mes.test index 66aae83d..a53349a5 100755 --- a/mes.test +++ b/mes.test @@ -1,4 +1,5 @@ #! /bin/sh +set -x mes=${1-./mes.scm} echo 0 | $mes echo 1 | $mes @@ -12,15 +13,14 @@ echo "(cdr '(0 1))" | $mes 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 "((label fun (lambda (x) x)) 2 2)" | $mes echo "(< 0 0)" | $mes echo "(< 0 1)" | $mes -echo "((label fun\ - (lambda (x) (cons x\ - (cond ((< 0 x) (fun (- x 1)))\ - (#t '())))))\ - 3)" | $mes +# echo "((label fun\ +# (lambda (x) (cons x\ +# (cond ((< 0 x) (fun (- x 1)))\ +# (#t '())))))\ +# 3)" | $mes echo "'(0 . 1)" | $mes echo "(cdr '(0 . 1))" | $mes -todo:oops echo "(define (list . rest) rest)" | $mes diff --git a/scm.mes b/scm.mes index 7b092bb7..2f979824 100755 --- a/scm.mes +++ b/scm.mes @@ -23,59 +23,6 @@ (define (list . rest) rest) -(define (equal? a b) ;; FIXME: only 2 arg - (cond ((and (null? a) (null? b)) #t) - ((and (pair? a) (pair? b)) - (and (equal? (car a) (car b)) - (equal? (cdr a) (cdr b)))) - ((and (vector? a) (vector? b)) - (equal? (vector->list a) (vector->list b))) - (#t (eq? a b)))) - -(define (vector . rest) (list->vector rest)) - -(define (apply f args) - (eval (cons f args) (current-module))) - -(define (defined? x) - (assq x (current-module))) - -(define (procedure? p) - (cond ((builtin? p) #t) - ((pair? p) (eq? (car p) 'lambda)) - (#t #f))) - -(define assv assq) -(define (memq x lst) - (cond ((null? lst) #f) - ((eq? x (car lst)) lst) - (#t (memq x (cdr lst))))) -(define memv memq) - -(define (member x lst) - (cond ((null? lst) #f) - ((equal? x (car lst)) lst) - (#t (member x (cdr lst))))) - -(define-macro (or2 x y) - `(cond (,x ,x) (#t ,y))) - -(define-macro (and2 x y) - `(cond (,x ,y) (#t #f))) - -(define-macro (or . x) - (cond - ((null? x) #f) - ((null? (cdr x)) (car x)) - (#t `(cond (,(car x)) - (#t (or ,@(cdr x))))))) - -(define-macro (and . x) - (cond ((null? x) #t) - ((null? (cdr x)) (car x)) - (#t `(cond (,(car x) (and ,@(cdr x))) - (#t #f))))) - (define (split-params bindings params) (cond ((null? bindings) params) (#t (split-params (cdr bindings) @@ -100,6 +47,25 @@ (let-loop ,bindings-or-label ,(car rest) ,(cdr rest)) (simple-let ,bindings-or-label ,rest))) +(define-macro (or2 x y) + `(cond (,x ,x) (#t ,y))) + +(define-macro (and2 x y) + `(cond (,x ,y) (#t #f))) + +(define-macro (or . x) + (cond + ((null? x) #f) + ((null? (cdr x)) (car x)) + (#t `(cond (,(car x)) + (#t (or ,@(cdr x))))))) + +(define-macro (and . x) + (cond ((null? x) #t) + ((null? (cdr x)) (car x)) + (#t `(cond (,(car x) (and ,@(cdr x))) + (#t #f))))) + (define (expand-let* bindings body) (cond ((null? bindings) `((lambda () ,@body))) @@ -110,6 +76,41 @@ (define-macro (let* bindings . body) (expand-let* bindings body)) +(define (equal? a b) ;; FIXME: only 2 arg + (cond ((and (null? a) (null? b)) #t) + ((and (pair? a) (pair? b)) + (and (equal? (car a) (car b)) + (equal? (cdr a) (cdr b)))) + ((and (vector? a) (vector? b)) + (equal? (vector->list a) (vector->list b))) + (#t (eq? a b)))) + +(define (vector . rest) (list->vector rest)) + +(define (apply f args) + (eval (cons f args) (current-module))) + +(define (defined? x) + (assq x (current-module))) + +(define (procedure? p) + (cond ((builtin? p) #t) + ((and (pair? p) (eq? (car p) 'lambda))) + ((and (pair? p) (eq? (car p) '*lambda*))) + (#t #f))) + +(define assv assq) +(define (memq x lst) + (cond ((null? lst) #f) + ((eq? x (car lst)) lst) + (#t (memq x (cdr lst))))) +(define memv memq) + +(define (member x lst) + (cond ((null? lst) #f) + ((equal? x (car lst)) lst) + (#t (member x (cdr lst))))) + (define (map f l . r) (cond ((null? l) '()) ((null? r) (cons (f (car l)) (map f (cdr l)))) @@ -167,12 +168,10 @@ ;; (define gensym ;; (let ((counter 0)) ;; (lambda (. rest) -;; (let ((val (number->string counter))) +;; (let ((value (number->string counter))) ;; (set! counter (+ counter 1)) -;; (string->symbol (string-append "g" val)))))) - -(define *gensym* 0) +;; (string->symbol (string-append "g" value)))))) +(define *gensym* -1) (define (gensym) (set! *gensym* (+ *gensym* 1)) (string->symbol (string-append "g" (number->string *gensym*)))) - diff --git a/test.mes b/test.mes index 787d56bc..68774d74 100644 --- a/test.mes +++ b/test.mes @@ -191,6 +191,14 @@ (pass-if "closure 3" (sequal? (x) '(0 0))) +(pass-if "closure 4 " + (seq? (begin + (let ((count (let ((counter 0)) + (lambda () + counter)))) + (count))) + 0)) + (newline) (display "passed: ") (display (car (result))) (newline) (display "failed: ") (display (cadr (result))) (newline)