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