chiark / gitweb /
Major cleanup of ffi abstraction layer
authorespen <espen>
Sat, 6 Nov 2004 21:39:57 +0000 (21:39 +0000)
committerespen <espen>
Sat, 6 Nov 2004 21:39:57 +0000 (21:39 +0000)
20 files changed:
atk/atk.lisp
gdk/gdk.lisp
gdk/gdkevents.lisp
gdk/gdktypes.lisp
glib/defpackage.lisp
glib/ffi.lisp
glib/gboxed.lisp
glib/gcallback.lisp
glib/genums.lisp
glib/ginterface.lisp
glib/glib.asd
glib/glib.lisp
glib/gobject.lisp
glib/gparam.lisp
glib/proxy.lisp
gtk/gtk.lisp
gtk/gtkobject.lisp
gtk/gtktypes.lisp
gtk/gtkwidget.lisp
pango/pango.lisp

index 1f9a731..8a2cd7c 100644 (file)
 ;; 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: atk.lisp,v 1.3 2004-10-31 11:44:45 espen Exp $
+;; $Id: atk.lisp,v 1.4 2004-11-06 21:39:57 espen Exp $
 
 (in-package "ATK")
 
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (init-types-in-library "libatk-1.0.so"))
+  (init-types-in-library 
+   #.(concatenate 'string (pkg-config:pkg-variable "atk" "libdir") 
+                         "/libatk-1.0.so") :prefix "atk_"))
 
 (define-types-by-introspection "Atk")
index c258377..497b985 100644 (file)
@@ -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: gdk.lisp,v 1.10 2004-10-31 11:51:08 espen Exp $
+;; $Id: gdk.lisp,v 1.11 2004-11-06 21:39:58 espen Exp $
 
 
 (in-package "GDK")
@@ -30,11 +30,12 @@ (defbinding (gdk-init "gdk_parse_args") () nil
 
 ;;; Display
 
-(defbinding %display-manager-get () display-manager)
+(defbinding (display-manager "gdk_display_manager_get") () display-manager)
+
 
 (defbinding (display-set-default "gdk_display_manager_set_default_display")
     (display) nil
-  ((%display-manager-get) display-manager)
+  ((display-manager) display-manager)
   (display display))
 
 (defbinding display-get-default () display)
@@ -318,15 +319,6 @@ (defbinding rgb-init () nil)
 
 ;;; Cursor
 
-(deftype-method alien-ref cursor (type-spec)
-  (declare (ignore type-spec))
-  '%cursor-ref)
-
-(deftype-method alien-unref cursor (type-spec)
-  (declare (ignore type-spec))
-  '%cursor-unref)
-
-
 (defbinding cursor-new () cursor
   (cursor-type cursor-type))
 
@@ -338,10 +330,19 @@ (defbinding cursor-new-from-pixmap () cursor
   (x int) (y int))
 
 (defbinding %cursor-ref () pointer
-  (cursor (or cursor pointer)))
+  (location pointer))
 
 (defbinding %cursor-unref () nil
-  (cursor (or cursor pointer)))
+  (location pointer))
+
+(defmethod reference-foreign ((class (eql (find-class 'cursor))) location)
+  (declare (ignore class))
+  (%cursor-ref location))
+
+(defmethod unreference-foreign ((class (eql (find-class 'cursor))) location)
+  (declare (ignore class))
+  (%cursor-unref location))
+
 
 
 
index fe7e357..7b0b698 100644 (file)
 ;; 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: gdkevents.lisp,v 1.4 2004-10-31 11:53:30 espen Exp $
+;; $Id: gdkevents.lisp,v 1.5 2004-11-06 21:39:58 espen Exp $
 
 (in-package "GDK")
 
 
 (defvar *event-classes* (make-hash-table))
 
-(defun %type-of-event (location)
-  (class-name
-   (gethash
-    (funcall (intern-reader-function 'event-type) location 0)
-    *event-classes*)))
-
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defclass event (boxed)
     ((%type
@@ -52,32 +46,32 @@ (defmethod initialize-instance ((event event) &rest initargs)
   (call-next-method)
   (setf (slot-value event '%type) (event-class-type (class-of event))))
 
-(deftype-method translate-from-alien
-    event (type-spec location &optional weak-ref)
-  (declare (ignore type-spec))    
-  `(let ((location ,location))
-     (unless (null-pointer-p location)
-       (ensure-proxy-instance (%type-of-event location) location ,weak-ref))))
-
 
 ;;;; Metaclass for event classes
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass event-class (proxy-class)
+  (defclass event-class (boxed-class)
     ((event-type :reader event-class-type)))
 
+  (defmethod validate-superclass ((class event-class) (super standard-class))
+    (subtypep (class-name super) 'event)))
+
+
+(defmethod shared-initialize ((class event-class) names &key name type)
+  (call-next-method)
+  (setf (slot-value class 'event-type) (first type))
+  (setf (gethash (first type) *event-classes*) class)
+  (let ((class-name (or name (class-name class))))
+    (register-type class-name 'event)))
   
-  (defmethod shared-initialize ((class event-class) names &key name type)
-    (call-next-method)
-    (setf (slot-value class 'event-type) (first type))
-    (setf (gethash (first type) *event-classes*) class)
-    (let ((class-name (or name (class-name class))))
-      (register-type class-name 'event)))
-  
+(let ((reader (reader-function 'event-type)))
+  (defun %event-class (location)
+    (gethash (funcall reader location 0) *event-classes*)))
 
-  (defmethod validate-superclass
-    ((class event-class) (super pcl::standard-class))
-    (subtypep (class-name super) 'event)))
+(defmethod ensure-proxy-instance ((class event-class) location)
+  (declare (ignore class))
+  (let ((class (%event-class location)))
+    (make-instance class :location location)))
 
 
 ;;;;
@@ -88,13 +82,14 @@ (defclass timed-event (event)
     :accessor event-time
     :initarg :time
     :type (unsigned 32)))
-  (:metaclass proxy-class))
+  (:metaclass event-class))
   
 (defclass delete-event (event)
   ()
   (:metaclass event-class)
   (:type :delete))
 
+
 (defclass destroy-event (event)
   ()
   (:metaclass event-class)
index a08da2e..bbc2f96 100644 (file)
 ;; 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: gdktypes.lisp,v 1.7 2002-03-19 19:06:22 espen Exp $
+;; $Id: gdktypes.lisp,v 1.8 2004-11-06 21:39:58 espen Exp $
 
 (in-package "GDK")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (init-types-in-library "libgdk-x11-2.0.so")
-  (init-types-in-library "libgdk_pixbuf-2.0.so"))
+  (init-types-in-library #.(concatenate 'string
+                           (pkg-config:pkg-variable "gtk+-2.0" "libdir")
+                           "/libgdk-x11-2.0.so") :prefix "gdk_")
+  (init-types-in-library #.(concatenate 'string
+                           (pkg-config:pkg-variable "gtk+-2.0" "libdir")
+                           "/libgdk-x11-2.0.so") :prefix "_gdk_")
+  (init-types-in-library #.(concatenate 'string
+                           (pkg-config:pkg-variable "gtk+-2.0" "libdir")
+                           "/libgdk_pixbuf-2.0.so") :prefix "gdk_"))
+
 
 (defclass color (boxed)
   ((pixel
@@ -63,11 +71,8 @@ (defclass cursor (struct)
     :accessor cursor-type
     :initarg :type
     :type cursor-type))
-  (:metaclass proxy-class)
-  (:copy %cursor-copy)
-  (:free %cursor-free))
+  (:metaclass struct-class))
 
 (defclass device (struct)
   ()
-  (:metaclass proxy-class))
-
+  (:metaclass struct-class))
index 7d3ecde..6fb1e46 100644 (file)
 ;; 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: defpackage.lisp,v 1.1 2004-10-27 14:48:00 espen Exp $
+;; $Id: defpackage.lisp,v 1.2 2004-11-06 21:39:58 espen Exp $
 
 ;(export 'kernel::type-expand-1 "KERNEL")
 
 (defpackage "GLIB"
-  (:use "ALIEN" "C-CALL" "SYSTEM" "COMMON-LISP" "PCL" "AUTOEXPORT"
-       "GLIB-SYSTEM")
-  (;:shadowing-
-   :import-from "PCL"
+  (:use "ALIEN" "SYSTEM" "COMMON-LISP" "PCL" "AUTOEXPORT")
+  (:import-from "PCL"
           "LOCATION" "ALLOCATION" "DIRECT-SLOTS" 
           "READER-FUNCTION" "WRITER-FUNCTION" "BOUNDP-FUNCTION" 
           "INITIALIZE-INTERNAL-SLOT-FUNCTIONS" "COMPUTE-SLOT-ACCESSOR-INFO"
           "COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS"
-          #:initialize-internal-slot-gfs)
- ; (:import-from "KERNEL" "TYPE-EXPAND-1")
-  (:export #:load-shared-library)
+          "INITIALIZE-INTERNAL-SLOT-GFS")
   (:export "DEFTYPE-METHOD" "TRANSLATE-TYPE-SPEC" "TRANSLATE-TO-ALIEN"
           "TRANSLATE-FROM-ALIEN" "CLEANUP-ALIEN" "UNREFERENCE-ALIEN"
           "SIZE-OF")
index 6fe93a5..0391858 100644 (file)
 ;; 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: ffi.lisp,v 1.1 2004-10-27 14:46:01 espen Exp $
+;; $Id: ffi.lisp,v 1.2 2004-11-06 21:39:58 espen Exp $
 
 (in-package "GLIB")
 
-;;;; Type methods
-
-(defvar *type-methods* (make-hash-table))
-
-(defun ensure-type-method-fun (fname)
-  (unless (fboundp fname)
-    (setf
-     (symbol-function fname)
-     #'(lambda (type-spec &rest args)
-        (apply
-         (find-applicable-type-method type-spec fname) type-spec args)))))
-
-(defmacro define-type-method-fun (fname lambda-list)
-  (declare (ignore lambda-list))
-  `(defun ,fname (type-spec &rest args)
-     (apply
-      (find-applicable-type-method type-spec ',fname) type-spec args)))
-
-
-(defun ensure-type-name (type)
-  (etypecase type
-    (symbol type)
-    (pcl::class (class-name type))))
-
-(defun add-type-method (type fname function)
-  (push
-   (cons fname function)
-   (gethash (ensure-type-name type) *type-methods*)))
-
-(defun find-type-method (type fname)
-  (cdr (assoc fname (gethash (ensure-type-name type) *type-methods*))))
-
-(defun find-applicable-type-method (type-spec fname &optional (error t))
-  (flet ((find-superclass-method (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)
-          (multiple-value-bind (expanded-type-spec expanded-p)
-              (type-expand-1 type-spec)
-            (cond
-             (expanded-p 
-              (find-applicable-type-method expanded-type-spec fname nil))
-             ((neq type-spec t)
-              (find-applicable-type-method t fname nil))))))
-
-    (or
-     (typecase type-spec
-       (pcl::class
-       (or
-        (find-type-method type-spec fname)
-        (find-superclass-method type-spec)))
-       (symbol
-       (or
-        (find-type-method type-spec fname)
-        (find-expanded-type-method type-spec)
-        (find-superclass-method (find-class type-spec nil))))
-       (cons
-       (or
-        (find-type-method (first type-spec) fname)
-        (find-expanded-type-method type-spec)))
-       (t
-       (error "Invalid type specifier ~A" type-spec)))
-     (and
-      error
-      (error
-       "No applicable method for ~A when called with type specifier ~A"
-       fname type-spec)))))
-
-(defmacro deftype-method (fname type lambda-list &body body)
-  `(progn
-     (ensure-type-method-fun ',fname)
-     (add-type-method ',type ',fname #'(lambda ,lambda-list ,@body))
-     ',fname))
-  
-;; 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 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)))
-
-
-;;;; 
-
-(defvar *type-function-cache* (make-hash-table :test #'equal))
-
-(defun get-cached-function (type-spec fname)
-  (cdr (assoc fname (gethash type-spec *type-function-cache*))))
-
-(defun set-cached-function (type-spec fname function)
-  (push (cons fname function) (gethash type-spec *type-function-cache*))
-  function)
-  
-
-(defun intern-argument-translator (type-spec)
-  (or
-   (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 t))))))
-
-(defun intern-return-value-translator (type-spec)
-  (or
-   (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 nil))))))
-
-(defun intern-cleanup-function (type-spec)
-  (or
-   (get-cached-function type-spec 'cleanup-function)
-   (set-cached-function type-spec 'cleanup-function
-    (compile
-     nil
-     `(lambda (alien)
-       (declare (ignorable alien))
-       ,(cleanup-alien type-spec 'alien t))))))
-
-
-
-;; 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
-    (compile
-     nil
-     `(lambda (value sap offset)
-       (declare (ignorable value sap offset))
-       (setf
-        (,(sap-ref-fname type-spec) sap offset)
-        ,(translate-to-alien type-spec 'value nil)))))))
-
-;; 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
-    (compile
-     nil
-     `(lambda (sap offset)      
-       (declare (ignorable sap offset))
-       ,(translate-from-alien
-         type-spec `(,(sap-ref-fname type-spec) sap offset) t))))))
-
-(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
+;; 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-sap+ 4)
+(defconstant +size-of-pointer+ 4)
 (defconstant +size-of-float+ 4)
 (defconstant +size-of-double+ 8)
 
-(defun sap-ref-unsigned (sap offset)
-  (sap-ref-32 sap offset))
-
-(defun sap-ref-signed (sap offset)
-  (signed-sap-ref-32 sap offset))
-
-(defun sap-ref-fname (type-spec)
-  (let ((alien-type-spec (mklist (translate-type-spec type-spec))))
-    (ecase (first alien-type-spec)
-      (unsigned
-       (ecase (second alien-type-spec)
-        (8 'sap-ref-8)
-        (16 'sap-ref-16)
-        (32 'sap-ref-32)
-        (64 'sap-ref-64)))
-      (signed
-       (ecase (second alien-type-spec)
-        (8 'signed-sap-ref-8)
-        (16 'signed-sap-ref-16)
-        (32 'signed-sap-ref-32)
-        (64 'signed-sap-ref-64)))
-      (system-area-pointer 'sap-ref-sap)
-      (single-float 'sap-ref-single)
-      (double-float 'sap-ref-double))))
+;; 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)
+
+
 
 
 ;;;; Foreign function call interface
@@ -288,7 +94,7 @@ (defun default-type-name (alien-name)
       (rest parts) #\-) (find-prefix-package (first parts)))))
     
         
-(defmacro defbinding (name lambda-list return-type-spec &rest docs/args)
+(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))
@@ -309,21 +115,24 @@ (defmacro defbinding (name lambda-list return-type-spec &rest docs/args)
                     (namep expr) (member style '(:in :in-out)))
                (push expr lambda-list))
              (push
-              (list (if (namep expr) (make-symbol (string expr)) (gensym)) expr type style) args)))))
+              (list (if (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-spec (reverse docs) (reverse args)))))
+       return-type (reverse docs) (reverse args)))))
 
 #+cmu
-(defun %defbinding (foreign-name lisp-name lambda-list
-                   return-type-spec docs args)
-  (ext:collect ((alien-types) (alien-bindings) (alien-parameters)
-               (alien-values) (alien-deallocators))
+(defun %defbinding (foreign-name lisp-name lambda-list return-type docs args)
+  (ext:collect ((alien-types) (alien-bindings) (alien-parameters) 
+               (alien-values) (cleanup-forms))
     (dolist (arg args)
-      (destructuring-bind (var expr type-spec style) arg
-       (let ((declaration (translate-type-spec type-spec))
-             (deallocation (cleanup-alien type-spec var t)))
+      (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))
@@ -331,17 +140,17 @@ (defun %defbinding (foreign-name lisp-name lambda-list
            (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
+                  (list (to-alien-form expr type)))))
+           (alien-values (from-alien-form var type)))
+         (cleanup
           (alien-types declaration)
           (alien-bindings
-           `(,var ,declaration ,(translate-to-alien type-spec expr t)))
+           `(,var ,declaration ,(to-alien-form expr type)))
           (alien-parameters var)
-          (alien-deallocators deallocation))
+          (cleanup-forms cleanup))
          (t
           (alien-types declaration)
-          (alien-parameters (translate-to-alien type-spec expr t)))))))
+          (alien-parameters (to-alien-form expr type)))))))
 
     (let* ((alien-name (make-symbol (string lisp-name)))
           (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters))))
@@ -350,413 +159,525 @@ (defun %defbinding (foreign-name lisp-name lambda-list
         (declare (optimize (ext:inhibit-warnings 3)))
         (with-alien ((,alien-name
                       (function
-                       ,(translate-type-spec return-type-spec)
+                       ,(alien-type return-type)
                        ,@(alien-types))
                       :extern ,foreign-name)
                      ,@(alien-bindings))
-          ,(if return-type-spec
-               `(let ((result
-                       ,(translate-from-alien return-type-spec alien-funcall nil)))
-                  ,@(alien-deallocators)
-                  (values result ,@(alien-values)))
+          ,(if return-type
+               `(values
+                 (unwind-protect 
+                     ,(from-alien-form alien-funcall return-type)
+                   ,@(cleanup-forms))
+                 ,@(alien-values))
              `(progn
-                ,alien-funcall
-                ,@(alien-deallocators)
-                (values ,@(alien-values)))))))))
+               (unwind-protect 
+                    ,alien-funcall
+                 ,@(cleanup-forms))
+               (values ,@(alien-values)))))))))
 
 
+;;; Creates bindings at runtime
 (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))))
+  (declare (optimize (ext:inhibit-warnings 3)))
+  (let* ((ftype 
+         `(function ,@(mapcar #'alien-type (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 :flavor :code))))
-        (translate-arguments
-         (mapcar #'intern-argument-translator arg-types))
-        (translate-return-value (intern-return-value-translator return-type))
-        (cleanup-arguments (mapcar #'intern-cleanup-function arg-types)))
-        
+        (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:alien-funcall alien args))
+           (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 nil))
-      #'(lambda (&rest args)
-         (cond
-          (binding (apply binding args))
-          ((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)))))))))
-
   
 
 ;;;; 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))
-(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 sap &optional weak-ref)
-  (declare (ignore type-spec sap weak-ref))
-  nil)
-
-
-(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 weak-ref)
-  (declare (ignore type-spec weak-ref))
-  number)
-
-
-(deftype-method translate-type-spec fixnum (type-spec)
-  (declare (ignore type-spec))
-  (translate-type-spec 'signed))
-
-(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 weak-ref)
-  (declare (ignore type-spec weak-ref))
-  number)
-
-
-(deftype-method translate-type-spec long (type-spec)
-  (declare (ignore type-spec))
-  `(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 ,(* +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+)
-
+(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)))))
+    
 
-(deftype-method translate-type-spec short (type-spec)
-  (declare (ignore type-spec))
-  `(signed ,(* +bits-per-unit+ +size-of-short+)))
+(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.")
 
-(deftype-method size-of short (type-spec)
-  (declare (ignore type-spec))
-  +size-of-short+)
+(def-type-method to-alien-function ())
+(def-type-method from-alien-function ())
+(def-type-method cleanup-function ())
 
+(def-type-method writer-function ())
+(def-type-method reader-function ())
+(def-type-method destroy-function ())
 
-(deftype-method translate-type-spec unsigned-short (type-spec)
-  (declare (ignore type-spec))
-  `(unsigned ,(* +bits-per-unit+ +size-of-short+)))
 
-(deftype-method size-of unsigned-short (type-spec)
-  (declare (ignore type-spec))
-  +size-of-short+)
+(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)
 
 
-(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)))))
+(defmethod to-alien-form (form (type t) &rest args)
+  (declare (ignore type args))
+  form)
 
-(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+)))))
+(defmethod to-alien-function ((type t) &rest args)
+  (declare (ignore type args))
+  #'identity)
 
-(deftype-method translate-to-alien signed-byte (type-spec number &optional weak-ref)
-  (declare (ignore type-spec weak-ref))
-  number)
+(defmethod from-alien-form (form (type t) &rest args)
+  (declare (ignore type args))
+  form)
 
-(deftype-method translate-from-alien signed-byte
-    (type-spec number &optional weak-ref)
-  (declare (ignore type-spec weak-ref))
-  number)
+(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 offset)
+      (declare (ignore location offset))))
+
+
+(defmethod alien-type ((type (eql 'signed-byte)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (&optional (size '*)) args
+    (ecase size
+      (#.+bits-of-byte+ '(signed-byte 8))
+      (#.+bits-of-short+ 'c-call:short)
+      ((* #.+bits-of-int+) 'c-call:int)
+      (#.+bits-of-long+ 'c-call: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 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)) 
+              (signed-sap-ref-8 sap offset)))
+       (16 #'(lambda (sap &optional (offset 0)) 
+               (signed-sap-ref-16 sap offset)))
+       (32 #'(lambda (sap &optional (offset 0)) 
+               (signed-sap-ref-32 sap offset)))
+       (64 #'(lambda (sap &optional (offset 0))
+               (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+ '(unsigned-byte 8))
+      (#.+bits-of-short+ 'c-call:unsigned-short)
+      ((* #.+bits-of-int+) 'c-call:unsigned-int)
+      (#.+bits-of-long+ 'c-call: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)) 
+              (sap-ref-8 sap offset)))
+       (16 #'(lambda (sap &optional (offset 0)) 
+               (sap-ref-16 sap offset)))
+       (32 #'(lambda (sap &optional (offset 0)) 
+               (sap-ref-32 sap offset)))
+       (64 #'(lambda (sap &optional (offset 0))
+               (sap-ref-64 sap offset)))))))
+  
+  
+(defmethod alien-type ((type (eql 'integer)) &rest args)
+  (declare (ignore type args))
+  (alien-type 'signed-byte))
 
-(deftype-method translate-type-spec unsigned-byte (type-spec)
-  (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec)))))
-    `(signed
-      ,(cond
-       ((member size '(nil *)) (* +bits-per-unit+ +size-of-int+))
-       (t size)))))
+(defmethod size-of ((type (eql 'integer)) &rest args)
+  (declare (ignore type args))
+  (size-of 'signed-byte))
 
-(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)
+(defmethod alien-type ((type (eql 'fixnum)) &rest args)
+  (declare (ignore type args))
+  (alien-type 'signed-byte))
 
-(deftype-method translate-from-alien unsigned-byte
-    (type-spec number &optional weak-ref)
-  (declare (ignore type-spec weak-ref))
-  number)
+(defmethod size-of ((type (eql 'fixnum)) &rest args)
+  (declare (ignore type args))
+  (size-of 'signed-byte))
 
 
-(deftype-method translate-type-spec single-float (type-spec)
-  (declare (ignore type-spec))
-  'single-float)
+(defmethod alien-type ((type (eql 'single-float)) &rest args)
+  (declare (ignore type args))
+  'alien:single-float)
 
-(deftype-method size-of single-float (type-spec)
-  (declare (ignore type-spec))
+(defmethod size-of ((type (eql 'single-float)) &rest args)
+  (declare (ignore type args))
   +size-of-float+)
 
-(deftype-method translate-to-alien single-float (type-spec number &optional weak-ref)
-  (declare (ignore type-spec weak-ref))
-  number)
+(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)))))
 
-(deftype-method translate-from-alien single-float
-    (type-spec number &optional weak-ref)
-  (declare (ignore type-spec weak-ref))
-  number)
+(defmethod reader-function ((type (eql 'single-float)) &rest args)
+  (declare (ignore type args))
+  #'(lambda (sap &optional (offset 0)) 
+      (sap-ref-single sap offset)))
 
 
-(deftype-method translate-type-spec double-float (type-spec)
-  (declare (ignore type-spec))
-  'double-float)
+(defmethod alien-type ((type (eql 'double-float)) &rest args)
+  (declare (ignore type args))
+  'alien:double-float)
 
-(deftype-method size-of double-float (type-spec)
-  (declare (ignore type-spec))
-  +size-of-double+)
+(defmethod size-of ((type (eql 'double-float)) &rest args)
+  (declare (ignore type args))
+  +size-of-float+)
 
-(deftype-method translate-to-alien double-float (type-spec number &optional weak-ref)
-  (declare (ignore type-spec weak-ref))
-  `(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))))
 
-(deftype-method translate-from-alien double-float
-    (type-spec number &optional weak-ref)
-  (declare (ignore type-spec weak-ref))
-  number)
+(defmethod reader-function ((type (eql 'double-float)) &rest args)
+  (declare (ignore type args))
+  #'(lambda (sap &optional (offset 0)) 
+      (sap-ref-double sap offset)))
 
 
-(deftype-method translate-type-spec base-char (type-spec)
-  (declare (ignore type-spec))
-  `(unsigned ,+bits-per-unit+))
+(defmethod alien-type ((type (eql 'base-char)) &rest args)
+  (declare (ignore type args))
+  'c-call:char)
 
-(deftype-method size-of base-char (type-spec)
-  (declare (ignore type-spec))
+(defmethod size-of ((type (eql 'base-char)) &rest args)
+  (declare (ignore type args))
   1)
 
-(deftype-method translate-to-alien base-char (type-spec char &optional weak-ref)
-  (declare (ignore type-spec weak-ref))
-  `(char-code ,char))
+(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))))
 
-(deftype-method translate-from-alien base-char (type-spec code &optional weak-ref)
-  (declare (ignore type-spec weak-ref))
-  `(code-char ,code))
+(defmethod reader-function ((type (eql 'base-char)) &rest args)
+  (declare (ignore type args))
+  #'(lambda (location &optional (offset 0))
+      (code-char (sap-ref-8 location offset))))
 
 
-(deftype-method translate-type-spec string (type-spec)
-  (declare (ignore type-spec))
-  'system-area-pointer)
+(defmethod alien-type ((type (eql 'string)) &rest args)
+  (declare (ignore type args))
+  (alien-type 'pointer))
 
-(deftype-method size-of string (type-spec)
-  (declare (ignore type-spec))
-  +size-of-sap+)
+(defmethod size-of ((type (eql 'string)) &rest args)
+  (declare (ignore type args))
+  (size-of 'pointer))
 
-(deftype-method translate-to-alien string (type-spec string &optional weak-ref)
-  (declare (ignore type-spec weak-ref))
+(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
      (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 ((c-string ,c-string))
-     (unless (null-pointer-p c-string)
-       (prog1
-          (c-call::%naturalize-c-string c-string)
-        ;,(unless weak-ref `(deallocate-memory c-string))
-        ))))
-
-(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))))
-
-
-;;; Pathname
-
-(deftype-method translate-type-spec pathname (type-spec)
-  (declare (ignore type-spec))
-  (translate-type-spec 'string))
-
-(deftype-method size-of pathname (type-spec)
-  (declare (ignore type-spec))
-  (size-of 'string))
-
-(deftype-method translate-to-alien pathname (type-spec path &optional weak-ref)
-  (declare (ignore type-spec))
-  (translate-to-alien 'string 
-   `(namestring (translate-logical-pathname ,path)) weak-ref))
-
-(deftype-method translate-from-alien pathname (type-spec c-string &optional weak-ref)
-  (declare (ignore type-spec))
-  `(parse-namestring ,(translate-from-alien 'string c-string weak-ref)))
-
-(deftype-method cleanup-alien pathname (type-spec c-string &optional weak-ref)
-  (declare (ignore type-spec))
-  (cleanup-alien 'string c-string weak-ref))
-
-(deftype-method unreference-alien pathname (type-spec c-string)
-  (declare (ignore type-spec))
-  (unreference-alien 'string c-string))
   
+(defmethod to-alien-function ((type (eql 'string)) &rest args)
+  (declare (ignore type args))
+  #'(lambda (string)
+      (copy-memory
+       (make-pointer (1+ (kernel:get-lisp-obj-address string)))
+       (1+ (length string)))))
+
+(defmethod from-alien-form (string (type (eql 'string)) &rest args)
+  (declare (ignore type args))
+  `(let ((string ,string))
+    (unless (null-pointer-p string)
+      (c-call::%naturalize-c-string string))))
 
-(deftype-method translate-type-spec boolean (type-spec)
-  (translate-type-spec
-   (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec))))))
+(defmethod from-alien-function ((type (eql 'string)) &rest args)
+  (declare (ignore type args))
+  #'(lambda (string)
+      (unless (null-pointer-p string)
+       (c-call::%naturalize-c-string string))))
 
-(deftype-method size-of boolean (type-spec)
-  (size-of
-   (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec))))))
+(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)
+  #'(lambda (string)
+      (unless (null-pointer-p string)
+       (deallocate-memory 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)
+       (copy-memory
+       (make-pointer (1+ (kernel:get-lisp-obj-address string)))
+       (1+ (length string))))))
+
+(defmethod reader-function ((type (eql 'string)) &rest args)
+  (declare (ignore type args))
+  #'(lambda (location &optional (offset 0))
+      (unless (null-pointer-p (sap-ref-sap location offset))
+       (c-call::%naturalize-c-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 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))
 
-(deftype-method translate-to-alien boolean (type-spec boolean &optional weak-ref)
-  (declare (ignore type-spec weak-ref))
+(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))
+      (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 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))
 
-(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)
-  (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)))
+(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))
+      (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))
 
-(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))
-    `(let ((value ,expr))
-       (etypecase value
-        ,@(map
-           'list
-             #'(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))
+(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)
 
-(deftype-method size-of system-area-pointer (type-spec)
-  (declare (ignore type-spec))
-  +size-of-sap+)
+(defmethod size-of ((type (eql 'system-area-pointer)) &rest args)
+  (declare (ignore type args))
+  +size-of-pointer+)
 
-(deftype-method translate-to-alien system-area-pointer (type-spec sap &optional weak-ref)
-  (declare (ignore type-spec weak-ref))
-  sap)
+(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)))
 
-(deftype-method translate-from-alien system-area-pointer
-    (type-spec sap &optional weak-ref)
-  (declare (ignore type-spec weak-ref))
-  sap)
+(defmethod reader-function ((type (eql 'system-area-pointer)) &rest args)
+  (declare (ignore type args))
+  #'(lambda (location &optional (offset 0))
+      (sap-ref-sap location offset)))
 
 
-(deftype-method translate-type-spec null (type-spec)
-  (declare (ignore type-spec))
-  'system-area-pointer)
+(defmethod alien-type ((type (eql 'null)) &rest args)
+  (declare (ignore type args))
+  (alien-type 'pointer))
 
-(deftype-method translate-to-alien null (type-spec expr &optional weak-ref)
-  (declare (ignore type-spec expr weak-ref))
+(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)))
 
-(deftype-method translate-type-spec nil (type-spec)
-  (declare (ignore type-spec))
-  'void)
 
-(deftype-method translate-from-alien nil (type-spec expr &optional weak-ref)
-  (declare (ignore type-spec weak-ref))
-  `(progn
-     ,expr
-     (values)))
+(defmethod alien-type ((type (eql 'nil)) &rest args)
+  (declare (ignore type args))
+  'c-call:void)
+
+(defmethod from-alien-function ((type (eql 'nil)) &rest args)
+  (declare (ignore type args))
+  #'(lambda (value)
+      (declare (ignore value))
+      (values)))
index f3a6270..caf5fb4 100644 (file)
 ;; 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: gboxed.lisp,v 1.10 2004-10-27 14:58:59 espen Exp $
+;; $Id: gboxed.lisp,v 1.11 2004-11-06 21:39:58 espen Exp $
 
 (in-package "GLIB")
 
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (init-types-in-library "libgobject-2.0.so")
-  (defclass boxed (proxy)
-    ()
-    (:metaclass proxy-class)
-    (:copy %boxed-copy)
-    (:free %boxed-free)))
+  (init-types-in-library #.(concatenate 'string
+                         (pkg-config:pkg-variable "glib-2.0" "libdir")
+                         "/libgobject-2.0.so")))
 
-(defbinding %boxed-copy (type location) pointer
-  ((find-type-number type) type-number)
-  (location pointer))
-
-(defbinding %boxed-free (type location) nil
-  ((find-type-number type) type-number)
-  (location pointer))
+(defclass boxed (proxy)
+  ()
+  (:metaclass struct-class))
 
 
 ;;;; Metaclass for boxed classes
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass boxed-class (proxy-class)
+  (defclass boxed-class (struct-class)
     ())
 
+  (defmethod validate-superclass ((class boxed-class) (super standard-class))
+    (subtypep (class-name super) 'boxed)))
 
-  (defmethod shared-initialize ((class boxed-class) names
-                               &rest initargs &key name alien-name)
-    (declare (ignore initargs names))
-    (call-next-method)
-    
-    (let* ((class-name (or name (class-name class)))
-          (type-number
-           (find-type-number
-            (or (first alien-name) (default-alien-type-name class-name)))))
-      (register-type class-name type-number)))
 
+(defmethod shared-initialize ((class boxed-class) names
+                             &rest initargs &key name alien-name)
+  (declare (ignore initargs names))
+  (call-next-method)
+  
+  (let* ((class-name (or name (class-name class)))
+        (type-number
+         (find-type-number
+          (or (first alien-name) (default-alien-type-name class-name)))))
+    (register-type class-name type-number)))
 
-  (defmethod validate-superclass
-    ((class boxed-class) (super pcl::standard-class))
-    (subtypep (class-name super) 'boxed)))
+
+(defbinding %boxed-copy (type location) pointer
+  ((find-type-number type) type-number)
+  (location pointer))
+
+(defbinding %boxed-free (type location) nil
+  ((find-type-number type) type-number)
+  (location pointer))
+
+(defmethod reference-foreign ((class boxed-class) location)
+  (%boxed-copy (class-name class) location))
+
+(defmethod unreference-foreign ((class boxed-class) location)
+  (%boxed-free (class-name class) location))
 
 
 ;;;; 
@@ -73,31 +79,31 @@ (register-derivable-type 'boxed "GBoxed" 'expand-boxed-type)
 
 ;;;; Special boxed types
 
-(defclass gstring (boxed)
-  ()
-  (:metaclass boxed-class)
-  (:alien-name "GString"))
-
-(deftype-method translate-from-alien
-    gstring (type-spec location &optional weak-ref)
-  `(let ((location ,location))
-     (unless (null-pointer-p location)
-       (prog1
-          (c-call::%naturalize-c-string location)
-        ,(unless weak-ref
-           (unreference-alien type-spec location))))))
-
-(deftype-method translate-to-alien
-    gstring (type-spec string &optional weak-ref)
-  (declare (ignore weak-ref))
-  `(let ((string ,string))
-     ;; Always copy strings to prevent seg fault due to GC
-     (funcall
-      ',(proxy-class-copy (find-class type-spec))
-      ',type-spec
-      (make-pointer (1+ (kernel:get-lisp-obj-address string))))))
-
-(deftype-method cleanup-alien gstring (type-spec c-string &optional weak-ref)
-  (when weak-ref
-    (unreference-alien type-spec c-string)))
+;; (defclass gstring (boxed)
+;;   ()
+;;   (:metaclass boxed-class)
+;;   (:alien-name "GString"))
+
+;; (deftype-method translate-from-alien
+;;     gstring (type-spec location &optional weak-ref)
+;;   `(let ((location ,location))
+;;      (unless (null-pointer-p location)
+;;        (prog1
+;;        (c-call::%naturalize-c-string location)
+;;      ,(unless weak-ref
+;;         (unreference-alien type-spec location))))))
+
+;; (deftype-method translate-to-alien
+;;     gstring (type-spec string &optional weak-ref)
+;;   (declare (ignore weak-ref))
+;;   `(let ((string ,string))
+;;      ;; Always copy strings to prevent seg fault due to GC
+;;      (funcall
+;;       ',(proxy-class-copy (find-class type-spec))
+;;       ',type-spec
+;;       (make-pointer (1+ (kernel:get-lisp-obj-address string))))))
+
+;; (deftype-method cleanup-alien gstring (type-spec c-string &optional weak-ref)
+;;   (when weak-ref
+;;     (unreference-alien type-spec c-string)))
 
index ee11387..520d7a8 100644 (file)
@@ -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: gcallback.lisp,v 1.11 2004-11-01 00:08:49 espen Exp $
+;; $Id: gcallback.lisp,v 1.12 2004-11-06 21:39:58 espen Exp $
 
 (in-package "GLIB")
 
@@ -35,13 +35,16 @@ (defun register-callback-function (function)
   (check-type function (or null symbol function))
   (register-user-data function))
 
-(def-callback closure-callback-marshal
-    (void (gclosure system-area-pointer) (return-value system-area-pointer)
-         (n-params unsigned-int) (param-values system-area-pointer)
-         (invocation-hint system-area-pointer) (callback-id unsigned-int))
+(def-callback closure-callback-marshal (c-call:void 
+                                       (gclosure system-area-pointer) 
+                                       (return-value system-area-pointer)
+                                       (n-params c-call:unsigned-int) 
+                                       (param-values system-area-pointer)
+                                       (invocation-hint system-area-pointer) 
+                                       (callback-id c-call:unsigned-int))
   (callback-trampoline callback-id n-params param-values return-value))
 
-(def-callback %destroy-user-data (void (id unsigned-int))
+(def-callback %destroy-user-data (c-call:void (id c-call:unsigned-int))
   (destroy-user-data id)) 
  
 (defun make-callback-closure (function)
@@ -75,7 +78,7 @@ (defun invoke-callback (callback-id type &rest args)
 
 ;;;; Timeouts and idle functions
 
-(def-callback source-callback-marshal (void (callback-id unsigned-int))
+(def-callback source-callback-marshal (c-call:void (callback-id c-call:unsigned-int))
   (callback-trampoline callback-id 0 nil (make-pointer 0)))
 
 (defbinding (timeout-add "g_timeout_add_full")
@@ -172,8 +175,9 @@ (defmethod signal-connect ((gobject gobject) signal function &key after object)
 
 ;; TODO: define and signal conditions based on log-level
 ;(defun log-handler (domain log-level message)
-(def-callback log-handler (void (domain c-string) (log-level int) 
-                               (message c-string))
+(def-callback log-handler (c-call:void (domain c-call:c-string) 
+                                      (log-level c-call:int) 
+                                      (message c-call:c-string))
   (error "~A: ~A" domain message))
 
 (setf (extern-alien "log_handler" system-area-pointer) (callback log-handler))
index 8200826..4fb3c10 100644 (file)
 ;; 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: genums.lisp,v 1.3 2001-10-21 22:02:01 espen Exp $
+;; $Id: genums.lisp,v 1.4 2004-11-06 21:39:58 espen Exp $
 
 (in-package "GLIB")
 
 
-(defun %map-mappings (args op)
+(defun %map-enum (args op)
   (let ((current-value 0))
-    (map
-     'list 
+    (mapcar
      #'(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 value #|(ash 1 value)|#))
+            (:flags-int (list symbol value))
             (:int-enum (list value symbol))
-            (:int-flags (list value #|(ash 1 value)|# symbol))
+            (:int-flags (list value symbol))
             (:symbols symbol))))
-     (if (integerp (first args))
-        (rest args)
-       args))))
+     args)))
 
 (defun %query-enum-or-flags-values (query-function class type)
   (multiple-value-bind (sap length)
       (funcall query-function (type-class-ref type))
     (let ((values nil)
-         (size (proxy-class-size (find-class class)))
-         (proxy (make-proxy-instance class sap nil)))
+         (size (proxy-instance-size (find-class class)))
+         (proxy (make-instance class :location sap)))
       (dotimes (i length)
        (with-slots (location nickname value) proxy
          (setf location sap)
@@ -56,42 +53,63 @@ (defun %query-enum-or-flags-values (query-function class type)
       values)))
    
   
-;;;; Enum type
+;;;; Generic enum type
 
 (deftype enum (&rest args)
-  `(member ,@(%map-mappings args :symbols)))
-
-(deftype-method translate-type-spec enum (type-spec)
-  (let ((args (cdr (type-expand-to 'enum type-spec))))
-    (if (integerp (first args))
-       (translate-type-spec `(signed ,(first args)))
-      (translate-type-spec 'signed))))
-
-(deftype-method size-of enum (type-spec)
-  (let ((args (cdr (type-expand-to 'enum type-spec))))
-    (if (integerp (first args))
-       (size-of `(signed ,(first args)))
-      (size-of 'signed))))
-
-(deftype-method translate-to-alien enum (type-spec expr &optional weak-ref)
-  (declare (ignore weak-ref))
-  (let ((args (cdr (type-expand-to 'enum type-spec))))
-    `(ecase ,expr
-       ,@(%map-mappings args :enum-int))))
-
-(deftype-method translate-from-alien enum (type-spec expr &optional weak-ref)
-  (declare (ignore weak-ref))
-  (destructuring-bind (name &rest args) (type-expand-to 'enum type-spec)
-    (declare (ignore name))
-    `(ecase ,expr
-       ,@(%map-mappings args :int-enum))))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass %enum-value (static)
-    ((value :allocation :alien :type int)
-     (name :allocation :alien :type string)
-     (nickname :allocation :alien :type string))
-    (:metaclass proxy-class)))
+  `(member ,@(%map-enum args :symbols)))
+
+(defmethod alien-type ((type (eql 'enum)) &rest args)
+  (declare (ignore type args))
+  (alien-type 'signed))
+
+(defmethod size-of ((type (eql 'enum)) &rest args)
+  (declare (ignore type args))
+  (size-of 'signed))
+
+(defmethod to-alien-form (form (type (eql 'enum)) &rest args)
+  (declare (ignore type))
+  `(ecase ,form
+    ,@(%map-enum args :enum-int)))
+
+(defmethod from-alien-form (form (type (eql 'enum)) &rest args)
+  (declare (ignore type))
+  `(ecase ,form
+    ,@(%map-enum args :int-enum)))
+
+(defmethod to-alien-function ((type (eql 'enum)) &rest args)
+  (let ((mappings (%map-enum args :enum-int)))
+    #'(lambda (enum)
+       (or
+        (second (assoc enum mappings))
+        (error "~S is not of type ~S" enum (cons type args))))))
+
+(defmethod from-alien-function ((type (eql 'enum)) &rest args)
+  (declare (ignore type))
+  (let ((mappings (%map-enum args :int-enum)))
+    #'(lambda (int)
+       (second (assoc int mappings)))))
+
+(defmethod writer-function ((type (eql 'enum)) &rest args)
+  (declare (ignore type))
+  (let ((writer (writer-function 'signed))
+       (function (apply #'to-alien-function 'enum args)))
+    #'(lambda (enum location &optional (offset 0))
+       (funcall writer (funcall function enum) location offset))))
+    
+(defmethod reader-function ((type (eql 'enum)) &rest args)
+  (declare (ignore type))
+  (let ((reader (reader-function 'signed))
+       (function (apply #'from-alien-function 'enum args)))
+    #'(lambda (location &optional (offset 0))
+       (funcall function (funcall reader location offset)))))
+
+
+
+(defclass %enum-value (struct)
+  ((value :allocation :alien :type int)
+   (name :allocation :alien :type string)
+   (nickname :allocation :alien :type string))
+  (:metaclass static-struct-class))
 
 (defbinding %enum-class-values () pointer
   (class pointer)
@@ -102,56 +120,80 @@ (defun query-enum-values (type)
 
 
 
-;;;;  Flags type
+;;;;  Generic flags type
 
 (deftype flags (&rest args)
-  `(or
-    null
-    (cons
-     (member ,@(%map-mappings args :symbols))
-     list)))
-
-(deftype-method translate-type-spec flags (type-spec)
-  (let ((args (cdr (type-expand-to 'flags type-spec))))
-    (if (integerp (first args))
-       (translate-type-spec `(unsigned ,(first args)))
-      (translate-type-spec 'unsigned))))
-
-(deftype-method size-of flags (type-spec)
-  (let ((args (cdr (type-expand-to 'flags type-spec))))
-    (if (integerp (first args))
-       (size-of `(unsigned ,(first args)))
-      (size-of 'unsigned))))
-
-(deftype-method translate-to-alien flags (type-spec expr &optional weak-ref)
-  (declare (ignore weak-ref))
-  (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec)
-    (declare (ignore name))
-    (let ((mappings (%map-mappings args :flags-int))
-         (value (make-symbol "VALUE")))
-      `(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 weak-ref)
-  (declare (ignore weak-ref))
-  (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec)
-    (declare (ignore name))
-    (let ((mappings (%map-mappings args :int-flags))
-         (result (make-symbol "RESULT")))
-      `(let ((,result nil))
-        (dolist (mapping ',mappings ,result)
-          (unless (zerop (logand ,expr (first mapping)))
-            (push (second mapping) ,result)))))))
-
-
-
-;(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass %flags-value (static)
-    ((value :allocation :alien :type unsigned-int)
-     (name :allocation :alien :type string)
-     (nickname :allocation :alien :type string))
-    (:metaclass proxy-class));)
+  `(or null (cons (member ,@(%map-enum args :symbols)) list)))
+
+(defmethod alien-type ((type (eql 'flags)) &rest args)
+  (declare (ignore type args))
+  (alien-type 'unsigned))
+
+(defmethod size-of ((type (eql 'flags)) &rest args)
+  (declare (ignore type args))
+  (size-of 'unsigned))
+
+(defmethod to-alien-form (flags (type (eql 'flags)) &rest args)
+  `(loop
+    with value = 0
+    with flags = ,flags
+    for flag in (mklist flags)
+    do (let ((flagval
+             (or
+              (second (assoc flag ',(%map-enum args :flags-int)))
+              (error "~S is not of type ~S" flags '(,type ,@args)))))
+        (setq value (logior value flagval)))
+    finally (return value)))
+
+(defmethod from-alien-form (int (type (eql 'flags)) &rest args)
+  (declare (ignore type))
+  `(loop
+    for mapping in ',(%map-enum args :int-flags)
+    unless (zerop (logand int (first mapping)))
+    collect (second mapping)))
+
+(defmethod to-alien-function ((type (eql 'flags)) &rest args)
+  (let ((mappings (%map-enum args :flags-int)))
+    #'(lambda (flags)  
+       (loop
+        with value = 0
+        for flag in (mklist flags)
+        do (let ((flagval (or
+                   (second (assoc flag mappings))
+                   (error "~S is not of type ~S" flags (cons type args)))))
+             (setq value (logior value flagval)))
+        finally (return value)))))
+
+(defmethod from-alien-function ((type (eql 'flags)) &rest args)
+  (declare (ignore type))
+  (let ((mappings (%map-enum args :int-flags)))
+    #'(lambda (int)
+       (loop
+        for mapping in mappings
+        unless (zerop (logand int (first mapping)))
+        collect (second mapping)))))
+
+(defmethod writer-function ((type (eql 'flags)) &rest args)
+  (declare (ignore type))
+  (let ((writer (writer-function 'unsigned))
+       (function (apply #'to-alien-function 'flags args)))
+    #'(lambda (flags location &optional (offset 0))
+       (funcall writer (funcall function flags) location offset))))
+    
+(defmethod reader-function ((type (eql 'flags)) &rest args)
+  (declare (ignore type))
+  (let ((reader (reader-function 'unsigned))
+       (function (apply #'from-alien-function 'flags args)))
+    #'(lambda (location &optional (offset 0))
+       (funcall function (funcall reader location offset)))))
+
+
+
+(defclass %flags-value (struct)
+  ((value :allocation :alien :type unsigned-int)
+   (name :allocation :alien :type string)
+   (nickname :allocation :alien :type string))
+  (:metaclass static-struct-class))
 
 (defbinding %flags-class-values () pointer
   (class pointer)
index 47fc9a3..f0d3dcc 100644 (file)
@@ -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: ginterface.lisp,v 1.3 2004-10-31 00:56:29 espen Exp $
+;; $Id: ginterface.lisp,v 1.4 2004-11-06 21:39:58 espen Exp $
 
 (in-package "GLIB")
 
@@ -26,30 +26,10 @@ (use-prefix "g")
 (defclass ginterface ()
   ())
 
-(deftype-method translate-type-spec ginterface (type-spec)
-  (declare (ignore type-spec))
-  (translate-type-spec 'gobject))
-
-(deftype-method size-of ginterface (type-spec)
-  (declare (ignore type-spec))
-  (size-of 'gobject))
-
-(deftype-method translate-from-alien
-    ginterface (type-spec location &optional weak-ref)
-  (declare (ignore type-spec))
-  (translate-from-alien 'gobject location weak-ref))
-
-(deftype-method translate-to-alien
-    ginterface (type-spec instance &optional weak-ref)
-  (declare (ignore type-spec))
-  (translate-to-alien 'gobject instance weak-ref))
-
-
-
 ;;;; Metaclass for interfaces
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass ginterface-class (virtual-slot-class)
+  (defclass ginterface-class (virtual-slots-class)
     ()))
 
 (defmethod direct-slot-definition-class ((class ginterface-class) &rest initargs)
@@ -90,6 +70,31 @@ (defmethod validate-superclass
   (subtypep (class-name super) 'ginterface))
 
 
+(defmethod alien-type ((class ginterface-class) &rest args)
+  (declare (ignore class args))
+  (alien-type 'gobject))
+
+(defmethod size-of ((class ginterface-class) &rest args)
+  (declare (ignore class args))
+  (size-of 'gobject))
+
+(defmethod from-alien-form (location (class ginterface-class) &rest args)
+  (declare (ignore class args))
+  (from-alien-form location 'gobject))
+
+(defmethod from-alien-function ((class ginterface-class) &rest args)
+  (declare (ignore class args))
+  (from-alien-function 'gobject))
+
+(defmethod to-alien-form (instance (class ginterface-class) &rest args)
+  (declare (ignore class args))
+  (to-alien-form instance 'gobject))
+
+(defmethod to-alien-function ((class ginterface-class) &rest args)
+  (declare (ignore class args))
+  (to-alien-function 'gobject))
+
+
 ;;;;
 
 
index bc1d30e..c779bec 100644 (file)
@@ -3,8 +3,7 @@
 (asdf:oos 'asdf:load-op :clg-tools)
 
 (defpackage "GLIB-SYSTEM"
-  (:use "COMMON-LISP" "ASDF" "PKG-CONFIG")
-  (:export "*GTK-LIBRARY-PATH*"))
+  (:use "COMMON-LISP" "ASDF" "PKG-CONFIG"))
 
 (ext:unlock-all-packages)
 
@@ -19,9 +18,6 @@
 
 (defvar *cmucl-include-path* "/usr/lib/cmucl/include")
 
-;; TODO: remove this
-(defvar *gtk-library-path* (pkg-variable "gtk+-2.0" "libdir"))
-
 
 (defsystem glib
     :depends-on (clg-tools)
index f949d17..149d392 100644 (file)
@@ -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: glib.lisp,v 1.15 2004-11-01 00:08:49 espen Exp $
+;; $Id: glib.lisp,v 1.16 2004-11-06 21:39:58 espen Exp $
 
 
 (in-package "GLIB")
@@ -34,8 +34,8 @@ (defbinding (reallocate-memory "g_realloc") () pointer
 
 (defbinding (deallocate-memory "g_free") () nil
   (address pointer))
-;(defun deallocate-memory (address)
-;  (declare (ignore address)))
+;(defun deallocate-memory (address)
+;  (declare (ignore address)))
 
 (defun copy-memory (from length &optional (to (allocate-memory length)))
   (kernel:system-area-copy from 0 to 0 (* 8 length))
@@ -122,7 +122,9 @@ (defun remove-quark (quark)
 
 ;;;; Linked list (GList)
 
-(deftype glist (type) `(or (null (cons ,type list))))
+(deftype glist (type &key copy) 
+  (declare (ignore copy))
+  `(or (null (cons ,type list))))
 
 (defbinding (%glist-append-unsigned "g_list_append") () pointer
   (glist pointer)
@@ -136,70 +138,94 @@ (defbinding (%glist-append-sap "g_list_append") () pointer
   (glist pointer)
   (data pointer))
 
-(defmacro glist-append (glist value type-spec)
-  (ecase (first (mklist (translate-type-spec type-spec)))
-    (unsigned `(%glist-append-unsigned ,glist ,value))
-    (signed `(%glist-append-signed ,glist ,value))
-    (system-area-pointer `(%glist-append-sap ,glist ,value))))
-
-(defmacro glist-data (glist type-spec)
-  (ecase (first (mklist (translate-type-spec type-spec)))
-    (unsigned `(sap-ref-unsigned ,glist 0))
-    (signed `(sap-ref-signed ,glist 0))
-    (system-area-pointer `(sap-ref-sap ,glist 0))))
+(defun make-glist (type list)
+  (let ((new-element (ecase (alien-type type)
+                      (system-area-pointer #'%glist-append-sap)
+                      ((signed-byte c-call:short c-call:int c-call:long)
+                       #'%glist-append-signed)
+                      ((unsigned-byte c-call:unsigned-short 
+                        c-call:unsigned-int c-call:unsigned-long)
+                       #'%glist-append-unsigned)))
+       (to-alien (to-alien-function type)))
+    (loop
+     for element in list
+     as glist = (funcall new-element (or glist (make-pointer 0)) 
+                (funcall to-alien element))
+     finally (return glist))))
 
 (defun glist-next (glist)
   (unless (null-pointer-p glist)
-    (sap-ref-sap glist +size-of-sap+)))
+    (sap-ref-sap glist +size-of-pointer+)))
   
+;; Also used for gslists
+(defun map-glist (seqtype function glist element-type)
+  (let ((reader (reader-function element-type)))
+    (case seqtype 
+     ((nil)
+      (loop
+       as tmp = glist then (glist-next tmp)
+       until (null-pointer-p tmp)
+       do (funcall function (funcall reader tmp))))
+     (list
+      (loop
+       as tmp = glist then (glist-next tmp)
+       until (null-pointer-p tmp)
+       collect (funcall function (funcall reader tmp))))
+     (t
+      (coerce 
+       (loop
+       as tmp = glist then (glist-next tmp)
+       until (null-pointer-p tmp)
+       collect (funcall function (funcall reader tmp)))
+       seqtype)))))
+
 (defbinding (glist-free "g_list_free") () nil
   (glist pointer))
 
-(deftype-method translate-type-spec glist (type-spec)
-  (declare (ignore type-spec))
-  (translate-type-spec 'pointer))
 
-(deftype-method size-of glist (type-spec)
-  (declare (ignore type-spec))
+(defmethod alien-type ((type (eql 'glist)) &rest args)
+  (declare (ignore type args))
+  (alien-type 'pointer))
+
+(defmethod size-of ((type (eql 'glist)) &rest args)
+  (declare (ignore type args))
   (size-of 'pointer))
 
-(deftype-method translate-to-alien glist (type-spec list &optional weak-ref)
-  (declare (ignore weak-ref))
-  (let* ((element-type (second (type-expand-to 'glist type-spec)))
-        (element (translate-to-alien element-type 'element)))
-    `(let ((glist (make-pointer 0))) 
-       (dolist (element ,list glist)
-        (setq glist (glist-append glist ,element ,element-type))))))
-
-(deftype-method translate-from-alien
-    glist (type-spec glist &optional weak-ref)
-  (let ((element-type (second (type-expand-to 'glist type-spec))))
-    `(let ((glist ,glist)
-          (list nil))
-       (do ((tmp glist (glist-next tmp)))
-          ((null-pointer-p tmp))
-        (push
-         ,(translate-from-alien
-           element-type `(glist-data tmp ,element-type) weak-ref)
-         list))
-       ,(unless weak-ref
-         '(glist-free glist))
-       (nreverse list))))
-
-(deftype-method cleanup-alien glist (type-spec glist &optional weak-ref)
-  (when weak-ref
-    (unreference-alien type-spec glist)))
-
-(deftype-method unreference-alien glist (type-spec glist)
-  (let ((element-type (second (type-expand-to 'glist type-spec))))
+(defmethod to-alien-form (list (type (eql 'glist)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type) args    
+    `(make-glist ',element-type ,list)))
+
+(defmethod to-alien-function ((type (eql 'glist)) &rest args)
+  (declare (ignore type args))
+  (destructuring-bind (element-type) args    
+    #'(lambda (list)
+       (make-glist element-type list))))
+
+(defmethod from-alien-form (glist (type (eql 'glist)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type) args
     `(let ((glist ,glist))
-       (unless (null-pointer-p glist)
-        ,(unless (atomic-type-p element-type)
-           `(do ((tmp glist (glist-next tmp)))
-                ((null-pointer-p tmp))
-              ,(unreference-alien
-                element-type `(glist-data tmp ,element-type))))
-        (glist-free glist)))))
+      (unwind-protect
+          (map-glist 'list #'identity glist ',element-type)
+       (glist-free glist)))))
+
+(defmethod from-alien-function ((type (eql 'glist)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type) args
+    #'(lambda (glist)
+       (unwind-protect
+            (map-glist 'list #'identity glist element-type)
+         (glist-free glist)))))
+
+(defmethod cleanup-form (glist (type (eql 'glist)) &rest args)
+  (declare (ignore type args))
+  `(glist-free ,glist))
+
+(defmethod cleanup-function ((type (eql 'glist)) &rest args)
+  (declare (ignore type args))
+  #'glist-free)
+
 
 
 ;;;; Single linked list (GSList)
@@ -218,163 +244,151 @@ (defbinding (%gslist-prepend-sap "g_slist_prepend") () pointer
   (gslist pointer)
   (data pointer))
 
-(defmacro gslist-prepend (gslist value type-spec)
-  (ecase (first (mklist (translate-type-spec type-spec)))
-    (unsigned `(%gslist-prepend-unsigned ,gslist ,value))
-    (signed `(%gslist-prepend-signed ,gslist ,value))
-    (system-area-pointer `(%gslist-prepend-sap ,gslist ,value))))
-  
+(defun make-gslist (type list)
+  (let ((new-element (ecase (alien-type type)
+                      (system-area-pointer #'%gslist-prepend-sap)
+                      ((signed-byte c-call:short c-call:int c-call:long)
+                       #'%gslist-prepend-signed)
+                      ((unsigned-byte c-call:unsigned-short 
+                        c-call:unsigned-int c-call:unsigned-long)
+                       #'%gslist-prepend-unsigned)))
+       (to-alien (to-alien-function type)))
+    (loop
+     for element in (reverse list)
+     as gslist = (funcall new-element (or gslist (make-pointer 0)) 
+                 (funcall to-alien element))
+     finally (return gslist))))
+
 (defbinding (gslist-free "g_slist_free") () nil
   (gslist pointer))
 
-(deftype-method translate-type-spec gslist (type-spec)
-  (declare (ignore type-spec))
-  (translate-type-spec 'pointer))
 
-(deftype-method size-of gslist (type-spec)
-  (declare (ignore type-spec))
+(defmethod alien-type ((type (eql 'gslist)) &rest args)
+  (declare (ignore type args))
+  (alien-type 'pointer))
+
+(defmethod size-of ((type (eql 'gslist)) &rest args)
+  (declare (ignore type args))
   (size-of 'pointer))
 
-(deftype-method translate-to-alien gslist (type-spec list &optional weak-ref)
-  (declare (ignore weak-ref))
-  (let* ((element-type (second (type-expand-to 'gslist type-spec)))
-        (element (translate-to-alien element-type 'element)))
-    `(let ((gslist (make-pointer 0))) 
-       (dolist (element (reverse ,list) gslist)
-        (setq gslist (gslist-prepend gslist ,element ,element-type))))))
-
-(deftype-method translate-from-alien
-    gslist (type-spec gslist &optional weak-ref)
-  (let ((element-type (second (type-expand-to 'gslist type-spec))))
-    `(let ((gslist ,gslist)
-          (list nil))
-       (do ((tmp gslist (glist-next tmp)))
-          ((null-pointer-p tmp))
-        (push
-         ,(translate-from-alien
-           element-type `(glist-data tmp ,element-type) weak-ref)
-         list))
-       ,(unless weak-ref
-         '(gslist-free gslist))
-       (nreverse list))))
-
-(deftype-method cleanup-alien gslist (type-spec gslist &optional weak-ref)
-  (when weak-ref
-    (unreference-alien type-spec gslist)))
-
-(deftype-method unreference-alien gslist (type-spec gslist)
-  (let ((element-type (second (type-expand-to 'gslist type-spec))))
+(defmethod to-alien-form (list (type (eql 'gslist)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type) args    
+    `(make-sglist ',element-type ,list)))
+
+(defmethod to-alien-function ((type (eql 'gslist)) &rest args)
+  (declare (ignore type args))
+  (destructuring-bind (element-type) args    
+    #'(lambda (list)
+       (make-gslist element-type list))))
+
+(defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type) args
     `(let ((gslist ,gslist))
-       (unless (null-pointer-p gslist)
-        ,(unless (atomic-type-p element-type)
-           `(do ((tmp gslist (glist-next tmp)))
-                ((null-pointer-p tmp))
-              ,(unreference-alien
-                element-type `(glist-data tmp ,element-type))))
-        (gslist-free gslist)))))
+      (unwind-protect
+          (map-glist 'list #'identity gslist ',element-type)
+       (gslist-free gslist)))))
 
+(defmethod from-alien-function ((type (eql 'gslist)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type) args
+    #'(lambda (gslist)
+       (unwind-protect
+            (map-glist 'list #'identity gslist element-type)
+         (gslist-free gslist)))))
 
+(defmethod cleanup-form (list (type (eql 'gslist)) &rest args)
+  (declare (ignore type args))
+  `(gslist-free ,list))
 
-;;; Vector
+(defmethod cleanup-function ((type (eql 'gslist)) &rest args)
+  (declare (ignore type args))
+  #'gslist-free)
 
-(defvar *magic-end-of-array* (allocate-memory 1))
 
-(deftype-method translate-type-spec vector (type-spec)
-  (declare (ignore type-spec))
-  (translate-type-spec 'pointer))
 
-(deftype-method size-of vector (type-spec)
-  (declare (ignore type-spec))
-  (size-of 'pointer))
+;;; Vector
 
-(deftype-method translate-to-alien vector (type-spec vector &optional weak-ref)
-  (declare (ignore weak-ref))
-  (destructuring-bind (element-type &optional (length '*))
-      (cdr (type-expand-to 'vector type-spec))
-    (let* ((element-size (size-of element-type))
-          (size (cond
-                 ((not (eq length '*))
-                  (* element-size length))
-                 ((not (atomic-type-p element-type))
-                  `(* ,element-size (1+ (length vector))))
-                 (t
-                  `(* ,element-size (length vector))))))
-         
-      `(let ((vector ,vector))
-        (let ((c-vector (allocate-memory ,size)))
-          (dotimes (i ,(if (eq length '*) '(length vector) length))
-            (setf
-             (,(sap-ref-fname element-type) c-vector (* i ,element-size))
-             ,(translate-to-alien element-type '(aref vector i))))
-          ,(when (and
-                  (eq length '*)
-                  (not (atomic-type-p element-type)))
-             `(setf
-               (sap-ref-sap c-vector (* (length vector) ,element-size))
-               *magic-end-of-array*))
-          c-vector)))))
-
-(deftype-method translate-from-alien
-    vector (type-spec c-array &optional weak-ref)
-  (destructuring-bind (element-type &optional (length '*))
-      (cdr (type-expand-to 'vector type-spec))
-    (when (eq length '*)
-      (error "Can't use vectors of variable length as return type"))
-    (let ((element-size (size-of element-type)))
-      `(let ((c-array ,c-array)
-            (vector (make-array ,length :element-type ',element-type)))
-        (dotimes (i ,length)
-          (setf
-           (aref vector i)
-           ,(translate-from-alien
-             element-type
-             `(,(sap-ref-fname element-type) c-array (* i ,element-size))
-             weak-ref)))
-        ,(unless weak-ref
-           '(deallocate-memory c-vector))
-        vector))))
-        
-
-(deftype-method cleanup-alien vector (type-spec c-vector &optional weak-ref)
-  (when weak-ref
-    (unreference-alien type-spec c-vector)))
-
-(deftype-method unreference-alien vector (type-spec c-vector)
-  (destructuring-bind (element-type &optional (length '*))
-      (cdr (type-expand-to 'vector type-spec))
-    `(let ((c-vector ,c-vector))
-       (unless (null-pointer-p c-vector)
-        ,(unless (atomic-type-p element-type)
-           (let ((element-size (size-of element-type)))
-             (if (not (eq length '*))
-                 `(dotimes (i ,length)
-                    (unreference-alien
-                     element-type (sap-ref-sap c-vector (* i ,element-size))))
-               `(do ((offset 0 (+ offset ,element-size)))
-                     ((sap=
-                       (sap-ref-sap c-vector offset)
-                       *magic-end-of-array*))
-                    ,(unreference-alien
-                      element-type '(sap-ref-sap c-vector offset))))))
-        (deallocate-memory c-vector)))))
-
-
-(defun map-c-array (seqtype function location element-type length)
-  (let ((reader (intern-reader-function element-type))
-       (size (size-of element-type)))
+(defun make-c-vector (type length &optional content location)
+  (let* ((size-of-type (size-of type))
+        (location (or location (allocate-memory (* size-of-type length))))
+        (writer (writer-function type)))
+    (loop
+     for element across content
+     for i from 0 below length
+     as offset = 0 then (+ offset size-of-type)
+     do (funcall writer element location offset))
+    location))
+
+
+(defun map-c-vector (seqtype function location element-type length)
+  (let ((reader (reader-function element-type))
+       (size-of-element (size-of element-type)))
     (case seqtype 
      ((nil)
-      (dotimes (i length)
-       (funcall function (funcall reader location (* i size)))))
+      (loop
+       for i from 0 below length
+       as offset = 0 then (+ offset size-of-element)
+       do (funcall function (funcall reader location offset))))
      (list
-      (let ((list nil))
-       (dotimes (i length)
-         (push (funcall function (funcall reader location (* i size))) list))
-       (nreverse list)))
+      (loop
+       for i from 0 below length
+       as offset = 0 then (+ offset size-of-element)
+       collect (funcall function (funcall reader location offset))))
      (t
-      (let ((sequence (make-sequence seqtype length)))
-       (dotimes (i length)
-         (setf
+      (loop
+       with sequence = (make-sequence seqtype length)
+       for i from 0 below length
+       as offset = 0 then (+ offset size-of-element)
+       do (setf 
           (elt sequence i)
-          (funcall function (funcall reader location (* i size)))))
-       sequence)))))
+          (funcall function (funcall reader location offset)))
+       finally (return sequence))))))
+
+
+(defmethod alien-type ((type (eql 'vector)) &rest args)
+  (declare (ignore type args))
+  (alien-type 'pointer))
+
+(defmethod size-of ((type (eql 'vector)) &rest args)
+  (declare (ignore type args))
+  (size-of 'pointer))
+
+(defmethod to-alien-form (vector (type (eql 'vector)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type &optional (length '*)) args
+    (if (eq length '*)
+       `(let* ((vector ,vector)
+               (location (sap+
+                          (allocate-memory (+ ,+size-of-int+ 
+                                              (* ,(size-of element-type) 
+                                                 (length vector))))
+                          ,+size-of-int+)))
+         (make-c-vector ',element-type (length vector) vector location)
+         (setf (sap-ref-32 location ,(- +size-of-int+)) (length vector))
+         location)       
+      `(make-c-vector ',element-type ,length ,vector))))
+
+(defmethod from-alien-form (location (type (eql 'vector)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type &optional (length '*)) args
+    (if (eq length '*)
+       (error "Can't use vector of variable size as return type")
+      `(map-c-vector 'vector #'identity ',element-type ',length ,location))))
+
+(defmethod cleanup-form (location (type (eql 'vector)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (element-type &optional (length '*)) args
+    `(let* ((location ,location)
+           (length ,(if (eq length '*)
+                        `(sap-ref-32 location ,(- +size-of-int+))
+                        length)))
+      (loop
+       with destroy = (destroy-function ',element-type)
+       for i from 0 below length
+       as offset = 0 then (+ offset ,(size-of element-type))
+       do (funcall destroy location offset))
+      (deallocate-memory ,(if (eq length '*) 
+                             `(sap+ location  ,(- +size-of-int+))
+                           'location)))))
index 1ecc1b4..620b7ba 100644 (file)
@@ -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: gobject.lisp,v 1.16 2004-11-03 16:18:16 espen Exp $
+;; $Id: gobject.lisp,v 1.17 2004-11-06 21:39:58 espen Exp $
 
 (in-package "GLIB")
 
@@ -24,84 +24,90 @@ (eval-when (:compile-toplevel :load-toplevel :execute)
   (defclass gobject (ginstance)
     ()
     (:metaclass ginstance-class)
-    (:alien-name "GObject")
-    (:copy %object-ref)
-    (:free %object-unref)))
+    (:alien-name "GObject")))
+
+(defmethod print-object ((instance gobject) stream)
+  (print-unreadable-object (instance stream :type t :identity nil)
+    (if (slot-boundp instance 'location)
+       (format stream "at 0x~X" (sap-int (proxy-location instance)))
+      (write-string "(destroyed)" stream))))
 
 
 (defmethod initialize-instance ((object gobject) &rest initargs)
-  (let ((slotds (class-slots (class-of object)))
-       (names (make-array 0 :adjustable t :fill-pointer t))
-       (values (make-array 0 :adjustable t :fill-pointer t)))
-
-    (loop 
-     as tmp = initargs then (cddr tmp) while tmp
-     as key = (first tmp)
-     as value = (second tmp)
-     as slotd = (find-if
-                #'(lambda (slotd)
-                    (member key (slot-definition-initargs slotd)))
-                slotds)
-     when (and (typep slotd 'effective-property-slot-definition)
-              (slot-value slotd 'construct))
-     do (let ((type (find-type-number (slot-definition-type slotd))))
-         (vector-push-extend (slot-definition-pname slotd) names)
-         (vector-push-extend (gvalue-new type value) values)
-         (remf initargs key)))
-
-    (setf  
-     (slot-value object 'location) 
-     (if (zerop (length names))
-        (%gobject-new (type-number-of object))
-       (%gobject-newvv (type-number-of object) (length names) names values)))
-    
-;    (map 'nil #'gvalue-free values)
-    )
+  ;; Extract initargs which we should pass directly to the GObeject
+  ;; constructor
+  (let* ((slotds (class-slots (class-of object)))
+        (args (loop 
+               as tmp = initargs then (cddr tmp) while tmp
+               as key = (first tmp)
+               as value = (second tmp)
+               as slotd = (find-if
+                           #'(lambda (slotd)
+                               (member key (slot-definition-initargs slotd)))
+                           slotds)
+               when (and (typep slotd 'effective-property-slot-definition)
+                         (slot-value slotd 'construct))
+               collect (progn 
+                         (remf initargs key)
+                         (list 
+                          (slot-definition-pname slotd)
+                          (slot-definition-type slotd)
+                          value)))))
+    (if args
+       (let* ((string-size (size-of 'string))
+              (string-writer (writer-function 'string))
+              (string-destroy (destroy-function 'string))
+              (params (allocate-memory 
+                       (* (length args) (+ string-size +gvalue-size+)))))
+         (loop
+          for (pname type value) in args
+          as tmp = params then (sap+ tmp (+ string-size +gvalue-size+))
+          do (funcall string-writer pname tmp)
+             (gvalue-init (sap+ tmp string-size) type value))
+         (unwind-protect
+              (setf  
+               (slot-value object 'location) 
+               (%gobject-newv (type-number-of object) (length args) params))
+           (loop
+            repeat (length args)
+            as tmp = params then (sap+ tmp (+ string-size +gvalue-size+))
+            do (funcall string-destroy tmp)
+               (gvalue-unset (sap+ tmp string-size)))
+           (deallocate-memory params)))
+      (setf  
+       (slot-value object 'location) 
+       (%gobject-new (type-number-of object)))))
   
   (%object-weak-ref object)
   (apply #'call-next-method object initargs))
 
 
-(defmethod initialize-proxy ((object gobject) &rest initargs &key weak-ref)
+(defmethod initialize-instance :around ((object gobject) &rest initargs)
   (declare (ignore initargs))
   (call-next-method)
-  (%object-weak-ref object)
-  (unless weak-ref
-    (object-ref object)))
+  (%object-weak-ref object))
 
-(def-callback weak-notify (void (data int) (location system-area-pointer))
-  (when (instance-cached-p location)
-    (warn "~A being finalized by the GObject system while still in existence in lisp" (find-cached-instance location))
-    (remove-cached-instance location)))
+
+(def-callback weak-notify (c-call:void (data c-call:int) (location system-area-pointer))
+  (let ((object (find-cached-instance location)))
+    (when object
+;;       (warn "~A being finalized by the GObject system while still in existence in lisp" object)
+      (slot-makunbound object 'location)
+      (remove-cached-instance location))))
 
 (defbinding %object-weak-ref (object) nil
   (object gobject)
   ((callback weak-notify) pointer)
   (0 unsigned-int))
 
-
 (defbinding (%gobject-new "g_object_new") () pointer
   (type type-number)
   (nil null))
 
-(defbinding (%gobject-newvv "g_object_newvv") () pointer
+(defbinding (%gobject-newv "g_object_newv") () pointer
   (type type-number)
   (n-parameters unsigned-int)
-  (names (vector string))
-  (values (vector gvalue)))
-
-
-(defbinding %object-ref (type location) pointer
-  (location pointer))
-
- (defbinding %object-unref (type location) nil
-   (location pointer))
-
-(defun object-ref (object)
-  (%object-ref nil (proxy-location object)))
-
-(defun object-unref (object)
-  (%object-unref nil (proxy-location object)))
+  (params pointer))
 
 
 
@@ -154,7 +160,7 @@ (defun object-data (object key &key (test #'eq))
 
 ;;;; Metaclass used for subclasses of gobject
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
+;(eval-when (:compile-toplevel :load-toplevel :execute)
   (defclass gobject-class (ginstance-class)
     ())
 
@@ -168,8 +174,21 @@   (defclass effective-property-slot-definition (effective-virtual-slot-definitio
     ((pname :reader slot-definition-pname :initarg :pname)
      (readable :reader slot-readable-p :initarg :readable)
      (writable :reader slot-writable-p :initarg :writable)
-     (construct :initarg :construct))))
+     (construct :initarg :construct)));)
 
+(defbinding %object-ref () pointer
+  (location pointer))
+
+(defbinding %object-unref () nil
+  (location pointer))
+
+(defmethod reference-foreign ((class gobject-class) location)
+  (declare (ignore class))
+  (%object-ref location))
+
+(defmethod unreference-foreign ((class gobject-class) location)
+  (declare (ignore class))
+  (%object-unref location))
 
 
 ; (defbinding object-class-install-param () nil
@@ -215,14 +234,13 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de
       (setf 
        (slot-value slotd 'reader-function)
        (if (slot-readable-p slotd)
-          #'(lambda (object)
-              (with-gc-disabled
-                  (let ((gvalue (gvalue-new type-number)))
-                    (%object-get-property object pname gvalue)
-                    (unwind-protect
-                         (funcall
-                          (intern-reader-function (type-from-number type-number)) gvalue +gvalue-value-offset+) ; temporary workaround for wrong topological sorting of types
-                      (gvalue-free gvalue t)))))
+          (let () ;(reader (reader-function (type-from-number type-number))))
+            #'(lambda (object)
+                (let ((gvalue (gvalue-new type-number)))
+                  (%object-get-property object pname gvalue)
+                  (unwind-protect
+                       (funcall #|reader|# (reader-function (type-from-number type-number))  gvalue +gvalue-value-offset+)
+                    (gvalue-free gvalue t)))))
           #'(lambda (value object)
               (error "Slot is not readable: ~A" (slot-definition-name slotd))))))
     
@@ -230,18 +248,15 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de
       (setf 
        (slot-value slotd 'writer-function)
        (if (slot-writable-p slotd)
-          #'(lambda (value object)
-              (with-gc-disabled
-                  (let ((gvalue (gvalue-new type-number)))
-                    (funcall
-                     (intern-writer-function (type-from-number type-number)) ; temporary
-                     value gvalue +gvalue-value-offset+)
-                    (%object-set-property object pname gvalue)
-                    (funcall
-                     (intern-destroy-function (type-from-number type-number)) ; temporary
-                     gvalue +gvalue-value-offset+)
-                    (gvalue-free gvalue nil)
-                    value)))
+          (let ();; (writer (writer-function (type-from-number type-number)))
+;;              (destroy (destroy-function (type-from-number type-number))))
+            #'(lambda (value object)
+                (let ((gvalue (gvalue-new type-number)))
+                  (funcall #|writer|# (writer-function (type-from-number type-number)) value gvalue +gvalue-value-offset+)
+                  (%object-set-property object pname gvalue)
+;                 (funcall #|destroy|#(destroy-function (type-from-number type-number)) gvalue +gvalue-value-offset+)
+                  (gvalue-free gvalue t)
+                  value)))
           #'(lambda (value object)
               (error "Slot is not writable: ~A" (slot-definition-name slotd))))))
     
@@ -270,9 +285,9 @@ (defbinding %object-class-list-properties () pointer
 
 (defun %map-params (params length type inherited-p)
   (if inherited-p
-      (map-c-array 'list #'identity params 'param length)
+      (map-c-vector 'list #'identity params 'param length)
     (let ((properties ()))
-      (map-c-array 'list 
+      (map-c-vector 'list 
        #'(lambda (param)
           (when (eql (param-owner-type param) type)
             (push param properties)))
index 10bdc7e..1d90291 100644 (file)
@@ -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: gparam.lisp,v 1.8 2004-10-28 09:33:56 espen Exp $
+;; $Id: gparam.lisp,v 1.9 2004-11-06 21:39:58 espen Exp $
 
 (in-package "GLIB")
 
@@ -24,27 +24,31 @@ (deftype gvalue () 'pointer)
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defbinding (size-of-gvalue "size_of_gvalue") () unsigned-int))
 
-(defconstant +gvalue-size+ (+ (size-of 'type-number) (* 2 (size-of 'double-float))))
+;(defconstant +gvalue-size+ (+ (size-of 'type-number) (* 2 (size-of 'double-float))))
 (defconstant +gvalue-size+ #.(size-of-gvalue))
 
 (defconstant +gvalue-value-offset+ (size-of 'type-number))
 
-(defbinding (gvalue-init "g_value_init") () nil
+(defbinding (%gvalue-init "g_value_init") () nil
   (value gvalue)
   (type type-number))
 
 (defbinding (gvalue-unset "g_value_unset") () nil
   (value gvalue))
 
+(defun gvalue-init (gvalue type &optional (value nil value-p))
+  (%gvalue-init gvalue (find-type-number type))
+  (when value-p
+    (funcall (writer-function type) value gvalue +gvalue-value-offset+)))
 
 (defun gvalue-new (type &optional (value nil value-p))
   (let ((gvalue (allocate-memory +gvalue-size+)))
-    (gvalue-init gvalue (find-type-number type))
-    (when value-p
-      (gvalue-set gvalue value))
+    (if value-p
+       (gvalue-init gvalue type value)
+      (gvalue-init gvalue type))
     gvalue))
 
-(defun gvalue-free (gvalue &optional unset-p)
+(defun gvalue-free (gvalue &optional (unset-p t))
   (unless (null-pointer-p gvalue)
     (when unset-p
       (gvalue-unset gvalue))
@@ -54,21 +58,15 @@ (defun gvalue-type (gvalue)
   (type-from-number (system:sap-ref-32 gvalue 0)))
 
 (defun gvalue-get (gvalue)
-  (funcall
-   (intern-reader-function (gvalue-type gvalue))
+  (funcall (reader-function (gvalue-type gvalue))
    gvalue +gvalue-value-offset+))
 
 (defun gvalue-set (gvalue value)
-  (funcall
-   (intern-writer-function (gvalue-type gvalue))
+  (funcall (writer-function (gvalue-type gvalue))
    value gvalue +gvalue-value-offset+)
   value)
 
 
-(deftype-method unreference-alien gvalue (type-spec location)
-  `(gvalue-free ,location nil))
-
-
 
 (deftype param-flag-type ()
   '(flags
@@ -79,38 +77,61 @@ (deftype param-flag-type ()
     (:lax-validation 16)
     (:private 32)))
 
-;(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defclass param-spec-class (ginstance-class)
+    ())
+
+  (defmethod validate-superclass 
+      ((class param-spec-class) (super pcl::standard-class))
+    t ;(subtypep (class-name super) 'param)
+))
+
+
+(defbinding %param-spec-ref () pointer
+  (location pointer))
+  
+(defbinding %param-spec-unref () nil
+  (location pointer))
+
+(defmethod reference-foreign ((class param-spec-class) location)
+  (declare (ignore class))
+  (%param-spec-ref location))
+
+(defmethod unreference-foreign ((class param-spec-class) location)
+  (declare (ignore class))
+  (%param-spec-unref location))
+
+
+
 ;; TODO: rename to param-spec
-  (defclass param (ginstance)
-    ((name
-      :allocation :alien
-      :reader param-name
-      :type string)
-     (flags
-      :allocation :alien
-      :reader param-flags
-      :type param-flag-type)
-     (value-type
-      :allocation :alien
-      :reader param-value-type
-      :type type-number)
-     (owner-type
-      :allocation :alien
-      :reader param-owner-type
-      :type type-number)
-     (nickname
-      :allocation :virtual
-      :getter "g_param_spec_get_nick"
-      :reader param-nickname
-      :type string)
-     (documentation
-      :allocation :virtual
-      :getter "g_param_spec_get_blurb"
-      :reader param-documentation
-      :type string))
-    (:metaclass ginstance-class)
-    (:ref "g_param_spec_ref")
-    (:unref "g_param_spec_unref"));)
+(defclass param (ginstance)
+  ((name
+    :allocation :alien
+    :reader param-name
+    :type string)
+   (flags
+    :allocation :alien
+    :reader param-flags
+    :type param-flag-type)
+   (value-type
+    :allocation :alien
+    :reader param-value-type
+    :type type-number)
+   (owner-type
+    :allocation :alien
+    :reader param-owner-type
+    :type type-number)
+   (nickname
+    :allocation :virtual
+    :getter "g_param_spec_get_nick"
+    :reader param-nickname
+    :type string)
+   (documentation
+    :allocation :virtual
+    :getter "g_param_spec_get_blurb"
+    :reader param-documentation
+    :type string))
+  (:metaclass param-spec-class))
 
 
 (defclass param-char (param)
@@ -126,7 +147,7 @@    (default-value
     :allocation :alien
     :reader param-char-default-value
     :type char))
-  (:metaclass ginstance-class))
+  (:metaclass param-spec-class))
 
 (defclass param-unsigned-char (param)
   (
@@ -143,7 +164,7 @@ (defclass param-unsigned-char (param)
 ;     :reader param-unsigned-char-default-value
 ;     :type unsigned-char)
    )
-  (:metaclass ginstance-class)
+  (:metaclass param-spec-class)
   (:alien-name "GParamUChar"))
 
 (defclass param-boolean (param)
@@ -151,7 +172,7 @@ (defclass param-boolean (param)
      :allocation :alien
      :reader param-boolean-default-value
      :type boolean))
-  (:metaclass ginstance-class))
+  (:metaclass param-spec-class))
 
 (defclass param-int (param)
   ((minimum
@@ -166,7 +187,7 @@    (default-value
     :allocation :alien
     :reader param-int-default-value
     :type int))
-  (:metaclass ginstance-class))
+  (:metaclass param-spec-class))
 
 (defclass param-unsigned-int (param)
   ((minimum
@@ -181,7 +202,7 @@    (default-value
     :allocation :alien
     :reader param-unsigned-int-default-value
     :type unsigned-int))
-  (:metaclass ginstance-class)
+  (:metaclass param-spec-class)
   (:alien-name "GParamUInt"))
 
 (defclass param-long (param)
@@ -197,7 +218,7 @@    (default-value
     :allocation :alien
     :reader param-long-default-value
     :type long))
-  (:metaclass ginstance-class))
+  (:metaclass param-spec-class))
 
 (defclass param-unsigned-long (param)
   ((minimum
@@ -212,12 +233,12 @@    (default-value
     :allocation :alien
     :reader param-unsigned-long-default-value
     :type unsigned-long))
-  (:metaclass ginstance-class)
+  (:metaclass param-spec-class)
   (:alien-name "GParamULong"))
 
 (defclass param-unichar (param)
   ()
-  (:metaclass ginstance-class))
+  (:metaclass param-spec-class))
 
 (defclass param-enum (param)
   ((class
@@ -228,7 +249,7 @@    (default-value
     :allocation :alien
     :reader param-enum-default-value
     :type long))
-  (:metaclass ginstance-class))
+  (:metaclass param-spec-class))
 
 (defclass param-flags (param)
   ((class
@@ -239,7 +260,7 @@    (default-value
     :allocation :alien
     :reader param-flags-default-value
     :type long))
-  (:metaclass ginstance-class))
+  (:metaclass param-spec-class))
 
 (defclass param-single-float (param)
   ((minimum
@@ -258,7 +279,7 @@    (default-value
     :allocation :alien
     :reader param-single-float-epsilon
     :type single-float))
-  (:metaclass ginstance-class)
+  (:metaclass param-spec-class)
   (:alien-name "GParamFloat"))
 
 (defclass param-double-float (param)
@@ -278,7 +299,7 @@    (default-value
     :allocation :alien
     :reader param-double-float-epsilon
     :type double-float))
-  (:metaclass ginstance-class)
+  (:metaclass param-spec-class)
   (:alien-name "GParamDouble"))
 
 (defclass param-string (param)
@@ -286,19 +307,19 @@ (defclass param-string (param)
     :allocation :alien
     :reader param-string-default-value
     :type string))
-  (:metaclass ginstance-class))
+  (:metaclass param-spec-class))
 
 (defclass param-param (param)
   ()
-  (:metaclass ginstance-class))
+  (:metaclass param-spec-class))
 
 (defclass param-boxed (param)
   ()
-  (:metaclass ginstance-class))
+  (:metaclass param-spec-class))
 
 (defclass param-pointer (param)
   ()
-  (:metaclass ginstance-class))
+  (:metaclass param-spec-class))
 
 (defclass param-value-array (param)
   ((element-spec
@@ -309,12 +330,12 @@ (defclass param-value-array (param)
     :allocation :alien
     :reader param-value-array-length
     :type unsigned-int))
-  (:metaclass ginstance-class))
+  (:metaclass param-spec-class))
 
 ;; (defclass param-closure (param)
 ;;   ()
-;;   (:metaclass ginstance-class))
+;;   (:metaclass param-spec-class))
 
 (defclass param-object (param)
   ()
-  (:metaclass ginstance-class))
+  (:metaclass param-spec-class))
index e9a0f13..eeecae1 100644 (file)
 ;; 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: proxy.lisp,v 1.10 2004-11-03 16:18:16 espen Exp $
+;; $Id: proxy.lisp,v 1.11 2004-11-06 21:39:58 espen Exp $
 
 (in-package "GLIB")
 
-(import 
-'(pcl::initialize-internal-slot-functions
-  pcl::compute-effective-slot-definition-initargs
-  pcl::compute-slot-accessor-info
-  pcl::reader-function pcl::writer-function pcl::boundp-function))
-
 ;;;; Superclass for all metaclasses implementing some sort of virtual slots
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass virtual-slot-class (standard-class) 
+  (defclass virtual-slots-class (standard-class) 
     ())
 
   (defclass direct-virtual-slot-definition (standard-direct-slot-definition)
@@ -48,17 +42,16 @@   (defun most-specific-slot-value (instances slot &optional default)
                   instances)))
       (if object
          (slot-value object slot)
-         default)))
-)
+         default))))
 
   
 
-(defmethod direct-slot-definition-class ((class virtual-slot-class) &rest initargs)
+(defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs)
   (if (eq (getf initargs :allocation) :virtual)
       (find-class 'direct-virtual-slot-definition)
     (call-next-method)))
 
-(defmethod effective-slot-definition-class ((class virtual-slot-class) &rest initargs)
+(defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs)
   (if (eq (getf initargs :allocation) :virtual)
       (find-class 'effective-virtual-slot-definition)
     (call-next-method)))
@@ -76,10 +69,13 @@ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-def
                   (error "Can't read slot: ~A" (slot-definition-name slotd))))
         (symbol #'(lambda (object)
                     (funcall getter object)))
-        (string (let ((reader (mkbinding-late getter 
-                               (slot-definition-type slotd) 'pointer)))
+        (string ;(let ()(reader  (mkbinding getter 
+;;                             (slot-definition-type slotd) 'pointer)))
                   (setf (slot-value slotd 'reader-function)
                         #'(lambda (object)
+                            (let ((reader
+                               (mkbinding getter 
+                                (slot-definition-type slotd) 'pointer)))
                             (funcall reader (proxy-location object)))))))))
 
     (unless (slot-boundp slotd 'writer-function)
@@ -93,10 +89,14 @@ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-def
         ((or symbol cons) #'(lambda (value object)
                               (funcall (fdefinition setter) value object)))
         (string
-         (let ((writer (mkbinding-late setter 'nil 'pointer 
-                        (slot-definition-type slotd))))
+         (let ((writer ()));; (mkbinding setter 'nil 'pointer 
+;;                      (slot-definition-type slotd))))
            (setf (slot-value slotd 'writer-function)
                  #'(lambda (value object)
+                     (unless writer
+                       (setq writer
+                        (mkbinding setter 'nil 'pointer 
+                         (slot-definition-type slotd))))
                      (funcall writer (proxy-location object) value))))))))
 
     (unless (slot-boundp slotd 'boundp-function)
@@ -117,7 +117,7 @@ (defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition)
                                            type gf)
   nil)
 
-(defmethod compute-effective-slot-definition-initargs ((class virtual-slot-class) direct-slotds)
+(defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds)
   (if (eq (most-specific-slot-value direct-slotds 'allocation) :virtual)
       (nconc 
        (list :getter (most-specific-slot-value direct-slotds 'getter)
@@ -128,25 +128,25 @@ (defmethod compute-effective-slot-definition-initargs ((class virtual-slot-class
 
 
 (defmethod slot-value-using-class
-    ((class virtual-slot-class) (object standard-object)
+    ((class virtual-slots-class) (object standard-object)
      (slotd effective-virtual-slot-definition))
   (if (funcall (slot-value slotd 'boundp-function) object)
       (funcall (slot-value slotd 'reader-function) object)
     (slot-unbound class object (slot-definition-name slotd))))
 
 (defmethod slot-boundp-using-class
-    ((class virtual-slot-class) (object standard-object)
+    ((class virtual-slots-class) (object standard-object)
      (slotd effective-virtual-slot-definition))
   (funcall (slot-value slotd 'boundp-function) object))
   
 (defmethod (setf slot-value-using-class) 
-    (value (class virtual-slot-class) (object standard-object)
+    (value (class virtual-slots-class) (object standard-object)
      (slotd effective-virtual-slot-definition))
   (funcall (slot-value slotd 'writer-function) value object))
 
   
 (defmethod validate-superclass
-    ((class virtual-slot-class) (super standard-class))
+    ((class virtual-slots-class) (super standard-class))
   t)
 
 
@@ -171,90 +171,69 @@ (defun instance-cached-p (location)
 (defun remove-cached-instance (location)
   (remhash (system:sap-int location) *instance-cache*))
 
+;; For debuging
+(defun cached-instances ()
+  (let ((instances ()))
+    (maphash #'(lambda (location ref)
+                (declare (ignore location))
+                (push (ext:weak-pointer-value ref) instances))
+            *instance-cache*)
+    instances))
+                       
 
 
 ;;;; Proxy for alien instances
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass proxy ()
-    ((location :reader proxy-location :type system-area-pointer)))
+(defclass proxy ()
+  ((location :reader proxy-location :type system-area-pointer)))
 
-  (defgeneric initialize-proxy (object &rest initargs))
-  (defgeneric instance-finalizer (object)))
+(defgeneric initialize-proxy (object &rest initargs))
+(defgeneric instance-finalizer (object))
+(defgeneric reference-foreign (class location))
+(defgeneric unreference-foreign (class location))
+
+(defmethod unreference-foreign :around ((class class) location)
+  (unless (null-pointer-p location)
+;;     (format t "Unreferencing ~A at ~A" (class-name class) location)
+;;     (finish-output *standard-output*)
+    (call-next-method)
+;;     (write-line " done")
+;;     (finish-output *standard-output*)
+    ))
 
 (defmethod print-object ((instance proxy) stream)
   (print-unreadable-object (instance stream :type t :identity nil)
     (format stream "at 0x~X" (sap-int (proxy-location instance)))))
 
+(defmethod print-object ((instance proxy) stream)
+  (print-unreadable-object (instance stream :type t :identity nil)
+    (format stream "at 0x~X" (sap-int (proxy-location instance)))))
 
-(defmethod initialize-instance :after ((instance proxy)
-                                      &rest initargs &key)
-  (declare (ignore initargs))
-  (cache-instance instance)
-  (ext:finalize instance (instance-finalizer instance)))
 
-(defmethod initialize-proxy ((instance proxy)
-                            &rest initargs &key location weak-ref)
-  (declare (ignore initargs))
-  (setf 
-   (slot-value instance 'location)
-   (if weak-ref
-       (funcall
-       (proxy-class-copy (class-of instance))
-       (type-of instance) location)
-     location))
+(defmethod initialize-instance :around ((instance proxy) &key location)
+  (if location
+      (setf (slot-value instance 'location) location)      
+    (call-next-method))
   (cache-instance instance)
-  (ext:finalize instance (instance-finalizer instance)))
+  (ext:finalize instance (instance-finalizer instance))
+  instance)
 
 (defmethod instance-finalizer ((instance proxy))
-  (let ((class (class-of instance))
-       (type (type-of instance))
-       (location (proxy-location instance)))
-    (declare (type symbol type) (type system-area-pointer location))
-    (let ((free (proxy-class-free class)))
-      #'(lambda ()
-         (when (instance-cached-p location)
-            (remove-cached-instance location)
-            (funcall free type location))))))
-
-
-(deftype-method translate-type-spec proxy (type-spec)
-  (declare (ignore type-spec))
-  (translate-type-spec 'pointer))
-
-(deftype-method size-of proxy (type-spec)
-  (declare (ignore type-spec))
-  (size-of 'pointer))
-
-(deftype-method translate-from-alien
-    proxy (type-spec location &optional weak-ref)
-  `(let ((location ,location))
-     (unless (null-pointer-p location)
-       (ensure-proxy-instance ',type-spec location ,weak-ref))))
-
-(deftype-method translate-to-alien
-    proxy (type-spec instance &optional weak-ref)
-  (if weak-ref
-      `(proxy-location ,instance)
-      (let ((copy (proxy-class-copy (find-class type-spec)))) 
-       (if (symbolp copy)
-           `(,copy ',type-spec (proxy-location ,instance))    
-       `(funcall ',copy ',type-spec (proxy-location ,instance))))))
-
-(deftype-method unreference-alien proxy (type-spec location)
-  (let ((free (proxy-class-free (find-class type-spec)))) 
-    (if (symbolp free)
-       `(,free ',type-spec ,location)
-    `(funcall ',free ',type-spec ,location))))
+  (let ((location (proxy-location instance))
+       (class (class-of instance)))    
+;;     (unless (find-method #'unreference-foreign nil (list (class-of class) t) nil)
+;;       (error "No matching method for UNREFERENCE-INSTANCE when called with class ~A" class))
+    #'(lambda ()
+       (when (instance-cached-p location)
+         (remove-cached-instance location))
+       (unreference-foreign class location))))
 
 
 ;;;; Metaclass used for subclasses of proxy
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass proxy-class (virtual-slot-class)
-    ((size :reader proxy-class-size)
-     (copy :reader proxy-class-copy)
-     (free :reader proxy-class-free)))
+  (defclass proxy-class (virtual-slots-class)
+    ((size :reader proxy-instance-size)))
 
   (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
     ((allocation :initform :alien)
@@ -277,26 +256,12 @@   (defmethod direct-proxy-superclass ((class proxy-class))
      (class-direct-superclasses class)))
   
   (defmethod shared-initialize ((class proxy-class) names
-                               &rest initargs &key size copy free)
+                               &rest initargs &key size)
     (declare (ignore initargs))
     (call-next-method)
     (cond
       (size (setf (slot-value class 'size) (first size)))
-      ((slot-boundp class 'size) (slot-makunbound class 'size)))
-    (cond
-      (copy (setf (slot-value class 'copy) (first copy)))
-      ((slot-boundp class 'copy) (slot-makunbound class 'copy)))
-    (cond
-      (free (setf (slot-value class 'free) (first free)))
-      ((slot-boundp class 'free) (slot-makunbound class 'free))))
-  
-  (defmethod shared-initialize :after ((class proxy-class) names &rest initargs)
-    (let ((super (most-specific-proxy-superclass class)))
-      (unless (or (not super) (eq super (find-class 'proxy)))
-       (unless (or (slot-boundp class 'copy) (not (slot-boundp super 'copy)))
-         (setf (slot-value class 'copy) (proxy-class-copy super)))
-       (unless (or (slot-boundp class 'free) (not (slot-boundp super 'free)))
-         (setf (slot-value class 'free) (proxy-class-free super))))))
+      ((slot-boundp class 'size) (slot-makunbound class 'size))))
   
   (defmethod direct-slot-definition-class ((class proxy-class) &rest initargs)
     (case (getf initargs :allocation)
@@ -319,23 +284,23 @@   (defmethod compute-effective-slot-definition-initargs ((class proxy-class) dir
 
   (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-definition))
     (with-slots (offset) slotd
-      (let* ((type (slot-definition-type slotd))
-            (reader (intern-reader-function type))
-            (writer (intern-writer-function type))
-            (destroy (intern-destroy-function type)))
+      (let ((type (slot-definition-type slotd)))
        (unless (slot-boundp slotd 'reader-function)
-         (setf 
-          (slot-value slotd 'reader-function)
-          #'(lambda (object)
-              (funcall reader (proxy-location object) offset))))
+         (let ((reader (reader-function type)))
+           (setf 
+            (slot-value slotd 'reader-function)
+            #'(lambda (object)
+                (funcall reader (proxy-location object) offset)))))
 
        (unless (slot-boundp slotd 'writer-function)
-         (setf 
-          (slot-value slotd 'writer-function)
-          #'(lambda (value object)
-              (let ((location (proxy-location object)))
-                (funcall destroy location offset)
-                (funcall writer value location offset)))))
+         (let ((writer (writer-function type))
+               (destroy (destroy-function type)))
+           (setf 
+            (slot-value slotd 'writer-function)
+            #'(lambda (value object)
+                (let ((location (proxy-location object)))
+                  (funcall destroy location offset) ; destroy old value
+                  (funcall writer value location offset))))))
 
        (unless (slot-boundp slotd 'boundp-function)
          (setf 
@@ -350,9 +315,8 @@   (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-def
   (defconstant +struct-alignmen+ 4)
 
   (defmethod compute-slots ((class proxy-class))
-    ;; This stuff should really go somewhere else
     (loop 
-     with offset = (proxy-class-size (most-specific-proxy-superclass class))
+     with offset = (proxy-instance-size (most-specific-proxy-superclass class))
      with size = offset
      for slotd in (class-direct-slots class)
      when (eq (slot-definition-allocation slotd) :alien)
@@ -372,69 +336,111 @@   (defmethod compute-slots ((class proxy-class))
   (defmethod validate-superclass ((class proxy-class) (super standard-class))
     (subtypep (class-name super) 'proxy))
   
-  (defmethod proxy-class-size (class)
+  (defmethod proxy-instance-size (class)
     (declare (ignore class))
     0)
 )
   
-(defgeneric make-proxy-instance (class location weak-ref
-                                      &rest initargs &key));)
+(defmethod alien-type ((class proxy-class) &rest args)
+  (declare (ignore class args))
+  (alien-type 'pointer))
+
+(defmethod size-of ((class proxy-class) &rest args)
+  (declare (ignore class args))
+  (size-of 'pointer))
+
+(defmethod from-alien-form (location (class proxy-class) &rest args)
+  (declare (ignore args))
+  `(ensure-proxy-instance ',(class-name class) ,location))
+
+(defmethod from-alien-function ((class proxy-class) &rest args)
+  (declare (ignore args))  
+  #'(lambda (location)
+      (ensure-proxy-instance class location)))
 
-(defmethod make-proxy-instance ((class symbol) location weak-ref
-                               &rest initargs &key)
-  (apply #'make-proxy-instance (find-class class) location weak-ref initargs))
+(defmethod to-alien-form (instance (class proxy-class) &rest args)
+  (declare (ignore class args))
+  `(proxy-location ,instance))
 
-(defmethod make-proxy-instance ((class proxy-class) location weak-ref
-                               &rest initargs &key)
-  (let ((instance (allocate-instance class)))
-    (apply
-     #'initialize-proxy
-     instance :location location :weak-ref weak-ref initargs)
-    instance))
+(defmethod to-alien-function ((class proxy-class) &rest args)
+  (declare (ignore class args))
+  #'proxy-location)
+
+(defmethod writer-function ((class proxy-class) &rest args)
+  (declare (ignore args))
+  #'(lambda (instance location &optional (offset 0))
+      (assert (null-pointer-p (sap-ref-sap location offset)))
+      (setf 
+       (sap-ref-sap location offset)
+       (reference-foreign class (proxy-location instance)))))
 
-(defun ensure-proxy-instance (class location weak-ref &rest initargs)
-  (or
-   (find-cached-instance location)
-   (apply #'make-proxy-instance class location weak-ref initargs)))
+(defmethod reader-function ((class proxy-class) &rest args)
+  (declare (ignore args))
+  #'(lambda (location &optional (offset 0))
+      (ensure-proxy-instance class (sap-ref-sap location offset))))
 
+(defmethod destroy-function ((class proxy-class) &rest args)
+  (declare (ignore args))
+  #'(lambda (location &optional (offset 0))
+      (unreference-foreign class (sap-ref-sap location offset))))
+
+
+(defgeneric ensure-proxy-instance (class location)
+  (:documentation "Returns a proxy object representing the foreign object at the give location."))
+
+(defmethod ensure-proxy-instance :around (class location)
+  (unless (null-pointer-p location)
+    (or 
+     (find-cached-instance location)
+     (call-next-method))))
+  
+(defmethod ensure-proxy-instance ((class symbol) location)
+  (ensure-proxy-instance (find-class class) location))
+
+(defmethod ensure-proxy-instance ((class proxy-class) location)
+  (make-instance class :location location))
 
 
 ;;;; Superclasses for wrapping of C structures
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass struct (proxy)
-    ()
-    (:metaclass proxy-class)
-    (:copy %copy-struct)
-    (:free %free-struct)))
+(defclass struct (proxy)
+  ()
+  (:metaclass proxy-class))
 
-(defmethod initialize-instance ((structure struct) &rest initargs)
+(defmethod initialize-instance ((struct struct) &rest initargs)
   (declare (ignore initargs))
   (setf 
-   (slot-value structure 'location)
-   (allocate-memory (proxy-class-size (class-of structure))))
+   (slot-value struct 'location)
+   (allocate-memory (proxy-instance-size (class-of struct))))
   (call-next-method))
 
 
-(defun %copy-struct (type location)
-  (copy-memory location (proxy-class-size (find-class type))))
+;;;; Metaclasses used for subclasses of struct
+
+(defclass struct-class (proxy-class)
+  ())
 
-(defun %free-struct (type location)
-  (declare (ignore type))
+(defmethod reference-foreign ((class struct-class) location)
+  (copy-memory location (proxy-instance-size class)))
+
+(defmethod unreference-foreign ((class struct-class) location)
   (deallocate-memory location))
 
+(defmethod reader-function ((class struct-class) &rest args)
+  (declare (ignore args))
+  #'(lambda (location &optional (offset 0))
+      (let ((instance (sap-ref-sap location offset)))
+       (unless (null-pointer-p instance)
+         (ensure-proxy-instance class (reference-foreign class instance))))))
+
 
-;(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass static (struct)
-    ()
-    (:metaclass proxy-class)
-    (:copy %copy-static)
-    (:free %free-static));)
+(defclass static-struct-class (struct-class)
+  ())
 
-(defun %copy-static (type location)
-  (declare (ignore type))
+(defmethod reference-foreign ((class static-struct-class) location)
+  (declare (ignore class))
   location)
 
-(defun %free-static (type location)
-  (declare (ignore type location))
+(defmethod unreference-foreign ((class static-struct-class) location)
+  (declare (ignore class location))
   nil)
index d71b327..845fdd8 100644 (file)
@@ -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: gtk.lisp,v 1.14 2004-11-03 10:41:23 espen Exp $
+;; $Id: gtk.lisp,v 1.15 2004-11-06 21:39:58 espen Exp $
 
 
 (in-package "GTK")
@@ -42,6 +42,27 @@ (defun gtk-version ()
 (defbinding get-default-language () string)
 
 
+;;;; Initalization
+
+(defbinding (gtk-init "gtk_parse_args") () nil
+  "Initializes the library without opening the display."
+  (nil null)
+  (nil null))
+
+(defun clg-init (&optional display)
+  "Initializes the system and starts the event handling"
+  (unless (gdk:display-get-default)
+    (gdk:gdk-init)
+    (gtk-init)
+    (prog1
+       (gdk:display-open display)
+      (system:add-fd-handler 
+       (gdk:display-connection-number) :input #'main-iterate-all)
+      (setq lisp::*periodic-polling-function* #'main-iterate-all)
+      (setq lisp::*max-event-to-sec* 0)
+      (setq lisp::*max-event-to-usec* 1000))))
+
+
 ;;; Acccel group
 
 
@@ -248,6 +269,7 @@ (defbinding (color-selection-is-adjusting-p
 
 (defmethod shared-initialize ((combo combo) names &rest initargs
                              &key popdown-strings)
+  (declare (ignore initargs))
   (call-next-method)
   (when popdown-strings
     (combo-set-popdown-strings combo popdown-strings)))
@@ -264,6 +286,7 @@ (defbinding combo-disable-activate () nil
 ;;;; Dialog
 
 (defmethod shared-initialize ((dialog dialog) names &rest initargs &key button)
+  (declare (ignore button))
   (call-next-method)
   (dolist (button-definition (get-all initargs :button))
     (apply #'dialog-add-button dialog (mklist button-definition))))
@@ -677,14 +700,14 @@ (defbinding window-begin-resize-drag () nil
   (edge gdk:window-edge)
   (button int)
   (root-x int) (root-y int)
-  (timestamp (unsigned-int 32)))
+  (timestamp unsigned-int))
 
 (defbinding window-begin-move-drag () nil
   (window window)
   (edge gdk:window-edge)
   (button int)
   (root-x int) (root-y int)
-  (timestamp (unsigned-int 32)))
+  (timestamp unsigned-int))
 
 (defbinding window-set-frame-dimensions () nil
   (window window)
index 0173ba6..3d1c67c 100644 (file)
@@ -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: gtkobject.lisp,v 1.18 2004-11-03 16:54:24 espen Exp $
+;; $Id: gtkobject.lisp,v 1.19 2004-11-06 21:39:58 espen Exp $
 
 
 (in-package "GTK")
@@ -34,7 +34,9 @@ (in-package "GTK")
 ;;;; Superclass for the gtk class hierarchy
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (init-types-in-library "libgtk-x11-2.0.so"
+  (init-types-in-library 
+   #.(concatenate 'string (pkg-config:pkg-variable "gtk+-2.0" "libdir") 
+                         "/libgtk-x11-2.0.so")
    :ignore ("gtk_window_get_type_hint"))
 
   (defclass %object (gobject)
@@ -43,15 +45,14 @@   (defclass %object (gobject)
     (:alien-name "GtkObject")))
 
 
-(defmethod shared-initialize ((object %object) names &rest initargs &key signal)
-  (declare (ignore names signal))
+(defmethod initialize-instance ((object %object) &rest initargs &key signal)
+  (declare (ignore signal))
   (call-next-method)
-  (object-ref object) ; inc ref count before sinking
-  (%object-sink object)
+  (reference-foreign (class-of object) (proxy-location object))
   (dolist (signal-definition (get-all initargs :signal))
     (apply #'signal-connect object signal-definition)))
 
-(defmethod initialize-proxy ((object %object) &rest initargs)
+(defmethod initialize-instance :around ((object %object) &rest initargs)
   (declare (ignore initargs))
   (call-next-method)
   (%object-sink object))
@@ -85,34 +86,13 @@ (defun main-iterate-all (&rest args)
     (main-iteration-do nil)
     (main-iterate-all)))
 
-;;;; Initalization
-
-(defbinding (gtk-init "gtk_parse_args") () nil
-  "Initializes the library without opening the display."
-  (nil null)
-  (nil null))
-
-(defun clg-init (&optional display)
-  "Initializes the system and starts the event handling"
-  (unless (gdk:display-get-default)
-    (gdk:gdk-init)
-    (gtk-init)
-    (prog1
-       (gdk:display-open display)
-      (system:add-fd-handler 
-       (gdk:display-connection-number) :input #'main-iterate-all)
-      (setq lisp::*periodic-polling-function* #'main-iterate-all)
-      (setq lisp::*max-event-to-sec* 0)
-      (setq lisp::*max-event-to-usec* 1000))))
-
-
 
 ;;;; Metaclass for child classes
  
 (defvar *container-to-child-class-mappings* (make-hash-table))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass child-class (virtual-slot-class)
+  (defclass child-class (virtual-slots-class)
     ())
 
   (defclass direct-child-slot-definition (direct-virtual-slot-definition)
@@ -128,15 +108,6 @@ (defmethod shared-initialize ((class child-class) names &key container)
    (gethash (find-class (first container)) *container-to-child-class-mappings*)
     class))
 
-;; (defmethod initialize-instance  ((slotd direct-child-slot-definition)
-;;                              &rest initargs &key pname)
-;;   (declare (ignore initargs))
-;;   (call-next-method)
-;;   (if pname
-;;       (setf (slot-value slotd 'pname) pname)
-;;     ; ???
-;;     (error "Need pname for slot with allocation :property")))
-
 (defmethod direct-slot-definition-class ((class child-class) &rest initargs)
   (case (getf initargs :allocation)
     (:property (find-class 'direct-child-slot-definition))
@@ -169,31 +140,25 @@ (defmethod initialize-internal-slot-functions ((slotd effective-child-slot-defin
        (slot-value slotd 'reader-function)
        #'(lambda (object)
           (with-slots (parent child) object       
-            (with-gc-disabled
-                (let ((gvalue (gvalue-new type-number)))
-                  (%container-child-get-property parent child pname gvalue)
-                  (unwind-protect
-                       (funcall
-                        (intern-reader-function type)
-                        gvalue +gvalue-value-offset+)
-                    (gvalue-free gvalue t))))))))
+            (let ((gvalue (gvalue-new type-number)))
+              (%container-child-get-property parent child pname gvalue)
+              (unwind-protect
+                   (funcall (reader-function type) gvalue +gvalue-value-offset+)
+                (gvalue-free gvalue t)))))))
     
     (unless (slot-boundp slotd 'writer-function)
       (setf 
        (slot-value slotd 'writer-function)
        #'(lambda (value object)
           (with-slots (parent child) object       
-            (with-gc-disabled
-                (let ((gvalue (gvalue-new type-number)))
-                  (funcall
-                   (intern-writer-function type)
-                   value gvalue +gvalue-value-offset+)
-                  (%container-child-set-property parent child pname gvalue)
-                  (funcall
-                   (intern-destroy-function type)
-                   gvalue +gvalue-value-offset+)
-                  (gvalue-free gvalue nil)
-                  value))))))
+            (let ((gvalue (gvalue-new type-number)))
+              (funcall (writer-function type) value gvalue +gvalue-value-offset+)
+              (%container-child-set-property parent child pname gvalue)
+;;                (funcall
+;;                 (destroy-function type)
+;;                 gvalue +gvalue-value-offset+)
+                  (gvalue-free gvalue t)
+                  value)))))
     
     (unless (slot-boundp slotd 'boundp-function)
       (setf 
@@ -250,7 +215,7 @@ (defun query-container-class-child-properties (type-number)
     (multiple-value-bind (array length)
        (%container-class-list-child-properties class)
       (unwind-protect
-         (map-c-array 'list #'identity array 'param length)
+         (map-c-vector 'list #'identity array 'param length)
        (deallocate-memory array)))))
 
 (defun default-container-child-name (container-class)
index 4b09c9a..00dd6f7 100644 (file)
@@ -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: gtktypes.lisp,v 1.16 2004-10-31 12:05:52 espen Exp $
+;; $Id: gtktypes.lisp,v 1.17 2004-11-06 21:39:58 espen Exp $
 
 
 (in-package "GTK")
@@ -55,7 +55,7 @@ (defclass allocation (struct)
     :accessor allocation-height
     :initarg :height
     :type int))
-  (:metaclass proxy-class))
+  (:metaclass struct-class))
 
 (defclass border (boxed)
   ((left
@@ -106,7 +106,7 @@ (defclass stock-item (struct)
     :accessor stock-item-translation-domain
     :initarg :translation-domain
     :type string))
-  (:metaclass proxy-class))
+  (:metaclass static-struct-class))
 
 
 (define-types-by-introspection "Gtk"
index e04d7f7..bd62906 100644 (file)
@@ -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: gtkwidget.lisp,v 1.9 2004-10-31 12:05:52 espen Exp $
+;; $Id: gtkwidget.lisp,v 1.10 2004-11-06 21:39:58 espen Exp $
 
 (in-package "GTK")
 
@@ -361,7 +361,7 @@ (defbinding %widget-get-size-request () nil
 
 (defun widget-get-size-request (widget)
   (multiple-value-bind (width height) (%widget-get-size-request widget)
-    (values (unless (= width -1) width) (unless (= height -1) height))))
+     (values (unless (= width -1) width) (unless (= height -1) height))))
 
 (defbinding widget-set-size-request (widget width height) nil
   (widget widget)
index 09a2265..32db14d 100644 (file)
 ;; 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: pango.lisp,v 1.5 2004-10-31 11:45:39 espen Exp $
+;; $Id: pango.lisp,v 1.6 2004-11-06 21:39:58 espen Exp $
 
 (in-package "PANGO")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (init-types-in-library "libpango-1.0.so" :ignore ("_pango_fribidi_get_type")))
+  (init-types-in-library 
+   #.(concatenate 'string (pkg-config:pkg-variable "atk" "libdir") 
+                         "/libpango-1.0.so")
+   :prefix "pango_" :ignore ("_pango_fribidi_get_type")))
 
 (define-types-by-introspection "Pango")