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.5 2007-09-07 07:28:42 espen Exp $
  24
  25
  26 (in-package "GFFI")
  27
  28
  29 ;;; Accessor functions for raw memory access
  30
  31 (define-memory-accessor int-16)
  32 (define-memory-accessor int-32)
  33 (define-memory-accessor int-64)
  34 (define-memory-accessor uint-16)
  35 (define-memory-accessor uint-32)
  36 (define-memory-accessor uint-64)
  37 (define-memory-accessor single-float)
  38 (define-memory-accessor double-float)
  39
  40
  41 ;;; Vector
  42
  43 (defun make-c-vector (type length &key content location temp)
  44   (let* ((element-size (size-of type))
  45          (location (or location (allocate-memory (* element-size length))))
  46          (writer (writer-function type :temp temp)))
  47     (etypecase content
  48       (vector
  49        (loop
  50         for element across content
  51         for i below length
  52         for offset by element-size
  53         do (funcall writer element location offset)))
  54       (list
  55        (loop
  56         for element in content
  57         for i below length
  58         for offset by element-size
  59         do (funcall writer element location offset))))
  60     location))
  61
  62
  63 (defun map-c-vector (seqtype function location element-type length
  64                      &optional (ref :read))
  65   (let ((reader (reader-function element-type :ref ref))
  66         (element-size (size-of element-type)))
  67     (case seqtype
  68      ((nil)
  69       (loop
  70        for i below length
  71        for offset by element-size
  72        do (funcall function (funcall reader location offset))))
  73      (list
  74       (loop
  75        for i below length
  76        for offset by element-size
  77        collect (funcall function (funcall reader location offset))))
  78      (t
  79       (loop
  80        with sequence = (make-sequence seqtype length)
  81        for i below length
  82        for offset by element-size
  83        do (setf
  84            (elt sequence i)
  85            (funcall function (funcall reader location offset)))
  86        finally (return sequence))))))
  87
  88
  89 (defun unset-c-vector (location element-type length &optional temp-p)
  90   (loop
  91    with destroy = (destroy-function element-type :temp temp-p)
  92    with element-size = (size-of element-type)
  93    for i below length
  94    for offset by element-size
  95    do (funcall destroy location offset)))
  96
  97
  98 (defun destroy-c-vector (location element-type length &optional temp-p)
  99   (unset-c-vector location element-type length temp-p)
 100   (deallocate-memory location))
 101
 102
 103 (defmacro with-c-vector (var type content &body body)
 104   (let ((length (make-symbol "LENGTH")))
 105     `(let ((,length (length ,content)))
 106        (with-memory (,var (* ,(size-of type) ,length))
 107          (make-c-vector ',type ,length :content ,content :location ,var :temp t)
 108          (unwind-protect
 109              (progn ,@body)
 110            (unset-c-vector ,var ',type ,length t))))))
 111
 112
 113 (define-type-method alien-type ((type vector))
 114   (declare (ignore type))
 115   (alien-type 'pointer))
 116
 117 (defun vector-type (type)
 118   (destructuring-bind (element-type &optional (length '*))
 119       (rest (type-expand-to 'vector type))
 120     (if (constantp length)
 121         `(vector ,(return-type element-type) ,length)
 122       `(vector ,(return-type element-type) *))))
 123
 124 (define-type-method argument-type ((type vector))
 125   (vector-type type))
 126
 127 (define-type-method return-type ((type vector))
 128   (vector-type type))
 129
 130 (define-type-method size-of ((type vector) &key inlined)
 131   (if inlined
 132       (destructuring-bind (element-type &optional (length '*))
 133           (rest (type-expand-to 'vector type))
 134         (if (eq length '*)
 135             (error "Can't inline vector with variable size: ~A" type)
 136           (* (size-of element-type) length)))
 137     (size-of 'pointer)))
 138
 139 (define-type-method type-alignment ((type vector) &key inlined)
 140   (if inlined
 141       (destructuring-bind (element-type &optional (length '*))
 142           (rest (type-expand-to 'vector type))
 143         (if (eq length '*)
 144             (error "Can't inline vector with variable size: ~A" type)
 145           (* (type-alignment element-type) length)))
 146     (type-alignment 'pointer)))
 147
 148 (define-type-method alien-arg-wrapper ((type vector) var vector style form &optional copy-in-p)
 149   (destructuring-bind (element-type &optional (length '*))
 150       (rest (type-expand-to 'vector type))
 151     (when (and (eq length '*) (out-arg-p style))
 152       (error "Can't use vector with variable size as return type"))
 153     (cond
 154       ((and (in-arg-p style) copy-in-p)
 155        `(with-pointer (,var `(make-c-vector ',element-type
 156                               ,(if (eq length '*) `(length ,vector) length)
 157                               :content ,vector))
 158          ,form))
 159       ((and (in-arg-p style) (not (out-arg-p style)))
 160        `(with-memory (,var ,(if (eq length '*)
 161                                 `(* ,(size-of element-type)
 162                                     (length ,vector))
 163                               `(* ,(size-of element-type) ,length)))
 164           (make-c-vector ',element-type
 165            ,(if (eq length '*) `(length ,vector) length)
 166            :content ,vector :location ,var :temp t)
 167           (unwind-protect
 168               ,form
 169             (unset-c-vector ,var ',element-type
 170              ,(if (eq length '*) `(length ,vector) length) t))))
 171       ((and (in-arg-p style) (out-arg-p style))
 172        (let ((c-vector (make-symbol "C-VECTOR")))
 173          `(with-memory (,c-vector (* ,(size-of element-type) length))
 174             (make-c-vector ',element-type ,length
 175              :content ,vector :location ,c-vector :temp t)
 176             (with-pointer (,var ,c-vector)
 177               (unwind-protect
 178                   ,form
 179                 (unset-c-vector ,c-vector ',element-type ,length t))))))
 180       ((and (out-arg-p style) (not (in-arg-p style)))
 181        `(with-pointer (,var)
 182           ,form)))))
 183
 184 ;; This will enable us specify vectors with variable length in C callbacks
 185 (define-type-method callback-wrapper ((type vector) var vector form)
 186   (funcall (find-applicable-type-method 'callback-wrapper t) type var vector form))
 187
 188 (define-type-method to-alien-form ((type vector) vector &optional copy-p)
 189   (declare (ignore copy-p))
 190   (destructuring-bind (element-type &optional (length '*))
 191       (rest (type-expand-to 'vector type))
 192     `(make-c-vector ',element-type
 193       ,(if (eq length '*) `(length ,vector) length) :content ,vector)))
 194
 195
 196 (define-type-method from-alien-form ((type vector) form &key (ref :free))
 197   (destructuring-bind (element-type &optional (length '*))
 198       (rest (type-expand-to 'vector type))
 199     (if (eq length '*)
 200         (error "Can't use vector of variable size as return type")
 201       `(let ((c-vector ,form))
 202          (prog1
 203              (map-c-vector 'vector #'identity c-vector ',element-type ,length
 204               ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
 205            ,(when (eq ref :free)
 206               `(deallocate-memory c-vector)))))))
 207
 208
 209 (define-type-method writer-function ((type vector) &key temp inlined)
 210   (destructuring-bind (element-type &optional (length '*))
 211       (rest (type-expand-to 'vector type))
 212     (if inlined
 213         (if (eq length '*)
 214             (error "Can't inline vector with variable size: ~A" type)
 215           #'(lambda (vector location &optional (offset 0))
 216               (make-c-vector element-type length
 217                :location (pointer+ location offset)
 218                :content vector :temp temp)))
 219       #'(lambda (vector location &optional (offset 0))
 220           (setf
 221            (ref-pointer location offset)
 222            (make-c-vector element-type length :content vector :temp temp))))))
 223
 224 (define-type-method reader-function ((type vector) &key (ref :read) 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 reader function for vector with variable size"))
 230      (inlined
 231       #'(lambda (location &optional (offset 0))
 232           (map-c-vector 'vector #'identity (pointer+ location offset)
 233            element-type length ref)))
 234      (t
 235       (ecase ref
 236         ((:read :peek)
 237          #'(lambda (location &optional (offset 0))
 238              (unless (null-pointer-p (ref-pointer location offset))
 239                (map-c-vector 'vector #'identity (ref-pointer location offset)
 240                 element-type length ref))))
 241         (:get
 242          #'(lambda (location &optional (offset 0))
 243              (unless (null-pointer-p (ref-pointer location offset))
 244                (prog1
 245                    (map-c-vector 'vector #'identity
 246                     (ref-pointer location offset) element-type length :get)
 247                  (deallocate-memory (ref-pointer location offset))
 248                  (setf (ref-pointer location offset) (make-pointer 0)))))))))))
 249
 250 (define-type-method destroy-function ((type vector) &key temp inlined)
 251   (destructuring-bind (element-type &optional (length '*))
 252       (rest (type-expand-to 'vector type))
 253     (cond
 254      ((eq length '*)
 255       (error "Can't create destroy function for vector with variable size"))
 256      (inlined
 257       #'(lambda (location &optional (offset 0))
 258           (unset-c-vector (pointer+ location offset)
 259            element-type length temp)))
 260      (t
 261       #'(lambda (location &optional (offset 0))
 262           (unless (null-pointer-p (ref-pointer location offset))
 263             (destroy-c-vector (ref-pointer location offset)
 264              element-type length temp)
 265             (setf (ref-pointer location offset) (make-pointer 0))))))))
 266
 267 (define-type-method copy-function ((type vector) &key inlined)
 268   (destructuring-bind (element-type &optional (length '*))
 269       (rest (type-expand-to 'vector type))
 270     (cond
 271      ((eq length '*) (error "Can't copy vector with variable size: ~A" type))
 272      (inlined
 273       (let ((copy-element (copy-function element-type))
 274             (element-size (size-of element-type)))
 275         #'(lambda (from to &optional (offset 0))
 276             (loop
 277              repeat length
 278              for element from offset by element-size
 279              do (funcall copy-element from to element)))))
 280      (t
 281       (let ((size (* length (size-of element-type)))
 282             (copy-content (copy-function type :inlined t)))
 283         #'(lambda (from to &optional (offset 0))
 284             (unless (null-pointer-p (ref-pointer from offset))
 285               (let ((vector (allocate-memory size)))
 286                 (setf (ref-pointer to offset) vector)
 287                 (funcall copy-content (ref-pointer from offset) vector)))))))))
 288
 289
 290 ;;;; Null terminated vector
 291
 292 (defun make-0-vector (type &key content location temp)
 293   (let* ((element-size (size-of type))
 294          (length (length content))
 295          (location (or location (allocate-memory (* element-size (1+ length))))))
 296     (make-c-vector type length :content content :location location :temp temp)))
 297
 298
 299 (defun map-0-vector (seqtype function location element-type &optional (ref :read))
 300   (let ((reader (reader-function element-type :ref ref))
 301         (element-size (size-of element-type)))
 302     (case seqtype
 303      ((nil)
 304       (loop
 305        for offset by element-size
 306        until (memory-clear-p (pointer+ location offset) element-size)
 307        do (funcall function (funcall reader location offset))))
 308      (list
 309       (loop
 310        for offset by element-size
 311        until (memory-clear-p (pointer+ location offset) element-size)
 312        collect (funcall function (funcall reader location offset))))
 313      (t
 314       (coerce
 315        (loop
 316         for offset by element-size
 317         until (memory-clear-p (pointer+ location offset) element-size)
 318         collect (funcall function (funcall reader location offset)))
 319        seqtype)))))
 320
 321
 322 (defun unset-0-vector (location element-type &optional temp-p)
 323   (loop
 324    with destroy = (destroy-function element-type :temp temp-p)
 325    with element-size = (size-of element-type)
 326    for offset by element-size
 327    until (memory-clear-p (pointer+ location offset) element-size)
 328    do (funcall destroy location offset)))
 329
 330 (defun destroy-0-vector (location element-type &optional temp-p)
 331   (unset-0-vector location element-type temp-p)
 332   (deallocate-memory location))
 333
 334
 335 (deftype vector0 (element-type) `(vector ,element-type))
 336 (deftype null-terminated-vector (element-type) `(vector0 ,element-type))
 337
 338 (define-type-method alien-type ((type vector0))
 339   (declare (ignore type))
 340   (alien-type 'pointer))
 341
 342 (define-type-method size-of ((type vector0) &key inlined)
 343   (assert-not-inlined type inlined)
 344   (size-of 'pointer))
 345
 346 (define-type-method type-alignment ((type vector0) &key inlined)
 347   (assert-not-inlined type inlined)
 348   (type-alignment 'pointer))
 349
 350 (define-type-method alien-arg-wrapper ((type vector0) var vector style form &optional copy-in-p)
 351   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 352     (cond
 353       ((and (in-arg-p style) copy-in-p)
 354        `(with-pointer (,var (make-0-vector ',element-type :content ,vector))
 355           ,form))
 356       ((and (in-arg-p style) (not (out-arg-p style)))
 357        `(with-memory (,var (* ,(size-of element-type) (1+ (length ,vector))))
 358           (make-0-vector ',element-type :content ,vector :location ,var :temp t)
 359           (unwind-protect
 360               ,form
 361             (unset-0-vector ,var ',element-type t))))
 362       ((and (in-arg-p style) (out-arg-p style))
 363        (let ((c-vector (make-symbol "C-VECTOR")))
 364          `(with-memory (,c-vector (* ,(size-of element-type) (1+ (length ,vector))))
 365             (make-0-vector ',element-type :content ,vector :location ,c-vector :temp t)
 366             (with-pointer (,var ,c-vector)
 367               (unwind-protect
 368                   ,form
 369                 (unset-0-vector ,c-vector ',element-type t))))))
 370       ((and (out-arg-p style) (not (in-arg-p style)))
 371        `(with-pointer (,var)
 372           ,form)))))
 373
 374
 375 (define-type-method to-alien-form ((type vector0) vector &optional copy-p)
 376   (declare (ignore copy-p))
 377   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 378     `(make-0-vector ',element-type :content ,vector)))
 379
 380 (define-type-method from-alien-form ((type vector0) form  &key (ref :free))
 381   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 382     `(let ((c-vector ,form))
 383        (prog1
 384            (map-0-vector 'vector #'identity c-vector ',element-type
 385             ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
 386          ,(when (eq ref :free)
 387             `(deallocate-memory c-vector))))))
 388
 389
 390 (define-type-method writer-function ((type vector0) &key temp inlined)
 391   (assert-not-inlined type inlined)
 392   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 393     #'(lambda (vector location &optional (offset 0))
 394         (setf
 395          (ref-pointer location offset)
 396          (make-0-vector element-type :content vector :temp temp)))))
 397
 398 (define-type-method reader-function ((type vector0) &key (ref :read) inlined)
 399   (assert-not-inlined type inlined)
 400   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 401     (ecase ref
 402       ((:read :peek)
 403        #'(lambda (location &optional (offset 0))
 404            (unless (null-pointer-p (ref-pointer location offset))
 405              (map-0-vector 'vector #'identity (ref-pointer location offset)
 406               element-type ref))))
 407       (:get
 408        #'(lambda (location &optional (offset 0))
 409            (unless (null-pointer-p (ref-pointer location offset))
 410              (prog1
 411                  (map-0-vector 'vector #'identity (ref-pointer location offset)
 412                   element-type :get)
 413                (deallocate-memory (ref-pointer location offset))
 414                (setf (ref-pointer location offset) (make-pointer 0)))))))))
 415
 416
 417 (define-type-method destroy-function ((type vector0) &key temp inlined)
 418   (assert-not-inlined type inlined)
 419   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 420     #'(lambda (location &optional (offset 0))
 421           (unless (null-pointer-p (ref-pointer location offset))
 422             (destroy-0-vector
 423              (ref-pointer location offset) element-type temp)
 424             (setf (ref-pointer location offset) (make-pointer 0))))))
 425
 426 (define-type-method copy-function ((type vector0) &key inlined)
 427   (assert-not-inlined type inlined)
 428   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 429     (let ((copy-element (copy-function element-type))
 430           (element-size (size-of element-type)))
 431       #'(lambda (from to &optional (offset 0))
 432           (unless (null-pointer-p (ref-pointer from offset))
 433             (let* ((from-vector (ref-pointer from offset))
 434                    (length
 435                     (loop
 436                      for length from 0
 437                      for element by element-size
 438                      until (memory-clear-p from-vector element-size element)
 439                      finally (return length)))
 440                    (to-vector
 441                     (setf (ref-pointer to offset)
 442                      (allocate-memory (* (1+ length) element-size)))))
 443               (loop
 444                repeat length
 445                for element by element-size
 446                do (funcall copy-element from-vector to-vector element))))))))
 447
 448 (define-type-method unbound-value ((type vector0))
 449   (declare (ignore type))
 450   nil)
 451
 452
 453
 454 ;;;; Counted vector
 455
 456 (defun make-counted-vector (type &key content location (counter-type 'unsigned-int) temp)
 457   (let* ((element-size (size-of type))
 458          (length (length content))
 459          (location (or
 460                     location
 461                     (allocate-memory
 462                      (+ (size-of counter-type) (* element-size length))))))
 463     (funcall (writer-function counter-type :temp temp) length location)
 464     (make-c-vector type length :content content :location (pointer+ location (size-of counter-type)))
 465     location))
 466
 467 (defun map-counted-vector (seqtype function location element-type &optional (counter-type 'unsigned-int) (ref :read))
 468   (let ((length (funcall (reader-function counter-type) location :ref ref)))
 469     (map-c-vector
 470      seqtype function (pointer+ location (size-of counter-type))
 471      element-type length)))
 472
 473 (defun unset-counted-vector (location element-type &optional (counter-type 'unsigned-int) temp-p)
 474   (let ((length (funcall (reader-function counter-type) location)))
 475     (unset-c-vector
 476      (pointer+ location (size-of counter-type)) element-type length temp-p)))
 477
 478 (defun destroy-counted-vector (location element-type &optional (counter-type 'unsigned-int) temp-p)
 479   (unset-counted-vector location element-type counter-type temp-p)
 480   (deallocate-memory location))
 481
 482
 483 (deftype counted-vector (element-type &optional counter-type)
 484   (declare (ignore counter-type))
 485   `(vector ,element-type))
 486
 487 (define-type-method alien-type ((type counted-vector))
 488   (declare (ignore type))
 489   (alien-type 'pointer))
 490
 491 (define-type-method size-of ((type counted-vector) &key inlined)
 492   (assert-not-inlined type inlined)
 493   (size-of 'pointer))
 494
 495 (define-type-method type-alignment ((type counted-vector) &key inlined)
 496   (assert-not-inlined type inlined)
 497   (type-alignment 'pointer))
 498
 499 (define-type-method alien-arg-wrapper ((type counted-vector) var vector style form &optional copy-in-p)
 500   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 501       (rest (type-expand-to 'counted-vector type))
 502     (cond
 503       ((and (in-arg-p style) copy-in-p)
 504        `(with-pointer (,var (make-counted-vector ',element-type
 505                              :content ,vector :counter-type ',counter-type))
 506           ,form))
 507       ((and (in-arg-p style) (not (out-arg-p style)))
 508        `(with-memory (,var (+ (* ,(size-of element-type) (length ,vector)) ,(size-of counter-type)))
 509           (make-counted-vector ',element-type :content ,vector
 510            :location ,var :counter-type ',counter-type :temp t)
 511           (unwind-protect
 512               ,form
 513             (unset-counted-vector ,var ',element-type ',counter-type t))))
 514       ((and (in-arg-p style) (out-arg-p style))
 515        (let ((c-vector (make-symbol "C-VECTOR")))
 516          `(with-memory (,c-vector (+ (* ,(size-of element-type) (length ,vector)) ,(size-of counter-type)))
 517             (make-counted-vector ',element-type :content ,vector ,c-vector
 518              :counter-type ',counter-type :temp t)
 519             (with-pointer (,var ,c-vector)
 520               (unwind-protect
 521                   ,form
 522                 (unset-counted-vector ,c-vector ',element-type ',counter-type t))))))
 523       ((and (out-arg-p style) (not (in-arg-p style)))
 524        `(with-pointer (,var)
 525           ,form)))))
 526
 527
 528 (define-type-method to-alien-form ((type counted-vector) vector &optional copy-p)
 529   (declare (ignore copy-p))
 530   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 531       (rest (type-expand-to 'counted-vector type))
 532     `(make-counted-vector ',element-type
 533       :content ,vector :counter-type ',counter-type)))
 534
 535 (define-type-method from-alien-form ((type counted-vector) form  &key (ref :free))
 536   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 537       (rest (type-expand-to 'counted-vector type))
 538     `(let ((c-vector ,form))
 539        (prog1
 540            (map-counted-vector 'vector #'identity c-vector ',element-type ',counter-type
 541             ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
 542          ,(when (eq ref :free)
 543             `(deallocate c-vector))))))
 544
 545 (define-type-method writer-function ((type counted-vector) &key temp inlined)
 546   (assert-not-inlined type inlined)
 547   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 548       (rest (type-expand-to 'counted-vector type))
 549     #'(lambda (vector location &optional (offset 0))
 550         (setf
 551          (ref-pointer location offset)
 552          (make-counted-vector element-type :content vector
 553           :counter-type counter-type :temp temp)))))
 554
 555 (define-type-method reader-function ((type counted-vector) &key (ref :read) inlined)
 556   (assert-not-inlined type inlined)
 557   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 558       (rest (type-expand-to 'counted-vector type))
 559     (ecase ref
 560       ((:read :peek)
 561        #'(lambda (location &optional (offset 0))
 562            (unless (null-pointer-p (ref-pointer location offset))
 563              (map-counted-vector 'vector #'identity
 564               (ref-pointer location offset) element-type counter-type ref))))
 565       (:get
 566        #'(lambda (location &optional (offset 0))
 567            (unless (null-pointer-p (ref-pointer location offset))
 568              (prog1
 569                  (map-counted-vector 'vector #'identity
 570                   (ref-pointer location offset) element-type counter-type :get)
 571                (deallocate-memory (ref-pointer location offset))
 572                (setf (ref-pointer location offset) (make-pointer 0)))))))))
 573
 574 (define-type-method destroy-function ((type counted-vector) &key temp inlined)
 575   (assert-not-inlined type inlined)
 576   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 577       (rest (type-expand-to 'counted-vector type))
 578     #'(lambda (location &optional (offset 0))
 579         (unless (null-pointer-p (ref-pointer location offset))
 580           (destroy-counted-vector (ref-pointer location offset)
 581            element-type counter-type temp)
 582           (setf (ref-pointer location offset) (make-pointer 0))))))
 583
 584 (define-type-method copy-function ((type counted-vector) &key inlined)
 585   (assert-not-inlined type inlined)
 586   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 587       (rest (type-expand-to 'counted-vector type))
 588     (let ((vector-length (reader-function counter-type))
 589           (counter-size (size-of counter-type))
 590           (copy-element (copy-function element-type))
 591           (element-size (size-of element-type)))
 592       #'(lambda (from to &optional (offset 0))
 593           (unless (null-pointer-p (ref-pointer from offset))
 594             (let* ((from-vector (ref-pointer from offset))
 595                    (length (funcall vector-length from-vector))
 596                    (to-vector  (setf
 597                                 (ref-pointer to offset)
 598                                 (allocate-memory (+ counter-size (* length element-size))))))
 599               (copy-memory from-vector counter-size to-vector)
 600               (loop
 601                repeat length
 602                for element from counter-size by element-size
 603                do (funcall copy-element from-vector to-vector element))))))))
 604
 605
 606 ;;;; Accessor functions for raw memory access
 607
 608 (defun vector-reader-function (type &key (start 0) end)
 609   "Returns a function for reading values from raw C vectors"
 610   (let ((element-size (size-of type))
 611         (reader (reader-function type)))
 612     #'(lambda (vector index)
 613         (assert (and (>= index start) (or (not end) (< index end))))
 614         (funcall reader vector (* index element-size)))))
 615
 616 (defun vector-writer-function (type &key (start 0) end)
 617   "Returns a function for writing values to raw C vectors"
 618   (let ((element-size (size-of type))
 619         (writer (writer-function type)))
 620     #'(lambda (value vector index)
 621         (assert (and (>= index start) (or (not end) (< index end))))
 622         (funcall writer value vector (* index element-size)))))
 623
 624
 625 (defmacro define-vector-accessor (type)
 626   (let ((name (intern (format nil "VECTOR-REF-~A" type)))
 627         (ref (intern (format nil "REF-~A" type))))
 628     `(progn
 629        (declaim
 630         (ftype (function (pointer fixnum) ,type) ,name)
 631         (inline ,name))
 632        (defun ,name (vector index)
 633          (,ref vector (* ,(size-of type) index)))
 634        (declaim
 635         (ftype (function (,type pointer fixnum) ,type) (setf ,name))
 636         (inline (setf ,name)))
 637        (defun (setf ,name) (value vector index)
 638          (setf (,ref vector (* ,(size-of type) index)) value)))))
 639
 640 (define-vector-accessor int-8)
 641 (define-vector-accessor uint-8)
 642 (define-vector-accessor int-16)
 643 (define-vector-accessor uint-16)
 644 (define-vector-accessor int-32)
 645 (define-vector-accessor uint-32)
 646 (define-vector-accessor int-64)
 647 (define-vector-accessor uint-64)
 648 (define-vector-accessor double-float)
 649 (define-vector-accessor single-float)
 650