From cbccc782f34477c924ea8ff7b6000cd52511a768 Mon Sep 17 00:00:00 2001
From: Benjamin Saunders <ralith@gmail.com>
Date: Sat, 7 Apr 2012 13:19:19 -0700
Subject: [PATCH] Added PROG1-LET

---
 binding.lisp |   27 +++++++++++++++++++++++++++
 package.lisp |    1 +
 tests.lisp   |   24 ++++++++++++++++++++++++
 3 files changed, 52 insertions(+)

diff --git a/binding.lisp b/binding.lisp
index 36d92bc..27db561 100644
--- a/binding.lisp
+++ b/binding.lisp
@@ -91,3 +91,30 @@ PROGN."
          (when ,(caar binding-list)
            ,@(bind (cdr binding-list) forms))))))
 
+(defmacro prog1-let (bindings &body forms)
+  "Creates new variable bindings and executes FORMS, returning the initial
+value of the first binding.
+
+BINDINGS must be either single binding of the form:
+
+ (variable initial-form)
+
+or a list of bindings of the form:
+
+ ((variable   initial-form)
+  (variable-2 initial-form-2)
+  ...
+  (variable-n initial-form-n))
+
+All initial-forms are executed sequentially in the specified order, then all
+the variables are bound to the corresponding values and FORMS are executed
+as an implicit PROGN. Finally, the value returned by INITIAL-FORM is
+returned."
+  (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+                           (list bindings)
+                           bindings))
+         (variables (mapcar #'car binding-list)))
+    `(let ,binding-list
+       (prog1 ,(first variables)
+         ,@forms))))
+
diff --git a/package.lisp b/package.lisp
index 673ed30..4bb5b56 100644
--- a/package.lisp
+++ b/package.lisp
@@ -11,6 +11,7 @@
    #:if-let
    #:when-let
    #:when-let*
+   #:prog1-let
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; REVIEW IN PROGRESS
    ;;
diff --git a/tests.lisp b/tests.lisp
index b875382..8a2dbeb 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -1779,6 +1779,30 @@
         :type-error))
   :type-error)
 
+(deftest prog1-let.1
+    (prog1-let (x :ok)
+      :oops)
+  :ok)
+
+(deftest prog1-let.2
+    (prog1-let ((x :ok)
+                (y :oops))
+      y)
+  :ok)
+
+(deftest prog1-let.3
+    (prog1-let (x (opaque :ok))
+      (setf x :oops))
+  :ok)
+
+(deftest prog1-let.error.1
+    (handler-case
+        (eval '(prog1-let x :oops))
+      (type-error ()
+        :type-error))
+  :type-error)
+
+
 (deftest doplist.1
     (let (keys values)
       (doplist (k v '(a 1 b 2 c 3) (values t (reverse keys) (reverse values) k v))
-- 
1.7.9.5