X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/560af5c515eb5b6206040a9334de4254d2650147..ac60c4d4c929172db12c2aa41b0c4b530639208f:/glib/gforeign.lisp

diff --git a/glib/gforeign.lisp b/glib/gforeign.lisp
index 3f004ae..5b2c8cb 100644
--- a/glib/gforeign.lisp
+++ b/glib/gforeign.lisp
@@ -1,5 +1,5 @@
 ;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 1999-2000 Espen S. Johnsen <espejohn@online.no>
+;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gforeign.lisp,v 1.1 2000-08-14 16:44:38 espen Exp $
+;; $Id: gforeign.lisp,v 1.11 2001-10-21 16:50:43 espen Exp $
 
 (in-package "GLIB")
 
@@ -53,7 +53,9 @@ (defun find-type-method (type fname)
 
 (defun find-applicable-type-method (type-spec fname &optional (error t))
   (flet ((find-superclass-method (class)
-	   (when class
+	   (when (and class (class-finalized-p class))
+;  	     (unless (class-finalized-p class)
+;	       (finalize-inheritance class))
 	     (dolist (super (cdr (pcl::class-precedence-list class)))
 	       (return-if (find-type-method super fname)))))
 	 (find-expanded-type-method (type-spec)
@@ -94,20 +96,15 @@ (defmacro deftype-method (fname type lambda-list &body body)
      (add-type-method ',type ',fname #'(lambda ,lambda-list ,@body))
      ',fname))
   
-(defmacro deftype (name parameters &body body)
-  (destructuring-bind (lisp-name &optional alien-name) (mklist name)
-    `(progn
-       ,(when alien-name
-	  `(setf (alien-type-name ',lisp-name) ,alien-name))
-       (lisp:deftype ,lisp-name ,parameters ,@body))))
-
-;; To make the compiler shut up
+;; To make the compiler happy
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (define-type-method-fun translate-type-spec (type-spec))
-  (define-type-method-fun translate-to-alien (type-spec expr &optional copy))
-  (define-type-method-fun translate-from-alien (type-spec expr &optional alloc))
-  (define-type-method-fun cleanup-alien (type-spec expr &optional copied)))
-  
+  (define-type-method-fun size-of (type-spec))
+  (define-type-method-fun translate-to-alien (type-spec expr &optional weak-ref))
+  (define-type-method-fun translate-from-alien (type-spec expr &optional weak-ref))
+  (define-type-method-fun cleanup-alien (type-spec sap &otional weak-ref))
+  (define-type-method-fun unreference-alien (type-spec sap)))
+
 
 ;;;; 
 
@@ -121,31 +118,27 @@ (defun set-cached-function (type-spec fname function)
   function)
   
 
-;; Creates a function to translate an object of the specified type
-;; from lisp to alien representation.
-(defun get-to-alien-function (type-spec)
+(defun intern-argument-translator (type-spec)
   (or
-   (get-cached-function type-spec 'to-alien-function)
-   (set-cached-function type-spec 'to-alien-function
+   (get-cached-function type-spec 'argument-translator)
+   (set-cached-function type-spec 'argument-translator
     (compile
      nil
      `(lambda (object)
 	(declare (ignorable object))
-	,(translate-to-alien type-spec 'object))))))
+	,(translate-to-alien type-spec 'object t))))))
 
-;; and the opposite
-(defun get-from-alien-function (type-spec)
+(defun intern-return-value-translator (type-spec)
   (or
-   (get-cached-function type-spec 'from-alien-function)
-   (set-cached-function type-spec 'from-alien-function
+   (get-cached-function type-spec 'return-value-translator)
+   (set-cached-function type-spec 'return-value-translator
     (compile
      nil
      `(lambda (alien)
 	(declare (ignorable alien))
-	,(translate-from-alien type-spec 'alien))))))
+	,(translate-from-alien type-spec 'alien nil))))))
 
-;; and for cleaning up
-(defun get-cleanup-function (type-spec)
+(defun intern-cleanup-function (type-spec)
   (or
    (get-cached-function type-spec 'cleanup-function)
    (set-cached-function type-spec 'cleanup-function
@@ -153,13 +146,13 @@ (defun get-cleanup-function (type-spec)
      nil
      `(lambda (alien)
 	(declare (ignorable alien))
-	,(cleanup-alien type-spec 'alien))))))
+	,(cleanup-alien type-spec 'alien t))))))
 
 
 
-;; Creates a function to write an object of the specified type
-;; to the given memory location
-(defun get-writer-function (type-spec)
+;; Returns a function to write an object of the specified type
+;; to a memory location
+(defun intern-writer-function (type-spec)
   (or
    (get-cached-function type-spec 'writer-function)
    (set-cached-function type-spec 'writer-function
@@ -169,11 +162,11 @@ (defun get-writer-function (type-spec)
 	(declare (ignorable value sap offset))
 	(setf
 	 (,(sap-ref-fname type-spec) sap offset)
-	 ,(translate-to-alien type-spec 'value :copy)))))))
+	 ,(translate-to-alien type-spec 'value nil)))))))
 
-;; Creates a function to read an object of the specified type
-;; from the given memory location
-(defun get-reader-function (type-spec)
+;; Returns a function to read an object of the specified type
+;; from a memory location
+(defun intern-reader-function (type-spec)
   (or
    (get-cached-function type-spec 'reader-function)
    (set-cached-function type-spec 'reader-function
@@ -182,25 +175,33 @@ (defun get-reader-function (type-spec)
      `(lambda (sap offset)	 
 	(declare (ignorable sap offset))
 	,(translate-from-alien
-	  type-spec `(,(sap-ref-fname type-spec) sap offset) :copy))))))
-
+	  type-spec `(,(sap-ref-fname type-spec) sap offset) t))))))
 
-(defun get-destroy-function (type-spec)
-  (or
-   (get-cached-function type-spec 'destroy-function)
-   (set-cached-function type-spec 'destroy-function
-    (compile
-     nil
-     `(lambda (sap offset)	 
-	(declare (ignorable sap offset))
-	,(cleanup-alien
-	  type-spec `(,(sap-ref-fname type-spec) sap offset) :copied))))))
+(defun intern-destroy-function (type-spec)
+  (if (atomic-type-p type-spec)
+      #'(lambda (sap offset)	 
+	  (declare (ignore sap offset)))
+    (or
+     (get-cached-function type-spec 'destroy-function)
+     (set-cached-function type-spec 'destroy-function
+       (compile
+	nil
+	`(lambda (sap offset)	 
+	   (declare (ignorable sap offset))
+	   ,(unreference-alien
+	     type-spec `(,(sap-ref-fname type-spec) sap offset))))))))
 
 
 
 ;;;;
 
+(defconstant +bits-per-unit+ 8
+  "Number of bits in an addressable unit (byte)")
+
+;; Sizes of fundamental C types in addressable units
+(defconstant +size-of-short+ 2)
 (defconstant +size-of-int+ 4)
+(defconstant +size-of-long+ 4)
 (defconstant +size-of-sap+ 4)
 (defconstant +size-of-float+ 4)
 (defconstant +size-of-double+ 8)
@@ -231,25 +232,6 @@ (defun sap-ref-fname (type-spec)
       (double-float 'sap-ref-double))))
 
 
-(defun signed (size)
-  (if (eq size '*)
-      `(signed ,(* 8 +size-of-int+))
-    `(signed ,size)))
-
-(defun unsigned (size)
-  (if (eq size '*)
-      `(unsigned ,(* 8 +size-of-int+))
-    `(unsigned ,size)))
-
-(defun size-of (type-spec)
-  (let ((alien-type-spec (translate-type-spec type-spec)))
-    (ecase (first (mklist alien-type-spec))
-     ((signed unsigned) (/ (second alien-type-spec) 8))
-     ((system-area-pointer single-float) +size-of-sap+)
-     (single-float +size-of-float+)
-     (double-float +size-of-double+))))
-
-
 ;;;; Foreign function call interface
 
 (defvar *package-prefix* nil)
@@ -266,12 +248,17 @@ (defun package-prefix (&optional (package *package*))
      (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-func-name (lisp-name)
+(defun default-alien-fname (lisp-name)
   (let* ((lisp-name-string
 	  (if (char= (char (the simple-string (string lisp-name)) 0) #\%)
 	      (subseq (the simple-string (string lisp-name)) 1)
@@ -282,12 +269,31 @@ (defun default-alien-func-name (lisp-name)
 	name
       (format nil "~A_~A" prefix name))))
 
-
-(defmacro define-foreign (name lambda-list return-type-spec &rest docs/args)
-  (multiple-value-bind (c-name lisp-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-spec &rest docs/args)
+  (multiple-value-bind (lisp-name c-name)
       (if (atom name)
-	  (values (default-alien-func-name name) name)
-	(values-list name))
+ 	  (values name (default-alien-fname name))
+ 	(values-list name))
+		       
     (let ((supplied-lambda-list lambda-list)
 	  (docs nil)
 	  (args nil))
@@ -296,42 +302,46 @@ (defmacro define-foreign (name lambda-list return-type-spec &rest docs/args)
 	    (push doc/arg docs)
 	  (progn
 	    (destructuring-bind (expr type &optional (style :in)) doc/arg
-	      (unless (member style '(:in :out))
+	      (unless (member style '(:in :out :in-out))
 		(error "Bogus argument style ~S in ~S." style doc/arg))
-	      (when (and (not supplied-lambda-list) (namep expr) (eq style :in))
+	      (when (and
+		     (not supplied-lambda-list)
+		     (namep expr) (member style '(:in :in-out)))
 		(push expr lambda-list))
 	      (push
 	       (list (if (namep expr) expr (gensym)) expr type style) args)))))
       
-      (%define-foreign
+      (%defbinding
        c-name lisp-name (or supplied-lambda-list (nreverse lambda-list))
        return-type-spec (reverse docs) (reverse args)))))
 
-
 #+cmu
-(defun %define-foreign (foreign-name lisp-name lambda-list
-			return-type-spec docs args)
+(defun %defbinding (foreign-name lisp-name lambda-list
+		    return-type-spec docs args)
   (ext:collect ((alien-types) (alien-bindings) (alien-parameters)
-		(alien-values) (alien-deallocatiors))
+		(alien-values) (alien-deallocators))
     (dolist (arg args)
       (destructuring-bind (var expr type-spec style) arg
 	(let ((declaration (translate-type-spec type-spec))
-	      (deallocation (cleanup-alien type-spec expr)))
+	      (deallocation (cleanup-alien type-spec var t)))
 	  (cond
-	   ((eq style :out)
+	   ((member style '(:out :in-out))
 	    (alien-types `(* ,declaration))
 	    (alien-parameters `(addr ,var))
-	    (alien-bindings `(,var ,declaration))
-	    (alien-values (translate-from-alien type-spec var)))
+	    (alien-bindings
+	     `(,var ,declaration
+	       ,@(when (eq style :in-out)
+		   (list (translate-to-alien type-spec expr t)))))
+	    (alien-values (translate-from-alien type-spec var nil)))
 	  (deallocation
 	   (alien-types declaration)
 	   (alien-bindings
-	    `(,var ,declaration ,(translate-to-alien type-spec expr)))
+	    `(,var ,declaration ,(translate-to-alien type-spec expr t)))
 	   (alien-parameters var)
-	   (alien-deallocatiors deallocation))
+	   (alien-deallocators deallocation))
 	  (t
 	   (alien-types declaration)
-	   (alien-parameters (translate-to-alien type-spec expr)))))))
+	   (alien-parameters (translate-to-alien type-spec expr t)))))))
 
     (let ((alien-funcall `(alien-funcall ,lisp-name ,@(alien-parameters))))
       `(defun ,lisp-name ,lambda-list
@@ -344,113 +354,214 @@ (defun %define-foreign (foreign-name lisp-name lambda-list
 		      ,@(alien-bindings))
 	   ,(if return-type-spec
 		`(let ((result
-			,(translate-from-alien return-type-spec alien-funcall)))
-		   ,@(alien-deallocatiors)
+			,(translate-from-alien return-type-spec alien-funcall nil)))
+		   ,@(alien-deallocators)
 		   (values result ,@(alien-values)))
 	      `(progn
 		 ,alien-funcall
-		 ,@(alien-deallocatiors)
+		 ,@(alien-deallocators)
 		 (values ,@(alien-values)))))))))
 
-  
 
+(defun mkbinding (name return-type &rest arg-types)
+   (declare (optimize (ext:inhibit-warnings 3)))
+   (let* ((ftype
+	   `(function
+	     ,@(mapcar #'translate-type-spec (cons return-type arg-types))))
+	 (alien
+	  (alien::%heap-alien
+	   (alien::make-heap-alien-info
+	    :type (alien::parse-alien-type ftype)
+	    :sap-form (system:foreign-symbol-address name))))
+	 (translate-arguments
+	  (mapcar #'intern-return-value-translator arg-types))
+	 (translate-return-value (intern-return-value-translator return-type))
+	 (cleanup-arguments (mapcar #'intern-cleanup-function arg-types)))
+	 
+    #'(lambda (&rest args)
+	(map-into args #'funcall translate-arguments args)
+	(prog1
+	    (funcall
+	     translate-return-value (apply #'alien:alien-funcall alien args))
+	  (mapc #'funcall cleanup-arguments args)))))
+
+
+(defun type-translateable-p (type-spec)
+  (find-applicable-type-method type-spec 'translate-type-spec nil))
+
+(defun every-type-translateable-p (type-specs)
+  (every #'type-translateable-p type-specs))
+
+(defun mkbinding-late (name return-type &rest arg-types)
+  (if (every-type-translateable-p (cons return-type arg-types))
+      (apply #'mkbinding name return-type arg-types)
+    (let* ((binding
+	    #'(lambda (&rest args)
+		(cond
+		 ((every-type-translateable-p (cons return-type arg-types))
+		  (setq binding (apply #'mkbinding name return-type arg-types))
+		  (apply binding args))
+		 (t
+		  (dolist (type-spec (cons return-type arg-types))
+		    (unless (type-translateable-p type-spec)
+		      (error "Can't translate type ~A" type-spec))))))))
+      #'(lambda (&rest args)
+	  (apply binding args)))))
+       
 
-;;;; Translations for fundamental types
+  
 
-(lisp:deftype long (&optional (min '*) (max '*)) `(integer ,min ,max))
-(lisp:deftype unsigned-long (&optional (min '*) (max '*)) `(integer ,min ,max))
-(lisp:deftype int (&optional (min '*) (max '*)) `(long ,min ,max))
-(lisp:deftype unsigned-int (&optional (min '*) (max '*)) `(unsigned-long ,min ,max))
-(lisp:deftype short (&optional (min '*) (max '*)) `(int ,min ,max))
-(lisp:deftype unsigned-short (&optional (min '*) (max '*)) `(unsigned-int ,min ,max))
-(lisp:deftype signed (&optional (size '*)) `(signed-byte ,size))
-(lisp:deftype unsigned (&optional (size '*)) `(signed-byte ,size))
-(lisp:deftype char () 'base-char)
-(lisp:deftype pointer () 'system-area-pointer)
-(lisp:deftype boolean (&optional (size '*))
+;;;; Definitons and translations of fundamental types
+
+(deftype long (&optional (min '*) (max '*)) `(integer ,min ,max))
+(deftype unsigned-long (&optional (min '*) (max '*)) `(integer ,min ,max))
+(deftype int (&optional (min '*) (max '*)) `(long ,min ,max))
+(deftype unsigned-int (&optional (min '*) (max '*)) `(unsigned-long ,min ,max))
+(deftype short (&optional (min '*) (max '*)) `(int ,min ,max))
+(deftype unsigned-short (&optional (min '*) (max '*)) `(unsigned-int ,min ,max))
+(deftype signed (&optional (size '*)) `(signed-byte ,size))
+(deftype unsigned (&optional (size '*)) `(signed-byte ,size))
+(deftype char () 'base-char)
+(deftype pointer () 'system-area-pointer)
+(deftype boolean (&optional (size '*))
   (declare (ignore size))
   `(member t nil))
-(lisp:deftype static (type) type)
-(lisp:deftype invalid () nil)
+(deftype invalid () nil)
+
+(defun atomic-type-p (type-spec)
+  (or
+   (eq type-spec 'pointer)
+   (not (eq (translate-type-spec type-spec) 'system-area-pointer))))
 
 
-(deftype-method cleanup-alien t (type-spec alien &optional copied)
-  (declare (ignore type-spec alien copied))
+(deftype-method cleanup-alien t (type-spec sap &optional weak-ref)
+  (declare (ignore type-spec sap weak-ref))
   nil)
 
 
-(deftype-method translate-to-alien integer (type-spec number &optional copy)
-  (declare (ignore type-spec copy))
+(deftype-method translate-to-alien integer (type-spec number &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   number)
 
-(deftype-method translate-from-alien integer (type-spec number &optional alloc)
-  (declare (ignore type-spec alloc))
+(deftype-method translate-from-alien integer (type-spec number &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   number)
 
 
 (deftype-method translate-type-spec fixnum (type-spec)
   (declare (ignore type-spec))
-  (signed '*))
+  (translate-type-spec 'signed))
 
-(deftype-method translate-to-alien fixnum (type-spec number &optional copy)
-  (declare (ignore type-spec copy))
+(deftype-method size-of fixnum (type-spec)
+  (declare (ignore type-spec))
+  (size-of 'signed))
+
+(deftype-method translate-to-alien fixnum (type-spec number &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   number)
 
-(deftype-method translate-from-alien fixnum (type-spec number &optional alloc)
-  (declare (ignore type-spec alloc))
+(deftype-method translate-from-alien fixnum (type-spec number &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   number)
 
 
 (deftype-method translate-type-spec long (type-spec)
   (declare (ignore type-spec))
-  (signed '*))
+  `(signed ,(* +bits-per-unit+ +size-of-long+)))
+
+(deftype-method size-of long (type-spec)
+  (declare (ignore type-spec))
+  +size-of-long+)
 
 
 (deftype-method translate-type-spec unsigned-long (type-spec)
   (declare (ignore type-spec))
-  (unsigned '*))
+  `(unsigned ,(* +bits-per-unit+ +size-of-long+)))
+
+(deftype-method size-of unsigned-long (type-spec)
+  (declare (ignore type-spec))
+  +size-of-long+)
+
+
+(deftype-method translate-type-spec int (type-spec)
+  (declare (ignore type-spec))
+  `(signed ,(* +bits-per-unit+ +size-of-int+)))
+
+(deftype-method size-of int (type-spec)
+  (declare (ignore type-spec))
+  +size-of-int+)
+
+
+(deftype-method translate-type-spec unsigned-int (type-spec)
+  (declare (ignore type-spec))
+  `(unsigned ,(* +bits-per-unit+ +size-of-int+)))
+
+(deftype-method size-of unsigned-int (type-spec)
+  (declare (ignore type-spec))
+  +size-of-int+)
 
 
 (deftype-method translate-type-spec short (type-spec)
   (declare (ignore type-spec))
-  '(signed 16))
+  `(signed ,(* +bits-per-unit+ +size-of-short+)))
+
+(deftype-method size-of short (type-spec)
+  (declare (ignore type-spec))
+  +size-of-short+)
 
 
 (deftype-method translate-type-spec unsigned-short (type-spec)
   (declare (ignore type-spec))
-  '(unsigned 16))
+  `(unsigned ,(* +bits-per-unit+ +size-of-short+)))
 
+(deftype-method size-of unsigned-short (type-spec)
+  (declare (ignore type-spec))
+  +size-of-short+)
 
-(deftype-method translate-type-spec signed-byte (type-spec)
-  (destructuring-bind (name &optional (size '*))
-      (type-expand-to 'signed-byte type-spec)
-    (declare (ignore name))
-    (signed size)))
 
-(deftype-method translate-to-alien signed-byte (type-spec number &optional copy)
-  (declare (ignore type-spec copy))
+(deftype-method translate-type-spec signed-byte (type-spec)
+  (let ((size (second (mklist (type-expand-to 'signed-byte type-spec)))))
+    `(signed
+      ,(cond
+	((member size '(nil *)) (* +bits-per-unit+ +size-of-int+))
+	(t size)))))
+
+(deftype-method size-of signed-byte (type-spec)
+  (let ((size (second (mklist (type-expand-to 'signed-byte type-spec)))))
+    (cond
+     ((member size '(nil *)) +size-of-int+)
+     (t (/ size +bits-per-unit+)))))
+
+(deftype-method translate-to-alien signed-byte (type-spec number &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   number)
 
-(deftype-method
-    translate-from-alien signed-byte (type-spec number &optional alloc)
-  (declare (ignore type-spec alloc))
+(deftype-method translate-from-alien signed-byte
+    (type-spec number &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   number)
 
 
 (deftype-method translate-type-spec unsigned-byte (type-spec)
-  (destructuring-bind (name &optional (size '*))
-      (type-expand-to 'unsigned-byte type-spec)
-    (declare (ignore name))
-    (unsigned size)))
-
-(deftype-method
-    translate-to-alien unsigned-byte (type-spec number &optional copy)
-  (declare (ignore type-spec copy))
+  (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec)))))
+    `(signed
+      ,(cond
+	((member size '(nil *)) (* +bits-per-unit+ +size-of-int+))
+	(t size)))))
+
+(deftype-method size-of unsigned-byte (type-spec)
+  (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec)))))
+    (cond
+     ((member size '(nil *)) +size-of-int+)
+     (t (/ size +bits-per-unit+)))))
+
+(deftype-method translate-to-alien unsigned-byte (type-spec number &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   number)
 
-(deftype-method
-    translate-from-alien unsigned-byte (type-spec number &optional alloc)
-  (declare (ignore type-spec alloc))
+(deftype-method translate-from-alien unsigned-byte
+    (type-spec number &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   number)
 
 
@@ -458,14 +569,17 @@ (deftype-method translate-type-spec single-float (type-spec)
   (declare (ignore type-spec))
   'single-float)
 
-(deftype-method
-    translate-to-alien single-float (type-spec number &optional copy)
-  (declare (ignore type-spec copy))
+(deftype-method size-of single-float (type-spec)
+  (declare (ignore type-spec))
+  +size-of-float+)
+
+(deftype-method translate-to-alien single-float (type-spec number &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   number)
 
-(deftype-method
-    translate-from-alien single-float (type-spec number &optional alloc)
-  (declare (ignore type-spec alloc))
+(deftype-method translate-from-alien single-float
+    (type-spec number &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   number)
 
 
@@ -473,27 +587,34 @@ (deftype-method translate-type-spec double-float (type-spec)
   (declare (ignore type-spec))
   'double-float)
 
-(deftype-method
-    translate-to-alien double-float (type-spec number &optional copy)
-  (declare (ignore type-spec copy))
+(deftype-method size-of double-float (type-spec)
+  (declare (ignore type-spec))
+  +size-of-double+)
+
+(deftype-method translate-to-alien double-float (type-spec number &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   number)
 
-(deftype-method
-    translate-from-alien double-float (type-spec number &optional alloc)
-  (declare (ignore type-spec alloc))
+(deftype-method translate-from-alien double-float
+    (type-spec number &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   number)
 
 
 (deftype-method translate-type-spec base-char (type-spec)
   (declare (ignore type-spec))
-  '(unsigned 8))
+  `(unsigned ,+bits-per-unit+))
 
-(deftype-method translate-to-alien base-char (type-spec char &optional copy)
-  (declare (ignore type-spec copy))
+(deftype-method size-of base-char (type-spec)
+  (declare (ignore type-spec))
+  1)
+
+(deftype-method translate-to-alien base-char (type-spec char &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   `(char-code ,char))
 
-(deftype-method translate-from-alien base-char (type-spec code &optional alloc)
-  (declare (ignore type-spec alloc))
+(deftype-method translate-from-alien base-char (type-spec code &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   `(code-char ,code))
 
 
@@ -501,61 +622,68 @@ (deftype-method translate-type-spec string (type-spec)
   (declare (ignore type-spec))
   'system-area-pointer)
 
-(deftype-method translate-to-alien string (type-spec string &optional copy)
+(deftype-method size-of string (type-spec)
   (declare (ignore type-spec))
-  (if copy
-      `(let ((string ,string))
-	 (copy-memory
-	  (make-pointer (1+ (kernel:get-lisp-obj-address string)))
-	  (1+ (length string))))
-    `(make-pointer (1+ (kernel:get-lisp-obj-address ,string)))))
-
-(deftype-method
-    translate-from-alien string (type-spec sap &optional (alloc :dynamic))
+  +size-of-sap+)
+
+(deftype-method translate-to-alien string (type-spec string &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
+  `(let ((string ,string))
+     ;; Always copy strings to prevent seg fault due to GC
+     (copy-memory
+      (make-pointer (1+ (kernel:get-lisp-obj-address string)))
+      (1+ (length string)))))
+
+(deftype-method translate-from-alien string
+    (type-spec c-string &optional weak-ref)
   (declare (ignore type-spec))
-  `(let ((sap ,sap))
-     (unless (null-pointer-p sap)
+  `(let ((c-string ,c-string))
+     (unless (null-pointer-p c-string)
        (prog1
-	   (c-call::%naturalize-c-string sap)
-	 ,(when (eq alloc :dynamic) `(deallocate-memory ,sap))))))
+	   (c-call::%naturalize-c-string c-string)
+	 ;,(unless weak-ref `(deallocate-memory c-string))
+	 ))))
 
-(deftype-method cleanup-alien string (type-spec sap &optional copied)
-  (declare (ignore type-spec))
-  (when copied
-    `(let ((sap ,sap))
-       (unless (null-pointer-p sap)
-	 (deallocate-memory sap)))))
+(deftype-method cleanup-alien string (type-spec c-string &optional weak-ref)
+  (when weak-ref
+    (unreference-alien type-spec c-string)))
 
+(deftype-method unreference-alien string (type-spec c-string)
+  (declare (ignore type-spec))
+  `(let ((c-string ,c-string))
+     (unless (null-pointer-p c-string)
+       (deallocate-memory c-string))))
+  
 
 (deftype-method translate-type-spec boolean (type-spec)
-  (if (atom type-spec)
-      (unsigned '*)
-    (destructuring-bind (name &optional (size '*))
-	(type-expand-to 'boolean type-spec)
-      (declare (ignore name))
-      (unsigned size))))
-
-(deftype-method translate-to-alien boolean (type-spec boolean &optional copy)
-  (declare (ignore type-spec copy))
+  (translate-type-spec
+   (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec))))))
+
+(deftype-method size-of boolean (type-spec)
+  (size-of
+   (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec))))))
+
+(deftype-method translate-to-alien boolean (type-spec boolean &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   `(if ,boolean 1 0))
 
-(deftype-method translate-from-alien boolean (type-spec int &optional alloc)
-  (declare (ignore type-spec alloc))
+(deftype-method translate-from-alien boolean (type-spec int &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   `(not (zerop ,int)))
 
 
-(deftype-method translate-type-spec or (union-type-spec)
-  (destructuring-bind (name &rest type-specs)
-      (type-expand-to 'or union-type-spec)
-    (declare (ignore name))
-    (let ((type-spec-translations
-	   (map 'list #'translate-type-spec type-specs)))
-      (unless (apply #'all-equal type-spec-translations)
-	(error
-	 "No common alien type specifier for union type: ~A" union-type-spec))
-      (first type-spec-translations))))
-
-(deftype-method translate-to-alien or (union-type-spec expr &optional copy)
+(deftype-method translate-type-spec or (union-type)
+  (let* ((member-types (cdr (type-expand-to 'or union-type)))
+	 (alien-type (translate-type-spec (first member-types))))
+    (dolist (type (cdr member-types))
+      (unless (eq alien-type (translate-type-spec type))
+	(error "No common alien type specifier for union type: ~A" union-type)))
+    alien-type))
+
+(deftype-method size-of or (union-type)
+  (size-of (first (cdr (type-expand-to 'or union-type)))))
+
+(deftype-method translate-to-alien or (union-type-spec expr &optional weak-ref)
   (destructuring-bind (name &rest type-specs)
       (type-expand-to 'or union-type-spec)
     (declare (ignore name))
@@ -563,24 +691,26 @@ (deftype-method translate-to-alien or (union-type-spec expr &optional copy)
        (etypecase value
 	 ,@(map
 	    'list
-	    #'(lambda (type-spec)
-		(list type-spec (translate-to-alien type-spec 'value copy)))
-	    type-specs)))))
-
+	      #'(lambda (type-spec)
+		  (list type-spec (translate-to-alien type-spec 'value weak-ref)))
+	      type-specs)))))
 
 
 (deftype-method translate-type-spec system-area-pointer (type-spec)
   (declare (ignore type-spec))
   'system-area-pointer)
 
-(deftype-method
-    translate-to-alien system-area-pointer (type-spec sap &optional copy)
-  (declare (ignore type-spec copy))
+(deftype-method size-of system-area-pointer (type-spec)
+  (declare (ignore type-spec))
+  +size-of-sap+)
+
+(deftype-method translate-to-alien system-area-pointer (type-spec sap &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   sap)
 
-(deftype-method
-  translate-from-alien system-area-pointer (type-spec sap &optional alloc)
-  (declare (ignore type-spec alloc))
+(deftype-method translate-from-alien system-area-pointer
+    (type-spec sap &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
   sap)
 
 
@@ -588,8 +718,8 @@ (deftype-method translate-type-spec null (type-spec)
   (declare (ignore type-spec))
   'system-area-pointer)
 
-(deftype-method translate-to-alien null (type-spec expr &optional copy)
-  (declare (ignore type-spec copy))
+(deftype-method translate-to-alien null (type-spec expr &optional weak-ref)
+  (declare (ignore type-spec expr weak-ref))
   `(make-pointer 0))
 
 
@@ -597,98 +727,8 @@ (deftype-method translate-type-spec nil (type-spec)
   (declare (ignore type-spec))
   'void)
 
-
-(deftype-method transalte-type-spec static (type-spec)
-  (translate-type-spec (second type-spec)))
-  
-(deftype-method translate-to-alien static (type-spec expr &optional copy)
-  (declare (ignore copy))
-  (translate-to-alien (second type-spec) expr nil))
-
-(deftype-method translate-from-alien static (type-spec alien &optional alloc)
-  (declare (ignore alloc))
-  (translate-from-alien (second type-spec) alien nil))
-
-(deftype-method cleanup-alien static (type-spec alien &optional copied)
-  (declare (ignore copied))
-  (cleanup-alien type-spec alien nil))
-
-
-
-;;;; Enum and flags type
-
-(defun map-mappings (args op)
-  (let ((current-value 0))
-    (map
-     'list 
-     #'(lambda (mapping)
-	 (destructuring-bind (symbol &optional (value current-value))
-	     (mklist mapping)
-	   (setf current-value (1+ value))
-	   (case op
-	     (:enum-int (list symbol value))
-	     (:flags-int (list symbol (ash 1 value)))
-	     (:int-enum (list value symbol))
-	     (:int-flags (list (ash 1 value) symbol))
-	     (:symbols symbol))))
-     (if (integerp (first args))
-	 (rest args)
-       args))))
-
-(lisp:deftype enum (&rest args)
-  `(member ,@(map-mappings args :symbols)))
-
-(deftype-method translate-type-spec enum (type-spec)
-  (destructuring-bind (name &rest args) (type-expand-to 'enum type-spec)
-    (declare (ignore name))
-    (if (integerp (first args))
-	`(signed ,(first args))
-      '(signed 32))))
-
-(deftype-method translate-to-alien enum (type-spec expr &optional copy)
-  (declare (ignore copy))
-  (destructuring-bind (name &rest args) (type-expand-to 'enum type-spec)
-    (declare (ignore name))
-    `(ecase ,expr
-       ,@(map-mappings args :enum-int))))
-
-(deftype-method translate-from-alien enum (type-spec expr &optional alloc)
-  (declare (ignore alloc))
-  (destructuring-bind (name &rest args) (type-expand-to 'enum type-spec)
-    (declare (ignore name))
-    `(ecase ,expr
-       ,@(map-mappings args :int-enum))))
-
-
-(lisp:deftype flags (&rest args)
-  `(or
-    null
-    (cons
-     (member ,@(map-mappings args :symbols))
-     list)))
-
-(deftype-method translate-type-spec flags (type-spec)
-  (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec)
-    (declare (ignore name))
-    (if (integerp (first args))
-	`(signed ,(first args))
-      '(signed 32))))
-
-(deftype-method translate-to-alien flags (type-spec expr &optional copy)
-  (declare (ignore copy))
-  (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec)
-    (declare (ignore name))
-    (let ((mappings (map-mappings args :flags-int)))
-      `(let ((value 0))
-	 (dolist (flag ,expr value)
-	   (setq value (logior value (second (assoc flag ',mappings)))))))))
-
-(deftype-method translate-from-alien flags (type-spec expr &optional alloc)
-  (declare (ignore alloc))
-  (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec)
-    (declare (ignore name))
-    (let ((mappings (map-mappings args :int-flags)))
-      `(let ((result nil))
-	 (dolist (mapping ',mappings result)
-	   (unless (zerop (logand ,expr (first mapping)))
-	     (push (second mapping) result)))))))
+(deftype-method translate-from-alien nil (type-spec expr &optional weak-ref)
+  (declare (ignore type-spec weak-ref))
+  `(progn
+     ,expr
+     (values)))