[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
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
fcd55ab5	23	;; $Id: glib.lisp,v 1.45 2008/12/14 21:37:25 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
c464b21b	42	(deftype gsize () 'unsigned-int)
fcd55ab5	43	(deftype gssize () 'int)
	44	(deftype goffset () '(unsigned-int 64))
	45
0d07716f	46
c464b21b	47	(defbinding malloc0 () pointer
c464b21b	48	(size gsize))
3d23e952	49
c464b21b	50	(defbinding free () nil
c464b21b	51	(address pointer))
0d07716f	52
c464b21b	53	(setf memory-allocator #'malloc0)
c464b21b	54	(setf memory-deallocator #'free)
b467f3d0	55
b9ec4185	56	(defbinding (reallocate-memory "g_realloc") () pointer
b9ec4185	57	(address pointer)
c464b21b	58	(size gsize))
b9ec4185	59
d09560df	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
b467f3d0	65
fcd55ab5	66	;; TODO: move to gffi
fcd55ab5	67
db4e735f	68	(defvar user-data-lock (make-mutex))
b467f3d0	69	(defvar user-data (make-hash-table))
d09560df	70	(defvar user-data-next-id 1)
b467f3d0	71
	72	(defun register-user-data (object &optional destroy-function)
	73	(check-type destroy-function (or null symbol function))
db4e735f	74	(with-mutex (user-data-lock)
db4e735f	75	(setf
d09560df	76	(gethash user-data-next-id user-data)
db4e735f	77	(cons object destroy-function))
d09560df	78	(1- (incf user-data-next-id))))
b467f3d0	79
	80	(defun find-user-data (id)
	81	(check-type id fixnum)
db4e735f	82	(with-mutex (user-data-lock)
	83	(multiple-value-bind (user-data p) (gethash id user-data)
	84	(values (car user-data) p))))
b467f3d0	85
3e033db9	86	(defun user-data-exists-p (id)
	87	(nth-value 1 (find-user-data id)))
	88
29c05201	89	(defun update-user-data (id object)
29c05201	90	(check-type id fixnum)
db4e735f	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))))))
29c05201	99
b467f3d0	100	(defun destroy-user-data (id)
b467f3d0	101	(check-type id fixnum)
db4e735f	102	(with-mutex (user-data-lock)
d09560df	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)
b467f3d0	130
0d07716f	131
6755fdad	132	;;;; Quarks
	133
	134	(deftype quark () 'unsigned)
	135
cb816364	136	(defbinding %quark-from-string () quark
e5b6173a	137	(string string))
e5b6173a	138
3e033db9	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)))))
6755fdad	146
7fa3e612	147	(defbinding quark-to-string () (static string)
3e033db9	148	(quark quark))
6755fdad	149
6755fdad	150
597999f9	151	;;;; Linked list (GList)
0d07716f	152
5f2222a9	153	(deftype glist (type)
4d1fea77	154	`(or null (cons ,type list)))
0d07716f	155
7b12efaf	156	(defbinding (%glist-prepend "g_list_prepend") () pointer
7fa3e612	157	(glist (or null pointer))
5f2222a9	158	(nil null))
597999f9	159
7b12efaf	160	(defbinding (%glist-reverse "g_list_reverse") () pointer
	161	(glist (or null pointer)))
	162
7fa3e612	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
7b12efaf	169	as glist = (%glist-prepend nil) then (%glist-prepend glist)
7fa3e612	170	do (funcall writer element glist)
7b12efaf	171	finally (return (%glist-reverse glist)))))
0d07716f	172
0d07716f	173	(defun glist-next (glist)
0d07716f	174	(unless (null-pointer-p glist)
7fa3e612	175	(ref-pointer glist #.(size-of 'pointer))))
0d07716f	176
6baf860c	177	;; Also used for gslists
7fa3e612	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))))
6baf860c	182	(case seqtype
	183	((nil)
	184	(loop
7fa3e612	185	as element = glist then (glist-next element)
	186	until (null-pointer-p element)
	187	do (funcall function (funcall reader element))))
6baf860c	188	(list
6baf860c	189	(loop
7fa3e612	190	as element = glist then (glist-next element)
	191	until (null-pointer-p element)
	192	collect (funcall function (funcall reader element))))
6baf860c	193	(t
	194	(coerce
	195	(loop
7fa3e612	196	as element = glist then (glist-next element)
	197	until (null-pointer-p element)
	198	collect (funcall function (funcall reader element)))
6baf860c	199	seqtype)))))
6baf860c	200
1c99696e	201	(defbinding (glist-free "g_list_free") () nil
0d07716f	202	(glist pointer))
0d07716f	203
7fa3e612	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)))
5f2222a9	212	(glist-free glist))
e5b6173a	213
4d1fea77	214	(define-type-method alien-type ((type glist))
4d1fea77	215	(declare (ignore type))
6baf860c	216	(alien-type 'pointer))
6baf860c	217
b9ec4185	218	(define-type-method argument-type ((type glist))
	219	'list)
	220
	221	(define-type-method return-type ((type glist))
	222	'list)
	223
7fa3e612	224	(define-type-method size-of ((type glist) &key inlined)
7fa3e612	225	(assert-not-inlined type inlined)
e5b6173a	226	(size-of 'pointer))
0d07716f	227
83f60e84	228	(define-type-method type-alignment ((type glist) &key inlined)
	229	(assert-not-inlined type inlined)
	230	(type-alignment 'pointer))
5f2222a9	231
7fa3e612	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)))
0d07716f	257
7fa3e612	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)
4d1fea77	294	(let ((element-type (second (type-expand-to 'glist type))))
02b6647e	295	#'(lambda (list location &optional (offset 0))
02b6647e	296	(setf
7fa3e612	297	(ref-pointer location offset)
7fa3e612	298	(make-glist element-type list temp)))))
02b6647e	299
7fa3e612	300	(define-type-method reader-function ((type glist) &key (ref :read) inlined)
7fa3e612	301	(assert-not-inlined type inlined)
4d1fea77	302	(let ((element-type (second (type-expand-to 'glist type))))
7fa3e612	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)
4d1fea77	318	(let ((element-type (second (type-expand-to 'glist type))))
02b6647e	319	#'(lambda (location &optional (offset 0))
7fa3e612	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
7b12efaf	331	as from-list = (ref-pointer from offset) then (glist-next from-list)
7b12efaf	332	as to-list = (%glist-prepend nil) then (%glist-prepend to-list)
7fa3e612	333	do (funcall copy-element from-list to-list)
7b12efaf	334	while (glist-next from-list)
7b12efaf	335	finally (setf (ref-pointer to offset) (%glist-reverse to-list))))))))
02b6647e	336
0d07716f	337
597999f9	338	;;;; Single linked list (GSList)
597999f9	339
4d1fea77	340	(deftype gslist (type) `(or null (cons ,type list)))
597999f9	341
5f2222a9	342	(defbinding (%gslist-prepend "g_slist_prepend") () pointer
597999f9	343	(gslist pointer)
5f2222a9	344	(nil null))
597999f9	345
7fa3e612	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))))
6baf860c	360
1c99696e	361	(defbinding (gslist-free "g_slist_free") () nil
597999f9	362	(gslist pointer))
597999f9	363
7fa3e612	364	(defun destroy-gslist (gslist element-type &optional temp-p)
5f2222a9	365	(loop
7fa3e612	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))
5f2222a9	370	(gslist-free gslist))
597999f9	371
4d1fea77	372	(define-type-method alien-type ((type gslist))
4d1fea77	373	(declare (ignore type))
6baf860c	374	(alien-type 'pointer))
6baf860c	375
b9ec4185	376	(define-type-method argument-type ((type gslist))
	377	'list)
	378
	379	(define-type-method return-type ((type gslist))
	380	'list)
	381
7fa3e612	382	(define-type-method size-of ((type gslist) &key inlined)
7fa3e612	383	(assert-not-inlined type inlined)
597999f9	384	(size-of 'pointer))
597999f9	385
83f60e84	386	(define-type-method type-alignment ((type gslist) &key inlined)
	387	(assert-not-inlined type inlined)
	388	(type-alignment 'pointer))
	389
7fa3e612	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)
4d1fea77	461	(let ((element-type (second (type-expand-to 'gslist type))))
7fa3e612	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)
4d1fea77	477	(let ((element-type (second (type-expand-to 'gslist type))))
02b6647e	478	#'(lambda (location &optional (offset 0))
7fa3e612	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)))))))