[clg] / glib / glib.lisp

;; Common Lisp bindings for GTK+ 2.x
;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
;;
;; 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:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; 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.42 2007/10/17 14:30:41 espen Exp $


(in-package "GLIB")

(use-prefix "g")

#-sb-thread
(progn
  (defun make-mutex ()
    nil)
  
  (defmacro with-mutex ((mutex) &body body)
    (declare (ignore mutex))
    `(progn ,@body)))


;;;; Memory management

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

(defbinding (%deallocate-memory "g_free") () nil
  (address pointer))

;; (setf
;;  (symbol-function 'allocate-memory) #'%allocate-memory
;;  (symbol-function 'deallocate-memory) #'%deallocate-memory)

(setf *memory-allocator* #'%allocate-memory)
(setf *memory-deallocator* #'%deallocate-memory)

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

(deftype gsize () 'unsigned-int)

(defbinding (slice-alloc "g_slice_alloc0") () pointer
  (block-size gsize))

;;;; User data is a mechanism to store references to lisp objects in
;;;; foreign code

(defvar *user-data-lock* (make-mutex))
(defvar *user-data* (make-hash-table))
(defvar *user-data-next-id* 1)

(defun register-user-data (object &optional destroy-function)
  (check-type destroy-function (or null symbol function))
  (with-mutex (*user-data-lock*)
    (setf
     (gethash *user-data-next-id* *user-data*)
     (cons object destroy-function))
    (1- (incf *user-data-next-id*))))

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

(defun user-data-exists-p (id)
  (nth-value 1 (find-user-data id)))

(defun update-user-data (id object)
  (check-type id fixnum)
  (with-mutex (*user-data-lock*)
    (multiple-value-bind (user-data exists-p) (gethash id *user-data*)
      (cond
       ((not exists-p) (error "User data id ~A does not exist" id))
       (t 
	(when (cdr user-data)
	  (funcall (cdr user-data) (car user-data)))
	(setf (car user-data) object))))))

(defun destroy-user-data (id)
  (check-type id fixnum)
  (with-mutex (*user-data-lock*)
    (multiple-value-bind (user-data exists-p) (gethash id *user-data*)
      (cond
;       ((not exists-p) (error "User data id ~A does not exist" id))
       (t
	(when (cdr user-data)
	  (funcall (cdr user-data) (car user-data)))
	(remhash id *user-data*))))))

(defun take-user-data (id)
  (check-type id fixnum)
  (multiple-value-bind (user-data exists-p) (gethash id *user-data*)
    (cond
      ((not exists-p) (error "User data id ~A does not exist" id))
      (t 
	(when (cdr user-data)
	  (funcall (cdr user-data) (car user-data)))
	(remhash id *user-data*)
	(car user-data)))))

(defmacro with-user-data ((var object) &body body)
  `(let ((,var (register-user-data ,object)))
     (unwind-protect
	  ,@body
       (destroy-user-data ,var))))


(deftype user-data-id () 'pointer-data)


;;;; Quarks

(deftype quark () 'unsigned)

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

(defun quark-intern (object)
  (etypecase object
    (quark object)
    (string (%quark-from-string object))
    (symbol (%quark-from-string (format nil "clg-~A:~A" 
				 (package-name (symbol-package object)) 
				 object)))))

(defbinding quark-to-string () (static string)
  (quark quark))


;;;; Linked list (GList)

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

(defbinding (%glist-append "g_list_append") () pointer
  (glist (or null pointer))
  (nil null))

(defun make-glist (element-type list &optional temp-p)
  (let ((writer (if (functionp element-type)
		    element-type
		  (writer-function element-type :temp temp-p))))
    (loop
     for element in list
     as glist = (%glist-append nil) then (%glist-append glist)
     do (funcall writer element glist)
     finally (return glist))))

(defun glist-next (glist)
  (unless (null-pointer-p glist)
    (ref-pointer glist #.(size-of 'pointer))))
  
;; Also used for gslists
(defun map-glist (seqtype function glist element-type &optional (ref :read))
  (let ((reader (if (functionp element-type)
		    element-type
		  (reader-function element-type :ref ref))))
    (case seqtype 
     ((nil)
      (loop
       as element = glist then (glist-next element)
       until (null-pointer-p element)
       do (funcall function (funcall reader element))))
     (list
      (loop
       as element = glist then (glist-next element)
       until (null-pointer-p element)
       collect (funcall function (funcall reader element))))
     (t
      (coerce 
       (loop
	as element = glist then (glist-next element)
	until (null-pointer-p element)
	collect (funcall function (funcall reader element)))
       seqtype)))))

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

(defun destroy-glist (glist element-type &optional temp-p)
  (let ((destroy (if (functionp element-type)
		     element-type
		   (destroy-function element-type :temp temp-p))))
    (loop
     as element = glist then (glist-next element)
     until (null-pointer-p element)
     do (funcall destroy element)))
  (glist-free glist))

(define-type-method alien-type ((type glist))
  (declare (ignore type))
  (alien-type 'pointer))

(define-type-method argument-type ((type glist))
  'list)

(define-type-method return-type ((type glist))
  'list)

(define-type-method size-of ((type glist) &key inlined)
  (assert-not-inlined type inlined)
  (size-of 'pointer))

(define-type-method type-alignment ((type glist) &key inlined)
  (assert-not-inlined type inlined)
  (type-alignment 'pointer))

(define-type-method alien-arg-wrapper ((type glist) var list style form &optional copy-in-p)
  (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
    (cond
      ((and (in-arg-p style) (not (out-arg-p style)))
       `(with-pointer (,var (make-glist ',element-type ,list ,(not copy-in-p)))
	  (unwind-protect
	      ,form
	    ,(unless copy-in-p
	       `(destroy-glist ,var ',element-type t)))))
      ((and (in-arg-p style) (out-arg-p style))
       (let ((glist (make-symbol "GLIST")))
	 `(with-pointer (,glist (make-glist ',element-type ,list ,(not copy-in-p)))
            (with-pointer (,var ,glist)		      
	      (unwind-protect
		  ,form
		,(unless copy-in-p
		   `(destroy-glist ,glist ',element-type t)))))))
      ((and (out-arg-p style) (not (in-arg-p style)))
       `(with-pointer (,var)
	  ,form)))))

(define-type-method to-alien-form ((type glist) list &optional copy-p)
  (declare (ignore copy-p))
  (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
    `(make-glist ',element-type ,list)))

(define-type-method to-alien-function ((type glist) &optional copy-p)
  (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
    (values
     #'(lambda (list)
	 (make-glist element-type list (not copy-p)))
     (unless copy-p
       #'(lambda (list glist)
	   (declare (ignore list))
	   (destroy-glist glist element-type t))))))

(define-type-method from-alien-form ((type glist) form &key (ref :free))
  (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
    `(let ((glist ,form))
       (unwind-protect
	   (map-glist 'list #'identity glist ',element-type 
	    ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
	 ,(when (eq ref :free)
	    `(destroy-glist glist ',element-type))))))

(define-type-method from-alien-function ((type glist) &key (ref :free))
  (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
    (ecase ref
      (:free 
       #'(lambda (glist)
	   (prog1
	       (map-glist 'list #'identity glist element-type :get)
	     (glist-free glist))))
      (:copy
       #'(lambda (glist)
	   (map-glist 'list #'identity glist element-type :read)))
      ((:static :temp)
       #'(lambda (glist)
	   (map-glist 'list #'identity glist element-type :peek))))))

(define-type-method writer-function ((type glist) &key temp inlined)
  (assert-not-inlined type inlined)
  (let ((element-type (second (type-expand-to 'glist type))))
    #'(lambda (list location &optional (offset 0))
	(setf 
	 (ref-pointer location offset)
	 (make-glist element-type list temp)))))

(define-type-method reader-function ((type glist) &key (ref :read) inlined)
  (assert-not-inlined type inlined)
  (let ((element-type (second (type-expand-to 'glist type))))
    (ecase ref
      ((:read :peek)
       #'(lambda (location &optional (offset 0))
	   (unless (null-pointer-p (ref-pointer location offset))
	     (map-glist 'list #'identity (ref-pointer location offset) element-type ref))))
      (:get
       #'(lambda (location &optional (offset 0))
	   (unless (null-pointer-p (ref-pointer location offset))
	     (prog1
		 (map-glist 'list #'identity (ref-pointer location offset) element-type :get)
	       (glist-free (ref-pointer location offset))
	       (setf (ref-pointer location offset) (make-pointer 0)))))))))

(define-type-method destroy-function ((type glist) &key temp inlined)
  (assert-not-inlined type inlined)
  (let ((element-type (second (type-expand-to 'glist type))))
    #'(lambda (location &optional (offset 0))
	(unless (null-pointer-p (ref-pointer location offset))
	  (destroy-glist (ref-pointer location offset) element-type temp)
	  (setf (ref-pointer location offset) (make-pointer 0))))))

(define-type-method copy-function ((type glist) &key inlined)
  (assert-not-inlined type inlined)
  (destructuring-bind (element-type) (rest (type-expand-to 'glist type))
    (let ((copy-element (copy-function element-type)))
      #'(lambda (from to &optional (offset 0))
	  (unless (null-pointer-p (ref-pointer from offset))
	    (loop
	     as from-list = (ref-pointer from offset) 
	                    then (glist-next from-list)
	     as to-list = (setf (ref-pointer to offset) (%glist-append nil)) 
	                  then (%glist-append to-list)
	     do (funcall copy-element from-list to-list)
	     while (glist-next from-lisT)))))))


;;;; Single linked list (GSList)

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

(defbinding (%gslist-prepend "g_slist_prepend") () pointer
  (gslist pointer)
  (nil null))

(defbinding (%gslist-append "g_slist_append") () pointer
  (glist (or null pointer))
  (nil null))


(defun make-gslist (element-type list &optional temp-p)
  (let ((writer (if (functionp element-type)
		    element-type
		  (writer-function element-type :temp temp-p))))
    (loop
     for element in (reverse list)
     as gslist = (%gslist-prepend (make-pointer 0)) then (%gslist-prepend gslist)
     do (funcall writer element gslist)
     finally (return gslist))))

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

(defun destroy-gslist (gslist element-type &optional temp-p)
  (loop
   with destroy = (destroy-function element-type :temp temp-p)
   as element = gslist then (glist-next element)
   until (null-pointer-p element)
   do (funcall destroy element 0))
  (gslist-free gslist))

(define-type-method alien-type ((type gslist))
  (declare (ignore type))
  (alien-type 'pointer))

(define-type-method argument-type ((type gslist))
  'list)

(define-type-method return-type ((type gslist))
  'list)

(define-type-method size-of ((type gslist) &key inlined)
  (assert-not-inlined type inlined)
  (size-of 'pointer))

(define-type-method type-alignment ((type gslist) &key inlined)
  (assert-not-inlined type inlined)
  (type-alignment 'pointer))

(define-type-method alien-arg-wrapper ((type gslist) var list style form &optional copy-in-p)
  (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
    (cond
      ((and (in-arg-p style) (not (out-arg-p style)))
       `(with-pointer (,var (make-gslist ',element-type ,list ,(not copy-in-p)))
	  (unwind-protect
	      ,form
	    ,(unless copy-in-p
	       `(destroy-gslist ,var ',element-type t)))))
      ((and (in-arg-p style) (out-arg-p style))
       (let ((gslist (make-symbol "GSLIST")))
	 `(with-pointer (,gslist (make-gslist ',element-type ,list ,(not copy-in-p)))
            (with-pointer (,var ,gslist)		      
	      (unwind-protect
		  ,form
		,(unless copy-in-p
		   `(destroy-gslist ,gslist ',element-type t)))))))
      ((and (out-arg-p style) (not (in-arg-p style)))
       `(with-pointer (,var)
	  ,form)))))

(define-type-method to-alien-form ((type gslist) list &optional copy-p)
  (declare (ignore copy-p))
  (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
    `(make-gslist ',element-type ,list)))

(define-type-method to-alien-function ((type gslist) &optional copy-p)
  (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
    (values
     #'(lambda (list)
	 (make-gslist element-type list (not copy-p)))
     (unless copy-p
       #'(lambda (list gslist)
	   (declare (ignore list))
	   (destroy-gslist gslist element-type t))))))

(define-type-method from-alien-form ((type gslist) form &key (ref :free))
  (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
    `(let ((gslist ,form))
       (unwind-protect
	   (map-glist 'list #'identity gslist ',element-type
	    ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
	 ,(when (eq ref :free)
	    `(destroy-gslist gslist ',element-type))))))

(define-type-method from-alien-function ((type gslist)  &key (ref :free))
  (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
    (ecase ref
      (:free 
       #'(lambda (glist)
	   (prog1
	       (map-glist 'list #'identity glist element-type :get)
	     (gslist-free glist))))
      (:copy
       #'(lambda (glist)
	   (map-glist 'list #'identity glist element-type :read)))
      ((:static :temp)
       #'(lambda (glist)
	   (map-glist 'list #'identity glist element-type :peek))))))

(define-type-method writer-function ((type gslist) &key temp inlined)
  (assert-not-inlined type inlined)
  (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
    (let ((element-writer (writer-function element-type :temp temp)))
      #'(lambda (list location &optional (offset 0))
	  (setf 
	   (ref-pointer location offset)
	   (make-gslist element-writer list))))))

(define-type-method reader-function ((type gslist) &key (ref :read) inlined)
  (assert-not-inlined type inlined)
  (let ((element-type (second (type-expand-to 'gslist type))))
    (ecase ref
      ((:read :peek)
       #'(lambda (location &optional (offset 0))
	   (unless (null-pointer-p (ref-pointer location offset))
	     (map-glist 'list #'identity (ref-pointer location offset) element-type ref))))
      (:get
       #'(lambda (location &optional (offset 0))
	   (unless (null-pointer-p (ref-pointer location offset))
	     (prog1
		 (map-glist 'list #'identity (ref-pointer location offset) element-type :get)
	       (gslist-free (ref-pointer location offset))
	       (setf (ref-pointer location offset) (make-pointer 0)))))))))

(define-type-method destroy-function ((type gslist) &key temp inlined)
  (assert-not-inlined type inlined)
  (let ((element-type (second (type-expand-to 'gslist type))))
    #'(lambda (location &optional (offset 0))
	(unless (null-pointer-p (ref-pointer location offset))
	  (destroy-gslist (ref-pointer location offset) element-type temp)
	  (setf (ref-pointer location offset) (make-pointer 0))))))

(define-type-method copy-function ((type gslist) &key inlined)
  (assert-not-inlined type inlined)
  (destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
    (let ((copy-element (copy-function element-type)))
      #'(lambda (from to &optional (offset 0))
	  (unless (null-pointer-p (ref-pointer from offset))
	    (loop
	     as from-list = (ref-pointer from offset) 
	                    then (glist-next from-list)
	     as to-list = (setf (ref-pointer to offset) (%gslist-append nil)) 
	                  then (%gslist-append to-list)
	     do (funcall copy-element from-list to-list)
	     while (glist-next from-list)))))))
Commit	Line	Data
55212af1	1	;; Common Lisp bindings for GTK+ 2.x
55212af1	2	;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
0d07716f	3	;;
55212af1	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:
0d07716f	11	;;
55212af1	12	;; The above copyright notice and this permission notice shall be
55212af1	13	;; included in all copies or substantial portions of the Software.
0d07716f	14	;;
55212af1	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
d09560df	23	;; $Id: glib.lisp,v 1.42 2007/10/17 14:30:41 espen Exp $
0d07716f	24
	25
	26	(in-package "GLIB")
b467f3d0	27
0d07716f	28	(use-prefix "g")
0d07716f	29
db4e735f	30	#-sb-thread
	31	(progn
	32	(defun make-mutex ()
	33	nil)
	34
	35	(defmacro with-mutex ((mutex) &body body)
	36	(declare (ignore mutex))
	37	`(progn ,@body)))
	38
0d07716f	39
	40	;;;; Memory management
	41
7fa3e612	42	(defbinding (%allocate-memory "g_malloc0") () pointer
0d07716f	43	(size unsigned-long))
0d07716f	44
7fa3e612	45	(defbinding (%deallocate-memory "g_free") () nil
3fa4f6bd	46	(address pointer))
3d23e952	47
c2dec722	48	;; (setf
	49	;; (symbol-function 'allocate-memory) #'%allocate-memory
	50	;; (symbol-function 'deallocate-memory) #'%deallocate-memory)
0d07716f	51
c2dec722	52	(setf memory-allocator #'%allocate-memory)
c2dec722	53	(setf memory-deallocator #'%deallocate-memory)
b467f3d0	54
b9ec4185	55	(defbinding (reallocate-memory "g_realloc") () pointer
	56	(address pointer)
	57	(size unsigned-long))
	58
d09560df	59	(deftype gsize () 'unsigned-int)
b9ec4185	60
d09560df	61	(defbinding (slice-alloc "g_slice_alloc0") () pointer
	62	(block-size gsize))
	63
	64	;;;; User data is a mechanism to store references to lisp objects in
	65	;;;; foreign code
b467f3d0	66
db4e735f	67	(defvar user-data-lock (make-mutex))
b467f3d0	68	(defvar user-data (make-hash-table))
d09560df	69	(defvar user-data-next-id 1)
b467f3d0	70
	71	(defun register-user-data (object &optional destroy-function)
	72	(check-type destroy-function (or null symbol function))
db4e735f	73	(with-mutex (user-data-lock)
db4e735f	74	(setf
d09560df	75	(gethash user-data-next-id user-data)
db4e735f	76	(cons object destroy-function))
d09560df	77	(1- (incf user-data-next-id))))
b467f3d0	78
	79	(defun find-user-data (id)
	80	(check-type id fixnum)
db4e735f	81	(with-mutex (user-data-lock)
	82	(multiple-value-bind (user-data p) (gethash id user-data)
	83	(values (car user-data) p))))
b467f3d0	84
3e033db9	85	(defun user-data-exists-p (id)
	86	(nth-value 1 (find-user-data id)))
	87
29c05201	88	(defun update-user-data (id object)
29c05201	89	(check-type id fixnum)
db4e735f	90	(with-mutex (user-data-lock)
	91	(multiple-value-bind (user-data exists-p) (gethash id user-data)
	92	(cond
	93	((not exists-p) (error "User data id ~A does not exist" id))
	94	(t
	95	(when (cdr user-data)
	96	(funcall (cdr user-data) (car user-data)))
	97	(setf (car user-data) object))))))
29c05201	98
b467f3d0	99	(defun destroy-user-data (id)
b467f3d0	100	(check-type id fixnum)
db4e735f	101	(with-mutex (user-data-lock)
d09560df	102	(multiple-value-bind (user-data exists-p) (gethash id user-data)
	103	(cond
	104	; ((not exists-p) (error "User data id ~A does not exist" id))
	105	(t
	106	(when (cdr user-data)
	107	(funcall (cdr user-data) (car user-data)))
	108	(remhash id user-data))))))
	109
	110	(defun take-user-data (id)
	111	(check-type id fixnum)
	112	(multiple-value-bind (user-data exists-p) (gethash id user-data)
	113	(cond
	114	((not exists-p) (error "User data id ~A does not exist" id))
	115	(t
	116	(when (cdr user-data)
	117	(funcall (cdr user-data) (car user-data)))
	118	(remhash id user-data)
	119	(car user-data)))))
	120
	121	(defmacro with-user-data ((var object) &body body)
	122	`(let ((,var (register-user-data ,object)))
	123	(unwind-protect
	124	,@body
	125	(destroy-user-data ,var))))
	126
	127
	128	(deftype user-data-id () 'pointer-data)
b467f3d0	129
0d07716f	130
6755fdad	131	;;;; Quarks
	132
	133	(deftype quark () 'unsigned)
	134
cb816364	135	(defbinding %quark-from-string () quark
e5b6173a	136	(string string))
e5b6173a	137
3e033db9	138	(defun quark-intern (object)
	139	(etypecase object
	140	(quark object)
	141	(string (%quark-from-string object))
	142	(symbol (%quark-from-string (format nil "clg-~A:~A"
	143	(package-name (symbol-package object))
	144	object)))))
6755fdad	145
7fa3e612	146	(defbinding quark-to-string () (static string)
3e033db9	147	(quark quark))
6755fdad	148
6755fdad	149
597999f9	150	;;;; Linked list (GList)
0d07716f	151
5f2222a9	152	(deftype glist (type)
4d1fea77	153	`(or null (cons ,type list)))
0d07716f	154
5f2222a9	155	(defbinding (%glist-append "g_list_append") () pointer
7fa3e612	156	(glist (or null pointer))
5f2222a9	157	(nil null))
597999f9	158
7fa3e612	159	(defun make-glist (element-type list &optional temp-p)
	160	(let ((writer (if (functionp element-type)
	161	element-type
	162	(writer-function element-type :temp temp-p))))
	163	(loop
	164	for element in list
	165	as glist = (%glist-append nil) then (%glist-append glist)
	166	do (funcall writer element glist)
	167	finally (return glist))))
0d07716f	168
0d07716f	169	(defun glist-next (glist)
0d07716f	170	(unless (null-pointer-p glist)
7fa3e612	171	(ref-pointer glist #.(size-of 'pointer))))
0d07716f	172
6baf860c	173	;; Also used for gslists
7fa3e612	174	(defun map-glist (seqtype function glist element-type &optional (ref :read))
	175	(let ((reader (if (functionp element-type)
	176	element-type
	177	(reader-function element-type :ref ref))))
6baf860c	178	(case seqtype
	179	((nil)
	180	(loop
7fa3e612	181	as element = glist then (glist-next element)
	182	until (null-pointer-p element)
	183	do (funcall function (funcall reader element))))
6baf860c	184	(list
6baf860c	185	(loop
7fa3e612	186	as element = glist then (glist-next element)
	187	until (null-pointer-p element)
	188	collect (funcall function (funcall reader element))))
6baf860c	189	(t
	190	(coerce
	191	(loop
7fa3e612	192	as element = glist then (glist-next element)
	193	until (null-pointer-p element)
	194	collect (funcall function (funcall reader element)))
6baf860c	195	seqtype)))))
6baf860c	196
1c99696e	197	(defbinding (glist-free "g_list_free") () nil
0d07716f	198	(glist pointer))
0d07716f	199
7fa3e612	200	(defun destroy-glist (glist element-type &optional temp-p)
	201	(let ((destroy (if (functionp element-type)
	202	element-type
	203	(destroy-function element-type :temp temp-p))))
	204	(loop
	205	as element = glist then (glist-next element)
	206	until (null-pointer-p element)
	207	do (funcall destroy element)))
5f2222a9	208	(glist-free glist))
e5b6173a	209
4d1fea77	210	(define-type-method alien-type ((type glist))
4d1fea77	211	(declare (ignore type))
6baf860c	212	(alien-type 'pointer))
6baf860c	213
b9ec4185	214	(define-type-method argument-type ((type glist))
	215	'list)
	216
	217	(define-type-method return-type ((type glist))
	218	'list)
	219
7fa3e612	220	(define-type-method size-of ((type glist) &key inlined)
7fa3e612	221	(assert-not-inlined type inlined)
e5b6173a	222	(size-of 'pointer))
0d07716f	223
83f60e84	224	(define-type-method type-alignment ((type glist) &key inlined)
	225	(assert-not-inlined type inlined)
	226	(type-alignment 'pointer))
5f2222a9	227
7fa3e612	228	(define-type-method alien-arg-wrapper ((type glist) var list style form &optional copy-in-p)
	229	(destructuring-bind (element-type) (rest (type-expand-to 'glist type))
	230	(cond
	231	((and (in-arg-p style) (not (out-arg-p style)))
	232	`(with-pointer (,var (make-glist ',element-type ,list ,(not copy-in-p)))
	233	(unwind-protect
	234	,form
	235	,(unless copy-in-p
	236	`(destroy-glist ,var ',element-type t)))))
	237	((and (in-arg-p style) (out-arg-p style))
	238	(let ((glist (make-symbol "GLIST")))
	239	`(with-pointer (,glist (make-glist ',element-type ,list ,(not copy-in-p)))
	240	(with-pointer (,var ,glist)
	241	(unwind-protect
	242	,form
	243	,(unless copy-in-p
	244	`(destroy-glist ,glist ',element-type t)))))))
	245	((and (out-arg-p style) (not (in-arg-p style)))
	246	`(with-pointer (,var)
	247	,form)))))
	248
	249	(define-type-method to-alien-form ((type glist) list &optional copy-p)
	250	(declare (ignore copy-p))
	251	(destructuring-bind (element-type) (rest (type-expand-to 'glist type))
	252	`(make-glist ',element-type ,list)))
0d07716f	253
7fa3e612	254	(define-type-method to-alien-function ((type glist) &optional copy-p)
	255	(destructuring-bind (element-type) (rest (type-expand-to 'glist type))
	256	(values
	257	#'(lambda (list)
	258	(make-glist element-type list (not copy-p)))
	259	(unless copy-p
	260	#'(lambda (list glist)
	261	(declare (ignore list))
	262	(destroy-glist glist element-type t))))))
	263
	264	(define-type-method from-alien-form ((type glist) form &key (ref :free))
	265	(destructuring-bind (element-type) (rest (type-expand-to 'glist type))
	266	`(let ((glist ,form))
	267	(unwind-protect
	268	(map-glist 'list #'identity glist ',element-type
	269	,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
	270	,(when (eq ref :free)
	271	`(destroy-glist glist ',element-type))))))
	272
	273	(define-type-method from-alien-function ((type glist) &key (ref :free))
	274	(destructuring-bind (element-type) (rest (type-expand-to 'glist type))
	275	(ecase ref
	276	(:free
	277	#'(lambda (glist)
	278	(prog1
	279	(map-glist 'list #'identity glist element-type :get)
	280	(glist-free glist))))
	281	(:copy
	282	#'(lambda (glist)
	283	(map-glist 'list #'identity glist element-type :read)))
	284	((:static :temp)
	285	#'(lambda (glist)
	286	(map-glist 'list #'identity glist element-type :peek))))))
	287
	288	(define-type-method writer-function ((type glist) &key temp inlined)
	289	(assert-not-inlined type inlined)
4d1fea77	290	(let ((element-type (second (type-expand-to 'glist type))))
02b6647e	291	#'(lambda (list location &optional (offset 0))
02b6647e	292	(setf
7fa3e612	293	(ref-pointer location offset)
7fa3e612	294	(make-glist element-type list temp)))))
02b6647e	295
7fa3e612	296	(define-type-method reader-function ((type glist) &key (ref :read) inlined)
7fa3e612	297	(assert-not-inlined type inlined)
4d1fea77	298	(let ((element-type (second (type-expand-to 'glist type))))
7fa3e612	299	(ecase ref
	300	((:read :peek)
	301	#'(lambda (location &optional (offset 0))
	302	(unless (null-pointer-p (ref-pointer location offset))
	303	(map-glist 'list #'identity (ref-pointer location offset) element-type ref))))
	304	(:get
	305	#'(lambda (location &optional (offset 0))
	306	(unless (null-pointer-p (ref-pointer location offset))
	307	(prog1
	308	(map-glist 'list #'identity (ref-pointer location offset) element-type :get)
	309	(glist-free (ref-pointer location offset))
	310	(setf (ref-pointer location offset) (make-pointer 0)))))))))
	311
	312	(define-type-method destroy-function ((type glist) &key temp inlined)
	313	(assert-not-inlined type inlined)
4d1fea77	314	(let ((element-type (second (type-expand-to 'glist type))))
02b6647e	315	#'(lambda (location &optional (offset 0))
7fa3e612	316	(unless (null-pointer-p (ref-pointer location offset))
	317	(destroy-glist (ref-pointer location offset) element-type temp)
	318	(setf (ref-pointer location offset) (make-pointer 0))))))
	319
	320	(define-type-method copy-function ((type glist) &key inlined)
	321	(assert-not-inlined type inlined)
	322	(destructuring-bind (element-type) (rest (type-expand-to 'glist type))
	323	(let ((copy-element (copy-function element-type)))
	324	#'(lambda (from to &optional (offset 0))
	325	(unless (null-pointer-p (ref-pointer from offset))
	326	(loop
	327	as from-list = (ref-pointer from offset)
	328	then (glist-next from-list)
	329	as to-list = (setf (ref-pointer to offset) (%glist-append nil))
	330	then (%glist-append to-list)
	331	do (funcall copy-element from-list to-list)
	332	while (glist-next from-lisT)))))))
02b6647e	333
0d07716f	334
597999f9	335	;;;; Single linked list (GSList)
597999f9	336
4d1fea77	337	(deftype gslist (type) `(or null (cons ,type list)))
597999f9	338
5f2222a9	339	(defbinding (%gslist-prepend "g_slist_prepend") () pointer
597999f9	340	(gslist pointer)
5f2222a9	341	(nil null))
597999f9	342
7fa3e612	343	(defbinding (%gslist-append "g_slist_append") () pointer
	344	(glist (or null pointer))
	345	(nil null))
	346
	347
	348	(defun make-gslist (element-type list &optional temp-p)
	349	(let ((writer (if (functionp element-type)
	350	element-type
	351	(writer-function element-type :temp temp-p))))
	352	(loop
	353	for element in (reverse list)
	354	as gslist = (%gslist-prepend (make-pointer 0)) then (%gslist-prepend gslist)
	355	do (funcall writer element gslist)
	356	finally (return gslist))))
6baf860c	357
1c99696e	358	(defbinding (gslist-free "g_slist_free") () nil
597999f9	359	(gslist pointer))
597999f9	360
7fa3e612	361	(defun destroy-gslist (gslist element-type &optional temp-p)
5f2222a9	362	(loop
7fa3e612	363	with destroy = (destroy-function element-type :temp temp-p)
	364	as element = gslist then (glist-next element)
	365	until (null-pointer-p element)
	366	do (funcall destroy element 0))
5f2222a9	367	(gslist-free gslist))
597999f9	368
4d1fea77	369	(define-type-method alien-type ((type gslist))
4d1fea77	370	(declare (ignore type))
6baf860c	371	(alien-type 'pointer))
6baf860c	372
b9ec4185	373	(define-type-method argument-type ((type gslist))
	374	'list)
	375
	376	(define-type-method return-type ((type gslist))
	377	'list)
	378
7fa3e612	379	(define-type-method size-of ((type gslist) &key inlined)
7fa3e612	380	(assert-not-inlined type inlined)
597999f9	381	(size-of 'pointer))
597999f9	382
83f60e84	383	(define-type-method type-alignment ((type gslist) &key inlined)
	384	(assert-not-inlined type inlined)
	385	(type-alignment 'pointer))
	386
7fa3e612	387	(define-type-method alien-arg-wrapper ((type gslist) var list style form &optional copy-in-p)
	388	(destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
	389	(cond
	390	((and (in-arg-p style) (not (out-arg-p style)))
	391	`(with-pointer (,var (make-gslist ',element-type ,list ,(not copy-in-p)))
	392	(unwind-protect
	393	,form
	394	,(unless copy-in-p
	395	`(destroy-gslist ,var ',element-type t)))))
	396	((and (in-arg-p style) (out-arg-p style))
	397	(let ((gslist (make-symbol "GSLIST")))
	398	`(with-pointer (,gslist (make-gslist ',element-type ,list ,(not copy-in-p)))
	399	(with-pointer (,var ,gslist)
	400	(unwind-protect
	401	,form
	402	,(unless copy-in-p
	403	`(destroy-gslist ,gslist ',element-type t)))))))
	404	((and (out-arg-p style) (not (in-arg-p style)))
	405	`(with-pointer (,var)
	406	,form)))))
	407
	408	(define-type-method to-alien-form ((type gslist) list &optional copy-p)
	409	(declare (ignore copy-p))
	410	(destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
	411	`(make-gslist ',element-type ,list)))
	412
	413	(define-type-method to-alien-function ((type gslist) &optional copy-p)
	414	(destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
	415	(values
	416	#'(lambda (list)
	417	(make-gslist element-type list (not copy-p)))
	418	(unless copy-p
	419	#'(lambda (list gslist)
	420	(declare (ignore list))
	421	(destroy-gslist gslist element-type t))))))
	422
	423	(define-type-method from-alien-form ((type gslist) form &key (ref :free))
	424	(destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
	425	`(let ((gslist ,form))
	426	(unwind-protect
	427	(map-glist 'list #'identity gslist ',element-type
	428	,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
	429	,(when (eq ref :free)
	430	`(destroy-gslist gslist ',element-type))))))
	431
	432	(define-type-method from-alien-function ((type gslist) &key (ref :free))
	433	(destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
	434	(ecase ref
	435	(:free
	436	#'(lambda (glist)
	437	(prog1
	438	(map-glist 'list #'identity glist element-type :get)
	439	(gslist-free glist))))
	440	(:copy
	441	#'(lambda (glist)
	442	(map-glist 'list #'identity glist element-type :read)))
	443	((:static :temp)
	444	#'(lambda (glist)
	445	(map-glist 'list #'identity glist element-type :peek))))))
	446
	447	(define-type-method writer-function ((type gslist) &key temp inlined)
	448	(assert-not-inlined type inlined)
	449	(destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
	450	(let ((element-writer (writer-function element-type :temp temp)))
451	#'(lambda (list location &optional (offset 0))
452	(setf
453	(ref-pointer location offset)
454	(make-gslist element-writer list))))))
455
456	(define-type-method reader-function ((type gslist) &key (ref :read) inlined)
457	(assert-not-inlined type inlined)
4d1fea77	458	(let ((element-type (second (type-expand-to 'gslist type))))
7fa3e612	459	(ecase ref
	460	((:read :peek)
	461	#'(lambda (location &optional (offset 0))
	462	(unless (null-pointer-p (ref-pointer location offset))
	463	(map-glist 'list #'identity (ref-pointer location offset) element-type ref))))
	464	(:get
	465	#'(lambda (location &optional (offset 0))
	466	(unless (null-pointer-p (ref-pointer location offset))
	467	(prog1
	468	(map-glist 'list #'identity (ref-pointer location offset) element-type :get)
	469	(gslist-free (ref-pointer location offset))
	470	(setf (ref-pointer location offset) (make-pointer 0)))))))))
	471
	472	(define-type-method destroy-function ((type gslist) &key temp inlined)
	473	(assert-not-inlined type inlined)
4d1fea77	474	(let ((element-type (second (type-expand-to 'gslist type))))
02b6647e	475	#'(lambda (location &optional (offset 0))
7fa3e612	476	(unless (null-pointer-p (ref-pointer location offset))
	477	(destroy-gslist (ref-pointer location offset) element-type temp)
	478	(setf (ref-pointer location offset) (make-pointer 0))))))
	479
	480	(define-type-method copy-function ((type gslist) &key inlined)
	481	(assert-not-inlined type inlined)
	482	(destructuring-bind (element-type) (rest (type-expand-to 'gslist type))
	483	(let ((copy-element (copy-function element-type)))
	484	#'(lambda (from to &optional (offset 0))
	485	(unless (null-pointer-p (ref-pointer from offset))
	486	(loop
	487	as from-list = (ref-pointer from offset)
	488	then (glist-next from-list)
	489	as to-list = (setf (ref-pointer to offset) (%gslist-append nil))
	490	then (%gslist-append to-list)
	491	do (funcall copy-element from-list to-list)
	492	while (glist-next from-list)))))))