chiark - git - mdw - clg/blob - gffi/vectors.lisp

   1 ;; Common Lisp bindings for GTK+ 2.x
   2 ;; Copyright 1999-2006 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: vectors.lisp,v 1.2 2006-06-08 13:24:25 espen Exp $
  24
  25
  26 (in-package "GFFI")
  27
  28 ;;; Vector
  29
  30 (defun make-c-vector (type length &key content location temp)
  31   (let* ((element-size (size-of type))
  32          (location (or location (allocate-memory (* element-size length))))
  33          (writer (writer-function type :temp temp)))
  34     (etypecase content
  35       (vector
  36        (loop
  37         for element across content
  38         for i below length
  39         for offset by element-size
  40         do (funcall writer element location offset)))
  41       (list
  42        (loop
  43         for element in content
  44         for i below length
  45         for offset by element-size
  46         do (funcall writer element location offset))))
  47     location))
  48
  49
  50 (defun map-c-vector (seqtype function location element-type length
  51                      &optional (ref :read))
  52   (let ((reader (reader-function element-type :ref ref))
  53         (element-size (size-of element-type)))
  54     (case seqtype
  55      ((nil)
  56       (loop
  57        for i below length
  58        for offset by element-size
  59        do (funcall function (funcall reader location offset))))
  60      (list
  61       (loop
  62        for i below length
  63        for offset by element-size
  64        collect (funcall function (funcall reader location offset))))
  65      (t
  66       (loop
  67        with sequence = (make-sequence seqtype length)
  68        for i below length
  69        for offset by element-size
  70        do (setf
  71            (elt sequence i)
  72            (funcall function (funcall reader location offset)))
  73        finally (return sequence))))))
  74
  75
  76 (defun unset-c-vector (location element-type length &optional temp-p)
  77   (loop
  78    with destroy = (destroy-function element-type :temp temp-p)
  79    with element-size = (size-of element-type)
  80    for i below length
  81    for offset by element-size
  82    do (funcall destroy location offset)))
  83
  84
  85 (defun destroy-c-vector (location element-type length &optional temp-p)
  86   (unset-c-vector location element-type length temp-p)
  87   (deallocate-memory location))
  88
  89
  90 (defmacro with-c-vector (var type content &body body)
  91   (let ((length (make-symbol "LENGTH")))
  92     `(let ((,length (length ,content)))
  93        (with-memory (,var (* ,(size-of type) ,length))
  94          (make-c-vector ',type ,length :content ,content :location ,var :temp t)
  95          (unwind-protect
  96              (progn ,@body)
  97            (unset-c-vector ,var ',type ,length t))))))
  98
  99
 100 (define-type-method alien-type ((type vector))
 101   (declare (ignore type))
 102   (alien-type 'pointer))
 103
 104 (define-type-method size-of ((type vector) &key inlined)
 105   (if inlined
 106       (destructuring-bind (element-type &optional (length '*))
 107           (rest (type-expand-to 'vector type))
 108         (if (eq length '*)
 109             (error "Can't inline vector with variable size: ~A" type)
 110           (* (size-of element-type) length)))
 111     (size-of 'pointer)))
 112
 113 (define-type-method type-alignment ((type vector) &key inlined)
 114   (if inlined
 115       (destructuring-bind (element-type &optional (length '*))
 116           (rest (type-expand-to 'vector type))
 117         (if (eq length '*)
 118             (error "Can't inline vector with variable size: ~A" type)
 119           (* (type-alignment element-type) length)))
 120     (type-alignment 'pointer)))
 121
 122 (define-type-method alien-arg-wrapper ((type vector) var vector style form &optional copy-in-p)
 123   (destructuring-bind (element-type &optional (length '*))
 124       (rest (type-expand-to 'vector type))
 125     (when (and (eq length '*) (out-arg-p style))
 126       (error "Can't use vector with variable size as return type"))
 127     (cond
 128       ((and (in-arg-p style) copy-in-p)
 129        `(with-pointer (,var `(make-c-vector ',element-type
 130                               ,(if (eq length '*) `(length ,vector) length)
 131                               :content ,vector))
 132          ,form))
 133       ((and (in-arg-p style) (not (out-arg-p style)))
 134        `(with-memory (,var ,(if (eq length '*)
 135                                 `(* ,(size-of element-type)
 136                                     (length ,vector))
 137                               `(* ,(size-of element-type) ,length)))
 138           (make-c-vector ',element-type
 139            ,(if (eq length '*) `(length ,vector) length)
 140            :content ,vector :location ,var :temp t)
 141           (unwind-protect
 142               ,form
 143             (unset-c-vector ,var ',element-type
 144              ,(if (eq length '*) `(length ,vector) length) t))))
 145       ((and (in-arg-p style) (out-arg-p style))
 146        (let ((c-vector (make-symbol "C-VECTOR")))
 147          `(with-memory (,c-vector (* ,(size-of element-type) length))
 148             (make-c-vector ',element-type ,length
 149              :content ,vector :location ,c-vector :temp t)
 150             (with-pointer (,var ,c-vector)
 151               (unwind-protect
 152                   ,form
 153                 (unset-c-vector ,c-vector ',element-type ,length t))))))
 154       ((and (out-arg-p style) (not (in-arg-p style)))
 155        `(with-pointer (,var)
 156           ,form)))))
 157
 158 ;; This will enable us specify vectors with variable length in C callbacks
 159 (define-type-method callback-wrapper ((type vector) var vector form)
 160   (funcall (find-applicable-type-method 'callback-wrapper t) type var vector form))
 161
 162 (define-type-method to-alien-form ((type vector) vector &optional copy-p)
 163   (declare (ignore copy-p))
 164   (destructuring-bind (element-type &optional (length '*))
 165       (rest (type-expand-to 'vector type))
 166     `(make-c-vector ',element-type
 167       ,(if (eq length '*) `(length ,vector) length) :content ,vector)))
 168
 169
 170 (define-type-method from-alien-form ((type vector) form &key (ref :free))
 171   (destructuring-bind (element-type &optional (length '*))
 172       (rest (type-expand-to 'vector type))
 173     (if (eq length '*)
 174         (error "Can't use vector of variable size as return type")
 175       `(let ((c-vector ,form))
 176          (prog1
 177              (map-c-vector 'vector #'identity c-vector ',element-type ,length
 178               ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
 179            ,(when (eq ref :free)
 180               `(deallocate-memory c-vector)))))))
 181
 182
 183 (define-type-method writer-function ((type vector) &key temp inlined)
 184   (destructuring-bind (element-type &optional (length '*))
 185       (rest (type-expand-to 'vector type))
 186     (if inlined
 187         (if (eq length '*)
 188             (error "Can't inline vector with variable size: ~A" type)
 189           #'(lambda (vector location &optional (offset 0))
 190               (make-c-vector element-type length
 191                :location (pointer+ location offset)
 192                :content vector :temp temp)))
 193       #'(lambda (vector location &optional (offset 0))
 194           (setf
 195            (ref-pointer location offset)
 196            (make-c-vector element-type length :content vector :temp temp))))))
 197
 198 (define-type-method reader-function ((type vector) &key (ref :read) inlined)
 199   (destructuring-bind (element-type &optional (length '*))
 200       (rest (type-expand-to 'vector type))
 201     (cond
 202      ((eq length '*)
 203       (error "Can't create reader function for vector with variable size"))
 204      (inlined
 205       #'(lambda (location &optional (offset 0))
 206           (map-c-vector 'vector #'identity (pointer+ location offset)
 207            element-type length ref)))
 208      (t
 209       (ecase ref
 210         ((:read :peek)
 211          #'(lambda (location &optional (offset 0))
 212              (unless (null-pointer-p (ref-pointer location offset))
 213                (map-c-vector 'vector #'identity (ref-pointer location offset)
 214                 element-type length ref))))
 215         (:get
 216          #'(lambda (location &optional (offset 0))
 217              (unless (null-pointer-p (ref-pointer location offset))
 218                (prog1
 219                    (map-c-vector 'vector #'identity
 220                     (ref-pointer location offset) element-type length :get)
 221                  (deallocate-memory (ref-pointer location offset))
 222                  (setf (ref-pointer location offset) (make-pointer 0)))))))))))
 223
 224 (define-type-method destroy-function ((type vector) &key temp inlined)
 225   (destructuring-bind (element-type &optional (length '*))
 226       (rest (type-expand-to 'vector type))
 227     (cond
 228      ((eq length '*)
 229       (error "Can't create destroy function for vector with variable size"))
 230      (inlined
 231       #'(lambda (location &optional (offset 0))
 232           (unset-c-vector (pointer+ location offset)
 233            element-type length temp)))
 234      (t
 235       #'(lambda (location &optional (offset 0))
 236           (unless (null-pointer-p (ref-pointer location offset))
 237             (destroy-c-vector (ref-pointer location offset)
 238              element-type length temp)
 239             (setf (ref-pointer location offset) (make-pointer 0))))))))
 240
 241 (define-type-method copy-function ((type vector) &key inlined)
 242   (destructuring-bind (element-type &optional (length '*))
 243       (rest (type-expand-to 'vector type))
 244     (cond
 245      ((eq length '*) (error "Can't copy vector with variable size: ~A" type))
 246      (inlined
 247       (let ((copy-element (copy-function element-type))
 248             (element-size (size-of element-type)))
 249         #'(lambda (from to &optional (offset 0))
 250             (loop
 251              repeat length
 252              for element from offset by element-size
 253              do (funcall copy-element from to element)))))
 254      (t
 255       (let ((size (* length (size-of element-type)))
 256             (copy-content (copy-function type :inlined t)))
 257         #'(lambda (from to &optional (offset 0))
 258             (unless (null-pointer-p (ref-pointer from offset))
 259               (let ((vector (allocate-memory size)))
 260                 (setf (ref-pointer to offset) vector)
 261                 (funcall copy-content (ref-pointer from offset) vector)))))))))
 262
 263
 264 ;;;; Null terminated vector
 265
 266 (defun make-0-vector (type &key content location temp)
 267   (let* ((element-size (size-of type))
 268          (length (length content))
 269          (location (or location (allocate-memory (* element-size (1+ length))))))
 270     (make-c-vector type length :content content :location location :temp temp)))
 271
 272
 273 (defun map-0-vector (seqtype function location element-type &optional (ref :read))
 274   (let ((reader (reader-function element-type :ref ref))
 275         (element-size (size-of element-type)))
 276     (case seqtype
 277      ((nil)
 278       (loop
 279        for offset by element-size
 280        until (memory-clear-p (pointer+ location offset) element-size)
 281        do (funcall function (funcall reader location offset))))
 282      (list
 283       (loop
 284        for offset by element-size
 285        until (memory-clear-p (pointer+ location offset) element-size)
 286        collect (funcall function (funcall reader location offset))))
 287      (t
 288       (coerce
 289        (loop
 290         for offset by element-size
 291         until (memory-clear-p (pointer+ location offset) element-size)
 292         collect (funcall function (funcall reader location offset)))
 293        seqtype)))))
 294
 295
 296 (defun unset-0-vector (location element-type &optional temp-p)
 297   (loop
 298    with destroy = (destroy-function element-type temp-p)
 299    with element-size = (size-of element-type)
 300    for offset by element-size
 301    until (memory-clear-p (pointer+ location offset) element-size)
 302    do (funcall destroy location offset)))
 303
 304 (defun destroy-0-vector (location element-type &optional temp-p)
 305   (unset-0-vector location element-type temp-p)
 306   (deallocate-memory location))
 307
 308
 309 (deftype vector0 (element-type) `(vector ,element-type))
 310 (deftype null-terminated-vector (element-type) `(vector0 ,element-type))
 311
 312 (define-type-method alien-type ((type vector0))
 313   (declare (ignore type))
 314   (alien-type 'pointer))
 315
 316 (define-type-method size-of ((type vector0) &key inlined)
 317   (assert-not-inlined type inlined)
 318   (size-of 'pointer))
 319
 320 (define-type-method type-alignment ((type vector0) &key inlined)
 321   (assert-not-inlined type inlined)
 322   (type-alignment 'pointer))
 323
 324 (define-type-method alien-arg-wrapper ((type vector0) var vector style form &optional copy-in-p)
 325   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 326     (cond
 327       ((and (in-arg-p style) copy-in-p)
 328        `(with-pointer (,var (make-0-vector ',element-type :content ,vector))
 329           ,form))
 330       ((and (in-arg-p style) (not (out-arg-p style)))
 331        `(with-memory (,var (* ,(size-of element-type) (1+ (length ,vector))))
 332           (make-0-vector ',element-type :content ,vector :location ,var :temp t)
 333           (unwind-protect
 334               ,form
 335             (unset-0-vector ,var ',element-type t))))
 336       ((and (in-arg-p style) (out-arg-p style))
 337        (let ((c-vector (make-symbol "C-VECTOR")))
 338          `(with-memory (,c-vector (* ,(size-of element-type) (1+ (length ,vector))))
 339             (make-0-vector ',element-type :content ,vector :location ,c-vector :temp t)
 340             (with-pointer (,var ,c-vector)
 341               (unwind-protect
 342                   ,form
 343                 (unset-0-vector ,c-vector ',element-type t))))))
 344       ((and (out-arg-p style) (not (in-arg-p style)))
 345        `(with-pointer (,var)
 346           ,form)))))
 347
 348
 349 (define-type-method to-alien-form ((type vector0) vector &optional copy-p)
 350   (declare (ignore copy-p))
 351   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 352     `(make-0-vector ',element-type :content ,vector)))
 353
 354 (define-type-method from-alien-form ((type vector0) form  &key (ref :free))
 355   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 356     `(let ((c-vector ,form))
 357        (prog1
 358            (map-0-vector 'vector #'identity c-vector ',element-type
 359             ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
 360          ,(when (eq ref :free)
 361             `(deallocate-memory c-vector))))))
 362
 363
 364 (define-type-method writer-function ((type vector0) &key temp inlined)
 365   (assert-not-inlined type inlined)
 366   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 367     #'(lambda (vector location &optional (offset 0))
 368         (setf
 369          (ref-pointer location offset)
 370          (make-0-vector element-type :content vector :temp temp)))))
 371
 372 (define-type-method reader-function ((type vector0) &key (ref :read) inlined)
 373   (assert-not-inlined type inlined)
 374   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 375     (ecase ref
 376       ((:read :peek)
 377        #'(lambda (location &optional (offset 0))
 378            (unless (null-pointer-p (ref-pointer location offset))
 379              (map-0-vector 'vector #'identity (ref-pointer location offset)
 380               element-type ref))))
 381       (:get
 382        #'(lambda (location &optional (offset 0))
 383            (unless (null-pointer-p (ref-pointer location offset))
 384              (prog1
 385                  (map-0-vector 'vector #'identity (ref-pointer location offset)
 386                   element-type :get)
 387                (deallocate-memory (ref-pointer location offset))
 388                (setf (ref-pointer location offset) (make-pointer 0)))))))))
 389
 390
 391 (define-type-method destroy-function ((type vector0) &key temp inlined)
 392   (assert-not-inlined type inlined)
 393   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 394     #'(lambda (location &optional (offset 0))
 395           (unless (null-pointer-p (ref-pointer location offset))
 396             (destroy-0-vector
 397              (ref-pointer location offset) element-type temp)
 398             (setf (ref-pointer location offset) (make-pointer 0))))))
 399
 400 (define-type-method copy-function ((type vector0) &key inlined)
 401   (assert-not-inlined type inlined)
 402   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 403     (let ((copy-element (copy-function element-type))
 404           (element-size (size-of element-type)))
 405       #'(lambda (from to &optional (offset 0))
 406           (unless (null-pointer-p (ref-pointer from offset))
 407             (let* ((from-vector (ref-pointer from offset))
 408                    (length
 409                     (loop
 410                      for length from 0
 411                      for element by element-size
 412                      until (memory-clear-p from-vector element-size element)
 413                      finally (return length)))
 414                    (to-vector (setf
 415                                (ref-pointer to offset)
 416                                (allocate-memory (* length element-size)))))
 417               (loop
 418                repeat length
 419                for element by element-size
 420                do (funcall copy-element from-vector to-vector element))))))))
 421
 422 (define-type-method unbound-value ((type vector0))
 423   (declare (ignore type))
 424   nil)
 425
 426
 427
 428 ;;;; Counted vector
 429
 430 (defun make-counted-vector (type &key content location (counter-type 'unsigned-int) temp)
 431   (let* ((element-size (size-of type))
 432          (length (length content))
 433          (location (or
 434                     location
 435                     (allocate-memory
 436                      (+ (size-of counter-type) (* element-size length))))))
 437     (funcall (writer-function counter-type :temp temp) length location)
 438     (make-c-vector type length :content content :location (pointer+ location (size-of counter-type)))
 439     location))
 440
 441 (defun map-counted-vector (seqtype function location element-type &optional (counter-type 'unsigned-int) (ref :read))
 442   (let ((length (funcall (reader-function counter-type) location :ref ref)))
 443     (map-c-vector
 444      seqtype function (pointer+ location (size-of counter-type))
 445      element-type length)))
 446
 447 (defun unset-counted-vector (location element-type &optional (counter-type 'unsigned-int) temp-p)
 448   (let ((length (funcall (reader-function counter-type) location)))
 449     (unset-c-vector
 450      (pointer+ location (size-of counter-type)) element-type length temp-p)))
 451
 452 (defun destroy-counted-vector (location element-type &optional (counter-type 'unsigned-int) temp-p)
 453   (unset-counted-vector location element-type counter-type temp-p)
 454   (deallocate-memory location))
 455
 456
 457 (deftype counted-vector (element-type &optional counter-type)
 458   (declare (ignore counter-type))
 459   `(vector ,element-type))
 460
 461 (define-type-method alien-type ((type counted-vector))
 462   (declare (ignore type))
 463   (alien-type 'pointer))
 464
 465 (define-type-method size-of ((type counted-vector) &key inlined)
 466   (assert-not-inlined type inlined)
 467   (size-of 'pointer))
 468
 469 (define-type-method type-alignment ((type counted-vector) &key inlined)
 470   (assert-not-inlined type inlined)
 471   (type-alignment 'pointer))
 472
 473 (define-type-method alien-arg-wrapper ((type counted-vector) var vector style form &optional copy-in-p)
 474   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 475       (rest (type-expand-to 'counted-vector type))
 476     (cond
 477       ((and (in-arg-p style) copy-in-p)
 478        `(with-pointer (,var (make-counted-vector ',element-type
 479                              :content ,vector :counter-type ',counter-type))
 480           ,form))
 481       ((and (in-arg-p style) (not (out-arg-p style)))
 482        `(with-memory (,var (+ (* ,(size-of element-type) (length ,vector)) ,(size-of counter-type)))
 483           (make-counted-vector ',element-type :content ,vector
 484            :location ,var :counter-type ',counter-type :temp t)
 485           (unwind-protect
 486               ,form
 487             (unset-counted-vector ,var ',element-type ',counter-type t))))
 488       ((and (in-arg-p style) (out-arg-p style))
 489        (let ((c-vector (make-symbol "C-VECTOR")))
 490          `(with-memory (,c-vector (+ (* ,(size-of element-type) (length ,vector)) ,(size-of counter-type)))
 491             (make-counted-vector ',element-type :content ,vector ,c-vector
 492              :counter-type ',counter-type :temp t)
 493             (with-pointer (,var ,c-vector)
 494               (unwind-protect
 495                   ,form
 496                 (unset-counted-vector ,c-vector ',element-type ',counter-type t))))))
 497       ((and (out-arg-p style) (not (in-arg-p style)))
 498        `(with-pointer (,var)
 499           ,form)))))
 500
 501
 502 (define-type-method to-alien-form ((type counted-vector) vector &optional copy-p)
 503   (declare (ignore copy-p))
 504   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 505       (rest (type-expand-to 'counted-vector type))
 506     `(make-counted-vector ',element-type
 507       :content ,vector :counter-type ',counter-type)))
 508
 509 (define-type-method from-alien-form ((type counted-vector) form  &key (ref :free))
 510   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 511       (rest (type-expand-to 'counted-vector type))
 512     `(let ((c-vector ,form))
 513        (prog1
 514            (map-counted-vector 'vector #'identity c-vector ',element-type ',counter-type
 515             ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
 516          ,(when (eq ref :free)
 517             `(deallocate c-vector))))))
 518
 519 (define-type-method writer-function ((type counted-vector) &key temp inlined)
 520   (assert-not-inlined type inlined)
 521   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 522       (rest (type-expand-to 'counted-vector type))
 523     #'(lambda (vector location &optional (offset 0))
 524         (setf
 525          (ref-pointer location offset)
 526          (make-counted-vector element-type :content vector
 527           :counter-type counter-type :temp temp)))))
 528
 529 (define-type-method reader-function ((type counted-vector) &key (ref :read) inlined)
 530   (assert-not-inlined type inlined)
 531   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 532       (rest (type-expand-to 'counted-vector type))
 533     (ecase ref
 534       ((:read :peek)
 535        #'(lambda (location &optional (offset 0))
 536            (unless (null-pointer-p (ref-pointer location offset))
 537              (map-counted-vector 'vector #'identity
 538               (ref-pointer location offset) element-type counter-type ref))))
 539       (:get
 540        #'(lambda (location &optional (offset 0))
 541            (unless (null-pointer-p (ref-pointer location offset))
 542              (prog1
 543                  (map-counted-vector 'vector #'identity
 544                   (ref-pointer location offset) element-type counter-type :get)
 545                (deallocate-memory (ref-pointer location offset))
 546                (setf (ref-pointer location offset) (make-pointer 0)))))))))
 547
 548 (define-type-method destroy-function ((type counted-vector) &key temp inlined)
 549   (assert-not-inlined type inlined)
 550   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 551       (rest (type-expand-to 'counted-vector type))
 552     #'(lambda (location &optional (offset 0))
 553         (unless (null-pointer-p (ref-pointer location offset))
 554           (destroy-counted-vector (ref-pointer location offset)
 555            element-type counter-type temp)
 556           (setf (ref-pointer location offset) (make-pointer 0))))))
 557
 558 (define-type-method copy-function ((type counted-vector) &key inlined)
 559   (assert-not-inlined type inlined)
 560   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 561       (rest (type-expand-to 'counted-vector type))
 562     (let ((vector-length (reader-function counter-type))
 563           (counter-size (size-of counter-type))
 564           (copy-element (copy-function element-type))
 565           (element-size (size-of element-type)))
 566       #'(lambda (from to &optional (offset 0))
 567           (unless (null-pointer-p (ref-pointer from offset))
 568             (let* ((from-vector (ref-pointer from offset))
 569                    (length (funcall vector-length from-vector))
 570                    (to-vector  (setf
 571                                 (ref-pointer to offset)
 572                                 (allocate-memory (+ counter-size (* length element-size))))))
 573               (copy-memory from-vector counter-size to-vector)
 574               (loop
 575                repeat length
 576                for element from counter-size by element-size
 577                do (funcall copy-element from-vector to-vector element))))))))