From abacb5b59dd5c157e9277a959e60f6ed765388c1 Mon Sep 17 00:00:00 2001
From: Douglas Katzman <dougk@google.com>
Date: Fri, 11 Aug 2017 09:16:45 -0400
Subject: [PATCH] Remove deprecated CLOBBER-IT restart

---
 NEWS                        |  4 ++++
 src/code/defstruct.lisp     | 24 ++++++++++++++++--------
 tests/defstruct.impure.lisp | 22 ++++++++++++++++++++++
 3 files changed, 42 insertions(+), 8 deletions(-)

diff --git a/NEWS b/NEWS
index 70ad45e52..430c5e650 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,9 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 changes relative to sbcl-1.3.20:
+  * minor incompatible change: the CLOBBER-IT restart for defstruct redefintion
+    has been removed after a 15 year deprecation cycle. Use the new name,
+    RECKLESSLY-CONTINUE. Note also that this restart is hidden if deemed unsafe
+    due to altered placement of untagged slots in the structure.
   * enhancement: backends using the generational GC are able to relocate
     dynamic space anywhere the operating system places it.
     This feature can be disabled by removing :relocatable-heap from the
diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 4bcec9a1c..2679da42b 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -1329,6 +1329,19 @@ or they must be declared locally notinline at each call site.~@:>"
          name moved retyped deleted)
         t))))
 
+;;; Return true if destructively modifying OLD-LAYOUT into NEW-LAYOUT
+;;; would be possible in as much as it won't harm the garbage collector.
+;;; Harm potentially results from turning a raw word into a tagged word.
+(defun mutable-layout-p (old-layout new-layout)
+  (let ((old-bitmap (layout-bitmap old-layout))
+        (new-bitmap (layout-bitmap new-layout)))
+    (assert (= old-bitmap (dd-bitmap (layout-info old-layout))))
+    (assert (= new-bitmap (dd-bitmap (layout-info new-layout))))
+    (dotimes (i (dd-length (layout-info old-layout)) t)
+      (when (and (logbitp i new-bitmap) ; a tagged (i.e. scavenged) slot
+                 (not (logbitp i old-bitmap))) ; that was opaque bits
+        (return nil)))))
+
 ;;; This function is called when we are incompatibly redefining a
 ;;; structure CLASS to have the specified NEW-LAYOUT. We signal an
 ;;; error with some proceed options and return the layout that should
@@ -1349,6 +1362,9 @@ or they must be declared locally notinline at each call site.~@:>"
                          name))
        (register-layout new-layout))
       (recklessly-continue ()
+       :test (lambda (c)
+               (declare (ignore c))
+               (mutable-layout-p old-layout new-layout))
        :report (lambda (s)
                  (format s
                          "~@<Use the new definition of ~S as if it were ~
@@ -1360,14 +1376,6 @@ or they must be declared locally notinline at each call site.~@:>"
        ;; I hope you know what you're doing..."
        (register-layout new-layout
                         :invalidate nil
-                        :destruct-layout old-layout))
-      (clobber-it ()
-       ;; FIXME: deprecated 2002-10-16, and since it's only interactive
-       ;; hackery instead of a supported feature, can probably be deleted
-       ;; in early 2003
-       :report "(deprecated synonym for RECKLESSLY-CONTINUE)"
-       (register-layout new-layout
-                        :invalidate nil
                         :destruct-layout old-layout))))
   (values))
 
diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index bd5f02eff..1ced89600 100644
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -1396,3 +1396,25 @@ redefinition."
 
   (compare-memory *c* 2 *acdf* 2 4) ; Array
   (compare-memory *c* 2 (make-struct-cdf) 2 4)) ; Structure
+
+(test-util:with-test (:name :recklessly-continuable-defstruct)
+  (flet ((redefine-defstruct (from to)
+           (eval from)
+           (handler-bind
+               ((error (lambda (c)
+                         (declare (ignore c))
+                         (return-from redefine-defstruct
+                           ;; RESTARTs are DX, don't return it.
+                           (not (null (find 'sb-kernel::recklessly-continue
+                                            (compute-restarts)
+                                            :key 'restart-name))))))
+                (warning #'muffle-warning))
+               (eval to))))
+    (assert (not (redefine-defstruct
+                  '(defstruct not-redefinable (a 0 :type sb-ext:word))
+                  '(defstruct not-redefinable (a)))))
+    (assert (redefine-defstruct
+             ;; Incompatible types has nothing to do with whether
+             ;; RECKLESSLY-CONTINUE is offered.
+             '(defstruct redefinable (a nil :type symbol))
+             '(defstruct redefinable (a nil :type cons))))))
-- 
2.11.4.GIT