From bb805bdb31f980cc2b5168c779ed78d55accf504 Mon Sep 17 00:00:00 2001
From: Douglas Katzman <dougk@google.com>
Date: Sun, 31 May 2015 03:33:24 -0400
Subject: [PATCH] Don't assume that MACRO-FUNCTION returns a simple-fun.

Also don't reinvent PROPER-LIST-P.
---
 NEWS                     |  4 ++++
 src/code/pprint.lisp     | 13 +++++++------
 tests/pprint.impure.lisp | 12 ++++++++++++
 3 files changed, 23 insertions(+), 6 deletions(-)

diff --git a/NEWS b/NEWS
index 1ead761bf..85350d902 100644
--- a/NEWS
+++ b/NEWS
@@ -11,6 +11,10 @@ changes relative to sbcl-1.2.12:
   * bug fix: calls to (SETF SLOT-VALUE) on a missing slot would in certain
     situations incorrectly return the result of a SLOT-MISSING method
     instead of always returning the new value. (lp#1460381)
+  * bug fix: a DEFMACRO occurring not at toplevel and capturing parts of
+    its lexical environment (thus being a closure) caused expressions
+    involving the macro name to cause corruption in the pretty-printer
+    due to faulty introspection of the lambda list of a closure.
 
 changes in sbcl-1.2.12 relative to sbcl-1.2.11:
   * minor incompatible change: the SB-C::*POLICY* variable is no longer
diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp
index 42aa06fb6..f7b637c68 100644
--- a/src/code/pprint.lisp
+++ b/src/code/pprint.lisp
@@ -1442,11 +1442,12 @@ line break."
 ;;; the first N arguments specially then indent any further arguments
 ;;; like a body.
 (defun macro-indentation (name)
-  (labels ((proper-list-p (list)
-             (not (nth-value 1 (ignore-errors (list-length list)))))
-           (macro-arglist (name)
-             (%simple-fun-arglist (macro-function name)))
-           (clean-arglist (arglist)
+  (labels ((clean-arglist (arglist)
+             ;; FIXME: for purposes of introspection, we should never "leak"
+             ;; that a macro uses an &AUX variable, that it takes &WHOLE,
+             ;; or that it cares about its lexenv (though that's debatable).
+             ;; Certainly the first two aspects are not part of the macro's
+             ;; interface, and as such, should not be stored at all.
              "Remove &whole, &enviroment, and &aux elements from ARGLIST."
              (cond ((null arglist) '())
                    ((member (car arglist) '(&whole &environment))
@@ -1454,7 +1455,7 @@ line break."
                    ((eq (car arglist) '&aux)
                     '())
                    (t (cons (car arglist) (clean-arglist (cdr arglist)))))))
-    (let ((arglist (macro-arglist name)))
+    (let ((arglist (%fun-lambda-list (macro-function name))))
       (if (proper-list-p arglist)       ; guard against dotted arglists
           (position '&body (remove '&optional (clean-arglist arglist)))
           nil))))
diff --git a/tests/pprint.impure.lisp b/tests/pprint.impure.lisp
index e1d3199ab..2d54b52ec 100644
--- a/tests/pprint.impure.lisp
+++ b/tests/pprint.impure.lisp
@@ -398,4 +398,16 @@
   (assert (string= (write-to-string (cons 'known-cons (cons 'known-cons t)) :pretty t)
                    "#<KNOWN-CONS #<KNOWN-CONS T>>")))
 
+;; force MACDADDY to be a closure over X.
+(let ((x 3)) (defmacro macdaddy (a b &body z) a b z `(who-cares ,x)) (incf x))
+
+(with-test (:name :closure-macro-arglist)
+  ;; assert correct test setup - MACDADDY is a closure
+  (assert (eq (sb-kernel:fun-subtype (macro-function 'macdaddy))
+              sb-vm:closure-header-widetag))
+  ;; MACRO-INDENTATION used %simple-fun-arglist instead of %fun-arglist.
+  ;; Depending on your luck it would either not return the right answer,
+  ;; or crash, depending on what lay at 4 words past the function address.
+  (assert (= (sb-pretty::macro-indentation 'macdaddy) 2)))
+
 ;;; success
-- 
2.11.4.GIT