From: espen Date: Thu, 3 Feb 2005 23:09:01 +0000 (+0000) Subject: Changes required by SBCL X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/commitdiff_plain/73572c12ccd49c661d06287903bfa725f5fd93a5 Changes required by SBCL --- diff --git a/atk/defpackage.lisp b/atk/defpackage.lisp index 87e7c3d..a43d295 100644 --- a/atk/defpackage.lisp +++ b/atk/defpackage.lisp @@ -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")) diff --git a/gdk/defpackage.lisp b/gdk/defpackage.lisp index 74c2165..5f6a76d 100644 --- a/gdk/defpackage.lisp +++ b/gdk/defpackage.lisp @@ -1,7 +1,5 @@ (defpackage "GDK" (:use "GLIB" "COMMON-LISP" "AUTOEXPORT") - (:shadowing-import-from "PCL" - "CLASS-NAME" "CLASS-OF" "FIND-CLASS") (:shadow "ATOM")) diff --git a/gdk/gdktypes.lisp b/gdk/gdktypes.lisp index f696675..9aef2b6 100644 --- 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 -;; $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 diff --git a/glib/defpackage.lisp b/glib/defpackage.lisp index ea2b4db..cfb9792 100644 --- 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 -;; $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")) diff --git a/glib/ffi.lisp b/glib/ffi.lisp index bd68c1e..36d0e7b 100644 --- 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 -;; $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) diff --git a/glib/gcallback.lisp b/glib/gcallback.lisp index 3ad4042..6cacfca 100644 --- 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 -;; $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)) diff --git a/glib/ginterface.lisp b/glib/ginterface.lisp index 17ced81..1882d35 100644 --- 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 -;; $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)) diff --git a/glib/glib.asd b/glib/glib.asd index c779bec..814930c 100644 --- a/glib/glib.asd +++ b/glib/glib.asd @@ -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 @@ -22,28 +26,23 @@ (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")) diff --git a/glib/glib.lisp b/glib/glib.lisp index 20fbc89..7ce7218 100644 --- 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 -;; $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) diff --git a/glib/gobject.lisp b/glib/gobject.lisp index a722174..811c837 100644 --- 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 -;; $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 diff --git a/glib/gparam.lisp b/glib/gparam.lisp index 5b2f4fa..d2a4b01 100644 --- 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 -;; $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) )) diff --git a/glib/gtype.lisp b/glib/gtype.lisp index 5c7e5a0..2a14c73 100644 --- 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 -;; $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) diff --git a/glib/proxy.lisp b/glib/proxy.lisp index 2e47394..6ad8b90 100644 --- 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 -;; $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)))) diff --git a/glib/utils.lisp b/glib/utils.lisp index f009374..b1b402c 100644 --- 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 -;; $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) diff --git a/gtk/defpackage.lisp b/gtk/defpackage.lisp index d336460..d80da7f 100644 --- a/gtk/defpackage.lisp +++ b/gtk/defpackage.lisp @@ -19,13 +19,16 @@ (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 diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp index d54aaca..b9e9c22 100644 --- 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 -;; $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)) diff --git a/gtk/gtkaction.lisp b/gtk/gtkaction.lisp index 5282dfd..ae5043b 100644 --- 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 -;; $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))) diff --git a/gtk/gtkobject.lisp b/gtk/gtkobject.lisp index d03e975..e643681 100644 --- 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 -;; $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) diff --git a/gtk/gtktext.lisp b/gtk/gtktext.lisp index 6887adb..d5a1f7d 100644 --- 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 -;; $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))) diff --git a/gtk/gtktree.lisp b/gtk/gtktree.lisp index 6ff82ce..5e4ca4e 100644 --- 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 -;; $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 n &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)) diff --git a/pango/defpackage.lisp b/pango/defpackage.lisp index 8054154..5a52ace 100644 --- a/pango/defpackage.lisp +++ b/pango/defpackage.lisp @@ -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")) diff --git a/pango/pango.asd b/pango/pango.asd index dd02dd0..96b1e2c 100644 --- a/pango/pango.asd +++ b/pango/pango.asd @@ -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")))) diff --git a/pango/pango.lisp b/pango/pango.lisp index 32db14d..c0f30fb 100644 --- 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 -;; $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") diff --git a/tools/asdf-extensions.lisp b/tools/asdf-extensions.lisp index 76a180b..617b4b3 100644 --- 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, -;;; 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)) diff --git a/tools/config.lisp b/tools/config.lisp index 0ec9a70..ffe8cfa 100644 --- a/tools/config.lisp +++ b/tools/config.lisp @@ -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)))))