[clg] / glib / glib.lisp

;; Common Lisp bindings for GTK+ v1.2.x
;; Copyright (C) 1999 Espen S. Johnsen <espejohn@online.no>
;;
;; 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.
;;
;; 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.
;;
;; 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

;; $Id: glib.lisp,v 1.18 2004-11-07 16:03:55 espen Exp $


(in-package "GLIB")

(use-prefix "g")


;;;; Memory management

(defbinding (allocate-memory "g_malloc0") () pointer
  (size unsigned-long))

(defbinding (reallocate-memory "g_realloc") () pointer
  (address pointer)
  (size unsigned-long))

(defbinding (deallocate-memory "g_free") () nil
  (address pointer))
;; (defun deallocate-memory (address)
;;   (declare (ignore address)))

(defun copy-memory (from length &optional (to (allocate-memory length)))
  (kernel:system-area-copy from 0 to 0 (* 8 length))
  to)


;;;; User data mechanism

(internal *user-data* *user-data-count*)

(declaim (fixnum *user-data-count*))

(defvar *user-data* (make-hash-table))
(defvar *user-data-count* 0)

(defun register-user-data (object &optional destroy-function)
  (check-type destroy-function (or null symbol function))
  (incf *user-data-count*)
  (setf
   (gethash *user-data-count* *user-data*)
   (cons object destroy-function))
  *user-data-count*)

(defun find-user-data (id)
  (check-type id fixnum)
  (multiple-value-bind (user-data p) (gethash id *user-data*)
    (values (car user-data) p)))

(defun destroy-user-data (id)
  (check-type id fixnum)
  (let ((user-data (gethash id *user-data*)))
    (when (cdr user-data)
      (funcall (cdr user-data) (car user-data))))
  (remhash id *user-data*))


;;;; Quarks

(internal *quark-counter* *quark-from-object* *quark-to-object*)

(deftype quark () 'unsigned)

;(defbinding %quark-get-reserved () quark)

(defbinding %quark-from-string () quark
  (string string))

(defvar *quark-counter* 0)

(defun %quark-get-reserved ()
  ;; The string is just a dummy
  (%quark-from-string (format nil "#@�$%&-quark-~D" (incf *quark-counter*))))

(defvar *quark-from-object* (make-hash-table))
(defvar *quark-to-object* (make-hash-table))

(defun quark-from-object (object &key (test #'eq))
  (let ((hash-code (sxhash object)))
    (or
     (assoc-ref object (gethash hash-code *quark-from-object*) :test test)
     (let ((quark (%quark-get-reserved)))
       (setf
	(gethash hash-code *quark-from-object*)
	(append
	 (gethash hash-code *quark-from-object*)
	 (list (cons object quark))))
       (setf (gethash quark *quark-to-object*) object)
       quark))))

(defun quark-to-object (quark) 
  (gethash quark *quark-to-object*))
  
(defun remove-quark (quark)
  (let* ((object (gethash quark *quark-to-object*))
	 (hash-code (sxhash object)))
    (remhash quark *quark-to-object*)
    (unless (setf
	     (gethash hash-code *quark-from-object*)
	     (assoc-delete object (gethash hash-code *quark-from-object*)))
      (remhash hash-code *quark-from-object*))))


;;;; Linked list (GList)

(deftype glist (type &key copy) 
  (declare (ignore copy))
  `(or (null (cons ,type list))))

(defbinding (%glist-append-unsigned "g_list_append") () pointer
  (glist pointer)
  (data unsigned))

(defbinding (%glist-append-signed "g_list_append") () pointer
  (glist pointer)
  (data signed))

(defbinding (%glist-append-sap "g_list_append") () pointer
  (glist pointer)
  (data pointer))

(defun make-glist (type list)
  (let ((new-element (ecase (alien-type type)
		       (system-area-pointer #'%glist-append-sap)
		       ((signed-byte c-call:short c-call:int c-call:long)
			#'%glist-append-signed)
		       ((unsigned-byte c-call:unsigned-short 
			 c-call:unsigned-int c-call:unsigned-long)
			#'%glist-append-unsigned)))
	(to-alien (to-alien-function type)))
    (loop
     for element in list
     as glist = (funcall new-element (or glist (make-pointer 0)) 
		 (funcall to-alien element))
     finally (return glist))))

(defun glist-next (glist)
  (unless (null-pointer-p glist)
    (sap-ref-sap glist +size-of-pointer+)))
  
;; Also used for gslists
(defun map-glist (seqtype function glist element-type)
  (let ((reader (reader-function element-type)))
    (case seqtype 
     ((nil)
      (loop
       as tmp = glist then (glist-next tmp)
       until (null-pointer-p tmp)
       do (funcall function (funcall reader tmp))))
     (list
      (loop
       as tmp = glist then (glist-next tmp)
       until (null-pointer-p tmp)
       collect (funcall function (funcall reader tmp))))
     (t
      (coerce 
       (loop
	as tmp = glist then (glist-next tmp)
	until (null-pointer-p tmp)
	collect (funcall function (funcall reader tmp)))
       seqtype)))))

(defbinding (glist-free "g_list_free") () nil
  (glist pointer))


(defmethod alien-type ((type (eql 'glist)) &rest args)
  (declare (ignore type args))
  (alien-type 'pointer))

(defmethod size-of ((type (eql 'glist)) &rest args)
  (declare (ignore type args))
  (size-of 'pointer))

(defmethod to-alien-form (list (type (eql 'glist)) &rest args)
  (declare (ignore type))
  (destructuring-bind (element-type) args    
    `(make-glist ',element-type ,list)))

(defmethod to-alien-function ((type (eql 'glist)) &rest args)
  (declare (ignore type))
  (destructuring-bind (element-type) args    
    #'(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
    `(let ((glist ,glist))
      (unwind-protect
	   (map-glist 'list #'identity glist ',element-type)
	(glist-free glist)))))

(defmethod from-alien-function ((type (eql 'glist)) &rest args)
  (declare (ignore type))
  (destructuring-bind (element-type) args
    #'(lambda (glist)
	(unwind-protect
	     (map-glist 'list #'identity glist element-type)
	  (glist-free glist)))))

(defmethod cleanup-form (glist (type (eql 'glist)) &rest args)
  (declare (ignore type args))
  `(glist-free ,glist))

(defmethod cleanup-function ((type (eql 'glist)) &rest args)
  (declare (ignore type args))
  #'glist-free)


;;;; Single linked list (GSList)

(deftype gslist (type) `(or (null (cons ,type list))))

(defbinding (%gslist-prepend-unsigned "g_slist_prepend") () pointer
  (gslist pointer)
  (data unsigned))

(defbinding (%gslist-prepend-signed "g_slist_prepend") () pointer
  (gslist pointer)
  (data signed))

(defbinding (%gslist-prepend-sap "g_slist_prepend") () pointer
  (gslist pointer)
  (data pointer))

(defun make-gslist (type list)
  (let ((new-element (ecase (alien-type type)
		       (system-area-pointer #'%gslist-prepend-sap)
		       ((signed-byte c-call:short c-call:int c-call:long)
			#'%gslist-prepend-signed)
		       ((unsigned-byte c-call:unsigned-short 
			 c-call:unsigned-int c-call:unsigned-long)
			#'%gslist-prepend-unsigned)))
	(to-alien (to-alien-function type)))
    (loop
     for element in (reverse list)
     as gslist = (funcall new-element (or gslist (make-pointer 0)) 
		  (funcall to-alien element))
     finally (return gslist))))

(defbinding (gslist-free "g_slist_free") () nil
  (gslist pointer))


(defmethod alien-type ((type (eql 'gslist)) &rest args)
  (declare (ignore type args))
  (alien-type 'pointer))

(defmethod size-of ((type (eql 'gslist)) &rest args)
  (declare (ignore type args))
  (size-of 'pointer))

(defmethod to-alien-form (list (type (eql 'gslist)) &rest args)
  (declare (ignore type))
  (destructuring-bind (element-type) args    
    `(make-sglist ',element-type ,list)))

(defmethod to-alien-function ((type (eql 'gslist)) &rest args)
  (declare (ignore type))
  (destructuring-bind (element-type) args    
    #'(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
    `(let ((gslist ,gslist))
      (unwind-protect
	   (map-glist 'list #'identity gslist ',element-type)
	(gslist-free gslist)))))

(defmethod from-alien-function ((type (eql 'gslist)) &rest args)
  (declare (ignore type))
  (destructuring-bind (element-type) args
    #'(lambda (gslist)
	(unwind-protect
	     (map-glist 'list #'identity gslist element-type)
	  (gslist-free gslist)))))

(defmethod cleanup-form (list (type (eql 'gslist)) &rest args)
  (declare (ignore type args))
  `(gslist-free ,list))

(defmethod cleanup-function ((type (eql 'gslist)) &rest args)
  (declare (ignore type args))
  #'gslist-free)


;;; Vector

(defun make-c-vector (type length &optional content location)
  (let* ((size-of-type (size-of type))
	 (location (or location (allocate-memory (* size-of-type length))))
	 (writer (writer-function type)))
    (loop
     for element across content
     for i from 0 below length
     as offset = 0 then (+ offset size-of-type)
     do (funcall writer element location offset))
    location))


(defun map-c-vector (seqtype function location element-type length)
  (let ((reader (reader-function element-type))
	(size-of-element (size-of element-type)))
    (case seqtype 
     ((nil)
      (loop
       for i from 0 below length
       as offset = 0 then (+ offset size-of-element)
       do (funcall function (funcall reader location offset))))
     (list
      (loop
       for i from 0 below length
       as offset = 0 then (+ offset size-of-element)
       collect (funcall function (funcall reader location offset))))
     (t
      (loop
       with sequence = (make-sequence seqtype length)
       for i from 0 below length
       as offset = 0 then (+ offset size-of-element)
       do (setf 
	   (elt sequence i)
	   (funcall function (funcall reader location offset)))
       finally (return sequence))))))


(defmethod alien-type ((type (eql 'vector)) &rest args)
  (declare (ignore type args))
  (alien-type 'pointer))

(defmethod size-of ((type (eql 'vector)) &rest args)
  (declare (ignore type args))
  (size-of 'pointer))

(defmethod to-alien-form (vector (type (eql 'vector)) &rest args)
  (declare (ignore type))
  (destructuring-bind (element-type &optional (length '*)) args
    (if (eq length '*)
	`(let* ((vector ,vector)
		(location (sap+
			   (allocate-memory (+ ,+size-of-int+ 
					       (* ,(size-of element-type) 
						  (length vector))))
			   ,+size-of-int+)))
	  (make-c-vector ',element-type (length vector) vector location)
	  (setf (sap-ref-32 location ,(- +size-of-int+)) (length vector))
	  location)	  
      `(make-c-vector ',element-type ,length ,vector))))

(defmethod from-alien-form (location (type (eql 'vector)) &rest args)
  (declare (ignore type))
  (destructuring-bind (element-type &optional (length '*)) args
    (if (eq length '*)
	(error "Can't use vector of variable size as return type")
      `(map-c-vector 'vector #'identity ',element-type ',length ,location))))

(defmethod cleanup-form (location (type (eql 'vector)) &rest args)
  (declare (ignore type))
  (destructuring-bind (element-type &optional (length '*)) args
    `(let* ((location ,location)
	    (length ,(if (eq length '*)
			 `(sap-ref-32 location ,(- +size-of-int+))
			 length)))
      (loop
       with destroy = (destroy-function ',element-type)
       for i from 0 below length
       as offset = 0 then (+ offset ,(size-of element-type))
       do (funcall destroy location offset))
      (deallocate-memory ,(if (eq length '*) 
			      `(sap+ location  ,(- +size-of-int+))
			    'location)))))
Commit	Line	Data
560af5c5	1	;; Common Lisp bindings for GTK+ v1.2.x
	2	;; Copyright (C) 1999 Espen S. Johnsen <espejohn@online.no>
	3	;;
	4	;; This library is free software; you can redistribute it and/or
	5	;; modify it under the terms of the GNU Lesser General Public
	6	;; License as published by the Free Software Foundation; either
	7	;; version 2 of the License, or (at your option) any later version.
	8	;;
	9	;; This library is distributed in the hope that it will be useful,
	10	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	11	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	12	;; Lesser General Public License for more details.
	13	;;
	14	;; You should have received a copy of the GNU Lesser General Public
	15	;; License along with this library; if not, write to the Free Software
	16	;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
	17
831d4900	18	;; $Id: glib.lisp,v 1.18 2004-11-07 16:03:55 espen Exp $
560af5c5	19
	20
	21	(in-package "GLIB")
c4e9d221	22
560af5c5	23	(use-prefix "g")
	24
	25
	26	;;;; Memory management
	27
dba0c446	28	(defbinding (allocate-memory "g_malloc0") () pointer
560af5c5	29	(size unsigned-long))
560af5c5	30
dba0c446	31	(defbinding (reallocate-memory "g_realloc") () pointer
560af5c5	32	(address pointer)
	33	(size unsigned-long))
	34
3c657c71	35	(defbinding (deallocate-memory "g_free") () nil
3c657c71	36	(address pointer))
9adccb27	37	;; (defun deallocate-memory (address)
9adccb27	38	;; (declare (ignore address)))
560af5c5	39
	40	(defun copy-memory (from length &optional (to (allocate-memory length)))
	41	(kernel:system-area-copy from 0 to 0 (* 8 length))
	42	to)
	43
	44
c4e9d221	45	;;;; User data mechanism
	46
	47	(internal user-data user-data-count)
	48
	49	(declaim (fixnum user-data-count))
	50
c4e9d221	51	(defvar user-data (make-hash-table))
	52	(defvar user-data-count 0)
	53
	54	(defun register-user-data (object &optional destroy-function)
	55	(check-type destroy-function (or null symbol function))
	56	(incf user-data-count)
	57	(setf
	58	(gethash user-data-count user-data)
	59	(cons object destroy-function))
	60	user-data-count)
	61
	62	(defun find-user-data (id)
	63	(check-type id fixnum)
	64	(multiple-value-bind (user-data p) (gethash id user-data)
	65	(values (car user-data) p)))
	66
	67	(defun destroy-user-data (id)
	68	(check-type id fixnum)
	69	(let ((user-data (gethash id user-data)))
	70	(when (cdr user-data)
	71	(funcall (cdr user-data) (car user-data))))
	72	(remhash id user-data))
	73
560af5c5	74
0aef1da8	75	;;;; Quarks
0aef1da8	76
c4e9d221	77	(internal quark-counter quark-from-object quark-to-object)
c4e9d221	78
0aef1da8	79	(deftype quark () 'unsigned)
0aef1da8	80
5cae32e1	81	;(defbinding %quark-get-reserved () quark)
415444ae	82
5cae32e1	83	(defbinding %quark-from-string () quark
415444ae	84	(string string))
415444ae	85
c4e9d221	86	(defvar quark-counter 0)
415444ae	87
415444ae	88	(defun %quark-get-reserved ()
c4e9d221	89	;; The string is just a dummy
c4e9d221	90	(%quark-from-string (format nil "#@�$%&-quark-~D" (incf quark-counter))))
0aef1da8	91
	92	(defvar quark-from-object (make-hash-table))
	93	(defvar quark-to-object (make-hash-table))
	94
	95	(defun quark-from-object (object &key (test #'eq))
	96	(let ((hash-code (sxhash object)))
	97	(or
	98	(assoc-ref object (gethash hash-code quark-from-object) :test test)
	99	(let ((quark (%quark-get-reserved)))
ab566f2c	100	(setf
	101	(gethash hash-code quark-from-object)
	102	(append
	103	(gethash hash-code quark-from-object)
	104	(list (cons object quark))))
0aef1da8	105	(setf (gethash quark quark-to-object) object)
	106	quark))))
	107
	108	(defun quark-to-object (quark)
	109	(gethash quark quark-to-object))
	110
	111	(defun remove-quark (quark)
	112	(let* ((object (gethash quark quark-to-object))
	113	(hash-code (sxhash object)))
	114	(remhash quark quark-to-object)
	115	(unless (setf
	116	(gethash hash-code quark-from-object)
	117	(assoc-delete object (gethash hash-code quark-from-object)))
	118	(remhash hash-code quark-from-object))))
	119
	120
	121
3846c0b6	122	;;;; Linked list (GList)
560af5c5	123
9adccb27	124	(deftype glist (type &key copy)
	125	(declare (ignore copy))
	126	`(or (null (cons ,type list))))
560af5c5	127
dba0c446	128	(defbinding (%glist-append-unsigned "g_list_append") () pointer
3846c0b6	129	(glist pointer)
560af5c5	130	(data unsigned))
560af5c5	131
dba0c446	132	(defbinding (%glist-append-signed "g_list_append") () pointer
3846c0b6	133	(glist pointer)
	134	(data signed))
	135
dba0c446	136	(defbinding (%glist-append-sap "g_list_append") () pointer
3846c0b6	137	(glist pointer)
	138	(data pointer))
	139
9adccb27	140	(defun make-glist (type list)
	141	(let ((new-element (ecase (alien-type type)
	142	(system-area-pointer #'%glist-append-sap)
	143	((signed-byte c-call:short c-call:int c-call:long)
	144	#'%glist-append-signed)
	145	((unsigned-byte c-call:unsigned-short
	146	c-call:unsigned-int c-call:unsigned-long)
	147	#'%glist-append-unsigned)))
	148	(to-alien (to-alien-function type)))
	149	(loop
	150	for element in list
	151	as glist = (funcall new-element (or glist (make-pointer 0))
	152	(funcall to-alien element))
	153	finally (return glist))))
560af5c5	154
560af5c5	155	(defun glist-next (glist)
560af5c5	156	(unless (null-pointer-p glist)
9adccb27	157	(sap-ref-sap glist +size-of-pointer+)))
560af5c5	158
9adccb27	159	;; Also used for gslists
	160	(defun map-glist (seqtype function glist element-type)
	161	(let ((reader (reader-function element-type)))
	162	(case seqtype
	163	((nil)
	164	(loop
	165	as tmp = glist then (glist-next tmp)
	166	until (null-pointer-p tmp)
	167	do (funcall function (funcall reader tmp))))
	168	(list
	169	(loop
	170	as tmp = glist then (glist-next tmp)
	171	until (null-pointer-p tmp)
	172	collect (funcall function (funcall reader tmp))))
	173	(t
	174	(coerce
	175	(loop
	176	as tmp = glist then (glist-next tmp)
	177	until (null-pointer-p tmp)
	178	collect (funcall function (funcall reader tmp)))
	179	seqtype)))))
	180
dba0c446	181	(defbinding (glist-free "g_list_free") () nil
560af5c5	182	(glist pointer))
560af5c5	183
415444ae	184
9adccb27	185	(defmethod alien-type ((type (eql 'glist)) &rest args)
	186	(declare (ignore type args))
	187	(alien-type 'pointer))
	188
	189	(defmethod size-of ((type (eql 'glist)) &rest args)
	190	(declare (ignore type args))
415444ae	191	(size-of 'pointer))
560af5c5	192
9adccb27	193	(defmethod to-alien-form (list (type (eql 'glist)) &rest args)
	194	(declare (ignore type))
	195	(destructuring-bind (element-type) args
	196	`(make-glist ',element-type ,list)))
	197
	198	(defmethod to-alien-function ((type (eql 'glist)) &rest args)
8755b1a5	199	(declare (ignore type))
9adccb27	200	(destructuring-bind (element-type) args
	201	#'(lambda (list)
	202	(make-glist element-type list))))
	203
	204	(defmethod from-alien-form (glist (type (eql 'glist)) &rest args)
	205	(declare (ignore type))
	206	(destructuring-bind (element-type) args
560af5c5	207	`(let ((glist ,glist))
9adccb27	208	(unwind-protect
	209	(map-glist 'list #'identity glist ',element-type)
	210	(glist-free glist)))))
	211
	212	(defmethod from-alien-function ((type (eql 'glist)) &rest args)
	213	(declare (ignore type))
	214	(destructuring-bind (element-type) args
	215	#'(lambda (glist)
	216	(unwind-protect
	217	(map-glist 'list #'identity glist element-type)
	218	(glist-free glist)))))
	219
	220	(defmethod cleanup-form (glist (type (eql 'glist)) &rest args)
	221	(declare (ignore type args))
	222	`(glist-free ,glist))
	223
	224	(defmethod cleanup-function ((type (eql 'glist)) &rest args)
	225	(declare (ignore type args))
	226	#'glist-free)
	227
560af5c5	228
560af5c5	229
3846c0b6	230	;;;; Single linked list (GSList)
	231
	232	(deftype gslist (type) `(or (null (cons ,type list))))
	233
dba0c446	234	(defbinding (%gslist-prepend-unsigned "g_slist_prepend") () pointer
3846c0b6	235	(gslist pointer)
	236	(data unsigned))
	237
dba0c446	238	(defbinding (%gslist-prepend-signed "g_slist_prepend") () pointer
3846c0b6	239	(gslist pointer)
	240	(data signed))
	241
dba0c446	242	(defbinding (%gslist-prepend-sap "g_slist_prepend") () pointer
3846c0b6	243	(gslist pointer)
	244	(data pointer))
	245
9adccb27	246	(defun make-gslist (type list)
	247	(let ((new-element (ecase (alien-type type)
	248	(system-area-pointer #'%gslist-prepend-sap)
	249	((signed-byte c-call:short c-call:int c-call:long)
	250	#'%gslist-prepend-signed)
	251	((unsigned-byte c-call:unsigned-short
	252	c-call:unsigned-int c-call:unsigned-long)
	253	#'%gslist-prepend-unsigned)))
	254	(to-alien (to-alien-function type)))
	255	(loop
	256	for element in (reverse list)
	257	as gslist = (funcall new-element (or gslist (make-pointer 0))
	258	(funcall to-alien element))
	259	finally (return gslist))))
	260
dba0c446	261	(defbinding (gslist-free "g_slist_free") () nil
3846c0b6	262	(gslist pointer))
3846c0b6	263
3846c0b6	264
9adccb27	265	(defmethod alien-type ((type (eql 'gslist)) &rest args)
	266	(declare (ignore type args))
	267	(alien-type 'pointer))
	268
	269	(defmethod size-of ((type (eql 'gslist)) &rest args)
	270	(declare (ignore type args))
3846c0b6	271	(size-of 'pointer))
3846c0b6	272
9adccb27	273	(defmethod to-alien-form (list (type (eql 'gslist)) &rest args)
	274	(declare (ignore type))
	275	(destructuring-bind (element-type) args
	276	`(make-sglist ',element-type ,list)))
	277
	278	(defmethod to-alien-function ((type (eql 'gslist)) &rest args)
8755b1a5	279	(declare (ignore type))
9adccb27	280	(destructuring-bind (element-type) args
	281	#'(lambda (list)
	282	(make-gslist element-type list))))
	283
	284	(defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args)
	285	(declare (ignore type))
	286	(destructuring-bind (element-type) args
3846c0b6	287	`(let ((gslist ,gslist))
9adccb27	288	(unwind-protect
	289	(map-glist 'list #'identity gslist ',element-type)
	290	(gslist-free gslist)))))
3846c0b6	291
9adccb27	292	(defmethod from-alien-function ((type (eql 'gslist)) &rest args)
	293	(declare (ignore type))
	294	(destructuring-bind (element-type) args
	295	#'(lambda (gslist)
	296	(unwind-protect
	297	(map-glist 'list #'identity gslist element-type)
	298	(gslist-free gslist)))))
3846c0b6	299
9adccb27	300	(defmethod cleanup-form (list (type (eql 'gslist)) &rest args)
	301	(declare (ignore type args))
	302	`(gslist-free ,list))
3846c0b6	303
9adccb27	304	(defmethod cleanup-function ((type (eql 'gslist)) &rest args)
	305	(declare (ignore type args))
	306	#'gslist-free)
415444ae	307
5cae32e1	308
415444ae	309
9adccb27	310	;;; Vector
415444ae	311
9adccb27	312	(defun make-c-vector (type length &optional content location)
	313	(let* ((size-of-type (size-of type))
	314	(location (or location (allocate-memory (* size-of-type length))))
	315	(writer (writer-function type)))
	316	(loop
	317	for element across content
	318	for i from 0 below length
	319	as offset = 0 then (+ offset size-of-type)
	320	do (funcall writer element location offset))
	321	location))
	322
	323
	324	(defun map-c-vector (seqtype function location element-type length)
	325	(let ((reader (reader-function element-type))
	326	(size-of-element (size-of element-type)))
dba0c446	327	(case seqtype
dba0c446	328	((nil)
9adccb27	329	(loop
	330	for i from 0 below length
	331	as offset = 0 then (+ offset size-of-element)
	332	do (funcall function (funcall reader location offset))))
dba0c446	333	(list
9adccb27	334	(loop
	335	for i from 0 below length
	336	as offset = 0 then (+ offset size-of-element)
	337	collect (funcall function (funcall reader location offset))))
dba0c446	338	(t
9adccb27	339	(loop
	340	with sequence = (make-sequence seqtype length)
	341	for i from 0 below length
	342	as offset = 0 then (+ offset size-of-element)
	343	do (setf
dba0c446	344	(elt sequence i)
9adccb27	345	(funcall function (funcall reader location offset)))
	346	finally (return sequence))))))
	347
	348
	349	(defmethod alien-type ((type (eql 'vector)) &rest args)
	350	(declare (ignore type args))
	351	(alien-type 'pointer))
	352
	353	(defmethod size-of ((type (eql 'vector)) &rest args)
	354	(declare (ignore type args))
	355	(size-of 'pointer))
	356
	357	(defmethod to-alien-form (vector (type (eql 'vector)) &rest args)
	358	(declare (ignore type))
	359	(destructuring-bind (element-type &optional (length '*)) args
	360	(if (eq length '*)
	361	`(let* ((vector ,vector)
	362	(location (sap+
	363	(allocate-memory (+ ,+size-of-int+
	364	(* ,(size-of element-type)
	365	(length vector))))
	366	,+size-of-int+)))
	367	(make-c-vector ',element-type (length vector) vector location)
	368	(setf (sap-ref-32 location ,(- +size-of-int+)) (length vector))
	369	location)
	370	`(make-c-vector ',element-type ,length ,vector))))
	371
	372	(defmethod from-alien-form (location (type (eql 'vector)) &rest args)
	373	(declare (ignore type))
	374	(destructuring-bind (element-type &optional (length '*)) args
	375	(if (eq length '*)
	376	(error "Can't use vector of variable size as return type")
	377	`(map-c-vector 'vector #'identity ',element-type ',length ,location))))
	378
	379	(defmethod cleanup-form (location (type (eql 'vector)) &rest args)
	380	(declare (ignore type))
	381	(destructuring-bind (element-type &optional (length '*)) args
	382	`(let* ((location ,location)
	383	(length ,(if (eq length '*)
	384	`(sap-ref-32 location ,(- +size-of-int+))
	385	length)))
	386	(loop
	387	with destroy = (destroy-function ',element-type)
	388	for i from 0 below length
	389	as offset = 0 then (+ offset ,(size-of element-type))
	390	do (funcall destroy location offset))
	391	(deallocate-memory ,(if (eq length '*)
	392	`(sap+ location ,(- +size-of-int+))
	393	'location)))))