anchor.diff:  ;; 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.36 2006-02-26 15:30:01 espen Exp $
  +;; $Id: glib.lisp,v 1.37 2006-04-25 21:51:32 espen Exp $
   
   
   (in-package "GLIB")
  
positive.code: 
  ;;;; Memory management
  
  (defbinding (allocate-memory "g_malloc0") () pointer
    (size unsigned-long))
  
  (defbinding (reallocate-memory "g_realloc") () pointer
    (address pointer)
    (size unsigned-long))
  
  (defbinding (deallocate-memory "g_free") () nil
    (address pointer))
  ;; (defun deallocate-memory (address)
  ;;   (declare (ignore address)))
  
  (defun copy-memory (from length &optional (to (allocate-memory length)))
    #+cmu(system-area-copy from 0 to 0 (* 8 length))
    #+sbcl(system-area-ub8-copy from 0 to 0 length)
    to)
  
  (defun clear-memory (from length)
    #+cmu(vm::system-area-fill 0 from 0 (* 8 length))
    #+sbcl(system-area-ub8-fill 0 from 0 length))
  
  (defmacro with-allocated-memory ((var size) &body body)
    (if (constantp size)
        (let ((alien (make-symbol "ALIEN"))
  	    (size (eval size)))
  	`(with-alien ((,alien (array #+sbcl(sb-alien:unsigned 8) #+cmu(alien:unsigned 8) ,size)))
  	   (let ((,var (alien-sap ,alien)))
  	     (clear-memory ,var ,size)
  	     ,@body)))
      `(let ((,var (allocate-memory ,size)))
         (unwind-protect
  	   (progn ,@body)
  	 (deallocate-memory ,var)))))
  
  
  ;;;; User data mechanism
  
  (internal *user-data* *user-data-count*)
  
  (defvar *user-data* (make-hash-table))
  (defvar *user-data-count* 0)
  
negative.code:   (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 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)))))))
  