[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.45 2008-12-14 21:37:25 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

(deftype gsize () 'unsigned-int)
(deftype gssize () 'int)
(deftype goffset () '(unsigned-int 64))


(defbinding malloc0 () pointer
  (size gsize))

(defbinding free () nil
  (address pointer))

(setf *memory-allocator* #'malloc0)
(setf *memory-deallocator* #'free)

(defbinding (reallocate-memory "g_realloc") () pointer
  (address pointer)
  (size gsize))

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

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

;; TODO: move to gffi

(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-prepend "g_list_prepend") () pointer
  (glist (or null pointer))
  (nil null))

(defbinding (%glist-reverse "g_list_reverse") () pointer
  (glist (or null pointer)))

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