Checkpoint before unquote-splicing

bin/pre.slime

@@ -12,20 +12,24 @@
       (pair elem (repeat (- times 1) elem))))
   (pair 'begin (repeat times action)))
 
-;; (define (fib n))
-;; (define-syntax define (name :rest value)
-;;   (print name)
-;;   (print (type name))
-;;   (if (= (type name) :pair)
-;;       (begin
-;;        ;; (print `(define ,(first name) ,`(pair lambda (pair (rest name) value))))
-;;        ;; (print rest)
-;;        (print "\naa\n")
-;;        (list 'define (first name) (pair 'lambda (pair (rest name) value))))
-;;     (begin
-;;      ;; (print (pair 'define (pair name value)))
-;;      (print "\nbb\n")
-;;      (pair 'define (pair name value)))))
+(define-syntax (let bindings :rest body)
+  (define (unzip lists)
+    (when lists
+      (define (iter lists l1 l2)
+        (define elem (first lists))
+        (if elem
+            (iter (rest lists)
+                  (pair (first elem) l1)
+                  (pair (first (rest elem)) l2))
+          (list l1 l2))))
+
+    (iter lists () ()))
+
+  (define unzipped (unzip bindings))
+
+  (pair `(lambda ,(first unzipped)
+           ,(pair 'begin body))
+        (first (rest unzipped))))
 
 (define-syntax (cond :rest clauses)
   (define (rec clauses)
@@ -41,6 +45,63 @@
               (rec (rest clauses))))))
     (rec clauses))
 
+(define-syntax (do-list :rest body)
+  (define (car seq) (first seq))
+  (define (cdr seq) (rest seq))
+  (define (cadr seq) (car (cdr seq)))
+  (define (cddr seq) (cdr (cdr seq)))
+  (define (caddr seq) (car (cddr seq)))
+  (define (cdddr seq) (cdr (cddr seq)))
+
+  (define (extend-map f ll)
+    (when ll
+      (extend
+       (f (first ll))
+       (extend-map f (rest ll)))))
+
+  (define (list-bind l f)
+    (extend-map f l))
+
+  (define (list-return x)
+    (list x))
+
+  (define (rec :rest body)
+    (cond
+     ((= () body) (begin))
+     ((= () (rest body)) (first body))
+     ((= (first (rest body)) "<-")
+      `(,list-bind ,(caddr body) (lambda (,(first body)) (,rec . (unquote (cdddr body))))))
+     ((= (first (rest body)) "when")
+      `(if ,(cadr body) (,rec . (unquote (cddr body))) (list-fail)))
+     ((= (first (rest body)) "yield")
+      `(,list-return ,(cadr body)))
+     (else (error "Not a do-able expression: ~S" `',body))))
+
+  (rec body))
+
+;; (define-syntax (define-special name-and-args)
+;;   (define (unzip lists)
+;;     (define elem (first lists))
+;;     (define l1 (pair (first       elem)  ()))
+;;     (define l2 (pair (first (rest elem)) ()))
+
+;;     (define (iter lists)
+;;       (define elem (first lists))
+;;       (when elem
+;;           (begin
+;;            (mutate l1 (pair (first       elem)  (copy l1)))
+;;            (mutate l2 (pair (first (rest elem)) (copy l2)))
+;;            (iter (rest lists)))))
+
+;;     (iter (rest lists))
+;;     (list l1 l2))
+
+;;   (define unzipped (unzip bindings))
+
+;;   (pair `(lambda ,(first unzipped)
+;;            ,(pair 'begin body))
+;;         (first (rest unzipped))))
+
 (define (nil? x)
   "Checks if the argument is nil."
   (= x nil))
@@ -102,10 +163,21 @@ the (rest) of the last element of the sequence."
         seq)
     elem))
 
+(define (extend2 seq elem)
+  "Extends a list with the given element, by putting it in
+the (rest) of the last element of the sequence."
+  (printf "addr of (end seq)" (addr-of (end seq)))
+  (if (pair? seq)
+       (let ((e (end seq)))
+         (printf "addr if e inner" (addr-of e))
+         (mutate e (pair (first e) elem))
+         seq))
+    elem)
+
 (define (append seq elem)
   "Appends an element to a sequence, by extendeing the list
 with (pair elem nil)."
-  (extend seq (pair elem nil)))
+  (extend seq (pair elem ())))
 
 (define (length seq)
   "Returns the length of the given sequence."
@@ -194,10 +266,23 @@ added to a list, which in the end is returned."
               (filter fun (rest seq)))
       (filter fun (rest seq)))))
 
+
 (define (zip l1 l2)
-  (if (and (nil? l1) (nil? l2))
-      nil
-    (pair (list (first l1) (first l2)) (zip (rest l1) (rest l2)))))
+  (unless (and (nil? l1) (nil? l2))
+    (pair (list (first l1) (first l2))
+          (zip (rest l1) (rest l2)))))
+
+(define (unzip lists)
+  (when lists
+    (define (iter lists l1 l2)
+      (define elem (first lists))
+      (if elem
+          (iter (rest lists)
+                (pair (first elem) l1)
+                (pair (first (rest elem)) l2))
+        (list l1 l2))))
+
+  (iter lists () ()))
 
 (define (enumerate seq)
   (define (enumerate-inner seq next-num)