chiark / gitweb /
Changes required by SBCL
authorespen <espen>
Thu, 3 Feb 2005 23:09:01 +0000 (23:09 +0000)
committerespen <espen>
Thu, 3 Feb 2005 23:09:01 +0000 (23:09 +0000)
25 files changed:
atk/defpackage.lisp
gdk/defpackage.lisp
gdk/gdktypes.lisp
glib/defpackage.lisp
glib/ffi.lisp
glib/gcallback.lisp
glib/ginterface.lisp
glib/glib.asd
glib/glib.lisp
glib/gobject.lisp
glib/gparam.lisp
glib/gtype.lisp
glib/proxy.lisp
glib/utils.lisp
gtk/defpackage.lisp
gtk/gtk.lisp
gtk/gtkaction.lisp
gtk/gtkobject.lisp
gtk/gtktext.lisp
gtk/gtktree.lisp
pango/defpackage.lisp
pango/pango.asd
pango/pango.lisp
tools/asdf-extensions.lisp
tools/config.lisp

index 87e7c3d..a43d295 100644 (file)
@@ -1,6 +1,4 @@
 (defpackage "ATK"
-  (:use "GLIB" "COMMON-LISP" "AUTOEXPORT")
-  (:shadowing-import-from "PCL"
-   "CLASS-NAME" "CLASS-OF" "FIND-CLASS"))
+  (:use "GLIB" "COMMON-LISP" "AUTOEXPORT"))
 
 
index 74c2165..5f6a76d 100644 (file)
@@ -1,7 +1,5 @@
 (defpackage "GDK"
   (:use "GLIB" "COMMON-LISP" "AUTOEXPORT")
-  (:shadowing-import-from "PCL"
-   "CLASS-NAME" "CLASS-OF" "FIND-CLASS")
   (:shadow "ATOM"))
 
 
index f696675..9aef2b6 100644 (file)
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: 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")
 
@@ -83,103 +83,100 @@ (defclass rectangle (boxed)
   (: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)
 
-(defclass cursor (struct)
+(defclass cursor (boxed)
   ((type
     :allocation :alien
     :reader cursor-type
@@ -192,11 +189,9 @@ (defclass cursor (struct)
     :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 
index ea2b4db..cfb9792 100644 (file)
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: defpackage.lisp,v 1.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"
-  (: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")
+  #+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"
-          "PACKAGE-PREFIX" "DEFCALLBACK")
+          "PACKAGE-PREFIX" "DEFCALLBACK" "CALLBACK")
   (: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"))
 
index bd68c1e..36d0e7b 100644 (file)
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: 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")
 
@@ -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)))))
 
-#+cmu
+#+(or cmu sbcl)
 (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))
@@ -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
-        (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)
@@ -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)
-  (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
-         (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)))
@@ -189,25 +191,30 @@ (defun mkbinding (name return-type &rest arg-types)
        (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)
-  `(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
@@ -329,10 +336,10 @@ (defmethod alien-type ((type (eql 'signed-byte)) &rest args)
   (declare (ignore type))
   (destructuring-bind (&optional (size '*)) args
     (ecase size
-      (#.+bits-of-byte+ '(signed-byte 8))
-      (#.+bits-of-short+ 'c-call:short)
-      ((* #.+bits-of-int+) 'c-call:int)
-      (#.+bits-of-long+ 'c-call:long))))
+      (#.+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))
@@ -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
-      (#.+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))
@@ -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))
-  '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))
@@ -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))
-  '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))
@@ -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))
-  'c-call:char)
+  #+cmu 'c-call:char #+sbcl 'sb-alien:char)
 
 (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
-      (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
-       (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)
@@ -526,7 +536,7 @@ (defmethod from-alien-form (string (type (eql 'string)) &rest args)
   `(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)
@@ -534,7 +544,7 @@ (defmethod from-alien-function ((type (eql 'string)) &rest args)
   #'(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)
@@ -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)
-      (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)
-       (c-call::%naturalize-c-string string))))
+       (%naturalize-c-string string))))
 
 (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
-       (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))
-       (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))
@@ -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))
-  'c-call:void)
+  'void)
 
 (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)))
-
-(export 'copy-of)
index 3ad4042..6cacfca 100644 (file)
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gcallback.lisp,v 1.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")
 
@@ -28,9 +28,6 @@ (defun register-callback-function (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)
@@ -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)
-  ((callback %destroy-user-data) pointer))
+  ((callback user-data-destroy-func) pointer))
 
 (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)
-  ((callback %destroy-user-data) pointer))
+  ((callback user-data-destroy-func) pointer))
 
 (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)
-  ((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)
@@ -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)
-  (may-be-blocked boolean))
+  (blocked boolean))
     
 (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) 
-      (callback %destroy-user-data))
+      (callback user-data-destroy-func))
      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))
 
 
-
 ;;; 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))
index 17ced81..1882d35 100644 (file)
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: ginterface.lisp,v 1.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")
 
@@ -65,8 +65,7 @@ (defmethod shared-initialize ((class ginterface-class) names
   (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))
 
 
index c779bec..814930c 100644 (file)
@@ -5,7 +5,11 @@
 (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
 (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" 
-                           :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"))
+                (: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 "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"))
index 20fbc89..7ce7218 100644 (file)
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: glib.lisp,v 1.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")
@@ -38,7 +38,9 @@ (defbinding (deallocate-memory "g_free") () nil
 ;;   (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)
 
 
@@ -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)))
 
-(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)
index a722174..811c837 100644 (file)
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gobject.lisp,v 1.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")
 
@@ -26,8 +26,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute)
   (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))
 
@@ -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)
-       (let ((reader nil))
+       (let ((reader (reader-function type)))
         #'(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
@@ -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)
-       (let ((writer nil))
+       (let ((writer (writer-function type)))
         #'(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)
@@ -277,9 +272,14 @@ (defbinding %object-set-qdata-full () nil
   (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)
-   (register-user-data data) (callback %destroy-user-data))
+   (register-user-data data) (callback user-data-destroy-func))
   data)
 
 ;; deprecated
index 5b2f4fa..d2a4b01 100644 (file)
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gparam.lisp,v 1.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")
 
@@ -57,7 +57,7 @@ (defun gvalue-free (gvalue &optional (unset-p t))
     (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))
@@ -96,8 +96,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute)
   (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)
 ))
 
index 5c7e5a0..2a14c73 100644 (file)
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: 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")
 
@@ -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)
-  (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)
-  (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)))))
@@ -131,7 +131,7 @@ (defun find-type-number (type &optional error)
        (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)
@@ -160,12 +160,12 @@ (defun init-type (init)
    (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 ()
-              (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
@@ -176,7 +176,7 @@ (defun %init-types-in-library (pathname prefix ignore)
                       (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)
index 2e47394..6ad8b90 100644 (file)
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: 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")
 
@@ -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)
-     (boundp :reader slot-definition-boundp :initarg :boundp)))
+     (boundp :reader slot-definition-boundp :initarg :boundp))))
   
   (defvar *unbound-marker* (gensym "UNBOUND-MARKER-"))
 
@@ -47,7 +47,7 @@                                  (default *unbound-marker*))
                   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
-   (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)
-  (let ((ref (gethash (system:sap-int location) *instance-cache*)))
+  (let ((ref (gethash (sap-int location) *instance-cache*)))
     (when ref
-      (ext:weak-pointer-value ref))))
+      (weak-pointer-value ref))))
 
 (defun instance-cached-p (location)
-  (gethash (system:sap-int location) *instance-cache*))
+  (gethash (sap-int location) *instance-cache*))
 
 (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))
-                (push (ext:weak-pointer-value ref) instances))
+                (push (weak-pointer-value ref) 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)
-  (ext:finalize instance (instance-finalizer instance))
+  (finalize instance (instance-finalizer instance))
   instance)
 
 (defmethod instance-finalizer ((instance proxy))
@@ -298,6 +298,10 @@ (defmethod instance-finalizer ((instance 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)))
@@ -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)))
 
-
   (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)
@@ -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)
-  (declare (ignore class args))
+  (declare (ignore args))
   #'(lambda (instance)
       (reference-foreign class (proxy-location instance))))
 
index f009374..b1b402c 100644 (file)
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: 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)
-                   (kernel::info type expander form))
+                   #+cmu(kernel::info type expander form)
+                   #+sbcl(sb-impl::info :type :expander 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)
@@ -45,12 +47,13 @@ (defun type-expand-to (type form)
 (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
-            (ext:gc-on)))))))
+            (gc-on)))))))
 
 (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))
-  (check-type string string)
-  (check-type delimiter character)
   (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))
-  (check-type string string)
-  (check-type predicate (or symbol function))
   (let ((pos (position-if predicate string :start 1)))
     (if (not pos)
         (list string)
index d336460..d80da7f 100644 (file)
 
 
 (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")
-  (: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"
@@ -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"))
\ No newline at end of file
index d54aaca..b9e9c22 100644 (file)
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gtk.lisp,v 1.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")
@@ -56,11 +56,10 @@ (defun clg-init (&optional 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
@@ -117,7 +116,7 @@ (defun accel-groups-activate (object accelerator)
 (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))
 
@@ -379,10 +378,6 @@ (defbinding check-menu-item-toggled () nil
   (check-menu-item check-menu-item))
 
 
-
-;;; Clipboard
-
-
 ;;; 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)
-  ((callback %destroy-user-data) pointer))
+  ((callback user-data-destroy-func) pointer))
 
 (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))
 
-(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)
-  ((callback %destroy-user-data) pointer))
+  ((callback user-data-destroy-func) pointer))
 
 (defbinding file-filter-get-needed () file-filter-flags
   (filter file-filter))
index 5282dfd..ae5043b 100644 (file)
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: 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")
@@ -81,7 +81,7 @@ (defbinding action-group-remove-action () nil
 
 (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)))
index d03e975..e643681 100644 (file)
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gtkobject.lisp,v 1.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")
@@ -60,11 +60,11 @@ (defmethod initialize-instance :around ((object %object) &rest initargs)
 (defbinding %object-sink () nil
   (object %object))
 
-;;;; Main loop, timeouts and idle functions
+;;;; Main loop and event handling
 
 (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)
 
@@ -82,9 +82,9 @@ (defbinding main-iteration-do (&optional (blocking t)) boolean
 
 (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
@@ -126,7 +126,8 @@ (defmethod compute-effective-slot-definition-initargs ((class child-class) direc
     (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)))
 
@@ -158,7 +159,7 @@ (defmethod initialize-internal-slot-functions ((slotd effective-child-slot-defin
   (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
@@ -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)))))
 
-(defmethod pcl::add-writer-method
+(defmethod add-writer-method
     ((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))))))
 
 
-(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)
 
index 6887adb..d5a1f7d 100644 (file)
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: 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")
@@ -563,17 +563,17 @@ (defbinding text-iter-backward-to-tag-toggle (iter tag) boolean
   (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)
-  ((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)
-  ((callback %text-char-redicate) pointer)
+  ((callback %text-char-predicate) pointer)
   ((register-callback-function predicate) unsigned-int)
   (limit (or null text-iter)))
 
index 6ff82ce..5e4ca4e 100644 (file)
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: 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")
@@ -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)
-  ((callback %destroy-user-data) pointer))
+  ((callback user-data-destroy-func) pointer))
 
 (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
-    (tree-model parent &optional (iter (make-instance 'tree-iter))) boolean
+    (tree-model parent &optional (iter (make-instance 'tree-iter))) boolean
   (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)
-  ((callback %destroy-user-data) pointer))
+  ((callback user-data-destroy-func) pointer))
 
 (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)))
 
-(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))
@@ -685,7 +685,7 @@ (defbinding tree-view-remove-column () int
   (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))
index 8054154..5a52ace 100644 (file)
@@ -1,6 +1,3 @@
 (defpackage "PANGO"
-  (:use "GLIB" "COMMON-LISP" "AUTOEXPORT")
-  (:shadowing-import-from "PCL"
-   "CLASS-NAME" "CLASS-OF" "FIND-CLASS"))
-
+  (:use "GLIB" "COMMON-LISP" "AUTOEXPORT"))
 
index dd02dd0..96b1e2c 100644 (file)
@@ -11,9 +11,8 @@
 
 (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"))))
 
index 32db14d..c0f30fb 100644 (file)
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: pango.lisp,v 1.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)
-  (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")
index 76a180b..617b4b3 100644 (file)
@@ -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,
-;;; 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)
@@ -51,25 +51,10 @@ (defmethod perform :after ((operation compile-op) (dso unix-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))
@@ -87,9 +72,7 @@    (definitions :initform nil :initarg :definitions)
 
 
 (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))
index 0ec9a70..ffe8cfa 100644 (file)
@@ -1,11 +1,11 @@
 (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)
 
-(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)))
@@ -44,19 +44,19 @@ (defun read-string (&optional (stream *standard-input*)
 
 (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*))
-    (let ((exit-code (ext:process-exit-code process)))
+    (let ((exit-code (process-exit-code process)))
       (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))))
-      (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)))))