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'"
+  "Doc String for `when'"
-  `(if ,condition ,(pair begin body) nil))
+  (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)
+  `((lambda ,(first unzipped) @body) @(first (rest unzipped))))
-           ,(pair 'begin 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))
+        `(if ,(first (first clauses))
-              (pair 'begin (rest (first clauses)))
+              (begin @(rest (first clauses)))
-              (rec (rest 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 (append-map f ll)
-  (define (cdr seq) (rest seq))
+    (unless (= ll ())
-  (define (cadr seq) (car (cdr seq)))
+      (define val (f (first ll)))
-  (define (cddr seq) (cdr (cdr seq)))
+      (if (= (first val) ())
-  (define (caddr seq) (car (cddr seq)))
+          (append-map f (rest ll))
-  (define (cdddr seq) (cdr (cddr seq)))
+        (extend
+         val
+         (append-map f (rest ll))))))
 
-  (define (extend-map f ll)
+  (define (rec body)
-    (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))
+     ((= () body) ())
      ((= () (rest body)) (first body))
-     ((= (first (rest body)) "<-")
+     ((= (first (rest body)) '<-)
-      `(,list-bind ,(caddr body) (lambda (,(first body)) (,rec . (unquote (cdddr body))))))
+      `(,append-map (lambda (,(first body)) (list ,(rec (rest (rest (rest body)))))) ,(first (rest (rest body)))))
-     ((= (first (rest body)) "when")
+     ((= (first body) 'when)
-      `(if ,(cadr body) (,rec . (unquote (cddr body))) (list-fail)))
+      `(if ,(first (rest body)) ,(rec (rest (rest body)))))
-     ((= (first (rest body)) "yield")
+     ((= (first body) 'yield)
-      `(,list-return ,(cadr body)))
+      (first (rest body)))
-     (else (error "Not a do-able expression: ~S" `',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 (append-map f ll)
-;;       (define elem (first lists))
+  ;; (unless (= ll ())
-;;       (when elem
+    ;; (define val (f (first ll)))
-;;           (begin
+    ;; (if (= (first val) ())
-;;            (mutate l1 (pair (first       elem)  (copy l1)))
+        ;; (append-map f (rest ll))
-;;            (mutate l2 (pair (first (rest elem)) (copy l2)))
+      ;; (extend
-;;            (iter (rest lists)))))
+       ;; val
+       ;; (append-map f (rest ll))))))
 
-;;     (iter (rest lists))
+  ;; (define-special (do-list :rest body)
-;;     (list l1 l2))
+    ;; (cond
-
+     ;; ((= () body) ())
-;;   (define unzipped (unzip bindings))
+     ;; ((= () (rest body)) (first body))
-
+     ;; ((= (first (rest body)) '<-)
-;;   (pair `(lambda ,(first unzipped)
+      ;; `(,append-map (lambda (,(first body)) (list ,(eval `(do-list @(rest (rest (rest body))))))) ,(first (rest (rest body)))))
-;;            ,(pair 'begin body))
+     ;; ((= (first body) 'when)
-;;         (first (rest unzipped))))
+      ;; `(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)
+  (define printf-quoted (special-lambda (:keys sep end :rest args)
-    (if (nil? @args)
+    (if (nil? args)
-        (begin (print (eval @end)) nil)
+        (begin (print (eval end)) nil)
       (begin
-       (print (first @args))
+       (print (first args))
-       (unless (nil? (rest @args))
+       (unless (nil? (rest args))
-         (print (eval @sep)))
+         (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))))
+  (eval (pair printf-quoted (extend (list :sep (eval sep) :end (eval end)) args))))
-
-(define-syntax (pe expr)
-  `(printf ',expr "evaluates to" ,expr))

bin/pre.slime.expanded

@@ -1,5 +1,3 @@
-(show do-list)
-
 (define (nil? x) "Checks if the argument is nil." (= x nil))
 
 (define (number? x) "Checks if the argument is a number." (= (type x) :number))
@@ -29,7 +27,7 @@ ithe sequence as arguemens." (eval (pair fun seq)))
 the (rest) of the last element of the sequence." (if (pair? seq) (begin (define e (end seq)) (mutate e (pair (first e) elem)) 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) ((lambda (e) (begin (printf "addr if e inner" (addr-of e)) (mutate e (pair (first e) elem)) seq)) (end seq))) elem)
+the (rest) of the last element of the sequence." (printf "addr of (end seq)" (addr-of (end seq))) (if (pair? seq) ((lambda (e) (printf "addr if e inner" (addr-of e)) (mutate e (pair (first e) elem)) seq) (end seq))) elem)
 
 (define (append seq elem) "Appends an element to a sequence, by extendeing the list
 with (pair elem nil)." (extend seq (pair elem ())))
@@ -41,7 +39,7 @@ with (pair elem nil)." (extend seq (pair elem ())))
 (define (decrement val) "Subtracts one from the argument." (- val 1))
 
 (define (range :keys from :defaults-to 0 to) "Returns a sequence of numbers starting with the number defined
-by the key 'from' and ends with the number defined in 'to'." (if (< from to) ([C-function] (pair from (range :from (+ 1 from) :to to))) nil))
+by the key 'from' and ends with the number defined in 'to'." (if (< from to) (pair from (range :from (+ 1 from) :to to))))
 
 (define (range-while :keys from :defaults-to 0 to) "Returns a sequence of numbers starting with the number defined
 by the key 'from' and ends with the number defined in 'to'." (define result (list (copy from))) (define head result) (mutate from (increment from)) (while (< from to) (begin (mutate head (pair (first head) (pair (copy from) nil))) (define head (rest head)) (mutate from (increment from)))) result)
@@ -64,17 +62,17 @@ as compared to `reduce'." (if (nil? (rest seq)) (first seq) (fun (first seq) (re
 (define (filter fun seq) "Takes a function and a sequence as arguments and applies the
 function to every value in the sequence. If the result of that
 funciton application returns a truthy value, the original value is
-added to a list, which in the end is returned." (if seq ([C-function] (if (fun (first seq)) (pair (first seq) (filter fun (rest seq))) (filter fun (rest seq)))) nil))
+added to a list, which in the end is returned." (if seq (if (fun (first seq)) (pair (first seq) (filter fun (rest seq))) (filter fun (rest seq)))))
 
-(define (zip l1 l2) (if (and (nil? l1) (nil? l2)) nil ([C-function] (pair (list (first l1) (first l2)) (zip (rest l1) (rest l2))))))
+(define (zip l1 l2) (if (and (nil? l1) (nil? l2)) nil (pair (list (first l1) (first l2)) (zip (rest l1) (rest l2)))))
 
-(define (unzip lists) (if lists ([C-function] (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)))) nil) (iter lists () ()))
+(define (unzip lists) (if 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) (if seq ([C-function] (pair (list (first seq) next-num) (enumerate-inner (rest seq) (+ 1 next-num)))) nil)) (enumerate-inner seq 0))
+(define (enumerate seq) (define (enumerate-inner seq next-num) (if seq (pair (list (first seq) next-num) (enumerate-inner (rest seq) (+ 1 next-num))))) (enumerate-inner seq 0))
 
 (define (printf :keys sep :defaults-to " " end :defaults-to "
 " :rest args) "A wrapper for the built-in (print) that accepts a variable number
 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) (begin (print (first @args)) (if (nil? (rest @args)) nil ([C-function] (print (eval @sep)))) (eval (pair printf-quoted (extend (list :@sep (eval @sep) :@end (eval @end)) (rest @args)))))))) (eval (pair printf-quoted (extend (list :@sep (eval sep) :@end (eval end)) args))))
+las argument." (define printf-quoted (special-lambda (:keys sep end :rest args) (if (nil? args) (begin (print (eval end)) nil) (begin (print (first args)) (if (nil? (rest args)) nil (print (eval sep))) (eval (pair printf-quoted (extend (list :sep (eval sep) :end (eval end)) (rest args)))))))) (eval (pair printf-quoted (extend (list :sep (eval sep) :end (eval end)) args))))
 

bin/tests/lexical_scope.slime.expanded

@@ -1,4 +1,4 @@
-(define (make-counter) (let ((var 0)) (lambda () (mutate var (+ 1 var)) var)))
+(define (make-counter) ((lambda (var) (lambda () (mutate var (+ 1 var)) var)) 0))
 
 (define counter1 (make-counter))
 

src/built_ins.cpp

@@ -461,7 +461,8 @@ proc load_built_ins_into_environment(Environment* env) -> void {
                 // it is a pair!
                 Lisp_Object* originalPair = expr->value.pair.first;
                 if (Memory::get_type(originalPair) == Lisp_Object_Type::Symbol &&
-                    string_equal(originalPair->value.symbol.identifier, "unquote"))
+                    (string_equal(originalPair->value.symbol.identifier, "unquote") ||
+                     string_equal(originalPair->value.symbol.identifier, "unquote-splicing")))
                 {
                     // eval replace the stuff
                     return eval_expr(expr->value.pair.rest->value.pair.first, env);
@@ -481,7 +482,25 @@ proc load_built_ins_into_environment(Environment* env) -> void {
                 Lisp_Object* newPairHead = newPair;
                 Lisp_Object* head = expr;
                 while (Memory::get_type(head) == Lisp_Object_Type::Pair) {
-                    newPairHead->value.pair.first = unquoteSomeExpressions(head->value.pair.first);
+                    // if it is ,@ we have to actually do more work
+                    // and inline the result
+                    if (Memory::get_type(head->value.pair.first) == Lisp_Object_Type::Pair &&
+                        Memory::get_type(head->value.pair.first->value.pair.first) == Lisp_Object_Type::Symbol &&
+                        string_equal(head->value.pair.first->value.pair.first->value.symbol.identifier, "unquote-splicing"))
+                    {
+                        Lisp_Object* spliced = unquoteSomeExpressions(head->value.pair.first);
+
+                        try assert_type(spliced, Lisp_Object_Type::Pair);
+                        newPairHead->value.pair.first = spliced->value.pair.first;
+                        newPairHead->value.pair.rest = spliced->value.pair.rest;
+
+                        // now skip to the end
+                        while (newPairHead->value.pair.rest != Memory::nil) {
+                            newPairHead = newPairHead->value.pair.rest;
+                        }
+                    } else {
+                        newPairHead->value.pair.first = unquoteSomeExpressions(head->value.pair.first);
+                    }
 
                     if (Memory::get_type(head->value.pair.rest) != Lisp_Object_Type::Pair)
                         break;

src/parse.cpp

@@ -246,8 +246,10 @@ namespace Parser {
     proc parse_expression(char* text, int* index_in_text) -> Lisp_Object* {
 
         // if it is quoted
+        // TODO(Felix): This looks totally broken..
         if (text[*index_in_text] == '\'' ||
             text[*index_in_text] == '`'  ||
+            text[*index_in_text] == '@'  ||
             text[*index_in_text] == ',')
         {
             char quoteType = text[*index_in_text];
@@ -257,15 +259,12 @@ namespace Parser {
             if (text[*index_in_text] == '('  ||
                 text[*index_in_text] == '\'' ||
                 text[*index_in_text] == '`'  ||
+                text[*index_in_text] == '@'  ||
                 text[*index_in_text] == ',')
             {
-                try {
+                try result = parse_expression(text, index_in_text);
-                    result = parse_expression(text, index_in_text);
-                }
             } else {
-                try {
+                try result = parse_atom(text, index_in_text);
-                    result = parse_atom(text, index_in_text);
-                }
             }
 
             Lisp_Object* ret = nullptr;
@@ -278,10 +277,14 @@ namespace Parser {
                 try ret = Memory::create_lisp_object_pair(
                     Memory::get_or_create_lisp_object_symbol("quasiquote"),
                     Memory::create_lisp_object_pair(result, Memory::nil));
-            else if (quoteType == ',') {
+            else if (quoteType == ',')
                 try ret = Memory::create_lisp_object_pair(
                     Memory::get_or_create_lisp_object_symbol("unquote"),
                     Memory::create_lisp_object_pair(result, Memory::nil));
+            else if (quoteType == '@') {
+                try ret = Memory::create_lisp_object_pair(
+                    Memory::get_or_create_lisp_object_symbol("unquote-splicing"),
+                    Memory::create_lisp_object_pair(result, Memory::nil));
             }
             if (ret) {
                 inject_scl(ret);
@@ -316,15 +319,12 @@ namespace Parser {
             if (text[*index_in_text] == '(' ||
                 text[*index_in_text] == '\''||
                 text[*index_in_text] == '`' ||
+                text[*index_in_text] == '@' ||
                 text[*index_in_text] == ',')
             {
-                try {
+                try head->value.pair.first = parse_expression(text, index_in_text);
-                    head->value.pair.first = parse_expression(text, index_in_text);
-                }
             } else {
-                try {
+                try head->value.pair.first = parse_atom(text, index_in_text);
-                    head->value.pair.first = parse_atom(text, index_in_text);
-                }
             }
 
             eat_until_code(text, index_in_text);
@@ -475,6 +475,7 @@ namespace Parser {
             return Memory::nil;
         if (text[index_in_text] == '('  ||
             text[index_in_text] == '\'' ||
+            text[index_in_text] == '@' ||
             text[index_in_text] == '`'  ||
             text[index_in_text] == ',')
         {
@@ -507,6 +508,7 @@ namespace Parser {
             return Memory::nil;
         if (text[index_in_text] == '('  ||
             text[index_in_text] == '\'' ||
+            text[index_in_text] == '@'  ||
             text[index_in_text] == '`'  ||
             text[index_in_text] == ',')
         {