Added support for SBCL's native C callbacks, new callback API and improved handling...

[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.24 2006-02-19 19:17:45 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)))))



;;;; C callbacks

(defmacro define-callback (name return-type args &body body)
  (let ((define-callback 
	  #+cmu'alien:def-callback 	              
	  #+(and sbcl alien-callbacks)'sb-alien::define-alien-callback
	  #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function))
    (multiple-value-bind (doc declaration body)
	(cond
	 ((and (stringp (first body)) (eq (cadr body) 'declare))
	  (values (first body) (second body) (cddr body)))
	 ((stringp (first body))
	  (values (first body) nil (rest body)))
	 ((eq (caar body) 'declare)
	  (values nil (first body) (rest body)))
	 (t (values nil nil body)))
      `(,define-callback ,name 
	 #+(and sbcl alien-callbacks),(alien-type return-type) 
         (#+(or cmu (and sbcl (not alien-callbacks))),(alien-type return-type)
	 ,@(mapcar #'(lambda (arg)
		       (destructuring-bind (name type) arg
			 `(,name ,(alien-type type))))
		   args))
	 ,@(when doc (list doc))
	 ,(to-alien-form 
	   `(let (,@(loop
		     for (name type) in args
		     as from-alien-form = (callback-from-alien-form name type)
		     collect `(,name ,from-alien-form)))
	      ,@(when declaration (list declaration))
	      (unwind-protect
		  (progn ,@body)	      
 	      ,@(loop 
 		 for (name type) in args
 		 do (callback-cleanup-form name type))))

	 return-type)))))

(defun callback-address (callback)
  #+cmu(alien::callback-trampoline callback)
  #+(and sbcl (not alien-callbacks))(sb-alien:alien-function-sap callback)
  #+(and sbcl alien-callbacks)(sb-alien:alien-sap callback))

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


;;; These are for backward compatibility

(defmacro defcallback (name (return-type &rest args) &body body)
  `(define-callback ,name ,return-type ,args ,@body))

#-cmu
(defun callback (callback)
  (callback-address callback))



;;;; 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 callback-from-alien-form (form))
(def-type-method callback-cleanup-form (form))

(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 callback-from-alien-form (form (type t) &rest args)
  (apply #'copy-from-alien-form form type args))

(defmethod callback-cleanup-form (form (type t) &rest args)
  (declare (ignore form type args))
  nil)

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

#+nil
(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))
  `(callback-address ,callback))

(defmethod to-alien-function ((type (eql 'callback)) &rest args)
  (declare (ignore type args))
  #'callback-address)

#+nil(
#+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))
)