[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.38 2006/06/08 13:24:25 espen Exp $


(in-package "GLIB")

(use-prefix "g")


;;;; 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)


;;;; User data mechanism

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

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

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

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

(defun update-user-data (id object)
  (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)))
      (setf (car user-data) object)))))

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


;;;; Quarks

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