From 1ad843b3c87aeba9b733160bb6e9b98b9788ec22 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@dino11.iro.umontreal.ca>
Date: Mon, 28 Jul 2008 17:08:26 -0400
Subject: [PATCH] Merged most of Etienne's improvements from last year,
 including macros, named lets, letrecs, etc. They seem to work.

---
 library.scm | 108 ++++++++++++++++++++++++++++-------------------
 picobit.scm | 138 +++++++++++++++++++++++++++++++++++++++++++++++++-----------
 2 files changed, 179 insertions(+), 67 deletions(-)

diff --git a/library.scm b/library.scm
index 38fe8c1..2320312 100644
--- a/library.scm
+++ b/library.scm
@@ -1,5 +1,22 @@
 ; File: "library.scm"
 
+(define-macro (cond . a)
+  (if (null? a) '(if #f #f)
+      (cond ((eq? (caar a) 'else) `(begin . ,(cdar a)))
+            ((and (not (null? (cdar a))) (eq? (cadar a) '=>))
+             (let ((x (gensym)))
+               `(let ((,x ,(caar a)))
+                  (if ,x (,(caddar a) ,x) (cond . ,(cdr a))))))
+            (else `(if ,(caar a) (begin . ,(cdar a)) (cond . ,(cdr a)))))))
+
+(define-macro (case a . cs)
+  (let ((x (gensym)))
+    `(let ((,x ,a))
+       (cond . ,(map (lambda (c)
+                       (if (eq? (car c) 'else) c
+                           `((memv ,x ',(car c)) . ,(cdr c))))
+                     cs)))))
+
 (define number?
   (lambda (x)
     (#%number? x)))
@@ -161,6 +178,12 @@
   (lambda (x y)
     (#%remainder x y)))
 
+(define #%box (lambda (a) (#%cons a '())))
+
+(define #%unbox (lambda (a) (#%car a)))
+
+(define #%box-set! (lambda (a b) (#%set-car! a b)))
+
 (define string
   (lambda chars
     (#%list->string chars)))
@@ -190,7 +213,7 @@
 
 (define #%substring-aux1
   (lambda (lst n)
-    (if (>= n 1) ;; TODO had an off-by-one
+    (if (>= n 1)
         (#%substring-aux1 (#%cdr lst) (#%- n 1))
         lst)))
 
@@ -323,35 +346,34 @@
 
 (define write
   (lambda (x)
-    (if (#%string? x)
-        (begin
-          (#%putchar #\" 3)
-          (display x)
-          (#%putchar #\" 3))
-        (if (#%number? x)
-            (display (number->string x))
-            (if (#%pair? x)
-                (begin
-                  (#%putchar #\( 3)
+    (cond ((#%string? x)
+	   (begin (#%putchar #\" 3)
+		  (display x)
+		  (#%putchar #\" 3)))
+	  ((#%number? x)
+	   (display (number->string x)))
+	  ((#%pair? x)
+	   (begin (#%putchar #\( 3)
                   (write (#%car x))
-                  (#%write-list (#%cdr x)))
-                (if (#%symbol? x)
-                    (display "#<symbol>")
-                    (display "#<object>")))))))
+                  (#%write-list (#%cdr x))))
+	  ((#%symbol? x)
+	   (display "#<symbol>"))
+	  (else
+	   (display "#<object>")))))
+;; TODO have vectors and co ?
 
 (define #%write-list
   (lambda (lst)
-    (if (#%null? lst)
-        (#%putchar #\) 3)
-        (if (#%pair? lst)
-            (begin
-              (#%putchar #\space 3)
-              (write (#%car lst))
-              (#%write-list (#%cdr lst)))
-            (begin
-              (display " . ")
-              (write lst)
-              (#%putchar #\) 3))))))
+    (cond ((#%null? lst)
+	   (#%putchar #\) 3))
+	  ((#%pair? lst)
+	   (begin (#%putchar #\space 3)
+		  (write (#%car lst))
+		  (#%write-list (#%cdr lst))))
+	  (else
+	   (begin (display " . ")
+		  (write lst)
+		  (#%putchar #\) 3))))))
 
 (define number->string
   (lambda (n)
@@ -410,15 +432,16 @@
     (#%cdr (#%cdr (#%cdr p)))))
 
 (define equal?
-  (lambda (x y) ;; TODO rewrite once we have cond, also add vectors, actually, we do have cond, but I don't really trust it
-    (if (#%eq? x y)
-	#t
-	(if (and (#%pair? x) (#%pair? y))
-	    (and (equal? (#%car x) (#%car y))
-		 (equal? (#%cdr x) (#%cdr y)))
-	    (if (and (#%u8vector? x) (#%u8vector? y))
-		(u8vector-equal? x y)
-		#f))))) ;; TODO could this have a problem ?
+  (lambda (x y)
+    (cond ((#%eq? x y)
+	   #t)
+	  ((and (#%pair? x) (#%pair? y))
+	   (and (equal? (#%car x) (#%car y))
+		(equal? (#%cdr x) (#%cdr y))))
+	  ((and (#%u8vector? x) (#%u8vector? y))
+	   (u8vector-equal? x y))
+	  (else
+	   #f))))
 
 (define u8vector-equal?
   (lambda (x y)
@@ -434,12 +457,13 @@
 	     (u8vector-equal?-loop x y (#%- l 1)))))) ;; TODO test this
 
 (define assoc
-  (lambda (t l) ;; TODO rewrite once we have cond
-    (if (#%null? l)
-	#f
-	(if (equal? t (caar l))
-	    (#%car l)
-	    (assoc t (#%cdr l))))))
+  (lambda (t l)
+    (cond ((#%null? l)
+	   #f)
+	  ((equal? t (caar l))
+	   (#%car l))
+	  (else
+	   (assoc t (#%cdr l))))))
 
 ;; TODO ordinary vectors are never more that 6 elements long in the stack, so implementing them as lists is acceptable
 (define vector list)
@@ -453,8 +477,6 @@
 (define current-time (lambda () (#%clock)))
 (define time->seconds (lambda (t) (#%quotient t 100))) ;; TODO no floats, is that a problem ?
 
-(define else #t) ; for cond, among others
-
 (define u8vector
   (lambda x
     (list->u8vector x)))
diff --git a/picobit.scm b/picobit.scm
index cc788ed..aed6f79 100644
--- a/picobit.scm
+++ b/picobit.scm
@@ -344,7 +344,14 @@
 (define parse-top
   (lambda (expr env)
     (cond ((and (pair? expr)
-                (eq? (car expr) 'begin))
+                (eq? (car expr) 'define-macro))
+           (set! *macros*
+		 (cons (cons (caadr expr)
+			     (eval `(lambda ,(cdadr expr) . ,(cddr expr))))
+		       *macros*))
+           '())
+	  ((and (pair? expr)
+		(eq? (car expr) 'begin))
            (parse-top-list (cdr expr) env))
           ((and (pair? expr)
                 (eq? (car expr) 'hide))
@@ -400,19 +407,24 @@
     (cond ((self-eval? expr)
            (make-cst #f '() expr))
           ((symbol? expr)
-           (let* ((var (env-lookup env expr))
-                  (r (make-ref #f '() var)))
-             (var-refs-set! var (cons r (var-refs var)))
-             r))
-	  ((and (pair? expr) ;; ADDED, when we have a true macroexpander, get rid
-		(eq? (car expr) 'cond))
-	   (parse use
-		  `(if ,(caadr expr)
-		       (begin ,@(cdadr expr))
-		       ,(if (null? (cddr expr))
-			    #f
-			    `(cond ,@(cddr expr))))
-		  env))
+	   (let* ((var (env-lookup env expr))
+		  (r (make-ref #f '() var)))
+	     (var-refs-set! var (cons r (var-refs var)))
+	     (if (not (var-global? var))
+		 (let* ((unbox (parse 'value '#%unbox env))
+			(app (make-call #f (list unbox r))))
+		   (node-parent-set! r app)
+		   (node-parent-set! unbox app)
+		   app)
+		 r)) ;; TODO Etienne's code for boxing
+;;; 	   (let* ((var (env-lookup env expr))
+;;;                   (r (make-ref #f '() var)))
+;;;              (var-refs-set! var (cons r (var-refs var)))
+;;;              r)
+	   )
+	  ((and (pair? expr)
+                (assq (car expr) *macros*))
+           => (lambda (p) (parse use (apply (cdr p) (cdr expr)) env)))
           ((and (pair? expr)
                 (eq? (car expr) 'set!))
            (let ((var (env-lookup env (cadr expr))))
@@ -422,8 +434,18 @@
                    (node-parent-set! val r)
                    (var-sets-set! var (cons r (var-sets var)))
                    r)
-		 (compiler-error "set! is only permitted on global variables"))))
-          ((and (pair? expr) ;; TODO since literal vectors are quoted, this does the job
+		 ;; (compiler-error "set! is only permitted on global variables")
+		 (let* ((body (parse 'value (caddr expr) env))
+                        (ref (make-ref #f '() var))
+                        (bs (make-ref #f '() (env-lookup env '#%box-set!)))
+                        (r (make-call #f (list bs ref body))))
+                   (node-parent-set! body r)
+                   (node-parent-set! ref r)
+                   (node-parent-set! bs r)
+                   (var-sets-set! var (cons r (var-sets var)))
+                   r) ;; TODO Etienne's code for boxing
+		 )))
+          ((and (pair? expr)
                 (eq? (car expr) 'quote))
            (make-cst #f '() (cadr expr)))
           ((and (pair? expr)
@@ -440,15 +462,56 @@
              r))
           ((and (pair? expr)
                 (eq? (car expr) 'lambda))
-           (let* ((pattern (cadr expr))
+;;;            (let* ((pattern (cadr expr))
+;;;                   (ids (extract-ids pattern))
+;;;                   (r (make-prc #f '() #f (has-rest-param? pattern) #f))
+;;;                   (new-env (env-extend env ids r))
+;;;                   (body (parse-body (cddr expr) new-env)))
+;;;              (prc-params-set! r (map (lambda (id) (env-lookup new-env id)) ids))
+;;;              (node-children-set! r (list body))
+;;;              (node-parent-set! body r)
+;;;              r)
+	   (let* ((pattern (cadr expr))
                   (ids (extract-ids pattern))
-                  (r (make-prc #f '() #f (has-rest-param? pattern) #f))
+                  (r (make-prc #f '() #f (has-rest-param? pattern) #f)) ; parent children params rest? entry-label
                   (new-env (env-extend env ids r))
-                  (body (parse-body (cddr expr) new-env)))
-             (prc-params-set! r (map (lambda (id) (env-lookup new-env id)) ids))
-             (node-children-set! r (list body))
-             (node-parent-set! body r)
-             r))
+                  (body (parse-body (cddr expr) new-env))
+                  (mut-vars (apply append (map (lambda (id)
+                                                 (let ((v (env-lookup new-env id)))
+                                                   (if (mutable-var? v) (list v) '())))
+                                               ids))))
+             (if (null? mut-vars)
+                 (begin
+                   (prc-params-set! r (map (lambda (id) (env-lookup new-env id)) ids))
+                   (node-children-set! r (list body))
+                   (node-parent-set! body r)
+                   r)
+                 (let* ((prc (make-prc #f (list body) mut-vars #f #f))
+                        (new-vars (map var-id mut-vars))
+                        (tmp-env (env-extend env new-vars r))
+                        (app (make-call r (cons prc (map (lambda (id) (parse 'value (cons '#%box (cons id '())) tmp-env)) new-vars)))))
+                   ;; (lambda (a b) (set! a b)) => (lambda (_a b) ((lambda (a) (box-set! a b)) (box _a)))
+                   (for-each (lambda (var)
+                               (var-defs-set! var (list prc)))
+                             mut-vars)
+                   (for-each (lambda (n) (node-parent-set! n app)) (cdr (node-children app)))
+                   (node-parent-set! prc app)
+                   (prc-params-set! r (map (lambda (id) (env-lookup tmp-env id)) ids))
+                   (node-children-set! r (list app))
+                   (node-parent-set! body prc)
+                   r))) ;; TODO Etienne's code for boxing
+	   )
+	  ((and (pair? expr)
+                (eq? (car expr) 'letrec))
+           (let ((ks (map car (cadr expr)))
+                 (vs (map cadr (cadr expr))))
+             (parse use
+                    (cons 'let
+			  (cons (map (lambda (k) (list k #f)) ks)
+				(append (map (lambda (k v) (list 'set! k v))
+					     ks vs) ; letrec*
+					(cddr expr))))
+                    env)))
           ((and (pair? expr)
                 (eq? (car expr) 'begin))
            (let* ((exprs (map (lambda (x) (parse 'value x env)) (cdr expr)))
@@ -458,7 +521,11 @@
           ((and (pair? expr)
                 (eq? (car expr) 'let))
            (if (symbol? (cadr expr))
-               (compiler-error "named let is not implemented")
+	       (parse use
+                      `(letrec ((,(cadr expr) (lambda ,(map car (caddr expr)) .
+                                                      ,(cdddr expr))))
+                         (,(cadr expr) . ,(map cadr (caddr expr))))
+                      env)
                (parse use
                       (cons (cons 'lambda
                                   (cons (map car (cadr expr))
@@ -581,6 +648,26 @@
         (has-rest-param? (cdr pattern))
         (symbol? pattern))))
 
+(define (adjust-unmutable-references! node)
+  '(pretty-print (list unmut: (node->expr node)))
+  (if (and (call? node)
+           '(display "call ")
+           (ref? (car (node-children node)))
+           '(display "ref ")
+           (eq? '#%unbox (var-id (ref-var (car (node-children node)))))
+           '(display "unbox")
+           (ref? (cadr (node-children node)))
+           '(display "ref ")
+           (not (mutable-var? (ref-var (cadr (node-children node)))))
+           '(display "unmut! ")) 
+      (let* ((parent (node-parent node)) (child (cadr (node-children node))))
+        (node-parent-set! child parent)
+        (if parent
+            (node-children-set! parent (map (lambda (c) (if (eq? c node) child c)) (node-children parent))))
+        child)
+      (begin (for-each (lambda (n) (adjust-unmutable-references! n)) (node-children node))
+             node))) ;; TODO Etienne's code for boxing
+
 ;-----------------------------------------------------------------------------
 
 ;; Compilation context representation.
@@ -3031,6 +3118,8 @@
             (string-append
              (path-strip-extension filename)
              ".hex")))
+      
+      (adjust-unmutable-references! node) ;; TODO Etienne's code for boxing
 
 ;      (pp (node->expr node))
 
@@ -3043,6 +3132,7 @@
 
 (define main
   (lambda (filename)
+    (current-exception-handler (lambda (e) (pp e) (##repl))) ;; TODO wow, that's useful
     (compile filename)))
 
 ;------------------------------------------------------------------------------
-- 
2.11.4.GIT