mes.c: refactor begin and closures. Fixes bugs/top.mes.

bugs/top.mes

@@ -1,12 +0,0 @@
-(begin (define *test-begin-a* '*test-begin-a*))
-
-(display "defined? *test-begin-a*: ")
-(display (defined? '*test-begin-a*))
-(newline)
-(display *test-begin-a*)
-(newline)
-
-(let () (define *test-let-a* '*test-let-a*) #f)
-(display "defined? *test-let-a*: ")
-(display (defined? '*test-let-a*))
-(newline)

mes.c

@@ -81,7 +81,7 @@ scm scm_t = {SYMBOL, "#t"};
 scm scm_f = {SYMBOL, "#f"};
 scm scm_unspecified = {SYMBOL, "*unspecified*"};
 
-scm symbol_closure = {SYMBOL, "*lambda*"};
+scm symbol_closure = {SYMBOL, "*closure*"};
 scm symbol_circ = {SYMBOL, "*circ*"};
 scm symbol_lambda = {SYMBOL, "lambda"};
 scm symbol_begin = {SYMBOL, "begin"};
@@ -277,13 +277,17 @@ apply_env (scm *fn, scm *x, scm *a)
       if (builtin_p (fn) == &scm_t)
         return call (fn, x);
     }
-  else if (car (fn) == &symbol_lambda)
+  else if (car (fn) == &symbol_lambda) {
-    return eval (cons (&symbol_begin, cddr (fn)), pairlis (cadr (fn), x, a));
+    scm *p = pairlis (cadr (fn), x, a);
+    return eval (cons (&symbol_begin, cddr (fn)), cons (cons (&symbol_closure, p), p));
+  }
   else if (car (fn) == &symbol_closure) {
     scm *args = caddr (fn);
     scm *body = cdddr (fn);
     a = cdadr (fn);
-    return eval (cons (&symbol_begin, body), pairlis (args, x, a));
+    a = cdr (a);
+    scm *p = pairlis (args, x, a);
+    return eval (cons (&symbol_begin, body), cons (cons (&symbol_closure, p), p));
   }
   else if ((macro = lookup_macro (car (fn), a)) != &scm_f) {
     scm *r = apply_env (eval (macro, a), cdr (fn), a);
@@ -303,6 +307,8 @@ eval (scm *e, scm *a)
 #if DEBUG
   printf ("\neval e=");
   display (e);
+  printf ("\na=");
+  display (a);
   puts ("");
 #endif
   scm *macro;
@@ -324,37 +330,15 @@ eval (scm *e, scm *a)
       if (car (e) == &symbol_begin)
         {
           scm *body = cdr (e);
-          scm *defines = &scm_nil;
+          if (body == &scm_nil) return &scm_unspecified;
-          while (body != &scm_nil) {
           e = car (body);
           body = cdr (body);
-            if (e->type == PAIR
+          scm *r = eval (e, a);
-                && (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));
-              e = &scm_unspecified;
-            }
-            else break;
-          }
-          a = append2 (defines, a);
-          while (defines != &scm_nil) {
-            scm *name = caar (defines);
-            scm *entry = assq (name, a);
-            scm *x = cdar (defines);
-            set_cdr_x (entry, cdr (define (x, a)));
-            // if (eq_p (car (x), &symbol_define_macro) == &scm_t)
-            //   set_cdr_x (last_pair (a), cons (cons (name, cdr (define (x, a))), &scm_nil));
-            defines = cdr (defines);
-          }
-          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);
         }
       if (car (e) == &symbol_lambda)
-        return make_closure (cadr (e), cddr (e), a);
+        return make_closure (cadr (e), cddr (e), assq (&symbol_closure, a));
       if (car (e) == &symbol_closure)
         return e;
       if (car (e) == &symbol_unquote)
@@ -363,8 +347,8 @@ eval (scm *e, scm *a)
         return eval_quasiquote (cadr (e), add_unquoters (a));
       if (car (e) == &symbol_cond)
         return evcon (cdr (e), a);
-      // if (eq_p (car (e), &symbol_define) == &scm_t)
+      if (eq_p (car (e), &symbol_define) == &scm_t)
-      //   return define (e, a);
+        return define (e, a);
       if (eq_p (car (e), &symbol_define_macro) == &scm_t)
         return define (e, a);
       if ((macro = lookup_macro (car (e), a)) != &scm_f)
@@ -820,6 +804,10 @@ display_helper (scm *x, bool cont, char *sep, bool quote)
       printf ("(*circ* . #-1#)");
       return &scm_unspecified;
     }
+    if (car (x) == &symbol_closure) {
+      printf ("(*closure* . #-1#)");
+      return &scm_unspecified;
+    }
     if (car (x) == &scm_quote) {
       printf ("'");
       return display_helper (car (cdr (x)), cont, "", true);
@@ -1129,8 +1117,13 @@ mes_environment ()
   a = cons (cons (&symbol_begin, &symbol_begin), a);
   a = cons (cons (&symbol_quote, &scm_quote), a);
   
+#if MES_FULL
 #include "environment.i"
-  
+#else
+  a = add_environment (a, "display", &scm_display);
+  a = add_environment (a, "newline", &scm_newline);
+#endif
+  a = cons (cons (&symbol_closure, a), a);
   return a;
 }
 
@@ -1143,15 +1136,7 @@ make_lambda (scm *args, scm *body)
 scm *
 make_closure (scm *args, scm *body, scm *a)
 {
-  return cons (&symbol_closure, cons (cons (&symbol_circ, cdr (a)), cons (args, body)));
+  return cons (&symbol_closure, cons (cons (&symbol_circ, 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 *
@@ -1168,7 +1153,13 @@ define (scm *x, scm *a)
   }
   if (eq_p (car (x), &symbol_define_macro) == &scm_t)
     e = make_macro (e);
-  return cons (name, e);
+  scm *entry = cons (name, e);
+  scm *aa = cons (entry, &scm_nil);
+  set_cdr_x (aa, cdr (a));
+  set_cdr_x (a, aa);
+  scm *cl = assq (&symbol_closure, a);
+  set_cdr_x (cl, aa);
+  return entry;
 }
  
 scm *

scm.mes

@@ -21,6 +21,15 @@
 ;; The Maxwell Equations of Software -- John McCarthy page 13
 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
 
+(define-macro (if expr then . else)
+  `(cond
+    (,expr ,then)
+    (#t (cond (,(pair? else) ((lambda () ,@else)))))))
+
+(define-macro (when expr . body)
+  `(if ,expr
+       ((lambda () ,@body))))
+
 (define (list . rest) rest)
 
 (define (split-params bindings params)
@@ -109,7 +118,7 @@
 (define (procedure? p)
   (cond ((builtin? p) #t)
         ((and (pair? p) (eq? (car p) 'lambda)))
-        ((and (pair? p) (eq? (car p) '*lambda*)))
+        ((and (pair? p) (eq? (car p) '*closure*)))
         (#t #f)))
 
 (define (assq-set! alist key val)
@@ -163,15 +172,6 @@
   (or (null? x)
       (and (pair? x) (list? (cdr x)))))
 
-(define-macro (if expr then . else)
-  `(cond
-    (,expr ,then)
-    (#t (cond (,(pair? else) ((lambda () ,@else)))))))
-
-(define-macro (when expr . body)
-  `(if ,expr
-       ((lambda () ,@body))))
-
 (define (unspecified-bindings bindings params)
   (cond ((null? bindings) params)
         (#t (unspecified-bindings
@@ -189,16 +189,8 @@
      ,@(letrec-setters bindings '())
      ,@body))
 
-;; TODO
+(define gensym
-;; (define gensym
+  (let ((counter 0))
-;;   (let ((counter 0))
-;;     (lambda (. rest)
-;;       (let ((value (number->string counter)))
-;;         (set! counter (+ counter 1))
-;;         (string->symbol (string-append "g" value))))))
-(define gensym #f)
-(let ((counter 0))
-  (set! gensym
     (lambda (. rest)
       (let ((value (number->string counter)))
         (set! counter (+ counter 1))

test.mes

@@ -22,16 +22,23 @@
 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
 
 ;; haha, broken...lat0r
-(define result #f)
+;; (define result #f)
-(let ((pass 0)
+;; (let ((pass 0)
-      (fail 0)
+;;       (fail 0))
-      (xresult #f))
+;;   (set! result
-  (set! result
+;;     (lambda (. t)
+;;       (cond ((null? t) (list pass fail))
+;;             ((car t) (display ": pass") (newline) (set! pass (+ pass 1)))
+;;             (#t (display ": fail") (newline) (set! fail (+ fail 1)))))))
+(define result
+  (let ((pass 0)
+        (fail 0))
     (lambda (. t)
       (cond ((null? t) (list pass fail))
             ((car t) (display ": pass") (newline) (set! pass (+ pass 1)))
             (#t (display ": fail") (newline) (set! fail (+ fail 1)))))))
 
+
 (define guile? (defined? 'gc))
 (when guile?
   (module-define! (current-module) 'builtin? (lambda (. x) #t))