X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/5e8ceafacd433a4483d356ded575c74e71de03d6..e339200bb4ce98efe8b1d052504e7d781087ede3:/glib/glib.lisp diff --git a/glib/glib.lisp b/glib/glib.lisp index fe40137..a5f29ac 100644 --- a/glib/glib.lisp +++ b/glib/glib.lisp @@ -1,21 +1,26 @@ -;; Common Lisp bindings for GTK+ v1.2.x -;; Copyright (C) 1999-2005 Espen S. Johnsen +;; Common Lisp bindings for GTK+ 2.x +;; Copyright 1999-2005 Espen S. Johnsen ;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2 of the License, or (at your option) any later version. +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: ;; -;; This library is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; Lesser General Public License for more details. +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. ;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: glib.lisp,v 1.29 2005-04-18 10:34:51 espen Exp $ +;; $Id: glib.lisp,v 1.36 2006-02-26 15:30:01 espen Exp $ (in-package "GLIB") @@ -42,6 +47,23 @@ #+sbcl(system-area-ub8-copy from 0 to 0 length) to) +(defun clear-memory (from length) + #+cmu(vm::system-area-fill 0 from 0 (* 8 length)) + #+sbcl(system-area-ub8-fill 0 from 0 length)) + +(defmacro with-allocated-memory ((var size) &body body) + (if (constantp size) + (let ((alien (make-symbol "ALIEN")) + (size (eval size))) + `(with-alien ((,alien (array #+sbcl(sb-alien:unsigned 8) #+cmu(alien:unsigned 8) ,size))) + (let ((,var (alien-sap ,alien))) + (clear-memory ,var ,size) + ,@body))) + `(let ((,var (allocate-memory ,size))) + (unwind-protect + (progn ,@body) + (deallocate-memory ,var))))) + ;;;; User data mechanism @@ -106,7 +128,7 @@ ;;;; Linked list (GList) (deftype glist (type) - `(or (null (cons ,type list)))) + `(or null (cons ,type list))) (defbinding (%glist-append "g_list_append") () pointer (glist pointer) @@ -157,81 +179,71 @@ do (funcall destroy tmp 0)) (glist-free glist)) -(defmethod alien-type ((type (eql 'glist)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type glist)) + (declare (ignore type)) (alien-type 'pointer)) -(defmethod size-of ((type (eql 'glist)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type glist)) + (declare (ignore type)) (size-of 'pointer)) -(defmethod to-alien-form (list (type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method to-alien-form ((type glist) list) + (let ((element-type (second (type-expand-to 'glist type)))) `(make-glist ',element-type ,list))) -(defmethod to-alien-function ((type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method to-alien-function ((type glist)) + (let ((element-type (second (type-expand-to 'glist type)))) #'(lambda (list) (make-glist element-type list)))) -(defmethod from-alien-form (glist (type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method from-alien-form ((type glist) glist) + (let ((element-type (second (type-expand-to 'glist type)))) `(let ((glist ,glist)) (unwind-protect (map-glist 'list #'identity glist ',element-type) (destroy-glist glist ',element-type))))) -(defmethod from-alien-function ((type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method from-alien-function ((type glist)) + (let ((element-type (second (type-expand-to 'glist type)))) #'(lambda (glist) (unwind-protect (map-glist 'list #'identity glist element-type) (destroy-glist glist element-type))))) -(defmethod copy-from-alien-form (glist (type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method copy-from-alien-form ((type glist) glist) + (let ((element-type (second (type-expand-to 'glist type)))) `(map-glist 'list #'identity ,glist ',element-type))) -(defmethod copy-from-alien-function ((type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method copy-from-alien-function ((type glist)) + (let ((element-type (second (type-expand-to 'glist type)))) #'(lambda (glist) (map-glist 'list #'identity glist element-type)))) -(defmethod cleanup-form (glist (type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method cleanup-form ((type glist) glist) + (let ((element-type (second (type-expand-to 'glist type)))) `(destroy-glist ,glist ',element-type))) -(defmethod cleanup-function ((type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method cleanup-function ((type glist)) + (let ((element-type (second (type-expand-to 'glist type)))) #'(lambda (glist) (destroy-glist glist element-type)))) -(defmethod writer-function ((type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method writer-function ((type glist)) + (let ((element-type (second (type-expand-to 'glist type)))) #'(lambda (list location &optional (offset 0)) (setf (sap-ref-sap location offset) (make-glist element-type list))))) -(defmethod reader-function ((type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args - #'(lambda (location &optional (offset 0)) +(define-type-method reader-function ((type glist)) + (let ((element-type (second (type-expand-to 'glist type)))) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) (unless (null-pointer-p (sap-ref-sap location offset)) (map-glist 'list #'identity (sap-ref-sap location offset) element-type))))) -(defmethod destroy-function ((type (eql 'glist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method destroy-function ((type glist)) + (let ((element-type (second (type-expand-to 'glist type)))) #'(lambda (location &optional (offset 0)) (unless (null-pointer-p (sap-ref-sap location offset)) (destroy-glist (sap-ref-sap location offset) element-type) @@ -241,7 +253,7 @@ ;;;; Single linked list (GSList) -(deftype gslist (type) `(or (null (cons ,type list)))) +(deftype gslist (type) `(or null (cons ,type list))) (defbinding (%gslist-prepend "g_slist_prepend") () pointer (gslist pointer) @@ -266,81 +278,71 @@ do (funcall destroy tmp 0)) (gslist-free gslist)) -(defmethod alien-type ((type (eql 'gslist)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type gslist)) + (declare (ignore type)) (alien-type 'pointer)) -(defmethod size-of ((type (eql 'gslist)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type gslist)) + (declare (ignore type)) (size-of 'pointer)) -(defmethod to-alien-form (list (type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method to-alien-form ((type gslist) list) + (let ((element-type (second (type-expand-to 'gslist type)))) `(make-sglist ',element-type ,list))) -(defmethod to-alien-function ((type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method to-alien-function ((type gslist)) + (let ((element-type (second (type-expand-to 'gslist type)))) #'(lambda (list) (make-gslist element-type list)))) -(defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method from-alien-form ((type gslist) gslist) + (let ((element-type (second (type-expand-to 'gslist type)))) `(let ((gslist ,gslist)) (unwind-protect (map-glist 'list #'identity gslist ',element-type) (destroy-gslist gslist ',element-type))))) -(defmethod from-alien-function ((type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method from-alien-function ((type gslist)) + (let ((element-type (second (type-expand-to 'gslist type)))) #'(lambda (gslist) (unwind-protect (map-glist 'list #'identity gslist element-type) (destroy-gslist gslist element-type))))) -(defmethod copy-from-alien-form (gslist (type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method copy-from-alien-form ((type gslist) gslist) + (let ((element-type (second (type-expand-to 'gslist type)))) `(map-glist 'list #'identity ,gslist ',element-type))) -(defmethod copy-from-alien-function ((type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method copy-from-alien-function ((type gslist)) + (let ((element-type (second (type-expand-to 'gslist type)))) #'(lambda (gslist) (map-glist 'list #'identity gslist element-type)))) -(defmethod cleanup-form (gslist (type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method cleanup-form ((type gslist) gslist) + (let ((element-type (second (type-expand-to 'gslist type)))) `(destroy-gslist ,gslist ',element-type))) -(defmethod cleanup-function ((type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method cleanup-function ((type gslist)) + (let ((element-type (second (type-expand-to 'gslist type)))) #'(lambda (gslist) (destroy-gslist gslist element-type)))) -(defmethod writer-function ((type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method writer-function ((type gslist)) + (let ((element-type (second (type-expand-to 'gslist type)))) #'(lambda (list location &optional (offset 0)) (setf (sap-ref-sap location offset) (make-gslist element-type list))))) -(defmethod reader-function ((type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args - #'(lambda (location &optional (offset 0)) +(define-type-method reader-function ((type gslist)) + (let ((element-type (second (type-expand-to 'gslist type)))) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) (unless (null-pointer-p (sap-ref-sap location offset)) (map-glist 'list #'identity (sap-ref-sap location offset) element-type))))) -(defmethod destroy-function ((type (eql 'gslist)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method destroy-function ((type gslist)) + (let ((element-type (second (type-expand-to 'gslist type)))) #'(lambda (location &optional (offset 0)) (unless (null-pointer-p (sap-ref-sap location offset)) (destroy-gslist (sap-ref-sap location offset) element-type) @@ -404,17 +406,17 @@ (deallocate-memory location)) -(defmethod alien-type ((type (eql 'vector)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type vector)) + (declare (ignore type)) (alien-type 'pointer)) -(defmethod size-of ((type (eql 'vector)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type vector)) + (declare (ignore type)) (size-of 'pointer)) -(defmethod to-alien-form (vector (type (eql 'vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type &optional (length '*)) args +(define-type-method to-alien-form ((type vector) vector) + (destructuring-bind (element-type &optional (length '*)) + (rest (type-expand-to 'vector type)) (if (eq length '*) `(let* ((vector ,vector) (location (sap+ @@ -427,9 +429,9 @@ location) `(make-c-vector ',element-type ,length ,vector)))) -(defmethod from-alien-form (c-vector (type (eql 'vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type &optional (length '*)) args +(define-type-method from-alien-form ((type vector) c-vector) + (destructuring-bind (element-type &optional (length '*)) + (rest (type-expand-to 'vector type)) (if (eq length '*) (error "Can't use vector of variable size as return type") `(let ((c-vector ,c-vector)) @@ -437,24 +439,24 @@ (map-c-vector 'vector #'identity c-vector ',element-type ,length) (destroy-c-vector c-vector ',element-type ,length)))))) -(defmethod copy-from-alien-form (c-vector (type (eql 'vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type &optional (length '*)) args +(define-type-method copy-from-alien-form ((type vector) c-vector) + (destructuring-bind (element-type &optional (length '*)) + (rest (type-expand-to 'vector type)) (if (eq length '*) (error "Can't use vector of variable size as return type") - `(map-c-vector 'vector #'identity ,c-vector ',element-type ',length)))) + `(map-c-vector 'vector #'identity ,c-vector ',element-type ,length)))) -(defmethod copy-from-alien-function ((type (eql 'vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type &optional (length '*)) args +(define-type-method copy-from-alien-function ((type vector)) + (destructuring-bind (element-type &optional (length '*)) + (rest (type-expand-to 'vector type)) (if (eq length '*) (error "Can't use vector of variable size as return type") #'(lambda (c-vector) (map-c-vector 'vector #'identity c-vector element-type length))))) -(defmethod cleanup-form (location (type (eql 'vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type &optional (length '*)) args +(define-type-method cleanup-form ((type vector) location) + (destructuring-bind (element-type &optional (length '*)) + (rest (type-expand-to 'vector type)) `(let* ((location ,location) (length ,(if (eq length '*) `(sap-ref-32 location ,(- +size-of-int+)) @@ -468,27 +470,37 @@ `(sap+ location ,(- +size-of-int+)) 'location))))) -(defmethod writer-function ((type (eql 'vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type &optional (length '*)) args +;; We need these so that we can specify vectors with length given as +;; a non constant in callbacks +(define-type-method callback-from-alien-form ((type vector) form) + (copy-from-alien-form type form)) +(define-type-method callback-cleanup-form ((type vector) form) + (declare (ignore type form)) + nil) + + +(define-type-method writer-function ((type vector)) + (destructuring-bind (element-type &optional (length '*)) + (rest (type-expand-to 'vector type)) #'(lambda (vector location &optional (offset 0)) (setf (sap-ref-sap location offset) (make-c-vector element-type length vector))))) -(defmethod reader-function ((type (eql 'vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type &optional (length '*)) args +(define-type-method reader-function ((type vector)) + (destructuring-bind (element-type &optional (length '*)) + (rest (type-expand-to 'vector type)) (if (eq length '*) (error "Can't create reader function for vector of variable size") - #'(lambda (location &optional (offset 0)) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) (unless (null-pointer-p (sap-ref-sap location offset)) (map-c-vector 'vector #'identity (sap-ref-sap location offset) element-type length)))))) -(defmethod destroy-function ((type (eql 'vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type &optional (length '*)) args +(define-type-method destroy-function ((type vector)) + (destructuring-bind (element-type &optional (length '*)) + (rest (type-expand-to 'vector type)) (if (eq length '*) (error "Can't create destroy function for vector of variable size") #'(lambda (location &optional (offset 0)) @@ -556,40 +568,40 @@ (deftype null-terminated-vector (element-type) `(vector ,element-type)) -(defmethod alien-type ((type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type null-terminated-vector)) + (declare (ignore type)) (alien-type 'pointer)) -(defmethod size-of ((type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type null-terminated-vector)) + (declare (ignore type)) (size-of 'pointer)) -(defmethod to-alien-form (vector (type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method to-alien-form ((type null-terminated-vector) vector) + (destructuring-bind (element-type) + (rest (type-expand-to 'null-terminated-vector type)) `(make-0-vector ',element-type ,vector))) -(defmethod from-alien-form (c-vector (type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method from-alien-form ((type null-terminated-vector) c-vector) + (destructuring-bind (element-type) + (rest (type-expand-to 'null-terminated-vector type)) `(let ((c-vector ,c-vector)) (prog1 (map-0-vector 'vector #'identity c-vector ',element-type) (destroy-0-vector c-vector ',element-type))))) -(defmethod copy-from-alien-form (c-vector (type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method copy-from-alien-form ((type null-terminated-vector) c-vector) + (destructuring-bind (element-type) + (rest (type-expand-to 'null-terminated-vector type)) `(map-0-vector 'vector #'identity ,c-vector ',element-type))) -(defmethod cleanup-form (location (type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method cleanup-form ((type null-terminated-vector) location) + (destructuring-bind (element-type) + (rest (type-expand-to 'null-terminated-vector type)) `(destroy-0-vector ,location ',element-type))) -(defmethod writer-function ((type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method writer-function ((type null-terminated-vector)) + (destructuring-bind (element-type) + (rest (type-expand-to 'null-terminated-vector type)) (unless (eq (alien-type element-type) (alien-type 'pointer)) (error "Elements in null-terminated vectors need to be of pointer types")) #'(lambda (vector location &optional (offset 0)) @@ -597,19 +609,20 @@ (sap-ref-sap location offset) (make-0-vector element-type vector))))) -(defmethod reader-function ((type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method reader-function ((type null-terminated-vector)) + (destructuring-bind (element-type) + (rest (type-expand-to 'null-terminated-vector type)) (unless (eq (alien-type element-type) (alien-type 'pointer)) (error "Elements in null-terminated vectors need to be of pointer types")) - #'(lambda (location &optional (offset 0)) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) (unless (null-pointer-p (sap-ref-sap location offset)) (map-0-vector 'vector #'identity (sap-ref-sap location offset) element-type))))) -(defmethod destroy-function ((type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method destroy-function ((type null-terminated-vector)) + (destructuring-bind (element-type) + (rest (type-expand-to 'null-terminated-vector type)) (unless (eq (alien-type element-type) (alien-type 'pointer)) (error "Elements in null-terminated vectors need to be of pointer types")) #'(lambda (location &optional (offset 0)) @@ -618,9 +631,11 @@ (sap-ref-sap location offset) element-type) (setf (sap-ref-sap location offset) (make-pointer 0)))))) -(defmethod unbound-value ((type (eql 'null-terminated-vector)) &rest args) - (declare (ignore type args)) - (values t nil)) +(define-type-method unbound-value ((type null-terminated-vector)) + (declare (ignore type)) + nil) + + ;;; Counted vector @@ -651,62 +666,63 @@ (deftype counted-vector (element-type) `(vector ,element-type)) -(defmethod alien-type ((type (eql 'counted-vector)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type counted-vector)) + (declare (ignore type)) (alien-type 'pointer)) -(defmethod size-of ((type (eql 'counted-vector)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type counted-vector)) + (declare (ignore type)) (size-of 'pointer)) -(defmethod to-alien-form (vector (type (eql 'counted-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method to-alien-form ((type counted-vector) vector) + (destructuring-bind (element-type) + (rest (type-expand-to 'counted-vector type)) `(make-counted-vector ',element-type ,vector))) -(defmethod from-alien-form (c-vector (type (eql 'counted-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method from-alien-form ((type counted-vector) c-vector) + (destructuring-bind (element-type) + (rest (type-expand-to 'counted-vector type)) `(let ((c-vector ,c-vector)) (prog1 (map-counted-vector 'vector #'identity c-vector ',element-type) (destroy-counted-vector c-vector ',element-type))))) -(defmethod copy-from-alien-form (c-vector (type (eql 'counted-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method copy-from-alien-form ((type counted-vector) c-vector) + (destructuring-bind (element-type) + (rest (type-expand-to 'counted-vector type)) `(map-counted-vector 'vector #'identity ,c-vector ',element-type))) -(defmethod copy-from-alien-function ((type (eql 'counted-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method copy-from-alien-function ((type counted-vector)) + (destructuring-bind (element-type) + (rest (type-expand-to 'counted-vector type)) #'(lambda (c-vector) (map-counted-vector 'vector #'identity c-vector element-type)))) -(defmethod cleanup-form (location (type (eql 'counted-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method cleanup-form ((type counted-vector) location) + (destructuring-bind (element-type) + (rest (type-expand-to 'counted-vector type)) `(destroy-counted-vector ,location ',element-type))) -(defmethod writer-function ((type (eql 'counted-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method writer-function ((type counted-vector)) + (destructuring-bind (element-type) + (rest (type-expand-to 'counted-vector type)) #'(lambda (vector location &optional (offset 0)) (setf (sap-ref-sap location offset) (make-counted-vector element-type vector))))) -(defmethod reader-function ((type (eql 'counted-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args - #'(lambda (location &optional (offset 0)) +(define-type-method reader-function ((type counted-vector)) + (destructuring-bind (element-type) + (rest (type-expand-to 'counted-vector type)) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) (unless (null-pointer-p (sap-ref-sap location offset)) (map-counted-vector 'vector #'identity (sap-ref-sap location offset) element-type))))) -(defmethod destroy-function ((type (eql 'counted-vector)) &rest args) - (declare (ignore type)) - (destructuring-bind (element-type) args +(define-type-method destroy-function ((type counted-vector)) + (destructuring-bind (element-type) + (rest (type-expand-to 'counted-vector type)) #'(lambda (location &optional (offset 0)) (unless (null-pointer-p (sap-ref-sap location offset)) (destroy-counted-vector