unquote splicing and implemented slime side list comprehensions

bin/pre.slime

@@ -1,16 +1,23 @@
+(define-syntax (pe expr)
+  `(printf ',expr "evaluates to" ,expr))
+
 (define-syntax (when condition :rest body)
-  "Doc String for 'when'"
-  `(if ,condition ,(pair begin body) nil))
+  "Doc String for `when'"
+  (if (= (rest body) ())
+      `(if ,condition @body)
+    `(if ,condition (begin @body))))
 
 (define-syntax (unless condition :rest body)
-  `(if ,condition nil ,(pair begin body)))
+  (if (= (rest body) ())
+      `(if ,condition nil @body)
+    `(if ,condition nil (begin @body))))
 
 (define-syntax (n-times times action)
   "Executes action times times."
   (define (repeat times elem)
     (unless (> 1 times)
       (pair elem (repeat (- times 1) elem))))
-  (pair 'begin (repeat times action)))
+  `(begin @(repeat times action)))
 
 (define-syntax (let bindings :rest body)
   (define (unzip lists)
@@ -27,9 +34,7 @@
 
   (define unzipped (unzip bindings))
 
-  (pair `(lambda ,(first unzipped)
-           ,(pair 'begin body))
-        (first (rest unzipped))))
+  `((lambda ,(first unzipped) @body) @(first (rest unzipped))))
 
 (define-syntax (cond :rest clauses)
   (define (rec clauses)
@@ -40,67 +45,60 @@
            (if (not (= () (rest clauses)))
                (error "There are additional clauses after the else clause!")
              (pair 'begin (rest (first clauses)))))
-        (list 'if (first (first clauses))
-              (pair 'begin (rest (first clauses)))
-              (rec (rest clauses))))))
+        `(if ,(first (first clauses))
+              (begin @(rest (first clauses)))
+              ,(rec (rest clauses))))))
     (rec clauses))
 
+(define-syntax (define-special name-and-args :rest body)
+  `(define ,(first name-and-args) (special-lambda ,(rest name-and-args) @body)))
+
 (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 (append-map f ll)
+    (unless (= ll ())
+      (define val (f (first ll)))
+      (if (= (first val) ())
+          (append-map f (rest ll))
+        (extend
+         val
+         (append-map f (rest ll))))))
 
-  (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)
+  (define (rec body)
     (cond
-     ((= () body) (begin))
+     ((= () body) ())
      ((= () (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))))
-
+     ((= (first (rest body)) '<-)
+      `(,append-map (lambda (,(first body)) (list ,(rec (rest (rest (rest body)))))) ,(first (rest (rest body)))))
+     ((= (first body) 'when)
+      `(if ,(first (rest body)) ,(rec (rest (rest body)))))
+     ((= (first body) 'yield)
+      (first (rest body)))
+     (t (error "Not a do-able expression: ~S" `(quote ,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)))))
+;; (define (append-map f ll)
+  ;; (unless (= ll ())
+    ;; (define val (f (first ll)))
+    ;; (if (= (first val) ())
+        ;; (append-map f (rest ll))
+      ;; (extend
+       ;; val
+       ;; (append-map f (rest ll))))))
 
-;;     (iter (rest lists))
-;;     (list l1 l2))
-
-;;   (define unzipped (unzip bindings))
-
-;;   (pair `(lambda ,(first unzipped)
-;;            ,(pair 'begin body))
-;;         (first (rest unzipped))))
+  ;; (define-special (do-list :rest body)
+    ;; (cond
+     ;; ((= () body) ())
+     ;; ((= () (rest body)) (first body))
+     ;; ((= (first (rest body)) '<-)
+      ;; `(,append-map (lambda (,(first body)) (list ,(eval `(do-list @(rest (rest (rest body))))))) ,(first (rest (rest body)))))
+     ;; ((= (first body) 'when)
+      ;; `(if ,(first (rest body)) ,(eval `(do-list @(rest (rest body))))))
+     ;; ((= (first body) 'yield)
+      ;; (first (rest body)))
+     ;; (t (error "Not a do-able expression: ~S" `(quote ,body))))
+    ;; )
 
 (define (nil? x)
   "Checks if the argument is nil."
@@ -297,17 +295,14 @@ added to a list, which in the end is returned."
 of arguments and also provides keywords for specifying the printed
 separators between the arguments and what should be printed after the
 las argument."
-  (define printf-quoted (special-lambda (:keys @sep @end :rest @args)
-    (if (nil? @args)
-        (begin (print (eval @end)) nil)
+  (define printf-quoted (special-lambda (:keys sep end :rest args)
+    (if (nil? args)
+        (begin (print (eval end)) nil)
       (begin
-       (print (first @args))
-       (unless (nil? (rest @args))
-         (print (eval @sep)))
+       (print (first args))
+       (unless (nil? (rest args))
+         (print (eval sep)))
        (eval (pair printf-quoted
-              (extend (list :@sep (eval @sep) :@end (eval @end)) (rest @args))))))))
+              (extend (list :sep (eval sep) :end (eval end)) (rest args))))))))
 
-  (eval (pair printf-quoted (extend (list :@sep (eval sep) :@end (eval end)) args))))
-
-(define-syntax (pe expr)
-  `(printf ',expr "evaluates to" ,expr))
+  (eval (pair printf-quoted (extend (list :sep (eval sep) :end (eval end)) args))))