Changes required by SBCL

diff --git a/atk/defpackage.lisp b/atk/defpackage.lisp
index 87e7c3dd57f677e32cfc377aa0dff91bdecfcc46..a43d295aec2d06a8e619c6a381604b4fedcb3bda 100644 (file)
--- a/atk/defpackage.lisp
+++ b/atk/defpackage.lisp
@@ -1,6 +1,4 @@
 (defpackage "ATK"
 (defpackage "ATK"

-  (:use "GLIB" "COMMON-LISP" "AUTOEXPORT")
-  (:shadowing-import-from "PCL"
-   "CLASS-NAME" "CLASS-OF" "FIND-CLASS"))
+  (:use "GLIB" "COMMON-LISP" "AUTOEXPORT"))

 
 
 
 

diff --git a/gdk/defpackage.lisp b/gdk/defpackage.lisp
index 74c21653250872c0b7d7131ed0184b0465e0c834..5f6a76d1d22a3de637c9565c4799cdb54772b2dd 100644 (file)
--- a/gdk/defpackage.lisp
+++ b/gdk/defpackage.lisp
@@ -1,7 +1,5 @@
 (defpackage "GDK"
   (:use "GLIB" "COMMON-LISP" "AUTOEXPORT")
 (defpackage "GDK"
   (:use "GLIB" "COMMON-LISP" "AUTOEXPORT")

-  (:shadowing-import-from "PCL"
-   "CLASS-NAME" "CLASS-OF" "FIND-CLASS")

   (:shadow "ATOM"))
 
 
   (:shadow "ATOM"))
 
 

diff --git a/gdk/gdktypes.lisp b/gdk/gdktypes.lisp
index 6334ae1f4537382222b14d35885d6975748342ea..e34f5b195c6bd50123ce5aa6e8f6919f3e6aae97 100644 (file)
--- a/gdk/gdktypes.lisp
+++ b/gdk/gdktypes.lisp
@@ -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
 
 ;; 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.11 2005/01/30 15:08:03 espen Exp $
+;; $Id: gdktypes.lisp,v 1.12 2005/02/03 23:09:07 espen Exp $

 
 (in-package "GDK")
 
 
 (in-package "GDK")
 


@@ -83,103 +83,100 @@ (defclass rectangle (boxed)
   (:alien-name "GdkRectangle"))
 
 
   (:alien-name "GdkRectangle"))
 
 

-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (define-types-by-introspection "Gdk"
-    ("GdkFunction" :type gc-function)
-    ("GdkWMDecoration" :type wm-decoration)
-    ("GdkWMFunction" :type wm-function)
-    ("GdkGC" :type gc)
-    ("GdkGCX11" :type gc-x11)
-    ("GdkGCValuesMask" :type gc-values-mask)
-    ("GdkDrawableImplX11" :ignore t)
-    ("GdkWindowImplX11" :ignore t)
-    ("GdkPixmapImplX11" :ignore t)
-    ("GdkGCX11" :ignore t)
-    ("GdkColor" :ignore t)
-    ("GdkEvent" :ignore t)
-    ("GdkRectngle" :ignore t)
-    ("GdkFont" :ignore t) ; deprecated
-
-    ("GdkDrawable"
-     :slots
-     ((display
-       :allocation :virtual
-       :getter "gdk_drawable_get_display"
-       :reader drawable-display
-       :type display)
-      (screen
-       :allocation :virtual
-       :getter "gdk_drawable_get_screen"
-       :reader drawable-screen
-       :type screen)
-      (visual
-       :allocation :virtual
-       :getter "gdk_drawable_get_visual"
-       :reader drawable-visual
-       :type visual)
-      (colormap
-       :allocation :virtual
-       :getter "gdk_drawable_get_colormap"
-       :setter "gdk_drawable_set_colormap"
-       :unbound nil
-       :accessor drawable-colormap
-       :initarg :colormap
-       :type colormap)
-      (depth
-       :allocation :virtual
-       :getter "gdk_drawable_get_depth"
-       :reader drawable-depth
-       :type int)
-      (with 
-       :allocation :virtual
-       :getter drawable-width)
-      (height
-       :allocation :virtual
-       :getter drawable-height)))
-
-    ("GdkWindow"
-     :slots
-     ((state
-       :allocation :virtual
-       :getter "gdk_window_get_state"
-       :reader window-state
-       :type window-state)
-      (parent
-       :allocation :virtual
-       :getter "gdk_window_get_parent"
-       :reader window-parent
-       :type window)
-      (toplevel
-       :allocation :virtual
-       :getter "gdk_window_get_toplevel"
-       :reader window-toplevel
-       :type window)
-      (children
-       :allocation :virtual
-       :getter "gdk_window_get_children"
-       :reader window-children
-       :type (glist window))
-      (events
-       :allocation :virtual
-       :getter "gdk_window_get_events"
-       :setter "gdk_window_set_events"
-       :accessor window-events
-       :type event-mask)
-      (group
-       :allocation :virtual
-       :getter "gdk_window_get_group"
-       :setter "gdk_window_set_group"
-       :unbound nil
-       :accessor window-group
-       :type window)
-
-      ))
-))
+(define-types-by-introspection "Gdk"
+  ("GdkFunction" :type gc-function)
+  ("GdkWMDecoration" :type wm-decoration)
+  ("GdkWMFunction" :type wm-function)
+  ("GdkGC" :type gc)
+  ("GdkGCX11" :type gc-x11)
+  ("GdkGCValuesMask" :type gc-values-mask)
+  ("GdkDrawableImplX11" :ignore t)
+  ("GdkWindowImplX11" :ignore t)
+  ("GdkPixmapImplX11" :ignore t)
+  ("GdkGCX11" :ignore t)
+  ("GdkColor" :ignore t)
+  ("GdkEvent" :ignore t)
+  ("GdkRectngle" :ignore t)
+  ("GdkCursor" :ignore t)
+  ("GdkFont" :ignore t) ; deprecated
+  
+  ("GdkDrawable"
+   :slots
+   ((display
+     :allocation :virtual
+     :getter "gdk_drawable_get_display"
+     :reader drawable-display
+     :type display)
+    (screen
+     :allocation :virtual
+     :getter "gdk_drawable_get_screen"
+     :reader drawable-screen
+     :type screen)
+    (visual
+     :allocation :virtual
+     :getter "gdk_drawable_get_visual"
+     :reader drawable-visual
+     :type visual)
+    (colormap
+     :allocation :virtual
+     :getter "gdk_drawable_get_colormap"
+     :setter "gdk_drawable_set_colormap"
+     :unbound nil
+     :accessor drawable-colormap
+     :initarg :colormap
+     :type colormap)
+    (depth
+     :allocation :virtual
+     :getter "gdk_drawable_get_depth"
+     :reader drawable-depth
+     :type int)
+    (with 
+     :allocation :virtual
+     :getter drawable-width)
+    (height
+     :allocation :virtual
+     :getter drawable-height)))
+  
+  ("GdkWindow"
+   :slots
+   ((state
+     :allocation :virtual
+     :getter "gdk_window_get_state"
+     :reader window-state
+     :type window-state)
+    (parent
+     :allocation :virtual
+     :getter "gdk_window_get_parent"
+     :reader window-parent
+     :type window)
+    (toplevel
+     :allocation :virtual
+     :getter "gdk_window_get_toplevel"
+     :reader window-toplevel
+     :type window)
+    (children
+     :allocation :virtual
+     :getter "gdk_window_get_children"
+     :reader window-children
+     :type (glist window))
+    (events
+     :allocation :virtual
+     :getter "gdk_window_get_events"
+     :setter "gdk_window_set_events"
+     :accessor window-events
+     :type event-mask)
+    (group
+     :allocation :virtual
+     :getter "gdk_window_get_group"
+     :setter "gdk_window_set_group"
+     :unbound nil
+     :accessor window-group
+     :type window))))

 
 
 (deftype bitmap () 'pixmap)
 
 
 
 (deftype bitmap () 'pixmap)
 

-(defclass cursor (struct)
+(defclass cursor (boxed)

   ((type
     :allocation :alien
     :reader cursor-type
   ((type
     :allocation :alien
     :reader cursor-type


@@ -192,11 +189,9 @@ (defclass cursor (struct)
     :getter "gdk_cursor_get_display"
     :reader cursor-display
     :type display))
     :getter "gdk_cursor_get_display"
     :reader cursor-display
     :type display))

-  (:metaclass struct-class))
+  (:metaclass boxed-class)
+  (:alien-name "GdkColor"))

 
 

-(defclass device (struct)
-  ()
-  (:metaclass struct-class))

 
 (defclass geometry (struct)
   ((min-width 
 
 (defclass geometry (struct)
   ((min-width 

diff --git a/glib/defpackage.lisp b/glib/defpackage.lisp
index 3829b4054dd03acea35157b9df8e229cef797e24..0fd7053d04c462e6c9a7d26b18c042550a192b96 100644 (file)
--- a/glib/defpackage.lisp
+++ b/glib/defpackage.lisp
@@ -15,26 +15,38 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
 ;; 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.4 2004/12/29 21:06:22 espen Exp $
+;; $Id: defpackage.lisp,v 1.5 2005/02/03 23:09:03 espen Exp $

 
 ;(export 'kernel::type-expand-1 "KERNEL")
 
 (defpackage "GLIB"
 
 ;(export 'kernel::type-expand-1 "KERNEL")
 
 (defpackage "GLIB"

-  (:use "ALIEN" "SYSTEM" "COMMON-LISP" "PCL" "AUTOEXPORT")
-  (:import-from "PCL"
+  (:use "COMMON-LISP""AUTOEXPORT")
+  #+cmu(:use "SYSTEM" "KERNEL" "PCL" "EXT")
+  #+sbcl(:use "SB-SYS" "SB-KERNEL" "SB-PCL" "SB-EXT")
+  #+cmu(:shadowing-import-from "PCL"
+           "CLASS-DIRECT-SUPERCLASSES" "CLASS-DIRECT-SUPERCLASSES")
+  (:shadow "POINTER")
+  (:import-from #+cmu"PCL" #+sbcl"SB-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")
           "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")

+  #+sbcl(:import-from "SB-EXT" "COLLECT")
+  #+cmu(:import-from "ALIEN" "CALLBACK")
+  (:import-from #+cmu"ALIEN" #+sbcl"SB-ALIEN" 
+          "WITH-ALIEN" "ALIEN-FUNCALL" "%HEAP-ALIEN" "MAKE-HEAP-ALIEN-INFO" 
+          "ADDR" "PARSE-ALIEN-TYPE" "SYSTEM-AREA-POINTER" "EXTERN-ALIEN")
+  (:import-from #+cmu"C-CALL" #+sbcl"SB-ALIEN" "%NATURALIZE-C-STRING" "VOID")

   (:export "DEFTYPE-METHOD" "TRANSLATE-TYPE-SPEC" "TRANSLATE-TO-ALIEN"
           "TRANSLATE-FROM-ALIEN" "CLEANUP-ALIEN" "UNREFERENCE-ALIEN"
           "SIZE-OF" "UNBOUND-VALUE")
   (:export "DEFBINDING" "DEFINE-FOREIGN" "MKBINDING" "USE-PREFIX"
   (:export "DEFTYPE-METHOD" "TRANSLATE-TYPE-SPEC" "TRANSLATE-TO-ALIEN"
           "TRANSLATE-FROM-ALIEN" "CLEANUP-ALIEN" "UNREFERENCE-ALIEN"
           "SIZE-OF" "UNBOUND-VALUE")
   (:export "DEFBINDING" "DEFINE-FOREIGN" "MKBINDING" "USE-PREFIX"

-          "PACKAGE-PREFIX" "DEFCALLBACK")
+          "PACKAGE-PREFIX" "DEFCALLBACK" "CALLBACK")

   (:export "LONG" "UNSIGNED-LONG" "INT" "UNSIGNED-INT" "SHORT" "UNSIGNED-SHORT"
   (:export "LONG" "UNSIGNED-LONG" "INT" "UNSIGNED-INT" "SHORT" "UNSIGNED-SHORT"

-          "SIGNED" "UNSIGNED" "CHAR" "POINTER")
-  (:export "INTERN-ARGUMENT-TRANSLATOR" "INTERN-RETURN-VALUE-TRANSLATOR"
-          "INTERN-CLEANUP-FUNCTION" "INTERN-WRITER-FUNCTION"
-          "INTERN-READER-FUNCTION" "INTERN-DESTROY-FUNCTION"))
+          "SIGNED" "UNSIGNED" "CHAR" "POINTER" "COPY-OF")
+  (:export "LOCATION" "ALLOCATION" "DIRECT-SLOTS" "READER-FUNCTION" 
+          "WRITER-FUNCTION" "BOUNDP-FUNCTION" 
+          "INITIALIZE-INTERNAL-SLOT-FUNCTIONS"
+          "COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS"))

 
 

diff --git a/glib/ffi.lisp b/glib/ffi.lisp
index 64ec4fc078c651518bc23ab37c3570e4f8f07e1f..a50499ed2e8f86ab6749375acb6613cfb26ae103 100644 (file)
--- a/glib/ffi.lisp
+++ b/glib/ffi.lisp
@@ -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
 
 ;; 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.12 2005/01/03 16:35:05 espen Exp $
+;; $Id: ffi.lisp,v 1.13 2005/02/03 23:09:03 espen Exp $

 
 (in-package "GLIB")
 
 
 (in-package "GLIB")
 


@@ -113,10 +113,10 @@ (defmacro defbinding (name lambda-list return-type &rest docs/args)
        c-name lisp-name (or supplied-lambda-list (nreverse lambda-list))
        return-type (reverse docs) (reverse args)))))
 
        c-name lisp-name (or supplied-lambda-list (nreverse lambda-list))
        return-type (reverse docs) (reverse args)))))
 

-#+cmu
+#+(or cmu sbcl)

 (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args)
 (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args)

-  (ext:collect ((alien-types) (alien-bindings) (alien-parameters) 
-               (return-values) (cleanup-forms))
+  (collect ((alien-types) (alien-bindings) (alien-parameters) 
+           (return-values) (cleanup-forms))

     (dolist (arg args)
       (destructuring-bind (var expr type style) arg
        (let ((declaration (alien-type type))
     (dolist (arg args)
       (destructuring-bind (var expr type style) arg
        (let ((declaration (alien-type type))


@@ -151,7 +151,8 @@ (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args)
           (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters))))
       `(defun ,lisp-name ,lambda-list
         ,@docs
           (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters))))
       `(defun ,lisp-name ,lambda-list
         ,@docs

-        (declare (optimize (ext:inhibit-warnings 3)))
+        #+cmu(declare (optimize (inhibit-warnings 3)))
+        #+sbcl(declare (muffle-conditions compiler-note))

         (with-alien ((,alien-name
                       (function
                        ,(alien-type return-type)
         (with-alien ((,alien-name
                       (function
                        ,(alien-type return-type)


@@ -173,14 +174,15 @@ (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args)
 
 ;;; Creates bindings at runtime
 (defun mkbinding (name return-type &rest arg-types)
 
 ;;; Creates bindings at runtime
 (defun mkbinding (name return-type &rest arg-types)

-  (declare (optimize (ext:inhibit-warnings 3)))
+  #+cmu(declare (optimize (inhibit-warnings 3)))
+  #+sbcl(declare (muffle-conditions compiler-note))

   (let* ((ftype 
          `(function ,@(mapcar #'alien-type (cons return-type arg-types))))
         (alien
   (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))))
+         (%heap-alien
+          (make-heap-alien-info
+           :type (parse-alien-type ftype #+sbcl nil)
+           :sap-form (foreign-symbol-address name))))

         (translate-arguments (mapcar #'to-alien-function arg-types))
         (translate-return-value (from-alien-function return-type))
         (cleanup-arguments (mapcar #'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)))


@@ -189,25 +191,30 @@ (defun mkbinding (name return-type &rest arg-types)
        (map-into args #'funcall translate-arguments args)
        (prog1
            (funcall translate-return-value 
        (map-into args #'funcall translate-arguments args)
        (prog1
            (funcall translate-return-value 

-            (apply #'alien:alien-funcall alien args))
+            (apply #'alien-funcall alien args))

          (mapc #'funcall cleanup-arguments args)))))
 
 
 (defmacro defcallback (name (return-type &rest args) &body body)
          (mapc #'funcall cleanup-arguments args)))))
 
 
 (defmacro defcallback (name (return-type &rest args) &body body)

-  `(def-callback ,name 
-       (,(alien-type return-type) 
-       ,@(mapcar #'(lambda (arg)
-                     (destructuring-bind (name type) arg
-                       `(,name ,(alien-type type))))
-                 args))
-    ,(to-alien-form 
-      `(let (,@(mapcar #'(lambda (arg)
-                          (destructuring-bind (name type) arg
-                            `(,name ,(from-alien-form name type))))
-                      args))
-       ,@body)
-      return-type)))
-
+  (let ((def-callback #+cmu'alien:def-callback 
+                     #+sbcl'sb-alien:define-alien-function))
+    `(,def-callback ,name 
+         (,(alien-type return-type) 
+         ,@(mapcar #'(lambda (arg)
+                       (destructuring-bind (name type) arg
+                         `(,name ,(alien-type type))))
+                   args))
+       ,(to-alien-form 
+        `(let (,@(mapcar #'(lambda (arg)
+                             (destructuring-bind (name type) arg
+                               `(,name ,(from-alien-form name type))))
+                         args))
+           ,@body)
+        return-type))))
+
+#+sbcl
+(defun callback (af)
+  (sb-alien:alien-function-sap af))

 
 
 ;;;; Definitons and translations of fundamental types
 
 
 ;;;; Definitons and translations of fundamental types


@@ -329,10 +336,10 @@ (defmethod alien-type ((type (eql 'signed-byte)) &rest args)
   (declare (ignore type))
   (destructuring-bind (&optional (size '*)) args
     (ecase size
   (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))))
+      (#.+bits-of-byte+ #+cmu'(alien:signed 8) #+sbcl'(sb-alien:signed 8))
+      (#.+bits-of-short+ #+cmu 'c-call:short #+sbcl 'sb-alien:short)
+      ((* #.+bits-of-int+) #+cmu 'c-call:int #+sbcl 'sb-alien:int)
+      (#.+bits-of-long+ #+cmu 'c-call:long #+sbcl 'sb-alien:long))))

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


@@ -378,10 +385,13 @@ (defmethod reader-function ((type (eql 'signed-byte)) &rest args)
 (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args)
   (destructuring-bind (&optional (size '*)) args
     (ecase size
 (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))))
+      (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8))
+      (#.+bits-of-short+ #+cmu 'c-call:unsigned-short 
+                        #+sbcl 'sb-alien:unsigned-short)
+      ((* #.+bits-of-int+) #+cmu 'c-call:unsigned-int 
+                           #+sbcl 'sb-alien:unsigned-int)
+      (#.+bits-of-long+ #+cmu 'c-call:unsigned-long 
+                       #+sbcl 'sb-alien:unsigned-long))))

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


@@ -443,7 +453,7 @@ (defmethod size-of ((type (eql 'fixnum)) &rest args)
 
 (defmethod alien-type ((type (eql 'single-float)) &rest args)
   (declare (ignore type args))
 
 (defmethod alien-type ((type (eql 'single-float)) &rest args)
   (declare (ignore type args))

-  'alien:single-float)
+  #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float)

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


@@ -462,7 +472,7 @@ (defmethod reader-function ((type (eql 'single-float)) &rest args)
 
 (defmethod alien-type ((type (eql 'double-float)) &rest args)
   (declare (ignore type args))
 
 (defmethod alien-type ((type (eql 'double-float)) &rest args)
   (declare (ignore type args))

-  'alien:double-float)
+  #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float)

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


@@ -481,7 +491,7 @@ (defmethod reader-function ((type (eql 'double-float)) &rest args)
 
 (defmethod alien-type ((type (eql 'base-char)) &rest args)
   (declare (ignore type args))
 
 (defmethod alien-type ((type (eql 'base-char)) &rest args)
   (declare (ignore type args))

-  'c-call:char)
+  #+cmu 'c-call:char #+sbcl 'sb-alien:char)

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


@@ -511,14 +521,14 @@ (defmethod to-alien-form (string (type (eql 'string)) &rest args)
   `(let ((string ,string))
      ;; Always copy strings to prevent seg fault due to GC
      (copy-memory
   `(let ((string ,string))
      ;; Always copy strings to prevent seg fault due to GC
      (copy-memory

-      (make-pointer (1+ (kernel:get-lisp-obj-address string)))
+      (vector-sap (coerce string 'simple-base-string))

       (1+ (length string)))))
   
 (defmethod to-alien-function ((type (eql 'string)) &rest args)
   (declare (ignore type args))
   #'(lambda (string)
       (copy-memory
       (1+ (length 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)))
+       (vector-sap (coerce string 'simple-base-string))

        (1+ (length string)))))
 
 (defmethod from-alien-form (string (type (eql 'string)) &rest args)
        (1+ (length string)))))
 
 (defmethod from-alien-form (string (type (eql 'string)) &rest args)


@@ -526,7 +536,7 @@ (defmethod from-alien-form (string (type (eql 'string)) &rest args)
   `(let ((string ,string))
     (unless (null-pointer-p string)
       (prog1
   `(let ((string ,string))
     (unless (null-pointer-p string)
       (prog1

-         (c-call::%naturalize-c-string string)
+         (%naturalize-c-string string)

        (deallocate-memory string)))))
 
 (defmethod from-alien-function ((type (eql 'string)) &rest args)
        (deallocate-memory string)))))
 
 (defmethod from-alien-function ((type (eql 'string)) &rest args)


@@ -534,7 +544,7 @@ (defmethod from-alien-function ((type (eql 'string)) &rest args)
   #'(lambda (string)
       (unless (null-pointer-p string)
        (prog1
   #'(lambda (string)
       (unless (null-pointer-p string)
        (prog1

-           (c-call::%naturalize-c-string string)
+           (%naturalize-c-string string)

          (deallocate-memory string)))))
 
 (defmethod cleanup-form (string (type (eql 'string)) &rest args)
          (deallocate-memory string)))))
 
 (defmethod cleanup-form (string (type (eql 'string)) &rest args)


@@ -553,13 +563,14 @@ (defmethod copy-from-alien-form (string (type (eql 'string)) &rest args)
   (declare (ignore type args))
   `(let ((string ,string))
     (unless (null-pointer-p string)
   (declare (ignore type args))
   `(let ((string ,string))
     (unless (null-pointer-p string)

-      (c-call::%naturalize-c-string string))))
+      (%naturalize-c-string string))))
+

 
 (defmethod copy-from-alien-function ((type (eql 'string)) &rest args)
   (declare (ignore type args))
   #'(lambda (string)
       (unless (null-pointer-p string)
 
 (defmethod copy-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))))
+       (%naturalize-c-string string))))

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


@@ -567,14 +578,14 @@ (defmethod writer-function ((type (eql 'string)) &rest args)
       (assert (null-pointer-p (sap-ref-sap location offset)))
       (setf (sap-ref-sap location offset)
        (copy-memory
       (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)))
+       (vector-sap (coerce string 'simple-base-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))
        (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)))))
+       (%naturalize-c-string (sap-ref-sap location offset)))))

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


@@ -756,7 +767,7 @@ (defmethod to-alien-function ((type (eql 'null)) &rest args)
 
 (defmethod alien-type ((type (eql 'nil)) &rest args)
   (declare (ignore type args))
 
 (defmethod alien-type ((type (eql 'nil)) &rest args)
   (declare (ignore type args))

-  'c-call:void)
+  'void)

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


@@ -796,5 +807,3 @@ (defmethod reader-function ((type (eql 'copy-of)) &rest args)
 (defmethod writer-function ((type (eql 'copy-of)) &rest args)
   (declare (ignore type))
   (writer-function (first args)))
 (defmethod writer-function ((type (eql 'copy-of)) &rest args)
   (declare (ignore type))
   (writer-function (first args)))

-
-(export 'copy-of)

diff --git a/glib/gcallback.lisp b/glib/gcallback.lisp
index 0f3171b35e1ed0fe24caff01205981e6da698971..60d66525655c1edfc1fa79b891b07f3e49716b50 100644 (file)
--- a/glib/gcallback.lisp
+++ b/glib/gcallback.lisp
@@ -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
 
 ;; 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.18 2005/01/30 14:23:20 espen Exp $
+;; $Id: gcallback.lisp,v 1.19 2005/02/03 23:09:04 espen Exp $

 
 (in-package "GLIB")
 
 
 (in-package "GLIB")
 


@@ -28,9 +28,6 @@ (defun register-callback-function (function)
   (check-type function (or null symbol function))
   (register-user-data function))
 
   (check-type function (or null symbol function))
   (register-user-data function))
 

-(defcallback %destroy-user-data (nil (id unsigned-int))
-  (destroy-user-data id))
-

 ;; Callback marshal for regular signal handlers
 (defcallback closure-marshal (nil
                              (gclosure pointer)
 ;; Callback marshal for regular signal handlers
 (defcallback closure-marshal (nil
                              (gclosure pointer)


@@ -92,7 +89,7 @@ (defbinding (timeout-add "g_timeout_add_full")
   (interval unsigned-int)
   ((callback source-callback-marshal) pointer)
   ((register-callback-function function) unsigned-long)
   (interval unsigned-int)
   ((callback source-callback-marshal) pointer)
   ((register-callback-function function) unsigned-long)

-  ((callback %destroy-user-data) pointer))
+  ((callback user-data-destroy-func) pointer))

 
 (defun timeout-remove (timeout)
   (source-remove timeout))
 
 (defun timeout-remove (timeout)
   (source-remove timeout))


@@ -102,7 +99,7 @@ (defbinding (idle-add "g_idle_add_full")
   (priority int)
   ((callback source-callback-marshal) pointer)
   ((register-callback-function function) unsigned-long)
   (priority int)
   ((callback source-callback-marshal) pointer)
   ((register-callback-function function) unsigned-long)

-  ((callback %destroy-user-data) pointer))
+  ((callback user-data-destroy-func) pointer))

 
 (defun idle-remove (idle)
   (source-remove idle))
 
 (defun idle-remove (idle)
   (source-remove idle))


@@ -203,7 +200,7 @@ (defbinding signal-add-emission-hook (type signal function &key (detail 0))
   (detail quark)
   ((callback signal-emission-hook) pointer)
   ((register-callback-function function) unsigned-int)
   (detail quark)
   ((callback signal-emission-hook) pointer)
   ((register-callback-function function) unsigned-int)

-  ((callback %destroy-user-data) pointer))
+  ((callback user-data-destroy-func) pointer))

 
 (defbinding signal-remove-emission-hook (type signal hook-id) nil
   ((ensure-signal-id-from-type signal type) unsigned-int)
 
 (defbinding signal-remove-emission-hook (type signal hook-id) nil
   ((ensure-signal-id-from-type signal type) unsigned-int)


@@ -215,7 +212,7 @@ (defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
   (instance ginstance)
   ((ensure-signal-id signal-id instance) unsigned-int)
   ((or detail 0) quark)
   (instance ginstance)
   ((ensure-signal-id signal-id instance) unsigned-int)
   ((or detail 0) quark)

-  (may-be-blocked boolean))
+  (blocked boolean))

     
 (defbinding %signal-connect-closure-by-id () unsigned-int
   (instance ginstance)
     
 (defbinding %signal-connect-closure-by-id () unsigned-int
   (instance ginstance)


@@ -252,7 +249,7 @@ (defun make-callback-closure (function)
     (values
      (callback-closure-new 
       callback-id (callback closure-marshal) 
     (values
      (callback-closure-new 
       callback-id (callback closure-marshal) 

-      (callback %destroy-user-data))
+      (callback user-data-destroy-func))

      callback-id)))
 
 (defmethod create-callback-function ((gobject gobject) function arg1)
      callback-id)))
 
 (defmethod create-callback-function ((gobject gobject) function arg1)


@@ -346,14 +343,13 @@ (defun signal-emit (object signal &rest args)
   (apply #'signal-emit-with-detail object signal 0 args))
 
 
   (apply #'signal-emit-with-detail object signal 0 args))
 
 

-

 ;;; Message logging
 
 ;;; Message logging
 

-;; TODO: define and signal conditions based on log-level
+TODO: define and signal conditions based on log-level

 
 

-(def-callback log-handler (c-call:void (domain c-call:c-string) 
-                                      (log-level c-call:int) 
-                                      (message c-call:c-string))
+(defcallback log-handler (nil (domain (copy-of string))
+                         (log-level int)
+                         (message (copy-of string)))

   (error "~A: ~A" domain message))
 
 (setf (extern-alien "log_handler" system-area-pointer) (callback log-handler))
   (error "~A: ~A" domain message))
 
 (setf (extern-alien "log_handler" system-area-pointer) (callback log-handler))

diff --git a/glib/ginterface.lisp b/glib/ginterface.lisp
index 4b654559e3d8cf1b61cbb47902d5c1bb452ce445..542351c61eb56de34187bb394a511475ccee1214 100644 (file)
--- a/glib/ginterface.lisp
+++ b/glib/ginterface.lisp
@@ -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
 
 ;; 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.6 2005/02/01 15:24:52 espen Exp $
+;; $Id: ginterface.lisp,v 1.7 2005/02/03 23:09:04 espen Exp $

 
 (in-package "GLIB")
 
 
 (in-package "GLIB")
 


@@ -65,8 +65,7 @@ (defmethod shared-initialize ((class ginterface-class) names
   (call-next-method))
 
 
   (call-next-method))
 
 

-(defmethod validate-superclass
-    ((class ginterface-class) (super pcl::standard-class))
+(defmethod validate-superclass ((class ginterface-class) (super standard-class))

   (subtypep (class-name super) 'ginterface))
 
 
   (subtypep (class-name super) 'ginterface))
 
 

diff --git a/glib/glib.asd b/glib/glib.asd
index c779bec03c73b41760948abeb50e077af7d0bc43..814930c2f956a8542ec869bf2b229b0631eb12ff 100644 (file)
--- a/glib/glib.asd
+++ b/glib/glib.asd
@@ -5,7 +5,11 @@
 (defpackage "GLIB-SYSTEM"
   (:use "COMMON-LISP" "ASDF" "PKG-CONFIG"))
 
 (defpackage "GLIB-SYSTEM"
   (:use "COMMON-LISP" "ASDF" "PKG-CONFIG"))
 

-(ext:unlock-all-packages)
+#+cmu(ext:unlock-all-packages)
+#+sbcl
+(progn
+  (sb-ext:unlock-package "COMMON-LISP")
+  (sb-ext:unlock-package "SB-PCL"))

 
 ;;; Better put this in ~/.cmucl-init.lisp or some other file read at startup
 ;; (setf
 
 ;;; Better put this in ~/.cmucl-init.lisp or some other file read at startup
 ;; (setf


@@ -22,28 +26,23 @@
 (defsystem glib
     :depends-on (clg-tools)
     :components ((:file "defpackage")
 (defsystem glib
     :depends-on (clg-tools)
     :components ((:file "defpackage")

-                (:file "pcl")
-                ;; It is necessary to load this before libglib-2.0.so,
-                ;; otherwise our implementation of g_logv won't be
-                ;; used by the library
-                (:unix-dso "alien"
-                 :components ((:c-source-file "callback"
-                               :definitions ("CMUCL")
-                               :include-paths (#.*cmucl-include-path*)
-                               :cflags #.(pkg-cflags "glib-2.0"))
-                              (:c-source-file "gobject" 
-                               :cflags #.(pkg-cflags "glib-2.0"))))
+                #+cmu(:file "pcl")

                 (:library "libglib-2.0" 
                 (:library "libglib-2.0" 

-                           :libdir #.(pkg-variable "glib-2.0" "libdir")
-                           :depends-on ("alien"))
+                           :libdir #.(pkg-variable "glib-2.0" "libdir"))

                 (:library "libgobject-2.0" 
                            :libdir #.(pkg-variable "glib-2.0" "libdir")
                            :depends-on ("libglib-2.0"))
                 (:library "libgobject-2.0" 
                            :libdir #.(pkg-variable "glib-2.0" "libdir")
                            :depends-on ("libglib-2.0"))

+                (:unix-dso "alien"
+                 :components ((:c-source-file "callback"
+                               :cflags #.(pkg-cflags "glib-2.0"))
+                              (:c-source-file "gobject" 
+                               :cflags #.(pkg-cflags "glib-2.0")))
+                 :depends-on ("libgobject-2.0"))

                 (:file "utils" :depends-on ("defpackage"))
                 (:file "ffi" :depends-on ("utils"))
                 (:file "glib" :depends-on ("ffi" "libglib-2.0"))
                 (:file "utils" :depends-on ("defpackage"))
                 (:file "ffi" :depends-on ("utils"))
                 (:file "glib" :depends-on ("ffi" "libglib-2.0"))

-                (:file "proxy" :depends-on ("pcl" "glib"))
-                (:file "gtype" :depends-on ("proxy" "libgobject-2.0"))
+                (:file "proxy" :depends-on (#+cmu"pcl" "glib"))
+                (:file "gtype" :depends-on ("proxy" "alien" "libgobject-2.0"))

                 (:file "gboxed" :depends-on ("gtype"))
                 (:file "genums" :depends-on ("gtype"))
                 (:file "gparam" :depends-on ("genums"))
                 (:file "gboxed" :depends-on ("gtype"))
                 (:file "genums" :depends-on ("gtype"))
                 (:file "gparam" :depends-on ("genums"))

diff --git a/glib/glib.lisp b/glib/glib.lisp
index 33ead6bebb018b6c0ebfe0b2a5d7ce744719c3eb..59a4fb0595e3e7a8b7b1c9ee636f1316b5b6b6c0 100644 (file)
--- a/glib/glib.lisp
+++ b/glib/glib.lisp
@@ -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
 
 ;; 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.24 2005/01/30 14:26:41 espen Exp $
+;; $Id: glib.lisp,v 1.25 2005/02/03 23:09:04 espen Exp $

 
 
 (in-package "GLIB")
 
 
 (in-package "GLIB")


@@ -38,7 +38,9 @@ (defbinding (deallocate-memory "g_free") () nil
 ;;   (declare (ignore address)))
 
 (defun copy-memory (from length &optional (to (allocate-memory length)))
 ;;   (declare (ignore address)))
 
 (defun copy-memory (from length &optional (to (allocate-memory length)))

-  (kernel:system-area-copy from 0 to 0 (* 8 length))
+  (;#+cmu kernel:system-area-copy 
+   ;#+sbcl sb-impl::system-area-copy 
+   system-area-copy from 0 to 0 (* 8 length))

   to)
 
 
   to)
 
 


@@ -305,7 +307,7 @@ (defmethod copy-from-alien-form (gslist (type (eql 'gslist)) &rest args)
   (destructuring-bind (element-type) args
     `(map-glist 'list #'identity ,gslist ',element-type)))
 
   (destructuring-bind (element-type) args
     `(map-glist 'list #'identity ,gslist ',element-type)))
 

-(defmethod from-alien-function ((type (eql 'gslist)) &rest args)
+(defmethod copy-from-alien-function ((type (eql 'gslist)) &rest args)

   (declare (ignore type))
   (destructuring-bind (element-type) args
     #'(lambda (gslist)
   (declare (ignore type))
   (destructuring-bind (element-type) args
     #'(lambda (gslist)

diff --git a/glib/gobject.lisp b/glib/gobject.lisp
index 67ae9132b1f10fc1b71bc4642702637979236f5b..621c370354954f59297602436859555950e94140 100644 (file)
--- a/glib/gobject.lisp
+++ b/glib/gobject.lisp
@@ -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
 
 ;; 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.30 2005/02/01 15:24:52 espen Exp $
+;; $Id: gobject.lisp,v 1.31 2005/02/03 23:09:04 espen Exp $

 
 (in-package "GLIB")
 
 
 (in-package "GLIB")
 


@@ -26,8 +26,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute)
   (defclass gobject-class (ginstance-class)
     ())
 
   (defclass gobject-class (ginstance-class)
     ())
 

-  (defmethod validate-superclass ((class gobject-class)
-                               (super pcl::standard-class))
+  (defmethod validate-superclass ((class gobject-class) (super standard-class))

 ;  (subtypep (class-name super) 'gobject)
     t))
 
 ;  (subtypep (class-name super) 'gobject)
     t))
 


@@ -109,10 +108,8 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de
     (when (and (not (slot-boundp slotd 'getter)) (slot-readable-p slotd))
       (setf 
        (slot-value slotd 'getter)
     (when (and (not (slot-boundp slotd 'getter)) (slot-readable-p slotd))
       (setf 
        (slot-value slotd 'getter)

-       (let ((reader nil))
+       (let ((reader (reader-function type)))

         #'(lambda (object)
         #'(lambda (object)

-            (unless reader
-              (setq reader (reader-function type))) ;(type-from-number type-number))))

             (let ((gvalue (gvalue-new type-number)))
               (%object-get-property object pname gvalue)
               (unwind-protect
             (let ((gvalue (gvalue-new type-number)))
               (%object-get-property object pname gvalue)
               (unwind-protect


@@ -122,10 +119,8 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de
     (when (and (not (slot-boundp slotd 'setter)) (slot-writable-p slotd))
       (setf 
        (slot-value slotd 'setter)
     (when (and (not (slot-boundp slotd 'setter)) (slot-writable-p slotd))
       (setf 
        (slot-value slotd 'setter)

-       (let ((writer nil))
+       (let ((writer (writer-function type)))

         #'(lambda (value object)
         #'(lambda (value object)

-            (unless writer
-              (setq writer (writer-function type))) ;(type-from-number type-number))))

             (let ((gvalue (gvalue-new type-number)))
               (funcall writer value gvalue +gvalue-value-offset+)
               (%object-set-property object pname gvalue)
             (let ((gvalue (gvalue-new type-number)))
               (funcall writer value gvalue +gvalue-value-offset+)
               (%object-set-property object pname gvalue)


@@ -277,9 +272,14 @@ (defbinding %object-set-qdata-full () nil
   (data unsigned-long)
   (destroy-marshal pointer))
 
   (data unsigned-long)
   (destroy-marshal pointer))
 

+(defcallback user-data-destroy-func (nil (id unsigned-int))
+  (destroy-user-data id))
+
+(export 'user-data-destroy-func)
+

 (defun (setf user-data) (data object key)
   (%object-set-qdata-full object (quark-intern key)
 (defun (setf user-data) (data object key)
   (%object-set-qdata-full object (quark-intern key)

-   (register-user-data data) (callback %destroy-user-data))
+   (register-user-data data) (callback user-data-destroy-func))

   data)
 
 ;; deprecated
   data)
 
 ;; deprecated

diff --git a/glib/gparam.lisp b/glib/gparam.lisp
index ea00893e93c6ccce5e3fae3cbea9bae62c9e7bd3..a0a0883c022b5c8be7e33593d3a75a546f7b84a9 100644 (file)
--- a/glib/gparam.lisp
+++ b/glib/gparam.lisp
@@ -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
 
 ;; 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.14 2005/01/12 13:31:57 espen Exp $
+;; $Id: gparam.lisp,v 1.15 2005/02/03 23:09:04 espen Exp $

 
 (in-package "GLIB")
 
 
 (in-package "GLIB")
 


@@ -57,7 +57,7 @@ (defun gvalue-free (gvalue &optional (unset-p t))
     (deallocate-memory gvalue)))
 
 (defun gvalue-type (gvalue)
     (deallocate-memory gvalue)))
 
 (defun gvalue-type (gvalue)

-  (type-from-number (system:sap-ref-32 gvalue 0)))
+  (type-from-number (sap-ref-32 gvalue 0)))

 
 (defun gvalue-get (gvalue)
   (funcall (reader-function (gvalue-type gvalue))
 
 (defun gvalue-get (gvalue)
   (funcall (reader-function (gvalue-type gvalue))


@@ -96,8 +96,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute)
   (defclass param-spec-class (ginstance-class)
     ())
 
   (defclass param-spec-class (ginstance-class)
     ())
 

-  (defmethod validate-superclass 
-      ((class param-spec-class) (super pcl::standard-class))
+  (defmethod validate-superclass  ((class param-spec-class) (super standard-class))

     t ;(subtypep (class-name super) 'param)
 ))
 
     t ;(subtypep (class-name super) 'param)
 ))
 

diff --git a/glib/gtype.lisp b/glib/gtype.lisp
index 46ea658559bd1b4379ae01c934134eaee8d7f637..3b9760af19296fbdaad8c74511eb9dc3160b9f37 100644 (file)
--- a/glib/gtype.lisp
+++ b/glib/gtype.lisp
@@ -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
 
 ;; 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: gtype.lisp,v 1.24 2005/02/01 15:24:52 espen Exp $
+;; $Id: gtype.lisp,v 1.25 2005/02/03 23:09:04 espen Exp $

 
 (in-package "GLIB")
 
 
 (in-package "GLIB")
 


@@ -56,13 +56,13 @@ (defmethod from-alien-function ((type (eql 'gtype)) &rest args)
       (type-from-number type-number)))
 
 (defmethod writer-function ((type (eql 'gtype)) &rest args)
       (type-from-number type-number)))
 
 (defmethod writer-function ((type (eql 'gtype)) &rest args)

-  (declare (ignore type))
+  (declare (ignore type args))

   (let ((writer (writer-function 'type-number)))
     #'(lambda (gtype location &optional (offset 0))
        (funcall writer (find-type-number gtype t) location offset))))
 
 (defmethod reader-function ((type (eql 'gtype)) &rest args)
   (let ((writer (writer-function 'type-number)))
     #'(lambda (gtype location &optional (offset 0))
        (funcall writer (find-type-number gtype t) location offset))))
 
 (defmethod reader-function ((type (eql 'gtype)) &rest args)

-  (declare (ignore type))
+  (declare (ignore type args))

   (let ((reader (reader-function 'type-number)))
     #'(lambda (location &optional (offset 0))
        (type-from-number (funcall reader location offset)))))
   (let ((reader (reader-function 'type-number)))
     #'(lambda (location &optional (offset 0))
        (type-from-number (funcall reader location offset)))))


@@ -131,7 +131,7 @@ (defun find-type-number (type &optional error)
        (or
        type-number
        (and error (error "Type not registered: ~A" type)))))
        (or
        type-number
        (and error (error "Type not registered: ~A" type)))))

-    (pcl::class (find-type-number (class-name type) error))))
+    (class (find-type-number (class-name type) error))))

  
 (defun type-from-number (type-number &optional error)
   (multiple-value-bind (type found)
  
 (defun type-from-number (type-number &optional error)
   (multiple-value-bind (type found)


@@ -160,12 +160,12 @@ (defun init-type (init)
    (mklist init)))
 
 (defun %init-types-in-library (pathname prefix ignore)
    (mklist init)))
 
 (defun %init-types-in-library (pathname prefix ignore)

-  (let ((process (ext:run-program
-                 "nm" (list "-D" (namestring (truename pathname)))
+  (let ((process (run-program
+                 "/usr/bin/nm" (list "--defined-only" "-D" (namestring (truename pathname)))

                  :output :stream :wait nil))
        (fnames ()))
     (labels ((read-symbols ()
                  :output :stream :wait nil))
        (fnames ()))
     (labels ((read-symbols ()

-              (let ((line (read-line (ext:process-output process) nil)))
+              (let ((line (read-line (process-output process) nil)))

                 (when line
                   (let ((symbol (subseq line 11)))
                     (when (and
                 (when line
                   (let ((symbol (subseq line 11)))
                     (when (and


@@ -176,7 +176,7 @@ (defun %init-types-in-library (pathname prefix ignore)
                       (push symbol fnames)))
                   (read-symbols)))))
       (read-symbols)
                       (push symbol fnames)))
                   (read-symbols)))))
       (read-symbols)

-      (ext:process-close process)
+      (process-close process)

       `(init-type ',fnames))))
 
 (defmacro init-types-in-library (filename &key (prefix "") ignore)
       `(init-type ',fnames))))
 
 (defmacro init-types-in-library (filename &key (prefix "") ignore)

diff --git a/glib/proxy.lisp b/glib/proxy.lisp
index a0e480876b3f04c25aa42ae3590b65d84b44fead..83a4a99b1bda0015b1ba5e2cd5c4bbfc0ea96c1b 100644 (file)
--- a/glib/proxy.lisp
+++ b/glib/proxy.lisp
@@ -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
 
 ;; 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.18 2005/01/12 13:35:19 espen Exp $
+;; $Id: proxy.lisp,v 1.19 2005/02/03 23:09:04 espen Exp $

 
 (in-package "GLIB")
 
 
 (in-package "GLIB")
 


@@ -35,7 +35,7 @@   (defclass effective-virtual-slot-definition (standard-effective-slot-definitio
     ((setter :reader slot-definition-setter :initarg :setter)
      (getter :reader slot-definition-getter :initarg :getter)
      (unbound :reader slot-definition-unbound :initarg :unbound)
     ((setter :reader slot-definition-setter :initarg :setter)
      (getter :reader slot-definition-getter :initarg :getter)
      (unbound :reader slot-definition-unbound :initarg :unbound)

-     (boundp :reader slot-definition-boundp :initarg :boundp)))
+     (boundp :reader slot-definition-boundp :initarg :boundp))))

   
   (defvar *unbound-marker* (gensym "UNBOUND-MARKER-"))
 
   
   (defvar *unbound-marker* (gensym "UNBOUND-MARKER-"))
 


@@ -47,7 +47,7 @@                                  (default *unbound-marker*))
                   instances)))
       (if object
          (slot-value object slot)
                   instances)))
       (if object
          (slot-value object slot)

-         default))))
+         default)));)

 
   
 
 
   
 


@@ -223,26 +223,26 @@ (defvar *instance-cache* (make-hash-table :test #'eql))
 
 (defun cache-instance (instance)
   (setf
 
 (defun cache-instance (instance)
   (setf

-   (gethash (system:sap-int (proxy-location instance)) *instance-cache*)
-   (ext:make-weak-pointer instance)))
+   (gethash (sap-int (proxy-location instance)) *instance-cache*)
+   (make-weak-pointer instance)))

 
 (defun find-cached-instance (location)
 
 (defun find-cached-instance (location)

-  (let ((ref (gethash (system:sap-int location) *instance-cache*)))
+  (let ((ref (gethash (sap-int location) *instance-cache*)))

     (when ref
     (when ref

-      (ext:weak-pointer-value ref))))
+      (weak-pointer-value ref))))

 
 (defun instance-cached-p (location)
 
 (defun instance-cached-p (location)

-  (gethash (system:sap-int location) *instance-cache*))
+  (gethash (sap-int location) *instance-cache*))

 
 (defun remove-cached-instance (location)
 
 (defun remove-cached-instance (location)

-  (remhash (system:sap-int location) *instance-cache*))
+  (remhash (sap-int location) *instance-cache*))

 
 ;; For debuging
 (defun cached-instances ()
   (let ((instances ()))
     (maphash #'(lambda (location ref)
                 (declare (ignore location))
 
 ;; For debuging
 (defun cached-instances ()
   (let ((instances ()))
     (maphash #'(lambda (location ref)
                 (declare (ignore location))

-                (push (ext:weak-pointer-value ref) instances))
+                (push (weak-pointer-value ref) instances))

             *instance-cache*)
     instances))
                        
             *instance-cache*)
     instances))
                        


@@ -283,7 +283,7 @@ (defmethod initialize-instance :around ((instance proxy) &key location)
       (setf (slot-value instance 'location) location)      
     (call-next-method))
   (cache-instance instance)
       (setf (slot-value instance 'location) location)      
     (call-next-method))
   (cache-instance instance)

-  (ext:finalize instance (instance-finalizer instance))
+  (finalize instance (instance-finalizer instance))

   instance)
 
 (defmethod instance-finalizer ((instance proxy))
   instance)
 
 (defmethod instance-finalizer ((instance proxy))


@@ -298,6 +298,10 @@ (defmethod instance-finalizer ((instance proxy))
 
 ;;;; Metaclass used for subclasses of proxy
 
 
 ;;;; Metaclass used for subclasses of proxy
 

+(defgeneric most-specific-proxy-superclass (class))
+(defgeneric direct-proxy-superclass (class))
+  
+

 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defclass proxy-class (virtual-slots-class)
     ((size :reader proxy-instance-size)))
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defclass proxy-class (virtual-slots-class)
     ((size :reader proxy-instance-size)))


@@ -309,13 +313,12 @@   (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
   (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
     ((offset :reader slot-definition-offset :initarg :offset)))
 
   (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
     ((offset :reader slot-definition-offset :initarg :offset)))
 

-

   (defmethod most-specific-proxy-superclass ((class proxy-class))
     (find-if
      #'(lambda (class)
         (subtypep (class-name class) 'proxy))
      (cdr (compute-class-precedence-list class))))
   (defmethod most-specific-proxy-superclass ((class proxy-class))
     (find-if
      #'(lambda (class)
         (subtypep (class-name class) 'proxy))
      (cdr (compute-class-precedence-list class))))

-  
+

   (defmethod direct-proxy-superclass ((class proxy-class))
     (find-if
      #'(lambda (class)
   (defmethod direct-proxy-superclass ((class proxy-class))
     (find-if
      #'(lambda (class)


@@ -448,7 +451,7 @@ (defmethod copy-to-alien-form (instance (class proxy-class) &rest args)
   `(reference-foreign ',(class-name class) (proxy-location ,instance)))
 
 (defmethod copy-to-alien-function ((class proxy-class) &rest args)
   `(reference-foreign ',(class-name class) (proxy-location ,instance)))
 
 (defmethod copy-to-alien-function ((class proxy-class) &rest args)

-  (declare (ignore class args))
+  (declare (ignore args))

   #'(lambda (instance)
       (reference-foreign class (proxy-location instance))))
 
   #'(lambda (instance)
       (reference-foreign class (proxy-location instance))))
 

diff --git a/glib/utils.lisp b/glib/utils.lisp
index d3722cfaf247cb6fdba310c06985a7fddf289a16..896a9eea3aa333c01a88b705faf91ec4fab3c311 100644 (file)
--- a/glib/utils.lisp
+++ b/glib/utils.lisp
@@ -15,16 +15,18 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
 ;; 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: utils.lisp,v 1.2 2004/12/05 16:59:58 espen Exp $
+;; $Id: utils.lisp,v 1.3 2005/02/03 23:09:05 espen Exp $

 
 
 (in-package "GLIB")
 
 (defun type-expand-1 (form)
   (let ((def (cond ((symbolp form)
 
 
 (in-package "GLIB")
 
 (defun type-expand-1 (form)
   (let ((def (cond ((symbolp form)

-                   (kernel::info type expander form))
+                   #+cmu(kernel::info type expander form)
+                   #+sbcl(sb-impl::info :type :expander form))

                   ((and (consp form) (symbolp (car form)))
                   ((and (consp form) (symbolp (car form)))

-                   (kernel::info type expander (car form)))
+                   #+cmu(kernel::info type expander (car form))
+                   #+sbcl(sb-impl::info :type :expander (car form)))

                   (t nil))))
     (if def
        (values (funcall def (if (consp form) form (list form))) t)
                   (t nil))))
     (if def
        (values (funcall def (if (consp form) form (list form))) t)


@@ -45,12 +47,13 @@ (defun type-expand-to (type form)
 (defmacro with-gc-disabled (&body body)
   (let ((gc-inhibit (make-symbol "GC-INHIBIT")))
     `(progn
 (defmacro with-gc-disabled (&body body)
   (let ((gc-inhibit (make-symbol "GC-INHIBIT")))
     `(progn

-       (let ((,gc-inhibit lisp::*gc-inhibit*))
-        (ext:gc-off)
+       (let ((,gc-inhibit #+cmu lisp::*gc-inhibit* 
+                         #+sbcl sb-impl::*gc-inhibit*))
+        (gc-off)

                 (unwind-protect
             ,@body
           (unless ,gc-inhibit
                 (unwind-protect
             ,@body
           (unless ,gc-inhibit

-            (ext:gc-on)))))))
+            (gc-on)))))))

 
 (defun mklist (obj)
   (if (and obj (atom obj)) (list obj) obj))
 
 (defun mklist (obj)
   (if (and obj (atom obj)) (list obj) obj))


@@ -117,8 +120,6 @@ (defun intersection-p (list1 list2 &key (test #'eq))
 
 (defun split-string (string delimiter)
   (declare (simple-string string) (character delimiter))
 
 (defun split-string (string delimiter)
   (declare (simple-string string) (character delimiter))

-  (check-type string string)
-  (check-type delimiter character)

   (let ((pos (position delimiter string)))
    (if (not pos)
         (list string)
   (let ((pos (position delimiter string)))
    (if (not pos)
         (list string)


@@ -128,8 +129,6 @@ (defun split-string (string delimiter)
 
 (defun split-string-if (string predicate)
   (declare (simple-string string))
 
 (defun split-string-if (string predicate)
   (declare (simple-string string))

-  (check-type string string)
-  (check-type predicate (or symbol function))

   (let ((pos (position-if predicate string :start 1)))
     (if (not pos)
         (list string)
   (let ((pos (position-if predicate string :start 1)))
     (if (not pos)
         (list string)

diff --git a/gtk/defpackage.lisp b/gtk/defpackage.lisp
index d336460d0891abbd1fe924211b791d29ecdacffe..d80da7f8054b03f43bf53c3b174cca578d23325d 100644 (file)
--- a/gtk/defpackage.lisp
+++ b/gtk/defpackage.lisp
@@ -19,13 +19,16 @@
 
 
 (defpackage "GTK"
 
 
 (defpackage "GTK"

-  (:use "GLIB" "COMMON-LISP" "PCL" "ALIEN" "AUTOEXPORT")
+  (:use "GLIB" "COMMON-LISP" "AUTOEXPORT")
+  #+cmu(:use "PCL" "EXT")
+  #+sbcl(:use "SB-PCL" "SB-EXT")

   (:shadowing-import-from "GLIB" "DEFTYPE")
   (:shadowing-import-from "GLIB" "DEFTYPE")

-  (:import-from "PCL"
-          "LOCATION" "ALLOCATION" "DIRECT-SLOTS" 
-          "READER-FUNCTION" "WRITER-FUNCTION" "BOUNDP-FUNCTION" 
-          "INITIALIZE-INTERNAL-SLOT-FUNCTIONS"
-          "COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS")
+  (:import-from #+cmu"PCL" #+sbcl"SB-PCL"
+          "ADD-READER-METHOD" "ADD-WRITER-METHOD")
+  (:import-from #+cmu"SYSTEM" #+sbcl"SB-SYS" "SAP-INT" "ADD-FD-HANDLER")
+  (:import-from #+cmu"LISP" #+sbcl"SB-IMPL"
+          "*PERIODIC-POLLING-FUNCTION*" "*MAX-EVENT-TO-SEC*" 
+          "*MAX-EVENT-TO-USEC*")               

   (:export "*CLG-VERSION*")
   (:export "OBJECT" "OBJECT-ARG" "OBJECT-SINK")
   (:export "REGISTER-USER-DATA" "FIND-USER-DATA" "REGISTER-CALLBACK-FUNCTION"
   (:export "*CLG-VERSION*")
   (:export "OBJECT" "OBJECT-ARG" "OBJECT-SINK")
   (:export "REGISTER-USER-DATA" "FIND-USER-DATA" "REGISTER-CALLBACK-FUNCTION"


@@ -36,4 +39,3 @@ (defpackage "GTK"
   (:export "SIGNAL-EMIT-STOP" "SIGNAL-CONNECT" "SIGNAL-DISCONNECT"
           "SIGNAL-HANDLER-BLOCK" "SIGNAL-HANDLER-UNBLOCK")
   (:export "OBJECT-CLASS" "WIDGET-CLASS" "CONTAINER-CLASS" "CHILD-CLASS"))
   (:export "SIGNAL-EMIT-STOP" "SIGNAL-CONNECT" "SIGNAL-DISCONNECT"
           "SIGNAL-HANDLER-BLOCK" "SIGNAL-HANDLER-UNBLOCK")
   (:export "OBJECT-CLASS" "WIDGET-CLASS" "CONTAINER-CLASS" "CHILD-CLASS"))

- 
\ No newline at end of file

diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp
index 99302c511e556a86af976a57f7f5cad41e01705b..d7ce35c1ff29a035befc5286bc1f23c68e875c33 100644 (file)
--- a/gtk/gtk.lisp
+++ b/gtk/gtk.lisp
@@ -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
 
 ;; 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.31 2005/01/13 00:17:55 espen Exp $
+;; $Id: gtk.lisp,v 1.32 2005/02/03 23:09:07 espen Exp $

 
 
 (in-package "GTK")
 
 
 (in-package "GTK")


@@ -56,11 +56,10 @@ (defun clg-init (&optional display)
     (gtk-init)
     (prog1
        (gdk:display-open display)
     (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))))
+      (add-fd-handler (gdk:display-connection-number) :input #'main-iterate-all)
+      (setq *periodic-polling-function* #'main-iterate-all)
+      (setq *max-event-to-sec* 0)
+      (setq *max-event-to-usec* 1000))))

 
 
 ;;; Acccel group
 
 
 ;;; Acccel group


@@ -117,7 +116,7 @@ (defun accel-groups-activate (object accelerator)
 (defbinding accel-groups-from-object () (gslist accel-groups)
   (object gobject))
 
 (defbinding accel-groups-from-object () (gslist accel-groups)
   (object gobject))
 

-(defbinding accelerator-valid-p (key &optional mask) boolean
+(defbinding accelerator-valid-p (key &optional modifiers) boolean

   (key unsigned-int)
   (modifiers gdk:modifier-type))
 
   (key unsigned-int)
   (modifiers gdk:modifier-type))
 


@@ -379,10 +378,6 @@ (defbinding check-menu-item-toggled () nil
   (check-menu-item check-menu-item))
 
 
   (check-menu-item check-menu-item))
 
 

-
-;;; Clipboard
-
-

 ;;; Color selection
 
 (defbinding (color-selection-is-adjusting-p
 ;;; Color selection
 
 (defbinding (color-selection-is-adjusting-p


@@ -622,7 +617,7 @@ (defbinding entry-completion-set-match-func (completion function) nil
   (completion entry-completion)
   ((callback %entry-completion-match-func) pointer)
   ((register-callback-function function) unsigned-int)
   (completion entry-completion)
   ((callback %entry-completion-match-func) pointer)
   ((register-callback-function function) unsigned-int)

-  ((callback %destroy-user-data) pointer))
+  ((callback user-data-destroy-func) pointer))

 
 (defbinding entry-completion-complete () nil
   (completion entry-completion))
 
 (defbinding entry-completion-complete () nil
   (completion entry-completion))


@@ -762,12 +757,12 @@ (defbinding file-filter-add-pixbuf-formats () nil
 
 (def-callback-marshal %file-filter-func (boolean file-filter-info))
 
 
 (def-callback-marshal %file-filter-func (boolean file-filter-info))
 

-(defbinding file-filter-add-custom () nil
+(defbinding file-filter-add-custom (filter needed function) nil

   (filter file-filter)
   (needed file-filter-flags)
   ((callback %file-filter-func) pointer)
   ((register-callback-function function) unsigned-int)
   (filter file-filter)
   (needed file-filter-flags)
   ((callback %file-filter-func) pointer)
   ((register-callback-function function) unsigned-int)

-  ((callback %destroy-user-data) pointer))
+  ((callback user-data-destroy-func) pointer))

 
 (defbinding file-filter-get-needed () file-filter-flags
   (filter file-filter))
 
 (defbinding file-filter-get-needed () file-filter-flags
   (filter file-filter))

diff --git a/gtk/gtkaction.lisp b/gtk/gtkaction.lisp
index c0315649ec2c3e6b514086a224b5a8098181dbb3..0b321db9f5b098500fedbbeb2e27dfabfff49959 100644 (file)
--- a/gtk/gtkaction.lisp
+++ b/gtk/gtkaction.lisp
@@ -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
 
 ;; 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: gtkaction.lisp,v 1.2 2004/12/17 00:13:33 espen Exp $
+;; $Id: gtkaction.lisp,v 1.3 2005/02/03 23:09:09 espen Exp $

 
 
 (in-package "GTK")
 
 
 (in-package "GTK")


@@ -81,7 +81,7 @@ (defbinding action-group-remove-action () nil
 
 (defmethod initialize-instance ((action radio-action) &key group value)
   (call-next-method)
 
 (defmethod initialize-instance ((action radio-action) &key group value)
   (call-next-method)

-  (setf (slot-value action '%value) (system:sap-int (proxy-location action)))
+  (setf (slot-value action '%value) (sap-int (proxy-location action)))

   (setf (object-data action 'radio-action-value) value)
   (when group
     (radio-action-add-to-group action group)))
   (setf (object-data action 'radio-action-value) value)
   (when group
     (radio-action-add-to-group action group)))

diff --git a/gtk/gtkobject.lisp b/gtk/gtkobject.lisp
index cbfb9669e0033122cc7508819f9017bb1cfdc6ce..191b8e60cf197cd517f24a60265f1b2fd956f289 100644 (file)
--- a/gtk/gtkobject.lisp
+++ b/gtk/gtkobject.lisp
@@ -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
 
 ;; 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.22 2005/02/01 15:24:56 espen Exp $
+;; $Id: gtkobject.lisp,v 1.23 2005/02/03 23:09:09 espen Exp $

 
 
 (in-package "GTK")
 
 
 (in-package "GTK")


@@ -60,11 +60,11 @@ (defmethod initialize-instance :around ((object %object) &rest initargs)
 (defbinding %object-sink () nil
   (object %object))
 
 (defbinding %object-sink () nil
   (object %object))
 

-;;;; Main loop, timeouts and idle functions
+;;;; Main loop and event handling

 
 (declaim (inline events-pending-p main-iteration))
 
 
 (declaim (inline events-pending-p main-iteration))
 

-(defbinding (events-pending-p "gtk_events_pending") () boolean)
+(defbinding events-pending-p () boolean)

 
 (defbinding get-current-event () gdk:event)
 
 
 (defbinding get-current-event () gdk:event)
 


@@ -82,9 +82,9 @@ (defbinding main-iteration-do (&optional (blocking t)) boolean
 
 (defun main-iterate-all (&rest args)
   (declare (ignore args))
 
 (defun main-iterate-all (&rest args)
   (declare (ignore args))

-  (when (events-pending-p)
-    (main-iteration-do nil)
-    (main-iterate-all)))
+  (loop
+   while (events-pending-p)
+   do (main-iteration-do nil)))

 
 
 ;;;; Metaclass for child classes
 
 
 ;;;; Metaclass for child classes


@@ -126,7 +126,8 @@ (defmethod compute-effective-slot-definition-initargs ((class child-class) direc
     (call-next-method)))
 
 (progn
     (call-next-method)))
 
 (progn

-  (declaim (optimize (ext:inhibit-warnings 3)))
+  #+cmu(declaim (optimize (inhibit-warnings 3)))
+  #+sbcl(declaim (muffle-conditions compiler-note))

   (defun %container-child-get-property (parent child pname gvalue))
   (defun %container-child-set-property (parent child pname gvalue)))
 
   (defun %container-child-get-property (parent child pname gvalue))
   (defun %container-child-set-property (parent child pname gvalue)))
 


@@ -158,7 +159,7 @@ (defmethod initialize-internal-slot-functions ((slotd effective-child-slot-defin
   (call-next-method)))
 
 
   (call-next-method)))
 
 

-(defmethod pcl::add-reader-method ((class child-class) generic-function slot-name)
+(defmethod add-reader-method ((class child-class) generic-function slot-name)

   (add-method
    generic-function
    (make-instance 'standard-method
   (add-method
    generic-function
    (make-instance 'standard-method


@@ -168,7 +169,7 @@ (defmethod pcl::add-reader-method ((class child-class) generic-function slot-nam
                  (declare (ignore next-methods))
                  (child-property-value (first args) slot-name)))))
 
                  (declare (ignore next-methods))
                  (child-property-value (first args) slot-name)))))
 

-(defmethod pcl::add-writer-method
+(defmethod add-writer-method

     ((class child-class) generic-function slot-name)
   (add-method
    generic-function
     ((class child-class) generic-function slot-name)
   (add-method
    generic-function


@@ -181,7 +182,7 @@ (defmethod pcl::add-writer-method
                    (setf (child-property-value widget slot-name) value))))))
 
 
                    (setf (child-property-value widget slot-name) value))))))
 
 

-(defmethod validate-superclass ((class child-class) (super pcl::standard-class))
+(defmethod validate-superclass ((class child-class) (super standard-class))

   ;(subtypep (class-name super) 'container-child)
   t)
 
   ;(subtypep (class-name super) 'container-child)
   t)
 

diff --git a/gtk/gtktext.lisp b/gtk/gtktext.lisp
index 8b67ff9b6bd5402f854df25104aad35cf11cc38c..f0a42c80469cea5433ccef39b966f3ab58e558d1 100644 (file)
--- a/gtk/gtktext.lisp
+++ b/gtk/gtktext.lisp
@@ -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
 
 ;; 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: gtktext.lisp,v 1.4 2005/01/12 13:36:40 espen Exp $
+;; $Id: gtktext.lisp,v 1.5 2005/02/03 23:09:09 espen Exp $

 
 
 (in-package "GTK")
 
 
 (in-package "GTK")


@@ -563,17 +563,17 @@ (defbinding text-iter-backward-to-tag-toggle (iter tag) boolean
   (iter text-iter)
   ((%ensure-tag tag iter) text-tag))
 
   (iter text-iter)
   ((%ensure-tag tag iter) text-tag))
 

-(def-callback-marshal %text-char-prediacte (boolean int))
+(def-callback-marshal %text-char-predicate (boolean int))

 
 (defbinding text-iter-forward-find-char (iter predicate &optional limit) boolean
   (iter text-iter)
 
 (defbinding text-iter-forward-find-char (iter predicate &optional limit) boolean
   (iter text-iter)

-  ((callback %text-char-redicate) pointer)
+  ((callback %text-char-predicate) pointer)

   ((register-callback-function predicate) unsigned-int)
   (limit (or null text-iter)))
 
 (defbinding text-iter-backward-find-char (iter predicate &optional limit) boolean
   (iter text-iter)
   ((register-callback-function predicate) unsigned-int)
   (limit (or null text-iter)))
 
 (defbinding text-iter-backward-find-char (iter predicate &optional limit) boolean
   (iter text-iter)

-  ((callback %text-char-redicate) pointer)
+  ((callback %text-char-predicate) pointer)

   ((register-callback-function predicate) unsigned-int)
   (limit (or null text-iter)))
 
   ((register-callback-function predicate) unsigned-int)
   (limit (or null text-iter)))
 

diff --git a/gtk/gtktree.lisp b/gtk/gtktree.lisp
index 861fdf517358640c2424ee958388af9ba44ef333..8025a15ed49befda8fe0a30ca20714a0f6da7fa4 100644 (file)
--- a/gtk/gtktree.lisp
+++ b/gtk/gtktree.lisp
@@ -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
 
 ;; 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: gtktree.lisp,v 1.5 2005/01/06 21:50:11 espen Exp $
+;; $Id: gtktree.lisp,v 1.6 2005/02/03 23:09:09 espen Exp $

 
 
 (in-package "GTK")
 
 
 (in-package "GTK")


@@ -61,7 +61,7 @@ (defbinding cell-layout-set-cell-data-func (cell-layout cell function) nil
   (cell cell-renderer)
   ((callback %cell-layout-data-func) pointer)
   ((register-callback-function function) unsigned-int)
   (cell cell-renderer)
   ((callback %cell-layout-data-func) pointer)
   ((register-callback-function function) unsigned-int)

-  ((callback %destroy-user-data) pointer))
+  ((callback user-data-destroy-func) pointer))

 
 (defbinding cell-layout-clear-attributes () nil
   (cell-layout cell-layout)
 
 (defbinding cell-layout-clear-attributes () nil
   (cell-layout cell-layout)


@@ -337,7 +337,7 @@ (defbinding tree-model-iter-n-children () int
   (iter tree-iter))
 
 (defbinding tree-model-iter-nth-child
   (iter tree-iter))
 
 (defbinding tree-model-iter-nth-child

-    (tree-model parent &optional (iter (make-instance 'tree-iter))) boolean
+    (tree-model parent n &optional (iter (make-instance 'tree-iter))) boolean

   (tree-model tree-model)
   (iter tree-iter :return)
   (parent (or null tree-iter))
   (tree-model tree-model)
   (iter tree-iter :return)
   (parent (or null tree-iter))


@@ -466,7 +466,7 @@ (defbinding tree-selection-set-select-function (selection function) nil
   (selection tree-selection)
   ((callback %tree-selection-func) pointer)
   ((register-callback-function function) unsigned-int)
   (selection tree-selection)
   ((callback %tree-selection-func) pointer)
   ((register-callback-function function) unsigned-int)

-  ((callback %destroy-user-data) pointer))
+  ((callback user-data-destroy-func) pointer))

 
 (defbinding tree-selection-get-selected 
     (selection &optional (iter (make-instance 'tree-iter))) boolean
 
 (defbinding tree-selection-get-selected 
     (selection &optional (iter (make-instance 'tree-iter))) boolean


@@ -589,7 +589,7 @@ (defbinding %tree-store-insert-before () nil
   (parent (or null tree-iter))
   (sibling (or null tree-iter)))
 
   (parent (or null tree-iter))
   (sibling (or null tree-iter)))
 

-(defun tree-store-insert-after 
+(defun tree-store-insert-before 

     (store parent sibling &optional data (iter (make-instance 'tree-iter)))
   (%tree-store-insert-before store iter parent sibling)
   (when data (%tree-model-set store iter data))
     (store parent sibling &optional data (iter (make-instance 'tree-iter)))
   (%tree-store-insert-before store iter parent sibling)
   (when data (%tree-model-set store iter data))


@@ -685,7 +685,7 @@ (defbinding tree-view-remove-column () int
   (tree-view tree-view)
   (tree-view-column tree-view-column))
 
   (tree-view tree-view)
   (tree-view-column tree-view-column))
 

-(defbinding tree-view-insert-column (view columnd position) int
+(defbinding tree-view-insert-column (view column position) int

   (view tree-view)
   (column tree-view-column)
   ((if (eq position :end) -1 position) int))
   (view tree-view)
   (column tree-view-column)
   ((if (eq position :end) -1 position) int))

diff --git a/pango/defpackage.lisp b/pango/defpackage.lisp
index 8054154bcad796c9d15de7748e0fac83bc20471f..5a52ace1047d67b2c83139334c481f6078568d3b 100644 (file)
--- a/pango/defpackage.lisp
+++ b/pango/defpackage.lisp
@@ -1,6 +1,3 @@
 (defpackage "PANGO"
 (defpackage "PANGO"

-  (:use "GLIB" "COMMON-LISP" "AUTOEXPORT")
-  (:shadowing-import-from "PCL"
-   "CLASS-NAME" "CLASS-OF" "FIND-CLASS"))
-
+  (:use "GLIB" "COMMON-LISP" "AUTOEXPORT"))

 
 

diff --git a/pango/pango.asd b/pango/pango.asd
index dd02dd0a71d8bd2b4c68ba24c6be123d1e8a8051..96b1e2cedd1e58007429e6bf96ab9deece720537 100644 (file)
--- a/pango/pango.asd
+++ b/pango/pango.asd
@@ -11,9 +11,8 @@
 
 (defsystem pango
     :depends-on (glib)
 
 (defsystem pango
     :depends-on (glib)

-    :components ((:library "libpango-1.0"
-                          :libdir #.(pkg-variable "pango" "libdir"))
-                (:file "defpackage")
-                (:file "pango" :depends-on ("defpackage" "libpango-1.0"))
+    :components ((:library "libpango-1.0" :libdir #.(pkg-variable "pango" "libdir"))
+                (:library "libpangoxft-1.0" :libdir #.(pkg-variable "pango" "libdir"))          (:file "defpackage")
+                (:file "pango" :depends-on ("defpackage" "libpango-1.0" "libpangoxft-1.0"))

                 (:file "export" :depends-on ("pango"))))
 
                 (:file "export" :depends-on ("pango"))))
 

diff --git a/pango/pango.lisp b/pango/pango.lisp
index 35d56b1df4cad04b75b7ce1e852ea4a573b6b1ed..9fdd0164c9904550fba7976d656becb160e840e0 100644 (file)
--- a/pango/pango.lisp
+++ b/pango/pango.lisp
@@ -15,14 +15,16 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
 ;; 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.6 2004/11/06 21:39:58 espen Exp $
+;; $Id: pango.lisp,v 1.7 2005/02/03 23:09:06 espen Exp $

 
 (in-package "PANGO")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 
 (in-package "PANGO")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)

-  (init-types-in-library 
-   #.(concatenate 'string (pkg-config:pkg-variable "atk" "libdir") 
-                         "/libpango-1.0.so")
-   :prefix "pango_" :ignore ("_pango_fribidi_get_type")))
+  (init-types-in-library #.(concatenate 'string 
+                         (pkg-config:pkg-variable "pango" "libdir")
+                         "/libpango-1.0.so") :prefix "pango_")
+  (init-types-in-library #.(concatenate 'string 
+                         (pkg-config:pkg-variable "pango" "libdir")
+                         "/libpangoxft-1.0.so") :prefix "pango_xft"))

 
 (define-types-by-introspection "Pango")
 
 (define-types-by-introspection "Pango")

diff --git a/tools/asdf-extensions.lisp b/tools/asdf-extensions.lisp
index 76a180b4c2dec73727eae5956e22eff7e3633e71..617b4b345dea217607dc2fb0122533f9d66b7648 100644 (file)
--- a/tools/asdf-extensions.lisp
+++ b/tools/asdf-extensions.lisp
@@ -12,7 +12,7 @@ (defun concatenate-strings (strings &optional delimiter)
      (concatenate-strings (rest strings) delimiter))))
 
 ;;; The following code is more or less copied frm sb-bsd-sockets.asd,
      (concatenate-strings (rest strings) delimiter))))
 
 ;;; The following code is more or less copied frm sb-bsd-sockets.asd,

-;;; but extended to allow flags set in a general way
+;;; but extended to allow flags to be set in a general way

 
 (defclass unix-dso (module) ())
 (defun unix-name (pathname)
 
 (defclass unix-dso (module) ())
 (defun unix-name (pathname)


@@ -51,25 +51,10 @@ (defmethod perform :after ((operation compile-op) (dso unix-dso))
                              (module-components dso)))))
       (error 'operation-error :operation operation :component dso))))
 
                              (module-components dso)))))
       (error 'operation-error :operation operation :component dso))))
 

-;; Taken from foreign.lisp in the CMUCL tree, but modified to delay
-;; resolving of symbols until they are used
-(defun load-dso (file)
-  (system::ensure-lisp-table-opened)
-  ; rtld global: so it can find all the symbols previously loaded
-  ; rtld lazy: that way dlopen will not fail if not all symbols are defined.
-  (let ((filename (namestring file)))
-    (format t ";;; Loading shared library ~A ...~%" filename)
-    (let ((sap (system::dlopen filename (logior system::rtld-lazy system::rtld-global))))
-      (cond ((zerop (system:sap-int sap))
-            (let ((err-string (system::dlerror)))
-
-              ;; For some reason dlerror always seems to return NIL,
-              ;; which isn't very informative.
-              (error "Can't open object ~S: ~S" file err-string)))
-           ((null (assoc sap system::*global-table* :test #'system:sap=))
-            (setf system::*global-table* (acons sap file system::*global-table*))
-            t)
-           (t nil)))))
+
+(defun load-dso (filename)
+  #+sbcl(sb-alien:load-shared-object filename)
+  #+cmu(system::load-object-file filename))

 
 
 (defmethod perform ((o load-op) (c unix-dso))
 
 
 (defmethod perform ((o load-op) (c unix-dso))


@@ -87,9 +72,7 @@    (definitions :initform nil :initarg :definitions)
 
 
 (defmethod output-files ((op compile-op) (c c-source-file))
 
 
 (defmethod output-files ((op compile-op) (c c-source-file))

-  (list 
-   (make-pathname :type "o" :defaults
-                 (component-pathname c))))
+  (list (make-pathname :type "o" :defaults (component-pathname c))))

 
 
 (defmethod perform ((op compile-op) (c c-source-file))
 
 
 (defmethod perform ((op compile-op) (c c-source-file))

diff --git a/tools/config.lisp b/tools/config.lisp
index 0ec9a70b8c6e086310bd29ab9885dc87a319d530..ffe8cfaf9d5b6e75623397781ae2d3f2834c7c8a 100644 (file)
--- a/tools/config.lisp
+++ b/tools/config.lisp
@@ -1,11 +1,11 @@
 (defpackage #:pkg-config
 (defpackage #:pkg-config

-  (:use #:common-lisp)
+  (:use #:common-lisp #+cmu #:ext #+sbcl #:sb-ext)

   (:export #:pkg-cflags #:pkg-libs #:pkg-exists-p #:pkg-version 
           #:pkg-variable))
 
 (in-package #:pkg-config)
 
   (:export #:pkg-cflags #:pkg-libs #:pkg-exists-p #:pkg-version 
           #:pkg-variable))
 
 (in-package #:pkg-config)
 

-(defparameter *pkg-config* "pkg-config")
+(defparameter *pkg-config* "/usr/bin/pkg-config")

 
 (defun split-string (string &key (start 0) (end (length string)))
   (let ((position (position #\sp string :start start :end end)))
 
 (defun split-string (string &key (start 0) (end (length string)))
   (let ((position (position #\sp string :start start :end end)))


@@ -44,19 +44,19 @@ (defun read-string (&optional (stream *standard-input*)
 
 (defun run-pkg-config (package error &rest options)
   (let ((process
 
 (defun run-pkg-config (package error &rest options)
   (let ((process

-        (ext:run-program
+        (run-program

          *pkg-config* (cons package options) :wait t :output :stream)))
     (unless process
       (error "Unable to run ~A" *pkg-config*))
          *pkg-config* (cons package options) :wait t :output :stream)))
     (unless process
       (error "Unable to run ~A" *pkg-config*))

-    (let ((exit-code (ext:process-exit-code process)))
+    (let ((exit-code (process-exit-code process)))

       (unless (or (not error) (zerop exit-code))
        (error
         (or
       (unless (or (not error) (zerop exit-code))
        (error
         (or

-         (read-string (ext:process-error process) nil)
+         (read-string (process-error process) nil)

          (format nil "~A terminated with exit code ~A"
                  *pkg-config* exit-code))))
          (format nil "~A terminated with exit code ~A"
                  *pkg-config* exit-code))))

-      (let ((output (read-lines (ext:process-output process))))          
-       (ext:process-close process)
+      (let ((output (read-lines (process-output process))))      
+       (process-close process)

        (values output exit-code)))))
 
 
        (values output exit-code)))))