Merge pull request #401 from asarhaddon/quasiquote

New soft tests, quasiquote algorithm described at  #103 on some impls.

docs/exercises.md

@@ -37,7 +37,7 @@ make REGRESS=1 TEST_OPTS='--hard --pre-eval=\(load-file\ \"../answer.mal\"\)' te
 
 - Implement `>`, `<=` and `>=` with `<`.
 
-- Implement `hash-map`, `list`, `prn` and `swap!` as non-recursive
+- Implement `list`, `vec`, `prn`, `hash-map` and `swap!` as non-recursive
   functions.
 
 - Implement `count`, `nth`, `map`, `concat` and `conj` with the empty

examples/exercises.mal

@@ -1,8 +1,7 @@
 ;; These are the answers to the questions in ../docs/exercise.md.
 
 ;; In order to avoid unexpected circular dependencies among solutions,
-;; this files attempts to be self-contained.
-(def! identity (fn* [x] x))
+;; this answer file attempts to be self-contained.
 (def! reduce (fn* (f init xs)
   (if (empty? xs) init (reduce f (f init (first xs)) (rest xs)))))
 (def! foldr (fn* [f init xs]
@@ -23,9 +22,10 @@
 (def! <= (fn* [a b] (not (< b a))))
 (def! >= (fn* [a b] (not (< a b))))
 
-(def! hash-map (fn* [& xs] (apply assoc {} xs)))
 (def! list (fn* [& xs] xs))
+(def! vec (fn* [xs] (apply vector xs)))
 (def! prn (fn* [& xs] (println (apply pr-str xs))))
+(def! hash-map (fn* [& xs] (apply assoc {} xs)))
 (def! swap! (fn* [a f & xs] (reset! a (apply f (deref a) xs))))
 
 (def! count
@@ -44,65 +44,65 @@
   (fn* [f xs]
     (foldr (fn* [x acc] (cons (f x) acc)) () xs)))
 (def! concat
-   (fn* [& xs]
-    (foldr (fn* [xs ys] (foldr cons ys xs)) () xs)))
+  (fn* [& xs]
+    (foldr (fn* [x acc] (foldr cons acc x)) () xs)))
 (def! conj
   (fn* [xs & ys]
     (if (vector? xs)
-      (apply vector (concat xs ys))
-      (reduce (fn* [xs x] (cons x xs)) xs ys))))
+      (vec (concat xs ys))
+      (reduce (fn* [acc x] (cons x acc)) xs ys))))
 
 (def! do2 (fn* [& xs] (nth xs (- (count xs) 1))))
-(def! do3 (fn* [& xs] (reduce (fn* [acc x] x) nil xs)))
+(def! do3 (fn* [& xs] (reduce (fn* [_ x] x) nil xs)))
 ;; do2 will probably be more efficient when lists are implemented as
 ;; arrays with direct indexing, but when they are implemented as
 ;; linked lists, do3 may win because it only does one traversal.
 
-(defmacro! quote (fn* [ast] (list (fn* [] ast))))
+(defmacro! quote2 (fn* [ast]
+  (list (fn* [] ast))))
 (def! _quasiquote_iter (fn* [x acc]
   (if (if (list? x) (= (first x) 'splice-unquote)) ; logical and
     (list 'concat (first (rest x)) acc)
-    (list 'cons (list 'quasiquote x) acc))))
-(defmacro! quasiquote (fn* [ast]
+    (list 'cons (list 'quasiquote2 x) acc))))
+(defmacro! quasiquote2 (fn* [ast]
   (if (list? ast)
     (if (= (first ast) 'unquote)
       (first (rest ast))
       (foldr _quasiquote_iter () ast))
     (if (vector? ast)
-      ;; TODO: once tests are fixed, replace 'list with 'vector.
-      (list 'apply 'list (foldr _quasiquote_iter () ast))
+      (list 'vec (foldr _quasiquote_iter () ast))
       (list 'quote ast)))))
 
-(def! _letA_keys (fn* [binds]
-  (if (empty? binds)
-    ()
-    (cons (first binds) (_letA_keys (rest (rest binds)))))))
-(def! _letA_values (fn* [binds]
-  (if (empty? binds)
-    ()
-    (_letA_keys (rest binds)))))
-(def! _letA (fn* [binds form]
-  (cons (list 'fn* (_letA_keys binds) form) (_letA_values binds))))
+;; Interpret kvs as [k1 v1 k2 v2 ... kn vn] and returns
+;; (f k1 v1 (f k2 v2 (f ... (f kn vn)))).
+(def! _foldr_pairs (fn* [f init kvs]
+  (if (empty? kvs)
+    init
+    (let* [key (first kvs)
+           rst (rest kvs)
+           val (first rst)
+           acc (_foldr_pairs f init (rest rst))]
+      (f key val acc)))))
+(defmacro! let*A (fn* [binds form]
+  (let* [formal (_foldr_pairs (fn* [key val acc] (cons key acc)) () binds)
+         actual (_foldr_pairs (fn* [key val acc] (cons val acc)) () binds)]
+    `((fn* ~formal ~form) ~@actual))))
 ;; Fails for (let* [a 1 b (+ 1 a)] b)
-(def! _letB (fn* [binds form]
-  (if (empty? binds)
-    form
-    (list (list 'fn* [(first binds)] (_letB (rest (rest binds)) form))
-          (first (rest binds))))))
+(defmacro! let*B (fn* [binds form]
+  (let* [f (fn* [key val acc]
+                `((fn* [~key] ~acc) ~val))]
+    (_foldr_pairs f form binds))))
 ;; Fails for (let* (cst (fn* (n) (if (= n 0) nil (cst (- n 1))))) (cst 1))
 (def! _c_combinator (fn* [x] (x x)))
 (def! _d_combinator (fn* [f] (fn* [x] (f (fn* [v] ((x x) v))))))
 (def! _Y_combinator (fn* [x] (_c_combinator (_d_combinator x))))
-(def! _letC
-  (fn* [binds form]
-    (if (empty? binds)
-      form
-      (list (list 'fn* [(first binds)] (_letC (rest (rest binds)) form))
-            (list '_Y_combinator (list 'fn* [(first binds)] (first (rest binds))))))))
+(defmacro! let*C (fn* [binds form]
+  (let* [f (fn* [key val acc]
+                `((fn* [~key] ~acc) (_Y_combinator (fn* [~key] ~val))))]
+    (_foldr_pairs f form binds))))
 ;; Fails for mutual recursion.
 ;; See http://okmij.org/ftp/Computation/fixed-point-combinators.html
 ;; if you are motivated to implement solution D.
-(defmacro! let* _letC)
 
 (def! apply
   ;; Replace (f a b [c d]) with ('f 'a 'b 'c 'd) then evaluate the
@@ -156,10 +156,8 @@
     (fn* [xs]
       (reduce update_max 0 xs))))
 
-(def! compose
-  (let* [compose2 (fn* [f acc] (fn* [x] (f (acc x))))]
-    (fn* [& fs]
-      (foldr compose2 identity fs))))
-;; ((compose f1 f2) x) is equivalent to (f1 (f2 x))
-;; This is the mathematical composition. For practical purposes, `->`
-;; and `->>` defined in `core.mal` are more efficient and general.
+;; (fn* [& fs] (foldr (fn* [f acc] (fn* [x] (f (acc x)))) identity fs))
+;; computes the composition of an arbitrary number of functions.
+;; The first anonymous function is the mathematical composition.
+;; For practical purposes, `->` and `->>` in `core.mal` are more
+;; efficient and general.

impls/ada.2/core.adb

@@ -256,6 +256,7 @@ package body Core is
       P ("throw",       Err.Throw'Access);
       P ("time-ms",     Time_Ms'Access);
       P ("vals",        Types.Maps.Vals'Access);
+      P ("vec",         Types.Sequences.Vec'Access);
       P ("vector",      Types.Sequences.Vector'Access);
       P ("with-meta",   With_Meta'Access);
    end NS_Add_To_Repl;

impls/ada.2/step7_quote.adb

@@ -1,5 +1,4 @@
 with Ada.Command_Line;
-with Ada.Containers.Vectors;
 with Ada.Environment_Variables;
 with Ada.Text_IO.Unbounded_IO;
 
@@ -23,7 +22,6 @@ procedure Step7_Quote is
    use all type Types.Kind_Type;
    use type Types.Strings.Instance;
    package ACL renames Ada.Command_Line;
-   package Vectors is new Ada.Containers.Vectors (Positive, Types.T);
 
    function Read return Types.T_Array with Inline;
 
@@ -32,12 +30,7 @@ procedure Step7_Quote is
    function Eval_Builtin (Args : in Types.T_Array) return Types.T;
    --  The built-in variant needs to see the Repl variable.
 
-   function Quasiquote (Ast : in Types.T;
-                        Env : in Envs.Ptr) return Types.T;
-   --  Mergeing quote and quasiquote into eval with a flag triggering
-   --  a different behaviour as done for macros in step8 would improve
-   --  the performances significantly, but Kanaka finds that it breaks
-   --  too much the step structure shared by all implementations.
+   function Quasiquote (Ast : in Types.T) return Types.T;
 
    procedure Print (Ast : in Types.T) with Inline;
 
@@ -174,9 +167,13 @@ procedure Step7_Quote is
                   Ast    => Ast.Sequence.all.Data (3),
                   Env    => Env));
             end;
+         elsif First.Str.all = "quasiquoteexpand" then
+            Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
+            return Quasiquote (Ast.Sequence.all.Data (2));
          elsif First.Str.all = "quasiquote" then
             Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
-            return Quasiquote (Ast.Sequence.all.Data (2), Env);
+            Ast := Quasiquote (Ast.Sequence.all.Data (2));
+            goto Restart;
          else
             --  Equivalent to First := Eval (First, Env)
             --  except that we already know enough to spare a recursive call.
@@ -266,62 +263,54 @@ procedure Step7_Quote is
       Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
    end Print;
 
-   function Quasiquote (Ast : in Types.T;
-                        Env : in Envs.Ptr) return Types.T
-   is
+   function Quasiquote (Ast : in Types.T) return Types.T is
 
-      function Quasiquote_List (List : in Types.T_Array) return Types.T;
-      --  Handle vectors and lists not starting with unquote.
+      function Qq_Seq return Types.T;
+      function Starts_With (Sequence : Types.T_Array;
+                            Symbol   : String) return Boolean;
 
-      function Quasiquote_List (List : in Types.T_Array) return Types.T is
-         Vector : Vectors.Vector; --  buffer for concatenation
-         Tmp    : Types.T;
+      function Qq_Seq return Types.T is
+         Result : Types.T := Types.Sequences.List ((1 .. 0 => Types.Nil));
       begin
-         for Elt of List loop
-            if Elt.Kind in Kind_List
-              and then 0 < Elt.Sequence.all.Length
-              and then Elt.Sequence.all.Data (1).Kind = Kind_Symbol
-              and then Elt.Sequence.all.Data (1).Str.all = "splice-unquote"
+         for Elt of reverse Ast.Sequence.all.Data loop
+            if Elt.Kind = Kind_List
+              and then Starts_With (Elt.Sequence.all.Data, "splice-unquote")
             then
                Err.Check (Elt.Sequence.all.Length = 2,
                           "splice-unquote expects 1 parameter");
-               Tmp := Eval (Elt.Sequence.all.Data (2), Env);
-               Err.Check (Tmp.Kind = Kind_List,
-                          "splice_unquote expects a list");
-               for Sub_Elt of Tmp.Sequence.all.Data loop
-                  Vector.Append (Sub_Elt);
-               end loop;
+               Result := Types.Sequences.List
+                 (((Kind_Symbol, Types.Strings.Alloc ("concat")),
+                   Elt.Sequence.all.Data (2), Result));
             else
-               Vector.Append (Quasiquote (Elt, Env));
+               Result := Types.Sequences.List
+                 (((Kind_Symbol, Types.Strings.Alloc ("cons")),
+                   Quasiquote (Elt), Result));
             end if;
          end loop;
-         --  Now that we know the number of elements, convert to a list.
-         declare
-            Sequence : constant Types.Sequence_Ptr
-              := Types.Sequences.Constructor (Natural (Vector.Length));
-         begin
-            for I in 1 .. Natural (Vector.Length) loop
-               Sequence.all.Data (I) := Vector (I);
-            end loop;
-            return (Kind_List, Sequence);
-         end;
-      end Quasiquote_List;
+         return Result;
+      end Qq_Seq;
 
-   begin                                --  Quasiquote
+      function Starts_With (Sequence : Types.T_Array;
+                            Symbol   : String) return Boolean is
+         (0 < Sequence'Length
+            and then Sequence (Sequence'First).Kind = Kind_Symbol
+            and then Sequence (Sequence'First).Str.all = Symbol);
+
+   begin
       case Ast.Kind is
-         when Kind_Vector =>
-            --  When the test is updated, replace Kind_List with Kind_Vector.
-            return Quasiquote_List (Ast.Sequence.all.Data);
          when Kind_List =>
-            if 0 < Ast.Sequence.all.Length
-              and then Ast.Sequence.all.Data (1).Kind = Kind_Symbol
-              and then Ast.Sequence.all.Data (1).Str.all = "unquote"
-            then
+            if Starts_With (Ast.Sequence.all.Data, "unquote") then
                Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
-               return Eval (Ast.Sequence.all.Data (2), Env);
+               return Ast.Sequence.all.Data (2);
             else
-               return Quasiquote_List (Ast.Sequence.all.Data);
+               return Qq_Seq;
             end if;
+         when Kind_Vector =>
+            return Types.Sequences.List
+              (((Kind_Symbol, Types.Strings.Alloc ("vec")), Qq_Seq));
+         when Kind_Map | Kind_Symbol =>
+            return Types.Sequences.List
+              (((Kind_Symbol, Types.Strings.Alloc ("quote")), Ast));
          when others =>
             return Ast;
       end case;