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.8 2008-04-30 17:35:48 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 (define-type-method argument-type ((type vector))
 118   (declare (ignore type))
 119   'sequence)
 120
 121 (define-type-method return-type ((type vector))
 122   (destructuring-bind (element-type &optional (length '*))
 123       (rest (type-expand-to 'vector type))
 124     (if (constantp length)
 125         `(vector ,(return-type element-type) ,length)
 126       `(vector ,(return-type element-type) *))))
 127
 128 (define-type-method size-of ((type vector) &key inlined)
 129   (if inlined
 130       (destructuring-bind (element-type &optional (length '*))
 131           (rest (type-expand-to 'vector type))
 132         (if (eq length '*)
 133             (error "Can't inline vector with variable size: ~A" type)
 134           (* (size-of element-type) length)))
 135     (size-of 'pointer)))
 136
 137 (define-type-method type-alignment ((type vector) &key inlined)
 138   (if inlined
 139       (destructuring-bind (element-type &optional (length '*))
 140           (rest (type-expand-to 'vector type))
 141         (if (eq length '*)
 142             (error "Can't inline vector with variable size: ~A" type)
 143           (* (type-alignment element-type) length)))
 144     (type-alignment 'pointer)))
 145
 146 (define-type-method alien-arg-wrapper ((type vector) var vector style form &optional copy-in-p)
 147   (destructuring-bind (element-type &optional (length '*))
 148       (rest (type-expand-to 'vector type))
 149     (when (and (eq length '*) (out-arg-p style))
 150       (error "Can't use vector with variable size as return type"))
 151     (cond
 152       ((and (in-arg-p style) copy-in-p)
 153        `(with-pointer (,var `(make-c-vector ',element-type
 154                               ,(if (eq length '*) `(length ,vector) length)
 155                               :content ,vector))
 156          ,form))
 157       ((and (in-arg-p style) (not (out-arg-p style)))
 158        `(with-memory (,var ,(if (eq length '*)
 159                                 `(* ,(size-of element-type)
 160                                     (length ,vector))
 161                               `(* ,(size-of element-type) ,length)))
 162           (make-c-vector ',element-type
 163            ,(if (eq length '*) `(length ,vector) length)
 164            :content ,vector :location ,var :temp t)
 165           (unwind-protect
 166               ,form
 167             (unset-c-vector ,var ',element-type
 168              ,(if (eq length '*) `(length ,vector) length) t))))
 169       ((and (in-arg-p style) (out-arg-p style))
 170        (let ((c-vector (make-symbol "C-VECTOR")))
 171          `(with-memory (,c-vector (* ,(size-of element-type) length))
 172             (make-c-vector ',element-type ,length
 173              :content ,vector :location ,c-vector :temp t)
 174             (with-pointer (,var ,c-vector)
 175               (unwind-protect
 176                   ,form
 177                 (unset-c-vector ,c-vector ',element-type ,length t))))))
 178       ((and (out-arg-p style) (not (in-arg-p style)))
 179        `(with-pointer (,var)
 180           ,form)))))
 181
 182 ;; This will enable us specify vectors with variable length in C callbacks
 183 (define-type-method callback-wrapper ((type vector) var vector form)
 184   (funcall (find-applicable-type-method 'callback-wrapper t) type var vector form))
 185
 186 (define-type-method to-alien-form ((type vector) vector &optional copy-p)
 187   (declare (ignore copy-p))
 188   (destructuring-bind (element-type &optional (length '*))
 189       (rest (type-expand-to 'vector type))
 190     `(make-c-vector ',element-type
 191       ,(if (eq length '*) `(length ,vector) length) :content ,vector)))
 192
 193
 194 (define-type-method from-alien-form ((type vector) form &key (ref :free))
 195   (destructuring-bind (element-type &optional (length '*))
 196       (rest (type-expand-to 'vector type))
 197     (if (eq length '*)
 198         (error "Can't use vector of variable size as return type")
 199       `(let ((c-vector ,form))
 200          (prog1
 201              (map-c-vector 'vector #'identity c-vector ',element-type ,length
 202               ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
 203            ,(when (eq ref :free)
 204               `(deallocate-memory c-vector)))))))
 205
 206
 207 (define-type-method writer-function ((type vector) &key temp inlined)
 208   (destructuring-bind (element-type &optional (length '*))
 209       (rest (type-expand-to 'vector type))
 210     (if inlined
 211         (if (eq length '*)
 212             (error "Can't inline vector with variable size: ~A" type)
 213           #'(lambda (vector location &optional (offset 0))
 214               (make-c-vector element-type length
 215                :location (pointer+ location offset)
 216                :content vector :temp temp)))
 217       #'(lambda (vector location &optional (offset 0))
 218           (setf
 219            (ref-pointer location offset)
 220            (make-c-vector element-type length :content vector :temp temp))))))
 221
 222 (define-type-method reader-function ((type vector) &key (ref :read) inlined)
 223   (destructuring-bind (element-type &optional (length '*))
 224       (rest (type-expand-to 'vector type))
 225     (cond
 226      ((eq length '*)
 227       (error "Can't create reader function for vector with variable size"))
 228      (inlined
 229       #'(lambda (location &optional (offset 0))
 230           (map-c-vector 'vector #'identity (pointer+ location offset)
 231            element-type length ref)))
 232      (t
 233       (ecase ref
 234         ((:read :peek)
 235          #'(lambda (location &optional (offset 0))
 236              (unless (null-pointer-p (ref-pointer location offset))
 237                (map-c-vector 'vector #'identity (ref-pointer location offset)
 238                 element-type length ref))))
 239         (:get
 240          #'(lambda (location &optional (offset 0))
 241              (unless (null-pointer-p (ref-pointer location offset))
 242                (prog1
 243                    (map-c-vector 'vector #'identity
 244                     (ref-pointer location offset) element-type length :get)
 245                  (deallocate-memory (ref-pointer location offset))
 246                  (setf (ref-pointer location offset) (make-pointer 0)))))))))))
 247
 248 (define-type-method destroy-function ((type vector) &key temp inlined)
 249   (destructuring-bind (element-type &optional (length '*))
 250       (rest (type-expand-to 'vector type))
 251     (cond
 252      ((eq length '*)
 253       (error "Can't create destroy function for vector with variable size"))
 254      (inlined
 255       #'(lambda (location &optional (offset 0))
 256           (unset-c-vector (pointer+ location offset)
 257            element-type length temp)))
 258      (t
 259       #'(lambda (location &optional (offset 0))
 260           (unless (null-pointer-p (ref-pointer location offset))
 261             (destroy-c-vector (ref-pointer location offset)
 262              element-type length temp)
 263             (setf (ref-pointer location offset) (make-pointer 0))))))))
 264
 265 (define-type-method copy-function ((type vector) &key inlined)
 266   (destructuring-bind (element-type &optional (length '*))
 267       (rest (type-expand-to 'vector type))
 268     (cond
 269      ((eq length '*) (error "Can't copy vector with variable size: ~A" type))
 270      (inlined
 271       (let ((copy-element (copy-function element-type))
 272             (element-size (size-of element-type)))
 273         #'(lambda (from to &optional (offset 0))
 274             (loop
 275              repeat length
 276              for element from offset by element-size
 277              do (funcall copy-element from to element)))))
 278      (t
 279       (let ((size (* length (size-of element-type)))
 280             (copy-content (copy-function type :inlined t)))
 281         #'(lambda (from to &optional (offset 0))
 282             (unless (null-pointer-p (ref-pointer from offset))
 283               (let ((vector (allocate-memory size)))
 284                 (setf (ref-pointer to offset) vector)
 285                 (funcall copy-content (ref-pointer from offset) vector)))))))))
 286
 287
 288 ;;;; Unboxed vector
 289
 290 (deftype unboxed-vector (element-type &optional (length '*))
 291   `(simple-array ,element-type (,length)))
 292
 293 (define-type-method argument-type ((type unboxed-vector))
 294   type)
 295
 296 (define-type-method return-type ((type unboxed-vector))
 297   (destructuring-bind (element-type &optional (length '*))
 298       (rest (type-expand-to 'unboxed-vector type))
 299     (if (constantp length)
 300         `(unboxed-vector ,(return-type element-type) ,length)
 301       `(unboxed-vector ,(return-type element-type) *))))
 302
 303 (defun check-unboxed-vector (type)
 304   #+(or sbcl cmu)
 305   (unless (subtypep type 'simple-unboxed-array)
 306     (error "~A is not a subtype of ~A" type 'simple-unboxed-array)))
 307
 308 #+(or sbcl cmu)
 309 (progn
 310   (define-type-method alien-arg-wrapper ((type unboxed-vector) var vector style form &optional copy-in-p)
 311     (check-unboxed-vector type)
 312     (destructuring-bind (element-type &optional (length '*))
 313         (rest (type-expand-to 'unboxed-vector type))
 314       (when (and (eq length '*) (out-arg-p style))
 315         (error "Can't use vector with variable size as return type"))
 316       (cond
 317         ((and (in-arg-p style) copy-in-p)
 318          `(with-pointer (,var (with-pinned-objects (,vector)
 319                                 (copy-memory (vector-sap ,vector)
 320                                  (* (length ,vector) ,(size-of element-type)))))
 321             ,form))
 322         ((in-arg-p style)
 323          `(with-pinned-objects (,vector)
 324             (let ((,var (vector-sap ,vector)))
 325               ,form)))
 326         ((out-arg-p style)
 327          `(with-pointer (,var)
 328             ,form)))))
 329
 330   (define-type-method to-alien-form ((type unboxed-vector) vector &optional copy-p)
 331     (declare (ignore copy-p))
 332     (check-unboxed-vector type)
 333     (destructuring-bind (element-type &optional (length '*))
 334         (rest (type-expand-to 'unboxed-vector type))
 335       `(with-pinned-objects (,vector)
 336          (copy-memory
 337           (vector-sap ,vector)
 338           (* ,(if (eq length '*) `(length ,vector) length)
 339              ,(size-of element-type))))))
 340
 341
 342   (define-type-method from-alien-form ((type unboxed-vector) form &key (ref :free))
 343     (check-unboxed-vector type)
 344     (destructuring-bind (element-type &optional (length '*))
 345         (rest (type-expand-to 'unboxed-vector type))
 346       (when (eq length '*)
 347         (error "Can't use vector of variable size as return type"))
 348       `(let ((c-vector ,form)
 349              (vector (make-array ,length :element-type ',element-type)))
 350          (with-pinned-objects (vector)
 351            (copy-memory c-vector (* ,length ,(size-of element-type)) (vector-sap vector))
 352            ,(when (eq ref :free)
 353              `(deallocate-memory c-vector))
 354            vector))))
 355
 356   (define-type-method writer-function ((type unboxed-vector) &key temp inlined)
 357     (declare (ignore temp))
 358     (check-unboxed-vector type)
 359     (destructuring-bind (element-type &optional (length '*))
 360         (rest (type-expand-to 'unboxed-vector type))
 361       (if inlined
 362           (if (eq length '*)
 363               (error "Can't inline vector with variable size: ~A" type)
 364               #'(lambda (vector location &optional (offset 0))
 365                   (with-pinned-objects (vector)
 366                     (copy-memory
 367                      (vector-sap vector)
 368                      (* length (size-of element-type))
 369                      (pointer+ location offset)))))
 370           #'(lambda (vector location &optional (offset 0))
 371               (setf
 372                (ref-pointer location offset)
 373                (with-pinned-objects (vector)
 374                  (copy-memory (vector-sap vector)
 375                   (* (length vector) (size-of element-type)))))))))
 376
 377   (define-type-method reader-function ((type unboxed-vector) &key (ref :read) inlined)
 378     (check-unboxed-vector type)
 379     (destructuring-bind (element-type &optional (length '*))
 380         (rest (type-expand-to 'unboxed-vector type))
 381       (cond
 382         ((eq length '*)
 383          (error "Can't create reader function for vector with variable size"))
 384         (inlined
 385          #'(lambda (location &optional (offset 0))
 386              (let ((vector (make-array length :element-type element-type)))
 387                (with-pinned-objects (vector)
 388                  (copy-memory
 389                   (pointer+ location offset)
 390                   (* length (size-of element-type))
 391                   (vector-sap vector))
 392                  vector))))
 393         (t
 394          #'(lambda (location &optional (offset 0))
 395              (let ((vector (make-array length :element-type element-type)))
 396                (unless (null-pointer-p (ref-pointer location offset))
 397                  (with-pinned-objects (vector)
 398                    (copy-memory
 399                     (ref-pointer location offset)
 400                     (* (length vector) (size-of element-type))
 401                     (vector-sap vector)))
 402                  (when (eq ref :get)
 403                    (deallocate-memory (ref-pointer location offset))
 404                    (setf (ref-pointer location offset) (make-pointer 0)))
 405                  vector))))))))
 406
 407
 408 #-(or sbcl cmu)
 409 (progn
 410   (define-type-method alien-arg-wrapper ((type unboxed-vector) var vector style form &optional copy-in-p)
 411     (check-unboxed-vector type)
 412     (destructuring-bind (element-type &optional (length '*))
 413         (rest (type-expand-to 'unboxed-vector type))
 414       (alien-arg-wrapper `(vector ,element-type ,length) var vector style form copy-in-p)))
 415
 416   (define-type-method to-alien-form ((type unboxed-vector) vector &optional copy-p)
 417     (check-unboxed-vector type)
 418     (destructuring-bind (element-type &optional (length '*))
 419         (rest (type-expand-to 'unboxed-vector type))
 420       (to-alien-form `(vector ,element-type ,length) vector copy-p)))
 421
 422   (define-type-method from-alien-form ((type unboxed-vector) form &key (ref :free))
 423     (check-unboxed-vector type)
 424     (destructuring-bind (element-type &optional (length '*))
 425         (rest (type-expand-to 'unboxed-vector type))
 426       (from-alien-form `(vector ,element-type ,length) form :ref ref)))
 427
 428   (define-type-method writer-function ((type unboxed-vector) &key temp inlined)
 429     (check-unboxed-vector type)
 430     (destructuring-bind (element-type &optional (length '*))
 431         (rest (type-expand-to 'unboxed-vector type))
 432       (writer-function `(vector ,element-type ,length) :temp temp :inlined inlined)))
 433
 434   (define-type-method reader-function ((type unboxed-vector) &key (ref :read) inlined)
 435     (check-unboxed-vector type)
 436     (destructuring-bind (element-type &optional (length '*))
 437         (rest (type-expand-to 'unboxed-vector type))
 438       (reader-function `(vector ,element-type ,length) :ref ref :inlined inlined))))
 439
 440 (define-type-method destroy-function ((type unboxed-vector) &key temp inlined)
 441   (declare (ignore temp))
 442   (check-unboxed-vector type)
 443   (destructuring-bind (element-type &optional (length '*))
 444       (rest (type-expand-to 'unboxed-vector type))
 445     (cond
 446      #+sbcl
 447      ((eq length '*)
 448       (error "Can't create destroy function for vector with variable size"))
 449      (inlined
 450       #'(lambda (location &optional (offset 0))
 451           (clear-memory location (* length (size-of element-type)) offset)))
 452      (t
 453       #'(lambda (location &optional (offset 0))
 454           (unless (null-pointer-p (ref-pointer location offset))
 455             (deallocate-memory (ref-pointer location offset))
 456             (setf (ref-pointer location offset) (make-pointer 0))))))))
 457
 458
 459 ;;;; Null terminated vector
 460
 461 (defun make-0-vector (type &key content location temp)
 462   (let* ((element-size (size-of type))
 463          (length (length content))
 464          (location (or location (allocate-memory (* element-size (1+ length))))))
 465     (make-c-vector type length :content content :location location :temp temp)))
 466
 467
 468 (defun map-0-vector (seqtype function location element-type &optional (ref :read))
 469   (let ((reader (reader-function element-type :ref ref))
 470         (element-size (size-of element-type)))
 471     (case seqtype
 472      ((nil)
 473       (loop
 474        for offset by element-size
 475        until (memory-clear-p (pointer+ location offset) element-size)
 476        do (funcall function (funcall reader location offset))))
 477      (list
 478       (loop
 479        for offset by element-size
 480        until (memory-clear-p (pointer+ location offset) element-size)
 481        collect (funcall function (funcall reader location offset))))
 482      (t
 483       (coerce
 484        (loop
 485         for offset by element-size
 486         until (memory-clear-p (pointer+ location offset) element-size)
 487         collect (funcall function (funcall reader location offset)))
 488        seqtype)))))
 489
 490
 491 (defun unset-0-vector (location element-type &optional temp-p)
 492   (loop
 493    with destroy = (destroy-function element-type :temp temp-p)
 494    with element-size = (size-of element-type)
 495    for offset by element-size
 496    until (memory-clear-p (pointer+ location offset) element-size)
 497    do (funcall destroy location offset)))
 498
 499 (defun destroy-0-vector (location element-type &optional temp-p)
 500   (unset-0-vector location element-type temp-p)
 501   (deallocate-memory location))
 502
 503
 504 (deftype vector0 (element-type) `(vector ,element-type))
 505 (deftype null-terminated-vector (element-type) `(vector0 ,element-type))
 506
 507 (define-type-method alien-type ((type vector0))
 508   (declare (ignore type))
 509   (alien-type 'pointer))
 510
 511 (define-type-method size-of ((type vector0) &key inlined)
 512   (assert-not-inlined type inlined)
 513   (size-of 'pointer))
 514
 515 (define-type-method type-alignment ((type vector0) &key inlined)
 516   (assert-not-inlined type inlined)
 517   (type-alignment 'pointer))
 518
 519 (define-type-method alien-arg-wrapper ((type vector0) var vector style form &optional copy-in-p)
 520   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 521     (cond
 522       ((and (in-arg-p style) copy-in-p)
 523        `(with-pointer (,var (make-0-vector ',element-type :content ,vector))
 524           ,form))
 525       ((and (in-arg-p style) (not (out-arg-p style)))
 526        `(with-memory (,var (* ,(size-of element-type) (1+ (length ,vector))))
 527           (make-0-vector ',element-type :content ,vector :location ,var :temp t)
 528           (unwind-protect
 529               ,form
 530             (unset-0-vector ,var ',element-type t))))
 531       ((and (in-arg-p style) (out-arg-p style))
 532        (let ((c-vector (make-symbol "C-VECTOR")))
 533          `(with-memory (,c-vector (* ,(size-of element-type) (1+ (length ,vector))))
 534             (make-0-vector ',element-type :content ,vector :location ,c-vector :temp t)
 535             (with-pointer (,var ,c-vector)
 536               (unwind-protect
 537                   ,form
 538                 (unset-0-vector ,c-vector ',element-type t))))))
 539       ((and (out-arg-p style) (not (in-arg-p style)))
 540        `(with-pointer (,var)
 541           ,form)))))
 542
 543
 544 (define-type-method to-alien-form ((type vector0) vector &optional copy-p)
 545   (declare (ignore copy-p))
 546   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 547     `(make-0-vector ',element-type :content ,vector)))
 548
 549 (define-type-method from-alien-form ((type vector0) form  &key (ref :free))
 550   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 551     `(let ((c-vector ,form))
 552        (prog1
 553            (map-0-vector 'vector #'identity c-vector ',element-type
 554             ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
 555          ,(when (eq ref :free)
 556             `(deallocate-memory c-vector))))))
 557
 558
 559 (define-type-method writer-function ((type vector0) &key temp inlined)
 560   (assert-not-inlined type inlined)
 561   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 562     #'(lambda (vector location &optional (offset 0))
 563         (setf
 564          (ref-pointer location offset)
 565          (make-0-vector element-type :content vector :temp temp)))))
 566
 567 (define-type-method reader-function ((type vector0) &key (ref :read) inlined)
 568   (assert-not-inlined type inlined)
 569   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 570     (ecase ref
 571       ((:read :peek)
 572        #'(lambda (location &optional (offset 0))
 573            (unless (null-pointer-p (ref-pointer location offset))
 574              (map-0-vector 'vector #'identity (ref-pointer location offset)
 575               element-type ref))))
 576       (:get
 577        #'(lambda (location &optional (offset 0))
 578            (unless (null-pointer-p (ref-pointer location offset))
 579              (prog1
 580                  (map-0-vector 'vector #'identity (ref-pointer location offset)
 581                   element-type :get)
 582                (deallocate-memory (ref-pointer location offset))
 583                (setf (ref-pointer location offset) (make-pointer 0)))))))))
 584
 585
 586 (define-type-method destroy-function ((type vector0) &key temp inlined)
 587   (assert-not-inlined type inlined)
 588   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 589     #'(lambda (location &optional (offset 0))
 590           (unless (null-pointer-p (ref-pointer location offset))
 591             (destroy-0-vector
 592              (ref-pointer location offset) element-type temp)
 593             (setf (ref-pointer location offset) (make-pointer 0))))))
 594
 595 (define-type-method copy-function ((type vector0) &key inlined)
 596   (assert-not-inlined type inlined)
 597   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
 598     (let ((copy-element (copy-function element-type))
 599           (element-size (size-of element-type)))
 600       #'(lambda (from to &optional (offset 0))
 601           (unless (null-pointer-p (ref-pointer from offset))
 602             (let* ((from-vector (ref-pointer from offset))
 603                    (length
 604                     (loop
 605                      for length from 0
 606                      for element by element-size
 607                      until (memory-clear-p from-vector element-size element)
 608                      finally (return length)))
 609                    (to-vector
 610                     (setf (ref-pointer to offset)
 611                      (allocate-memory (* (1+ length) element-size)))))
 612               (loop
 613                repeat length
 614                for element by element-size
 615                do (funcall copy-element from-vector to-vector element))))))))
 616
 617 (define-type-method unbound-value ((type vector0))
 618   (declare (ignore type))
 619   nil)
 620
 621
 622
 623 ;;;; Counted vector
 624
 625 (defun make-counted-vector (type &key content location (counter-type 'unsigned-int) temp)
 626   (let* ((element-size (size-of type))
 627          (length (length content))
 628          (location (or
 629                     location
 630                     (allocate-memory
 631                      (+ (size-of counter-type) (* element-size length))))))
 632     (funcall (writer-function counter-type :temp temp) length location)
 633     (make-c-vector type length :content content :location (pointer+ location (size-of counter-type)))
 634     location))
 635
 636 (defun map-counted-vector (seqtype function location element-type &optional (counter-type 'unsigned-int) (ref :read))
 637   (let ((length (funcall (reader-function counter-type) location :ref ref)))
 638     (map-c-vector
 639      seqtype function (pointer+ location (size-of counter-type))
 640      element-type length)))
 641
 642 (defun unset-counted-vector (location element-type &optional (counter-type 'unsigned-int) temp-p)
 643   (let ((length (funcall (reader-function counter-type) location)))
 644     (unset-c-vector
 645      (pointer+ location (size-of counter-type)) element-type length temp-p)))
 646
 647 (defun destroy-counted-vector (location element-type &optional (counter-type 'unsigned-int) temp-p)
 648   (unset-counted-vector location element-type counter-type temp-p)
 649   (deallocate-memory location))
 650
 651
 652 (deftype counted-vector (element-type &optional counter-type)
 653   (declare (ignore counter-type))
 654   `(vector ,element-type))
 655
 656 (define-type-method alien-type ((type counted-vector))
 657   (declare (ignore type))
 658   (alien-type 'pointer))
 659
 660 (define-type-method size-of ((type counted-vector) &key inlined)
 661   (assert-not-inlined type inlined)
 662   (size-of 'pointer))
 663
 664 (define-type-method type-alignment ((type counted-vector) &key inlined)
 665   (assert-not-inlined type inlined)
 666   (type-alignment 'pointer))
 667
 668 (define-type-method alien-arg-wrapper ((type counted-vector) var vector style form &optional copy-in-p)
 669   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 670       (rest (type-expand-to 'counted-vector type))
 671     (cond
 672       ((and (in-arg-p style) copy-in-p)
 673        `(with-pointer (,var (make-counted-vector ',element-type
 674                              :content ,vector :counter-type ',counter-type))
 675           ,form))
 676       ((and (in-arg-p style) (not (out-arg-p style)))
 677        `(with-memory (,var (+ (* ,(size-of element-type) (length ,vector)) ,(size-of counter-type)))
 678           (make-counted-vector ',element-type :content ,vector
 679            :location ,var :counter-type ',counter-type :temp t)
 680           (unwind-protect
 681               ,form
 682             (unset-counted-vector ,var ',element-type ',counter-type t))))
 683       ((and (in-arg-p style) (out-arg-p style))
 684        (let ((c-vector (make-symbol "C-VECTOR")))
 685          `(with-memory (,c-vector (+ (* ,(size-of element-type) (length ,vector)) ,(size-of counter-type)))
 686             (make-counted-vector ',element-type :content ,vector ,c-vector
 687              :counter-type ',counter-type :temp t)
 688             (with-pointer (,var ,c-vector)
 689               (unwind-protect
 690                   ,form
 691                 (unset-counted-vector ,c-vector ',element-type ',counter-type t))))))
 692       ((and (out-arg-p style) (not (in-arg-p style)))
 693        `(with-pointer (,var)
 694           ,form)))))
 695
 696
 697 (define-type-method to-alien-form ((type counted-vector) vector &optional copy-p)
 698   (declare (ignore copy-p))
 699   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 700       (rest (type-expand-to 'counted-vector type))
 701     `(make-counted-vector ',element-type
 702       :content ,vector :counter-type ',counter-type)))
 703
 704 (define-type-method from-alien-form ((type counted-vector) form  &key (ref :free))
 705   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 706       (rest (type-expand-to 'counted-vector type))
 707     `(let ((c-vector ,form))
 708        (prog1
 709            (map-counted-vector 'vector #'identity c-vector ',element-type ',counter-type
 710             ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
 711          ,(when (eq ref :free)
 712             `(deallocate c-vector))))))
 713
 714 (define-type-method writer-function ((type counted-vector) &key temp inlined)
 715   (assert-not-inlined type inlined)
 716   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 717       (rest (type-expand-to 'counted-vector type))
 718     #'(lambda (vector location &optional (offset 0))
 719         (setf
 720          (ref-pointer location offset)
 721          (make-counted-vector element-type :content vector
 722           :counter-type counter-type :temp temp)))))
 723
 724 (define-type-method reader-function ((type counted-vector) &key (ref :read) inlined)
 725   (assert-not-inlined type inlined)
 726   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 727       (rest (type-expand-to 'counted-vector type))
 728     (ecase ref
 729       ((:read :peek)
 730        #'(lambda (location &optional (offset 0))
 731            (unless (null-pointer-p (ref-pointer location offset))
 732              (map-counted-vector 'vector #'identity
 733               (ref-pointer location offset) element-type counter-type ref))))
 734       (:get
 735        #'(lambda (location &optional (offset 0))
 736            (unless (null-pointer-p (ref-pointer location offset))
 737              (prog1
 738                  (map-counted-vector 'vector #'identity
 739                   (ref-pointer location offset) element-type counter-type :get)
 740                (deallocate-memory (ref-pointer location offset))
 741                (setf (ref-pointer location offset) (make-pointer 0)))))))))
 742
 743 (define-type-method destroy-function ((type counted-vector) &key temp inlined)
 744   (assert-not-inlined type inlined)
 745   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 746       (rest (type-expand-to 'counted-vector type))
 747     #'(lambda (location &optional (offset 0))
 748         (unless (null-pointer-p (ref-pointer location offset))
 749           (destroy-counted-vector (ref-pointer location offset)
 750            element-type counter-type temp)
 751           (setf (ref-pointer location offset) (make-pointer 0))))))
 752
 753 (define-type-method copy-function ((type counted-vector) &key inlined)
 754   (assert-not-inlined type inlined)
 755   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
 756       (rest (type-expand-to 'counted-vector type))
 757     (let ((vector-length (reader-function counter-type))
 758           (counter-size (size-of counter-type))
 759           (copy-element (copy-function element-type))
 760           (element-size (size-of element-type)))
 761       #'(lambda (from to &optional (offset 0))
 762           (unless (null-pointer-p (ref-pointer from offset))
 763             (let* ((from-vector (ref-pointer from offset))
 764                    (length (funcall vector-length from-vector))
 765                    (to-vector  (setf
 766                                 (ref-pointer to offset)
 767                                 (allocate-memory (+ counter-size (* length element-size))))))
 768               (copy-memory from-vector counter-size to-vector)
 769               (loop
 770                repeat length
 771                for element from counter-size by element-size
 772                do (funcall copy-element from-vector to-vector element))))))))
 773
 774
 775 ;;;; Accessor functions for raw memory access
 776
 777 (defun vector-reader-function (type &key (start 0) end)
 778   "Returns a function for reading values from raw C vectors"
 779   (let ((element-size (size-of type))
 780         (reader (reader-function type)))
 781     #'(lambda (vector index)
 782         (assert (and (>= index start) (or (not end) (< index end))))
 783         (funcall reader vector (* index element-size)))))
 784
 785 (defun vector-writer-function (type &key (start 0) end)
 786   "Returns a function for writing values to raw C vectors"
 787   (let ((element-size (size-of type))
 788         (writer (writer-function type)))
 789     #'(lambda (value vector index)
 790         (assert (and (>= index start) (or (not end) (< index end))))
 791         (funcall writer value vector (* index element-size)))))
 792
 793
 794 (defmacro define-vector-accessor (type)
 795   (let ((name (intern (format nil "VECTOR-REF-~A" type)))
 796         (ref (intern (format nil "REF-~A" type))))
 797     `(progn
 798        (declaim
 799         (ftype (function (pointer fixnum) ,type) ,name)
 800         (inline ,name))
 801        (defun ,name (vector index)
 802          (,ref vector (* ,(size-of type) index)))
 803        (declaim
 804         (ftype (function (,type pointer fixnum) ,type) (setf ,name))
 805         (inline (setf ,name)))
 806        (defun (setf ,name) (value vector index)
 807          (setf (,ref vector (* ,(size-of type) index)) value)))))
 808
 809 (define-vector-accessor int-8)
 810 (define-vector-accessor uint-8)
 811 (define-vector-accessor int-16)
 812 (define-vector-accessor uint-16)
 813 (define-vector-accessor int-32)
 814 (define-vector-accessor uint-32)
 815 (define-vector-accessor int-64)
 816 (define-vector-accessor uint-64)
 817 (define-vector-accessor double-float)
 818 (define-vector-accessor single-float)
 819