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 f696675b179ed9287e80cddb456473cf9f291a0f..9aef2b6ca9d3d59622396bf080c109b0f6035162 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 ea2b4dbafeefe1d7be6de02af172fed74178518a..cfb9792e036f1757c7df1db9e0489e8aced4b641 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 bd68c1e78edbc6998f22800d833304c5dedc4621..36d0e7baea31c4fff0570d15eeebbb4c26d43564 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 3ad404271bd94d7d404e0a051770448636322aa0..6cacfcab34e792870d595b6819b1a34378a10308 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 17ced81de955c525cb12a16b3dcc9e278fd9c42c..1882d351ab90c813221e3d436f4cff3c3b17671c 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 20fbc891c2592524ebf71a2d65d4d96e920c1f90..7ce7218c3224fc7dd4f5eed8e12a7685ba05334d 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 a722174e7f2fdb639eb7dfd1c700b08f3a1d3bf3..811c837afc2a1d4ec5565472370875eb5e104587 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 5b2f4faf3a1c81df86bd719ca77aa27bf49dd66c..d2a4b01db5388cf8806c68dfb91fcd146d28594d 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 5c7e5a0d078c465a34da9ed36a5c98dd723e81a4..2a14c73aaa729cd26c840f4987150d11c5b9923f 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 2e473947b6058122ce74ff06665ae50728a48133..6ad8b907363828c28ad0e4cfac74fa2fb02b30dd 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 f0093747dce79079aed435d43bad8dbc5db0ef6d..b1b402c83cd147152b8d0d89d9126eeaacc0a6fd 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 d54aacaf7a7473f8cc5c61f18762625b9e9897c1..b9e9c2217795b15955fccfb438a2fba0307d6391 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 5282dfd36af64c8bfbc3082e7da82a5e022e6378..ae5043b6e507aaadda974b8501529db403101e24 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 d03e975a34a9f08661de0931d18c56f2e38e8065..e6436816a95ab86d85258df47dd2bfc1ef1f0ca1 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 6887adbd5f71fbe73f122725942025ab8db52ac6..d5a1f7db873e93ca8cfe1a40a2792160ec94627b 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 6ff82ce18b55689794bb909c3343d0d69dd4fefe..5e4ca4eb984c36cdc8fa34dd2e102a4fb6f77d33 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 32db14da7b76974865126aa2813aaa79051d8bcb..c0f30fbc166c5ceee1770b4090fdcf9cc622b651 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)))))