1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
|
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
|