在 common lisp 中，如何以可移植的方式检查对象的类型

Question

我想定义一个专门处理具有无符号字节 8 元素的数组类型对象的方法。在 sbcl 中，当您 (make-array x :element-type '(unsigned-byte 8)) 时，对象类由 SB-KERNEL::SIMPLE-ARRAY-UNSIGNED-BYTE-8 实现。是否有一种独立于实现的方式专门研究无符号字节数组类型？

Answer 1

使用尖号点在读取时插入实现依赖的对象类：

(defmethod foo ((v #.(class-of (make-array 0 :element-type '(unsigned-byte 8)))))
  :unsigned-byte-8-array)

sharpsign-dot 读取器宏在读取时评估表单，确定数组的类别。该方法将专门针对特定 Common Lisp 实现用于数组的类。

Answer 2

请注意，MAKE-ARRAY 的 :ELEMENT-TYPE 参数做了一些特殊的事情，它的确切行为可能有点令人惊讶。

通过使用它，您告诉 Common Lisp ARRAY 应该能够存储该元素类型或其某些子类型的项目。

Common Lisp 系统然后将返回一个可以存储这些元素的数组。它可能是一个专门的数组，也可能是一个还可以存储更通用元素的数组。

注意：它不是类型声明，不一定会在编译或运行时检查。

UPGRADED-ARRAY-ELEMENT-TYPE 函数告诉你一个数组实际上可以升级到什么元素。

LispWorks 64 位：

CL-USER 10 > (upgraded-array-element-type '(unsigned-byte 8))
(UNSIGNED-BYTE 8)

CL-USER 11 > (upgraded-array-element-type '(unsigned-byte 4))
(UNSIGNED-BYTE 4)

CL-USER 12 > (upgraded-array-element-type '(unsigned-byte 12))
(UNSIGNED-BYTE 16)

因此，Lispworks 64 位具有用于 4 位和 8 位元素的特殊数组。对于 12 位元素，它分配一个数组，最多可以存储 16 位元素。

我们生成一个可以存储十个最多 12 位的数组：

CL-USER 13 > (make-array 10
                         :element-type '(unsigned-byte 12)
                         :initial-element 0)
#(0 0 0 0 0 0 0 0 0 0)

让我们检查一下它的类型：

CL-USER 14 > (type-of *)
(SIMPLE-ARRAY (UNSIGNED-BYTE 16) (10))

它是一个简单的数组（不可调整，无填充指针）。 它可以存储(UNSIGNED-BYTE 16) 类型的元素及其子类型。 它的长度为 10，只有一维。

Answer 3

在普通函数中，您可以使用 etypecase 进行调度：

以下代码不是独立的，但应该提供一个如何实现的想法 当对 3D 数组偶数时执行逐点操作的函数：

(.* (make-array 3 :element-type 'single-float
                :initial-contents '(1s0 2s0 3s0))
    (make-array 3 :element-type 'single-float
                :initial-contents '(2s0 2s0 3s0)))

代码如下：

(def-generator (point-wise (op rank type) :override-name t)
  (let ((name (format-symbol ".~a-~a-~a" op rank type)))
    (store-new-function name)
    `(defun ,name (a b &optional (b-start (make-vec-i)))
       (declare ((simple-array ,long-type ,rank) a b)
                (vec-i b-start)
                (values (simple-array ,long-type ,rank) &optional))
       (let ((result (make-array (array-dimensions b)
                                 :element-type ',long-type)))
         ,(ecase rank
            (1 `(destructuring-bind (x)
                   (array-dimensions b)
                 (let ((sx (vec-i-x b-start)))
                   (do-region ((i) (x))
                     (setf (aref result i)
                           (,op (aref a (+ i sx))
                              (aref b i)))))))
            (2 `(destructuring-bind (y x)
                   (array-dimensions b)
                 (let ((sx (vec-i-x b-start))
                       (sy (vec-i-y b-start)))
                   (do-region ((j i) (y x))
                     (setf (aref result j i)
                           (,op (aref a (+ j sy) (+ i sx))
                              (aref b j i)))))))
            (3 `(destructuring-bind (z y x)
                   (array-dimensions b)
                 (let ((sx (vec-i-x b-start))
                       (sy (vec-i-y b-start))
                       (sz (vec-i-z b-start)))
                   (do-region ((k j i) (z y x))
                     (setf (aref result k j i)
                         (,op (aref a (+ k sz) (+ j sy) (+ i sx))
                            (aref b k j i))))))))
         result))))
#+nil
(def-point-wise-op-rank-type * 1 sf)

(defmacro def-point-wise-functions (ops ranks types)
  (let ((specific-funcs nil)
        (generic-funcs nil))
    (loop for rank in ranks do
         (loop for type in types do
              (loop for op in ops do
                   (push `(def-point-wise-op-rank-type ,op ,rank ,type)
                         specific-funcs))))
    (loop for op in ops do
         (let ((cases nil))
           (loop for rank in ranks do
                (loop for type in types do
                     (push `((simple-array ,(get-long-type type) ,rank)
                             (,(format-symbol  ".~a-~a-~a" op rank type) 
                               a b b-start))
                           cases)))
           (let ((name (format-symbol ".~a" op)))
             (store-new-function name)
            (push `(defun ,name (a b &optional (b-start (make-vec-i)))
                       (etypecase a
                         ,@cases
                         (t (error "The given type can't be handled with a generic
                 point-wise function."))))  
                  generic-funcs))))
    `(progn ,@specific-funcs
            ,@generic-funcs)))

(def-point-wise-functions (+ - * /) (1 2 3) (ub8 sf df csf cdf))