From 6fb9452b2bbd3867aa29bb0070d8919c4d1a572d Mon Sep 17 00:00:00 2001
From: "James M. Lawrence" <llmjjmll@gmail.com>
Date: Wed, 2 Nov 2011 18:25:13 +0200
Subject: [PATCH] fix bug in CURRY compiler-macro

  Multiple evaluation of the function argument, oops.
---
 functions.lisp | 12 ++++++++----
 tests.lisp     | 22 ++++++++++++++++++++++
 2 files changed, 30 insertions(+), 4 deletions(-)

diff --git a/functions.lisp b/functions.lisp
index 15032be..f703a99 100644
--- a/functions.lisp
+++ b/functions.lisp
@@ -1,6 +1,8 @@
 (in-package :alexandria)
 
-(declaim (inline ensure-function))	; to propagate return type.
+;;; To propagate return type and allow the compiler to eliminate the IF when
+;;; it is known if the argument is function or not.
+(declaim (inline ensure-function))
 
 (declaim (ftype (function (t) (values function &optional))
                 ensure-function))
@@ -120,11 +122,13 @@ it is called with to FUNCTION."
       (multiple-value-call fn (values-list arguments) (values-list more)))))
 
 (define-compiler-macro curry (function &rest arguments)
-  (let ((curries (make-gensym-list (length arguments) "CURRY")))
-    `(let ,(mapcar #'list curries arguments)
+  (let ((curries (make-gensym-list (length arguments) "CURRY"))
+        (fun (gensym "FUN")))
+    `(let ((,fun (ensure-function ,function))
+           ,@(mapcar #'list curries arguments))
        (declare (optimize (speed 3) (safety 1) (debug 1)))
        (lambda (&rest more)
-         (apply ,function ,@curries more)))))
+         (apply ,fun ,@curries more)))))
 
 (defun rcurry (function &rest arguments)
   "Returns a function that applies the arguments it is called
diff --git a/tests.lisp b/tests.lisp
index a4a8e55..20caf8a 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -508,11 +508,33 @@
         (funcall fun 2)))
   4)
 
+(deftest curry.4
+    (let* ((x 1)
+           (curried (curry (progn
+                             (incf x)
+                             (lambda (y z) (* x y z)))
+                           3)))
+      (list (funcall curried 7)
+            (funcall curried 7)
+            x))
+  (42 42 2))
+
 (deftest rcurry.1
     (let ((r (rcurry '/ 2)))
       (funcall r 8))
   4)
 
+(deftest rcurry.2
+    (let* ((x 1)
+           (curried (rcurry (progn
+                              (incf x)
+                              (lambda (y z) (* x y z)))
+                            3)))
+      (list (funcall curried 7)
+            (funcall curried 7)
+            x))
+  (42 42 2))
+
 (deftest named-lambda.1
     (let ((fac (named-lambda fac (x)
                  (if (> x 1)
-- 
2.11.4.GIT