[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.40 2007-06-15 12:25:16 espen Exp $


(in-package "GLIB")

(use-prefix "g")

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


;;;; Memory management

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

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

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

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

;;;; User data mechanism

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