From a62ac0b66098913f304c589c43cf5e4b0fa077cc Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Tue, 22 Oct 2013 15:41:34 -0400
Subject: [PATCH] Locatives are joined getter/setter values. Better condition
 designators.

---
 base/macros.lisp | 21 +++++++++++++++++----
 1 file changed, 17 insertions(+), 4 deletions(-)

diff --git a/base/macros.lisp b/base/macros.lisp
index a0f5bbf..b39061b 100644
--- a/base/macros.lisp
+++ b/base/macros.lisp
@@ -85,6 +85,14 @@ CMUCL's EXT:ONCE-ONLY has a different interface."
 	  (values ,@store-vars)))))
 |#
 
+(defmacro locative (place &environment env)
+  "Given a place, return as two values a getter and a setter for that place"
+  (multiple-value-bind (vars vals store-vars writer-form reader-form)
+      (get-setf-expansion place env)
+    `(let* (,@(mapcar #'list vars vals))
+       (values
+        #'(lambda () ,reader-form)
+        #'(lambda (,@store-vars) ,writer-form)))))
 
 (defmacro define-values-modify-macro (name val-vars lambda-list function)
   "Multiple-values variant on define-modify macro, by Tim Moore"
@@ -408,19 +416,24 @@ outputs a tag plus a list of variable and their values, returns the last value"
 ; -----------------------------------------------------------------------------
 ;;; Manipulating Source
 
+(defun condition-name-p (name)
+  (and (symbolp name)
+       (subtypep name 'condition)
+       t))
+
 (defun error-behavior (e &rest r)
   "generic way to specify behavior in exceptional situations"
   (etypecase e
-   (function (apply e r))
    (null nil)
    ((eql t) (error "Something bad happened. Check the backtrace."))
-   (cons (apply 'error-behavior (append e r)))
-   ((or string symbol)
+   ((or string (and symbol (satisfies condition-name-p)))
     (with-standard-io-syntax
       (let ((*read-eval* nil)
 	    (*print-readably* nil)
 	    (*print-circle* t))
-	(apply #'error e r))))))
+	(apply #'error e r))))
+   ((or function (and symbol (satisfies fboundp))) (apply e r))
+   (cons (apply 'error-behavior (append e r)))))
 
 (defun form-starting-with-p (tag x)
   (and (consp x) (equal tag (car x))))
-- 
GitLab