[clg] / glib / ffi.lisp

;; Common Lisp bindings for GTK+ v2.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: ffi.lisp,v 1.23 2006-02-06 18:12:19 espen Exp $

(in-package "GLIB")


;;;; Foreign function call interface

(defvar *package-prefix* nil)

(defun set-package-prefix (prefix &optional (package *package*))
  (let ((package (find-package package)))
    (delete-if #'(lambda (assoc) (eq (car assoc) package)) *package-prefix*)
    (push (cons package prefix) *package-prefix*))
  prefix)

(defun package-prefix (&optional (package *package*))
  (let ((package (find-package package)))
    (or
     (cdr (assoc package *package-prefix*))
     (substitute #\_ #\- (string-downcase (package-name package))))))

(defun find-prefix-package (prefix)
  (or
   (car (rassoc (string-downcase prefix) *package-prefix* :test #'string=))
   (find-package (string-upcase prefix))))

(defmacro use-prefix (prefix &optional (package *package*))
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (set-package-prefix ,prefix ,package)))


(defun default-alien-fname (lisp-name)
  (let* ((name (substitute #\_ #\- (string-downcase lisp-name)))
	 (stripped-name
	  (cond
	   ((and 
	     (char= (char name 0) #\%)
	     (string= "_p" name :start2 (- (length name) 2)))
	    (subseq name 1 (- (length name) 2)))
	   ((char= (char name 0) #\%)
	    (subseq name 1))
	   ((string= "_p" name :start2 (- (length name) 2))
	    (subseq name 0 (- (length name) 2)))
	   (name)))
	 (prefix (package-prefix *package*)))
    (if (or (not prefix) (string= prefix ""))
	stripped-name
      (format nil "~A_~A" prefix stripped-name))))

(defun default-alien-type-name (type-name)
  (let ((prefix (package-prefix *package*)))
    (apply
     #'concatenate
     'string
     (mapcar
      #'string-capitalize    
      (cons prefix (split-string (symbol-name type-name) #\-))))))

(defun default-type-name (alien-name)
  (let ((parts
	 (mapcar
	  #'string-upcase
	  (split-string-if alien-name #'upper-case-p))))
    (intern
     (concatenate-strings
      (rest parts) #\-) (find-prefix-package (first parts)))))
    
	 
(defmacro defbinding (name lambda-list return-type &rest docs/args)
  (multiple-value-bind (lisp-name c-name)
      (if (atom name)
 	  (values name (default-alien-fname name))
 	(values-list name))
		       
    (let ((supplied-lambda-list lambda-list)
	  (docs nil)
	  (args nil))
      (dolist (doc/arg docs/args)
	(if (stringp doc/arg)
	    (push doc/arg docs)
	  (progn
	    (destructuring-bind (expr type &optional (style :in)) doc/arg
	      (unless (member style '(:in :out :in-out :return))
		(error "Bogus argument style ~S in ~S." style doc/arg))
	      (when (and
		     (not supplied-lambda-list)
		     (namep expr) (member style '(:in :in-out :return)))
		(push expr lambda-list))
	      (push (list (cond 
			   ((and (namep expr) (eq style :out)) expr)
			   ((namep expr) (make-symbol (string expr)))
			   ((gensym)))
			  expr (mklist type) style) args)))))
      
      (%defbinding
       c-name lisp-name (or supplied-lambda-list (nreverse lambda-list))
       return-type (reverse docs) (reverse args)))))

#+(or cmu sbcl)
(defun %defbinding (foreign-name lisp-name lambda-list return-type docs args)
  (collect ((alien-types) (alien-bindings) (alien-parameters) 
	    (return-values) (cleanup-forms))
    (dolist (arg args)
      (destructuring-bind (var expr type style) arg
	(let ((declaration (alien-type type))
	      (cleanup (cleanup-form var type)))

	  (cond
	    ((member style '(:out :in-out))
	     (alien-types `(* ,declaration))
	     (alien-parameters `(addr ,var))
	     (alien-bindings
	      `(,var ,declaration
		,@(cond 
		   ((eq style :in-out) (list (to-alien-form expr type)))
		   ((eq declaration 'system-area-pointer) 
		    (list '(make-pointer 0))))))
	     (return-values (from-alien-form var type)))
	    ((eq style :return)
	     (alien-types declaration)
	     (alien-bindings
	      `(,var ,declaration ,(to-alien-form expr type)))
	     (alien-parameters var)
	     (return-values (from-alien-form var type)))
	    (cleanup
	     (alien-types declaration)
	     (alien-bindings
	      `(,var ,declaration ,(to-alien-form expr type)))
	     (alien-parameters var)
	     (cleanup-forms cleanup))
	    (t
	     (alien-types declaration)
	     (alien-parameters (to-alien-form expr type)))))))

    (let* ((alien-name (make-symbol (string lisp-name)))
	   (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters))))
      `(defun ,lisp-name ,lambda-list
	 ,@docs
	 #+cmu(declare (optimize (inhibit-warnings 3)))
	 #+sbcl(declare (muffle-conditions compiler-note))
	 (with-alien ((,alien-name
		       (function
			,(alien-type return-type)
			,@(alien-types))
		       :extern ,foreign-name)
		      ,@(alien-bindings))
	   ,(if return-type
		`(values
		  (unwind-protect 
		      ,(from-alien-form alien-funcall return-type)
		    ,@(cleanup-forms))
		  ,@(return-values))
	      `(progn
		(unwind-protect 
		     ,alien-funcall
		  ,@(cleanup-forms))
		(values ,@(return-values)))))))))


;;; Creates bindings at runtime
(defun mkbinding (name return-type &rest arg-types)
  #+cmu(declare (optimize (inhibit-warnings 3)))
  #+sbcl(declare (muffle-conditions compiler-note))
  (let* ((ftype 
	  `(function ,@(mapcar #'alien-type (cons return-type arg-types))))
	 (alien
	  (%heap-alien
	   (make-heap-alien-info
	    :type (parse-alien-type ftype #+sbcl nil)
	    :sap-form (let ((address (foreign-symbol-address name)))
			(etypecase address
			  (integer (int-sap address))
			  (system-area-pointer address))))))
	 (translate-arguments (mapcar #'to-alien-function arg-types))
	 (translate-return-value (from-alien-function return-type))
	 (cleanup-arguments (mapcar #'cleanup-function arg-types)))
        
    #'(lambda (&rest args)
	(map-into args #'funcall translate-arguments args)
	(prog1
	    (funcall translate-return-value 
	     (apply #'alien-funcall alien args))
	  (mapc #'funcall cleanup-arguments args)))))


(defmacro defcallback (name (return-type &rest args) &body body)
  (let ((def-callback #+cmu'alien:def-callback 
	              #+sbcl'sb-alien:define-alien-function))
    `(,def-callback ,name 
         (,(alien-type return-type) 
	  ,@(mapcar #'(lambda (arg)
			(destructuring-bind (name type) arg
			  `(,name ,(alien-type type))))
		    args))
       ,(to-alien-form 
	 `(let (,@(delete nil
		     (mapcar #'(lambda (arg)
				 (destructuring-bind (name type) arg
				   (let ((from-alien 
					  (from-alien-form name type)))
				     (unless (eq name from-alien)
				       `(,name ,from-alien)))))
		      args)))
	    ,@body)
	 return-type))))

#+sbcl
(defun callback (af)
  (sb-alien:alien-function-sap af))

#+sbcl
(deftype callback () 'sb-alien:alien-function)

;;;; Definitons and translations of fundamental types

(defmacro def-type-method (name args &optional documentation)
  `(progn
    (defgeneric ,name (,@args type &rest args)
      ,@(when documentation `((:documentation ,documentation))))
    (defmethod ,name (,@args (type symbol) &rest args)
      (let ((class (find-class type nil)))
	(if class 
	    (apply #',name ,@args class args)
	  (multiple-value-bind (super-type expanded-p)
	      (type-expand-1 (cons type args))
	    (if expanded-p
		(,name ,@args super-type)
	      (call-next-method))))))
    (defmethod ,name (,@args (type cons) &rest args)
      (declare (ignore args))
      (apply #',name ,@args (first type) (rest type)))))
    

(def-type-method alien-type ())
(def-type-method size-of ())
(def-type-method to-alien-form (form))
(def-type-method from-alien-form (form))
(def-type-method cleanup-form (form)
  "Creates a form to clean up after the alien call has finished.")

(def-type-method to-alien-function ())
(def-type-method from-alien-function ())
(def-type-method cleanup-function ())

(def-type-method copy-to-alien-form (form))
(def-type-method copy-to-alien-function ())
(def-type-method copy-from-alien-form (form))
(def-type-method copy-from-alien-function ())

(def-type-method writer-function ())
(def-type-method reader-function ())
(def-type-method destroy-function ())

(def-type-method unbound-value ()
  "First return value is true if the type has an unbound value, second return value is the actual unbound value")


;; Sizes of fundamental C types in bytes (8 bits)
(defconstant +size-of-short+ 2)
(defconstant +size-of-int+ 4)
(defconstant +size-of-long+ 4)
(defconstant +size-of-pointer+ 4)
(defconstant +size-of-float+ 4)
(defconstant +size-of-double+ 8)

;; Sizes of fundamental C types in bits
(defconstant +bits-of-byte+ 8)
(defconstant +bits-of-short+ 16)
(defconstant +bits-of-int+ 32)
(defconstant +bits-of-long+ 32)


(deftype int () '(signed-byte #.+bits-of-int+))
(deftype unsigned-int () '(unsigned-byte #.+bits-of-int+))
(deftype long () '(signed-byte #.+bits-of-long+))
(deftype unsigned-long () '(unsigned-byte #.+bits-of-long+))
(deftype short () '(signed-byte #.+bits-of-short+))
(deftype unsigned-short () '(unsigned-byte #.+bits-of-short+))
(deftype signed (&optional (size '*)) `(signed-byte ,size))
(deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
(deftype char () 'base-char)
(deftype pointer () 'system-area-pointer)
(deftype boolean (&optional (size '*)) (declare (ignore size)) `(member t nil))
;(deftype invalid () nil)


(defmethod to-alien-form (form (type t) &rest args)
  (declare (ignore type args))
  form)

(defmethod to-alien-function ((type t) &rest args)
  (declare (ignore type args))
  #'identity)

(defmethod from-alien-form (form (type t) &rest args)
  (declare (ignore type args))
  form)

(defmethod from-alien-function ((type t) &rest args)
  (declare (ignore type args))
  #'identity)
 
(defmethod cleanup-form (form (type t) &rest args)
  (declare (ignore form type args))
  nil)

(defmethod cleanup-function ((type t) &rest args)
  (declare (ignore type args))
  #'identity)

(defmethod destroy-function ((type t) &rest args)
  (declare (ignore type args))
  #'(lambda (location &optional offset)
      (declare (ignore location offset))))

(defmethod copy-to-alien-form  (form (type t) &rest args)
  (apply #'to-alien-form form type args))

(defmethod copy-to-alien-function  ((type t) &rest args)
  (apply #'to-alien-function type args))

(defmethod copy-from-alien-form  (form (type t) &rest args)
  (apply #'from-alien-form form type args))

(defmethod copy-from-alien-function  ((type t) &rest args)
  (apply #'from-alien-function type args))

(defmethod alien-type ((type (eql 'signed-byte)) &rest args)
  (declare (ignore type))
  (destructuring-bind (&optional (size '*)) args
    (ecase size
      (#.+bits-of-byte+ #+cmu'(alien:signed 8) #+sbcl'(sb-alien:signed 8))
      (#.+bits-of-short+ #+cmu 'c-call:short #+sbcl 'sb-alien:short)
      ((* #.+bits-of-int+) #+cmu 'c-call:int #+sbcl 'sb-alien:int)
      (#.+bits-of-long+ #+cmu 'c-call:long #+sbcl 'sb-alien:long))))

(defmethod size-of ((type (eql 'signed-byte)) &rest args)
  (declare (ignore type))
  (destructuring-bind (&optional (size '*)) args
    (ecase size
      (#.+bits-of-byte+ 1)
      (#.+bits-of-short+ +size-of-short+)
      ((* #.+bits-of-int+) +size-of-int+)
      (#.+bits-of-long+ +size-of-long+))))

(defmethod unbound-value ((type t) &rest args)
  (declare (ignore type args))
  nil)

(defmethod writer-function ((type (eql 'signed-byte)) &rest args)
  (declare (ignore type))
  (destructuring-bind (&optional (size '*)) args
    (let ((size (if (eq size '*) +bits-of-int+ size)))
      (ecase size
	(8 #'(lambda (value location &optional (offset 0))
	       (setf (signed-sap-ref-8 location offset) value)))
	(16 #'(lambda (value location &optional (offset 0))
		(setf (signed-sap-ref-16 location offset) value)))
	(32 #'(lambda (value location &optional (offset 0))
		(setf (signed-sap-ref-32 location offset) value)))
	(64 #'(lambda (value location &optional (offset 0))
		(setf (signed-sap-ref-64 location offset) value)))))))
  
(defmethod reader-function ((type (eql 'signed-byte)) &rest args)
  (declare (ignore type))
  (destructuring-bind (&optional (size '*)) args
    (let ((size (if (eq size '*) +bits-of-int+ size)))
      (ecase size
	(8 #'(lambda (sap &optional (offset 0) weak-p) 
	       (declare (ignore weak-p))
	       (signed-sap-ref-8 sap offset)))
	(16 #'(lambda (sap &optional (offset 0) weak-p)
		(declare (ignore weak-p))
		(signed-sap-ref-16 sap offset)))
	(32 #'(lambda (sap &optional (offset 0) weak-p) 
		(declare (ignore weak-p)) 
		(signed-sap-ref-32 sap offset)))
	(64 #'(lambda (sap &optional (offset 0) weak-p) 
		(declare (ignore weak-p))
		(signed-sap-ref-64 sap offset)))))))

(defmethod alien-type ((type (eql 'unsigned-byte)) &rest args)
  (destructuring-bind (&optional (size '*)) args
    (ecase size
      (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8))
      (#.+bits-of-short+ #+cmu 'c-call:unsigned-short 
			 #+sbcl 'sb-alien:unsigned-short)
      ((* #.+bits-of-int+) #+cmu 'c-call:unsigned-int 
                           #+sbcl 'sb-alien:unsigned-int)
      (#.+bits-of-long+ #+cmu 'c-call:unsigned-long 
			#+sbcl 'sb-alien:unsigned-long))))

(defmethod size-of ((type (eql 'unsigned-byte)) &rest args)
  (apply #'size-of 'signed args))

(defmethod writer-function ((type (eql 'unsigned-byte)) &rest args)
  (declare (ignore type))
  (destructuring-bind (&optional (size '*)) args
    (let ((size (if (eq size '*) +bits-of-int+ size)))
      (ecase size
	(8 #'(lambda (value location &optional (offset 0))
	       (setf (sap-ref-8 location offset) value)))
	(16 #'(lambda (value location &optional (offset 0))
		(setf (sap-ref-16 location offset) value)))
	(32 #'(lambda (value location &optional (offset 0))
		(setf (sap-ref-32 location offset) value)))
	(64 #'(lambda (value location &optional (offset 0))
		(setf (sap-ref-64 location offset) value)))))))
      
(defmethod reader-function ((type (eql 'unsigned-byte)) &rest args)
  (declare (ignore type))
  (destructuring-bind (&optional (size '*)) args
    (let ((size (if (eq size '*) +bits-of-int+ size)))
      (ecase size
	(8 #'(lambda (sap &optional (offset 0) weak-p)
	       (declare (ignore weak-p))
	       (sap-ref-8 sap offset)))
	(16 #'(lambda (sap &optional (offset 0) weak-p)
		(declare (ignore weak-p)) 
		(sap-ref-16 sap offset)))
	(32 #'(lambda (sap &optional (offset 0) weak-p)
		(declare (ignore weak-p)) 
		(sap-ref-32 sap offset)))
	(64 #'(lambda (sap &optional (offset 0) weak-p)
		(declare (ignore weak-p))
		(sap-ref-64 sap offset)))))))
  
  
(defmethod alien-type ((type (eql 'integer)) &rest args)
  (declare (ignore type args))
  (alien-type 'signed-byte))

(defmethod size-of ((type (eql 'integer)) &rest args)
  (declare (ignore type args))
  (size-of 'signed-byte))

(defmethod writer-function ((type (eql 'integer)) &rest args)
  (declare (ignore type args))
  (writer-function 'signed-byte))

(defmethod reader-function ((type (eql 'integer)) &rest args)
  (declare (ignore type args))
  (reader-function 'signed-byte))


(defmethod alien-type ((type (eql 'fixnum)) &rest args)
  (declare (ignore type args))
  (alien-type 'signed-byte))

(defmethod size-of ((type (eql 'fixnum)) &rest args)
  (declare (ignore type args))
  (size-of 'signed-byte))


(defmethod alien-type ((type (eql 'single-float)) &rest args)
  (declare (ignore type args))
  #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float)

(defmethod size-of ((type (eql 'single-float)) &rest args)
  (declare (ignore type args))
  +size-of-float+)

(defmethod to-alien-form (form (type (eql 'single-float)) &rest args)
  (declare (ignore type args))
  `(coerce ,form 'single-float))

(defmethod to-alien-function ((type (eql 'single-float)) &rest args)
  (declare (ignore type args))
  #'(lambda (number)
      (coerce number 'single-float)))

(defmethod writer-function ((type (eql 'single-float)) &rest args)
  (declare (ignore type args))
  #'(lambda (value location &optional (offset 0))
      (setf (sap-ref-single location offset) (coerce value 'single-float))))

(defmethod reader-function ((type (eql 'single-float)) &rest args)
  (declare (ignore type args))
  #'(lambda (sap &optional (offset 0) weak-p)
      (declare (ignore weak-p))
      (sap-ref-single sap offset)))


(defmethod alien-type ((type (eql 'double-float)) &rest args)
  (declare (ignore type args))
  #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float)

(defmethod size-of ((type (eql 'double-float)) &rest args)
  (declare (ignore type args))
  +size-of-double+)

(defmethod to-alien-form (form (type (eql 'double-float)) &rest args)
  (declare (ignore type args))
  `(coerce ,form 'double-float))

(defmethod to-alien-function ((type (eql 'double-float)) &rest args)
  (declare (ignore type args))
  #'(lambda (number)
      (coerce number 'double-float)))

(defmethod writer-function ((type (eql 'double-float)) &rest args)
  (declare (ignore type args))
  #'(lambda (value location &optional (offset 0))
      (setf (sap-ref-double location offset) (coerce value 'double-float))))

(defmethod reader-function ((type (eql 'double-float)) &rest args)
  (declare (ignore type args))
  #'(lambda (sap &optional (offset 0) weak-p)
      (declare (ignore weak-p))
      (sap-ref-double sap offset)))


(defmethod alien-type ((type (eql 'base-char)) &rest args)
  (declare (ignore type args))
  #+cmu 'c-call:char #+sbcl 'sb-alien:char)

(defmethod size-of ((type (eql 'base-char)) &rest args)
  (declare (ignore type args))
  1)

(defmethod writer-function ((type (eql 'base-char)) &rest args)
  (declare (ignore type args))
  #'(lambda (char location &optional (offset 0))
      (setf (sap-ref-8 location offset) (char-code char))))

(defmethod reader-function ((type (eql 'base-char)) &rest args)
  (declare (ignore type args))
  #'(lambda (location &optional (offset 0) weak-p)
      (declare (ignore weak-p))
      (code-char (sap-ref-8 location offset))))


(defmethod alien-type ((type (eql 'string)) &rest args)
  (declare (ignore type args))
  (alien-type 'pointer))

(defmethod size-of ((type (eql 'string)) &rest args)
  (declare (ignore type args))
  (size-of 'pointer))

(defmethod to-alien-form (string (type (eql 'string)) &rest args)
  (declare (ignore type args))
  `(let ((string ,string))
     ;; Always copy strings to prevent seg fault due to GC
     #+cmu
     (copy-memory
      (vector-sap (coerce string 'simple-base-string))
      (1+ (length string)))
     #+sbcl
     (let ((utf8 (%deport-utf8-string string)))
       (copy-memory (vector-sap utf8) (length utf8)))))
  
(defmethod to-alien-function ((type (eql 'string)) &rest args)
  (declare (ignore type args))
  #'(lambda (string)
      #+cmu
      (copy-memory
       (vector-sap (coerce string 'simple-base-string))
       (1+ (length string)))
      #+sbcl
      (let ((utf8 (%deport-utf8-string string)))
	(copy-memory (vector-sap utf8) (length utf8)))))

(defmethod from-alien-form (string (type (eql 'string)) &rest args)
  (declare (ignore type args))
  `(let ((string ,string))
    (unless (null-pointer-p string)
      (prog1
	  #+cmu(%naturalize-c-string string)
	  #+sbcl(%naturalize-utf8-string string)
	(deallocate-memory string)))))

(defmethod from-alien-function ((type (eql 'string)) &rest args)
  (declare (ignore type args))
  #'(lambda (string)
      (unless (null-pointer-p string)
	(prog1
	    #+cmu(%naturalize-c-string string)
	    #+sbcl(%naturalize-utf8-string string)
	  (deallocate-memory string)))))

(defmethod cleanup-form (string (type (eql 'string)) &rest args)
  (declare (ignore type args))
  `(let ((string ,string))
    (unless (null-pointer-p string)
      (deallocate-memory string))))

(defmethod cleanup-function ((type (eql 'string)) &rest args)
  (declare (ignore args))
  #'(lambda (string)
      (unless (null-pointer-p string)
	(deallocate-memory string))))

(defmethod copy-from-alien-form (string (type (eql 'string)) &rest args)
  (declare (ignore type args))
  `(let ((string ,string))
    (unless (null-pointer-p string)
      #+cmu(%naturalize-c-string string)
      #+sbcl(%naturalize-utf8-string string))))

(defmethod copy-from-alien-function ((type (eql 'string)) &rest args)
  (declare (ignore type args))
  #'(lambda (string)
      (unless (null-pointer-p string)
	#+cmu(%naturalize-c-string string)
	#+sbcl(%naturalize-utf8-string string))))

(defmethod writer-function ((type (eql 'string)) &rest args)
  (declare (ignore type args))
  #'(lambda (string location &optional (offset 0))
      (assert (null-pointer-p (sap-ref-sap location offset)))
      (setf (sap-ref-sap location offset)
       #+cmu
       (copy-memory
	(vector-sap (coerce string 'simple-base-string))
	(1+ (length string)))
       #+sbcl
       (let ((utf8 (%deport-utf8-string string)))
	 (copy-memory (vector-sap utf8) (length utf8))))))

(defmethod reader-function ((type (eql 'string)) &rest args)
  (declare (ignore type args))
  #'(lambda (location &optional (offset 0) weak-p)
      (declare (ignore weak-p))
      (unless (null-pointer-p (sap-ref-sap location offset))
	#+cmu(%naturalize-c-string (sap-ref-sap location offset))
	#+sbcl(%naturalize-utf8-string (sap-ref-sap location offset)))))

(defmethod destroy-function ((type (eql 'string)) &rest args)
  (declare (ignore type args))
  #'(lambda (location &optional (offset 0))
      (unless (null-pointer-p (sap-ref-sap location offset))
	(deallocate-memory (sap-ref-sap location offset))
	(setf (sap-ref-sap location offset) (make-pointer 0)))))

(defmethod unbound-value ((type (eql 'string)) &rest args)
  (declare (ignore type args))
  (values t nil))


(defmethod alien-type ((type (eql 'pathname)) &rest args)
  (declare (ignore type args))
  (alien-type 'string))

(defmethod size-of ((type (eql 'pathname)) &rest args)
  (declare (ignore type args))
  (size-of 'string))

(defmethod to-alien-form (path (type (eql 'pathname)) &rest args)
  (declare (ignore type args))
  (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string))

(defmethod to-alien-function ((type (eql 'pathname)) &rest args)
  (declare (ignore type args))
  (let ((string-function (to-alien-function 'string)))
    #'(lambda (path)
	(funcall string-function (namestring path)))))

(defmethod from-alien-form (string (type (eql 'pathname)) &rest args)
  (declare (ignore type args))
  `(parse-namestring ,(from-alien-form string 'string)))

(defmethod from-alien-function ((type (eql 'pathname)) &rest args)
  (declare (ignore type args))
  (let ((string-function (from-alien-function 'string)))
    #'(lambda (string)
	(parse-namestring (funcall string-function string)))))

(defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args)
  (declare (ignore type args))
  (cleanup-form string 'string))

(defmethod cleanup-function ((type (eql 'pathnanme)) &rest args)
  (declare (ignore type args))
  (cleanup-function 'string))

(defmethod writer-function ((type (eql 'pathname)) &rest args)
  (declare (ignore type args))
  (let ((string-writer (writer-function 'string)))
    #'(lambda (path location &optional (offset 0))
	(funcall string-writer (namestring path) location offset))))

(defmethod reader-function ((type (eql 'pathname)) &rest args)
  (declare (ignore type args))
  (let ((string-reader (reader-function 'string)))
  #'(lambda (location &optional (offset 0) weak-p)
      (declare (ignore weak-p))
      (let ((string (funcall string-reader location offset)))
	(when string
	  (parse-namestring string))))))

(defmethod destroy-function ((type (eql 'pathname)) &rest args)
  (declare (ignore type args))
  (destroy-function 'string))

(defmethod unbound-value ((type (eql 'pathname)) &rest args)
  (declare (ignore type args))
  (unbound-value 'string))


(defmethod alien-type ((type (eql 'boolean)) &rest args)
  (apply #'alien-type 'signed-byte args))

(defmethod size-of ((type (eql 'boolean)) &rest args)
  (apply #'size-of 'signed-byte args))

(defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args)
  (declare (ignore type args))
  `(if ,boolean 1 0))

(defmethod to-alien-function ((type (eql 'boolean)) &rest args)
  (declare (ignore type args))
  #'(lambda (boolean)
      (if boolean 1 0)))

(defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args)
  (declare (ignore type args))
  `(not (zerop ,boolean)))

(defmethod from-alien-function ((type (eql 'boolean)) &rest args)
  (declare (ignore type args))
  #'(lambda (boolean)
      (not (zerop boolean))))

(defmethod writer-function ((type (eql 'boolean)) &rest args)
  (declare (ignore type))
  (let ((writer (apply #'writer-function 'signed-byte args)))
    #'(lambda (boolean location &optional (offset 0))
	(funcall writer (if boolean 1 0) location offset))))

(defmethod reader-function ((type (eql 'boolean)) &rest args)
  (declare (ignore type))
  (let ((reader (apply #'reader-function 'signed-byte args)))
  #'(lambda (location &optional (offset 0) weak-p)
      (declare (ignore weak-p))
      (not (zerop (funcall reader location offset))))))


(defmethod alien-type ((type (eql 'or)) &rest args)
  (let ((alien-type (alien-type (first args))))
    (unless (every #'(lambda (type)
		       (eq alien-type (alien-type type)))
		   (rest args))
      (error "No common alien type specifier for union type: ~A" 
       (cons type args)))
    alien-type))

(defmethod size-of ((type (eql 'or)) &rest args)
  (declare (ignore type))
  (size-of (first args)))

(defmethod to-alien-form (form (type (eql 'or)) &rest args)
  (declare (ignore type))
  `(let ((value ,form))
    (etypecase value
      ,@(mapcar	 
	 #'(lambda (type)
	     `(,type ,(to-alien-form 'value type)))
	 args))))

(defmethod to-alien-function ((type (eql 'or)) &rest types)
  (declare (ignore type))
  (let ((functions (mapcar #'to-alien-function types)))
    #'(lambda (value)
	(loop
	 for function in functions
	 for type in types
	 when (typep value type)
	 do (return (funcall function value))
	 finally (error "~S is not of type ~A" value `(or ,@types))))))

(defmethod alien-type ((type (eql 'system-area-pointer)) &rest args)
  (declare (ignore type args))
  'system-area-pointer)

(defmethod size-of ((type (eql 'system-area-pointer)) &rest args)
  (declare (ignore type args))
  +size-of-pointer+)

(defmethod writer-function ((type (eql 'system-area-pointer)) &rest args)
  (declare (ignore type args))
  #'(lambda (sap location &optional (offset 0))
      (setf (sap-ref-sap location offset) sap)))

(defmethod reader-function ((type (eql 'system-area-pointer)) &rest args)
  (declare (ignore type args))
  #'(lambda (location &optional (offset 0) weak-p)
      (declare (ignore weak-p))
      (sap-ref-sap location offset)))


(defmethod alien-type ((type (eql 'null)) &rest args)
  (declare (ignore type args))
  (alien-type 'pointer))

(defmethod size-of ((type (eql 'null)) &rest args)
  (declare (ignore type args))
  (size-of 'pointer))

(defmethod to-alien-form (null (type (eql 'null)) &rest args)
  (declare (ignore null type args))
  `(make-pointer 0))

(defmethod to-alien-function ((type (eql 'null)) &rest args)
  (declare (ignore type args))
  #'(lambda (null)
      (declare (ignore null))
      (make-pointer 0)))


(defmethod alien-type ((type (eql 'nil)) &rest args)
  (declare (ignore type args))
  'void)

(defmethod from-alien-function ((type (eql 'nil)) &rest args)
  (declare (ignore type args))
  #'(lambda (value)
      (declare (ignore value))
      (values)))


(defmethod alien-type ((type (eql 'copy-of)) &rest args)
  (declare (ignore type))
  (alien-type (first args)))

(defmethod size-of ((type (eql 'copy-of)) &rest args)
  (declare (ignore type))
  (size-of (first args)))

(defmethod to-alien-form (form (type (eql 'copy-of)) &rest args)
  (declare (ignore type))
  (copy-to-alien-form form (first args)))

(defmethod to-alien-function ((type (eql 'copy-of)) &rest args)
  (declare (ignore type))
  (copy-to-alien-function (first args)))

(defmethod from-alien-form (form (type (eql 'copy-of)) &rest args)
  (declare (ignore type))
  (copy-from-alien-form form (first args)))

(defmethod from-alien-function ((type (eql 'copy-of)) &rest args)
  (declare (ignore type))
  (copy-from-alien-function (first args)))

(defmethod reader-function ((type (eql 'copy-of)) &rest args)
  (declare (ignore type))
  (reader-function (first args)))

(defmethod writer-function ((type (eql 'copy-of)) &rest args)
  (declare (ignore type))
  (writer-function (first args)))


(defmethod alien-type ((type (eql 'callback)) &rest args)
  (declare (ignore type args))
  (alien-type 'pointer))

(defmethod size-of ((type (eql 'callback)) &rest args)
  (declare (ignore type args))
  (size-of 'pointer))

(defmethod to-alien-form (callback (type (eql 'callback)) &rest args)
  (declare (ignore type args))
  #+cmu `(callback ,callback)
  #+sbcl `(sb-alien:alien-function-sap ,callback))

(defmethod to-alien-function ((type (eql 'callback)) &rest args)
  (declare (ignore type args))
  #+cmu #'(lambda (callback) (callback callback))
  #+sbcl #'sb-alien:alien-function-sap)

#+cmu
(defun find-callback (pointer)
  (find pointer alien::*callbacks* :key #'callback-trampoline :test #'sap=))

(defmethod from-alien-form (pointer (type (eql 'callback)) &rest args)
  (declare (ignore type args))
  #+cmu  `(find-callback ,pointer)
  #+sbcl `(sb-alien::%find-alien-function ,pointer))

(defmethod from-alien-function ((type (eql 'callback)) &rest args)
  (declare (ignore type args))
  #+cmu  #'find-callback
  #+sbcl #'sb-alien::%find-alien-function)

(defmethod writer-function ((type (eql 'callback)) &rest args)
  (declare (ignore type args))
  (let ((writer (writer-function 'pointer))
	(to-alien (to-alien-function 'callback)))
    #'(lambda (callback location &optional (offset 0))
	(funcall writer (funcall to-alien callback) location offset))))

(defmethod reader-function ((type (eql 'callback)) &rest args)
  (declare (ignore type args))
  (let ((reader (reader-function 'pointer))
	(from-alien (from-alien-function 'callback)))
  #'(lambda (location &optional (offset 0) weak-p)
      (declare (ignore weak-p))
      (let ((pointer (funcall reader location offset)))
	(unless (null-pointer-p pointer)
	  (funcall from-alien pointer))))))

(defmethod unbound-value ((type (eql 'callback)) &rest args)
  (declare (ignore type args))
  (values t nil))