guix/gnu/packages/patches/sbcl-png-fix-sbcl-compatibility.patch

From 60bbad167b0691995a659121acda55392e4021b6 Mon Sep 17 00:00:00 2001
From: Andrew Berkley <ajb@dwavesys.com>
Date: Sun, 4 Jul 2021 12:50:34 -0700
Subject: [PATCH] Fix for sbcl 2.1.6

---
 compat.lisp | 30 +++++++++++++++---------------
 1 file changed, 15 insertions(+), 15 deletions(-)

diff --git a/compat.lisp b/compat.lisp
index 95a9869..ea6d1a1 100644
--- a/compat.lisp
+++ b/compat.lisp
@@ -1,12 +1,13 @@
 (in-package #:png)
 
-#+sbcl ; Present in SBCL 1.0.24.
-(declaim (ftype (function (array) (values (simple-array * (*)) &optional))
-                array-storage-vector))
-
 #+sbcl
-(defun array-storage-vector (array)
-  "Returns the underlying storage vector of ARRAY, which must be a non-displaced array.
+(macrolet ((make-array-storage-vector ()
+             (let ((%array-data-vector (or (find-symbol "%ARRAY-DATA-VECTOR" :sb-kernel)
+                                           (find-symbol "%ARRAY-DATA" :sb-kernel)))) ;; renamed in sbcl 2.1.6
+               `(progn
+                  (declaim (ftype (function (array) (values (simple-array * (*)) &optional)) array-storage-vector))
+                  (defun array-storage-vector (array)
+                    "Returns the underlying storage vector of ARRAY, which must be a non-displaced array.
 
 In SBCL, if ARRAY is a of type \(SIMPLE-ARRAY * \(*)), it is its own storage
 vector. Multidimensional arrays, arrays with fill pointers, and adjustable
@@ -16,15 +17,14 @@ ARRAY, which this function returns.
 Important note: the underlying vector is an implementation detail. Even though
 this function exposes it, changes in the implementation may cause this
 function to be removed without further warning."
-  ;; KLUDGE: Without TRULY-THE the system is not smart enough to
-  ;; figure out that the return value is always of the known type.
-  (sb-ext:truly-the (simple-array * (*))
-             (if (sb-kernel:array-header-p array)
-                 (if (sb-kernel:%array-displaced-p array)
-                     (error "~S cannot be used with displaced arrays. Use ~S instead."
-                            'array-storage-vector 'array-displacement)
-                     (sb-kernel:%array-data-vector array))
-                 array)))
+                    (sb-ext:truly-the (simple-array * (*))
+                                      (if (sb-kernel:array-header-p array)
+                                          (if (sb-kernel:%array-displaced-p array)
+                                              (error "~S cannot be used with displaced arrays. Use ~S instead."
+                                                     'array-storage-vector 'array-displacement)
+                                              (,%array-data-vector array))
+                                          array)))))))
+  (make-array-storage-vector))
 
 #+allegro
 (defmacro with-pointer-to-array-data ((ptr-var array) &body body)
-- 
2.33.0