From 8b6767cf4830672f2d929b66031f561857b9f1cd Mon Sep 17 00:00:00 2001 From: Dmitry Kalyanov Date: Wed, 13 May 2009 00:14:50 +0400 Subject: [PATCH] Removed dependency on anaphora and metabang-bind --- glib/glib.asd | 2 +- glib/gobject.foreign-gboxed.lisp | 85 +++++++++++++------------ glib/gobject.foreign-gobject-subclassing.lisp | 12 ++-- glib/gobject.foreign-gobject.lisp | 18 +++--- glib/gobject.package.lisp | 2 +- gtk/gtk.asd | 2 +- gtk/gtk.builder.lisp | 5 +- gtk/gtk.demo.lisp | 13 ++-- gtk/gtk.package.lisp | 2 +- gtk/gtk.text.lisp | 45 +++++++------ gtk/gtk.tree-model.lisp | 7 +- gtk/gtk.tree-view.lisp | 15 +++-- subtest.lisp | 7 +- 13 files changed, 118 insertions(+), 97 deletions(-) diff --git a/glib/glib.asd b/glib/glib.asd index 43fc30c..2454c44 100644 --- a/glib/glib.asd +++ b/glib/glib.asd @@ -27,4 +27,4 @@ (:file "gobject.generating") (:file "gobject.object-defs") (:file "gobject.foreign-gobject-subclassing")) - :depends-on (:cffi :trivial-garbage :metabang-bind :iterate :anaphora :bordeaux-threads :iterate :closer-mop)) \ No newline at end of file + :depends-on (:cffi :trivial-garbage :iterate :bordeaux-threads :iterate :closer-mop)) \ No newline at end of file diff --git a/glib/gobject.foreign-gboxed.lisp b/glib/gobject.foreign-gboxed.lisp index abae705..5b201be 100644 --- a/glib/gobject.foreign-gboxed.lisp +++ b/glib/gobject.foreign-gboxed.lisp @@ -106,7 +106,7 @@ name)) (defun slot->slot-parser (class-name pointer-var slot) - (bind (((slot-name slot-type &key parser &allow-other-keys) slot)) + (destructuring-bind (slot-name slot-type &key parser &allow-other-keys) slot (cond (parser `(setf ,slot-name (funcall ,parser ',class-name ,pointer-var))) @@ -122,7 +122,7 @@ ,@(mapcar (lambda (slot) (slot->slot-parser name 'pointer slot)) slots))))) (defun slot->slot-unparser (class-name pointer-var slot object) - (bind (((slot-name slot-type &key unparser &allow-other-keys) slot)) + (destructuring-bind (slot-name slot-type &key unparser &allow-other-keys) slot (cond (unparser `(funcall ,unparser ',class-name ,pointer-var ,object)) @@ -148,7 +148,7 @@ (intern (format nil "MAKE-~A" (symbol-name name)) (symbol-package name))) (defun get-g-boxed-direct-subclasses (name) - (mapcar (lambda (spec) (bind (((name slot values) spec)) + (mapcar (lambda (spec) (destructuring-bind (name slot values) spec (declare (ignore slot values)) name)) (get name 'boxed-dispatch))) @@ -176,29 +176,30 @@ (get-g-boxed-completed-c-definition (g-boxed-root name) (get name 'c-name)))) (defmacro define-g-boxed-class (g-name-and-c-name name (&optional superclass-and-dispatch (export t)) &body slots) - (bind (((&optional g-name c-name) (ensure-list g-name-and-c-name)) - ((&optional superclass dispatch-slot dispatch-values) superclass-and-dispatch) - (superclass-slots (get superclass 'boxed-combined-slots)) - (combined-slots (append superclass-slots slots))) - (setf c-name (or c-name (gensym "C-UNION-"))) - `(progn ,(cstruct-definition name combined-slots) - ,(struct-definition name superclass slots) - ,(parse-method-definition name combined-slots) - ,(unparse-method-definition name combined-slots) - (eval-when (:load-toplevel :compile-toplevel :execute) - (setf (get ',name 'boxed-slots) ',slots - (get ',name 'boxed-combined-slots) ',combined-slots - (get ',name 'superclass) ',superclass - (get ',name 'c-name) (or (get ',name 'c-name) ',c-name)) - ,@(when superclass - (list `(pushnew '(,name ,dispatch-slot ,(ensure-list dispatch-values)) (get ',superclass 'boxed-dispatch) :test 'equalp)))) - (update-g-boxed-root-c-class ,name) - ,@(when g-name - (list `(register-boxed-type ,g-name ',name))) - ,@(when export - (append (list `(export ',name (symbol-package ',name)) - `(export ',(struct-constructor-name name) (symbol-package ',(struct-constructor-name name)))) - (mapcar (lambda (slot) (slot->export-accessor name slot)) slots)))))) + (destructuring-bind (&optional g-name c-name) (ensure-list g-name-and-c-name) + (destructuring-bind (&optional superclass dispatch-slot dispatch-values) superclass-and-dispatch + (let* ((superclass-slots (get superclass 'boxed-combined-slots)) + (combined-slots (append superclass-slots slots))) + + (setf c-name (or c-name (gensym "C-UNION-"))) + `(progn ,(cstruct-definition name combined-slots) + ,(struct-definition name superclass slots) + ,(parse-method-definition name combined-slots) + ,(unparse-method-definition name combined-slots) + (eval-when (:load-toplevel :compile-toplevel :execute) + (setf (get ',name 'boxed-slots) ',slots + (get ',name 'boxed-combined-slots) ',combined-slots + (get ',name 'superclass) ',superclass + (get ',name 'c-name) (or (get ',name 'c-name) ',c-name)) + ,@(when superclass + (list `(pushnew '(,name ,dispatch-slot ,(ensure-list dispatch-values)) (get ',superclass 'boxed-dispatch) :test 'equalp)))) + (update-g-boxed-root-c-class ,name) + ,@(when g-name + (list `(register-boxed-type ,g-name ',name))) + ,@(when export + (append (list `(export ',name (symbol-package ',name)) + `(export ',(struct-constructor-name name) (symbol-package ',(struct-constructor-name name)))) + (mapcar (lambda (slot) (slot->export-accessor name slot)) slots)))))))) (defun boxed-c-structure-name (name) (get (g-boxed-root name) 'c-name)) @@ -223,9 +224,10 @@ (unless (gethash (pointer-address pointer) *boxed-ref-count*) (error "g-boxed-ref ~A is already disposed from lisp-side" pointer)) (with-recursive-lock-held (*g-boxed-gc-lock*) - (awhen (gethash (pointer-address pointer) *known-boxed-refs*) - (debugf "Removing finalization from ~A for pointer ~A~%" it pointer) - (tg:cancel-finalization it)) + (let ((object (gethash (pointer-address pointer) *known-boxed-refs*))) + (when object + (debugf "Removing finalization from ~A for pointer ~A~%" object pointer) + (tg:cancel-finalization object))) (when (eq :lisp (gethash (pointer-address pointer) *boxed-ref-owner*)) (funcall (boxed-ref-free-function type) pointer)) (remhash (pointer-address pointer) *known-boxed-refs*) @@ -238,8 +240,9 @@ (defmethod initialize-instance :after ((object g-boxed-ref) &key) (with-recursive-lock-held (*g-boxed-gc-lock*) (let ((address (pointer-address (pointer object)))) - (awhen (gethash address *known-boxed-refs*) - (tg:cancel-finalization it)) + (let ((object (gethash address *known-boxed-refs*))) + (when object + (tg:cancel-finalization object))) (setf (gethash address *known-boxed-refs*) object) (setf (gethash address *boxed-ref-count*) 1) (setf (gethash address *boxed-ref-owner*) @@ -279,15 +282,15 @@ (defun convert-g-boxed-ref-from-pointer (pointer name type) (unless (null-pointer-p pointer) (with-recursive-lock-held (*g-boxed-gc-lock*) - (or (aprog1 (gethash (pointer-address pointer) *known-boxed-refs*) - (when it (debugf "Boxed-ref for ~A is found (~A)~%" pointer it)) - (when it (incf (gethash (pointer-address pointer) *boxed-ref-count*))) - it) - (aprog1 (make-instance name :pointer pointer) - (setf (gethash (pointer-address pointer) *boxed-ref-owner*) (g-boxed-ref-owner type)) - (debugf "Boxed-ref for ~A is created (~A) with owner ~A~%" pointer it - (gethash (pointer-address pointer) *boxed-ref-owner*)) - it))))) + (or (let ((object (gethash (pointer-address pointer) *known-boxed-refs*))) + (when object (debugf "Boxed-ref for ~A is found (~A)~%" pointer object)) + (when object (incf (gethash (pointer-address pointer) *boxed-ref-count*))) + object) + (let ((object (make-instance name :pointer pointer))) + (setf (gethash (pointer-address pointer) *boxed-ref-owner*) (g-boxed-ref-owner type)) + (debugf "Boxed-ref for ~A is created (~A) with owner ~A~%" pointer object + (gethash (pointer-address pointer) *boxed-ref-owner*)) + object))))) (defmethod translate-from-foreign (value (type g-boxed-ref-type)) (let ((owner (or (gethash (pointer-address value) *boxed-ref-owner*) (g-boxed-ref-owner type)))) ;;This is needed to prevent changing ownership of already created @@ -296,7 +299,7 @@ (setf (gethash (pointer-address value) *boxed-ref-owner*) owner)))) (defun g-boxed-ref-slot->methods (class slot) - (bind (((slot-name &key reader writer type (accessor slot-name)) slot)) + (destructuring-bind (slot-name &key reader writer type (accessor slot-name)) slot `(progn ,@(when reader (list `(defmethod ,accessor ((object ,class)) ,(if (stringp reader) diff --git a/glib/gobject.foreign-gobject-subclassing.lisp b/glib/gobject.foreign-gobject-subclassing.lisp index 53b424d..b64f451 100644 --- a/glib/gobject.foreign-gobject-subclassing.lisp +++ b/glib/gobject.foreign-gobject-subclassing.lisp @@ -124,12 +124,12 @@ (return-from-interface-method-implementation (v) :interactive (lambda () (list (eval (read)))) v))))))) (defun interface-init (iface data) - (bind (((class-name interface-name) (prog1 (get-stable-pointer-value data) (free-stable-pointer data))) - (vtable (gethash interface-name *vtables*)) - (vtable-cstruct (vtable-description-cstruct-name vtable))) - (debugf "interface-init for class ~A and interface ~A~%" class-name interface-name) - (iter (for method in (vtable-description-methods vtable)) - (setf (foreign-slot-value iface vtable-cstruct (vtable-method-info-name method)) (get-callback (vtable-method-info-callback-name method)))))) + (destructuring-bind (class-name interface-name) (prog1 (get-stable-pointer-value data) (free-stable-pointer data)) + (let* ((vtable (gethash interface-name *vtables*)) + (vtable-cstruct (vtable-description-cstruct-name vtable))) + (debugf "interface-init for class ~A and interface ~A~%" class-name interface-name) + (iter (for method in (vtable-description-methods vtable)) + (setf (foreign-slot-value iface vtable-cstruct (vtable-method-info-name method)) (get-callback (vtable-method-info-callback-name method))))))) (defcallback c-interface-init :void ((iface :pointer) (data :pointer)) (interface-init iface data)) diff --git a/glib/gobject.foreign-gobject.lisp b/glib/gobject.foreign-gobject.lisp index d02bea8..33b8434 100644 --- a/glib/gobject.foreign-gobject.lisp +++ b/glib/gobject.foreign-gobject.lisp @@ -115,9 +115,10 @@ (gethash (pointer-address pointer) *foreign-gobjects*) (gethash (pointer-address pointer) *foreign-gobjects-ref-count*) (ref-count pointer)) - (awhen (gethash (pointer-address pointer) *foreign-gobjects*) - (setf (pointer it) nil) - (cancel-finalization it)) + (let ((object (gethash (pointer-address pointer) *foreign-gobjects*))) + (when object + (setf (pointer object) nil) + (cancel-finalization object))) (remhash (pointer-address pointer) *foreign-gobjects*) (remhash (pointer-address pointer) *foreign-gobjects-ref-count*) (g-object-unref pointer)) @@ -175,11 +176,12 @@ (defun get-g-object-for-pointer (pointer) (unless (null-pointer-p pointer) - (aif (gethash (pointer-address pointer) *foreign-gobjects*) - (prog1 it - (incf (gethash (pointer-address pointer) *foreign-gobjects-ref-count*)) - (debugf "increfering object ~A~%" pointer)) - (make-g-object-from-pointer pointer)))) + (let ((object (gethash (pointer-address pointer) *foreign-gobjects*))) + (if object + (prog1 object + (incf (gethash (pointer-address pointer) *foreign-gobjects-ref-count*)) + (debugf "increfering object ~A~%" pointer)) + (make-g-object-from-pointer pointer))))) (defmethod translate-from-foreign (pointer (type foreign-g-object-type)) (get-g-object-for-pointer pointer)) diff --git a/glib/gobject.package.lisp b/glib/gobject.package.lisp index 40852a5..cbffca7 100644 --- a/glib/gobject.package.lisp +++ b/glib/gobject.package.lisp @@ -1,5 +1,5 @@ (defpackage :gobject - (:use :cl :glib :cffi :tg :bind :anaphora :bordeaux-threads :iter :closer-mop) + (:use :cl :glib :cffi :tg :bordeaux-threads :iter :closer-mop) (:export #:g-object #:register-object-type #:g-object-call-constructor diff --git a/gtk/gtk.asd b/gtk/gtk.asd index 3654983..b8ca600 100644 --- a/gtk/gtk.asd +++ b/gtk/gtk.asd @@ -54,4 +54,4 @@ (:file "gtk.dialog.example") (:file "gtk.demo")) - :depends-on (:glib :cffi :gdk :anaphora :bordeaux-threads)) \ No newline at end of file + :depends-on (:glib :cffi :gdk :bordeaux-threads)) \ No newline at end of file diff --git a/gtk/gtk.builder.lisp b/gtk/gtk.builder.lisp index 659d8af..bcc06d5 100644 --- a/gtk/gtk.builder.lisp +++ b/gtk/gtk.builder.lisp @@ -101,8 +101,9 @@ (defun builder-connect-signals-simple (builder handlers-list) (flet ((connect-func (builder object signal-name handler-name connect-object flags) (declare (ignore builder connect-object)) - (awhen (find handler-name handlers-list :key 'first :test 'string=) - (g-signal-connect object signal-name (second it) :after (member :after flags))))) + (let ((handler (find handler-name handlers-list :key 'first :test 'string=))) + (when handler + (g-signal-connect object signal-name (second handler) :after (member :after flags)))))) (builder-connect-signals-full builder #'connect-func))) (export 'builder-connect-signals-simple) diff --git a/gtk/gtk.demo.lisp b/gtk/gtk.demo.lisp index 57f38b1..8fe99b9 100644 --- a/gtk/gtk.demo.lisp +++ b/gtk/gtk.demo.lisp @@ -1,5 +1,5 @@ (defpackage :gtk-demo - (:use :cl :gtk :gdk :gobject :anaphora :iter) + (:use :cl :gtk :gdk :gobject :iter) (:export #:test #:test-entry #:table-packing @@ -12,7 +12,6 @@ #:demo-code-editor #:test-treeview-list #:test-combo-box - #:test-toolbar #:test-ui-manager #:test-color-button #:test-color-selection @@ -393,8 +392,9 @@ (for action = (make-instance 'action :name name :stock-id stock-id)) (g-signal-connect action "activate" fn) (action-group-add-action action-group action)) - (awhen (ui-manager-widget ui-manager "/toolbar1") - (container-add window it)) + (let ((widget (ui-manager-widget ui-manager "/toolbar1"))) + (when widget + (container-add window widget))) (widget-show window)))) (defun test-color-button () @@ -545,8 +545,9 @@ (defun demo-text-editor () (within-main-loop - (let* ((builder (aprog1 (make-instance 'builder) - (builder-add-from-file it (namestring (merge-pathnames "demo/text-editor.ui" *src-location*))))) + (let* ((builder (let ((builder (make-instance 'builder))) + (builder-add-from-file builder (namestring (merge-pathnames "demo/text-editor.ui" *src-location*))) + builder)) (window (builder-get-object builder "window1")) (text-view (builder-get-object builder "textview1")) (status-bar (builder-get-object builder "statusbar1")) diff --git a/gtk/gtk.package.lisp b/gtk/gtk.package.lisp index b71d700..15bce8e 100644 --- a/gtk/gtk.package.lisp +++ b/gtk/gtk.package.lisp @@ -1,5 +1,5 @@ (defpackage :gtk - (:use :cl :cffi :gobject :gdk :glib :metabang-bind :anaphora) + (:use :cl :cffi :gobject :gdk :glib) (:export #:register-object-type #:gtk-main #:gtk-main-quit diff --git a/gtk/gtk.text.lisp b/gtk/gtk.text.lisp index b697e10..716d6b1 100644 --- a/gtk/gtk.text.lisp +++ b/gtk/gtk.text.lisp @@ -596,8 +596,9 @@ (char-offset :int)) (defun text-buffer-get-iter-at-line-offset (buffer line-number char-offset) - (aprog1 (make-instance 'text-iter) - (gtk-text-buffer-get-iter-at-line-offset buffer it line-number char-offset))) + (let ((iter (make-instance 'text-iter))) + (gtk-text-buffer-get-iter-at-line-offset buffer iter line-number char-offset) + iter)) (export 'text-buffer-get-iter-at-line-offset) @@ -607,8 +608,9 @@ (char-offset :int)) (defun text-buffer-get-iter-at-offset (buffer offset) - (aprog1 (make-instance 'text-iter) - (gtk-text-buffer-get-iter-at-offset buffer it offset))) + (let ((iter (make-instance 'text-iter))) + (gtk-text-buffer-get-iter-at-offset buffer iter offset) + iter)) (export 'text-buffer-get-iter-at-offset) @@ -618,8 +620,9 @@ (line-number :int)) (defun text-buffer-get-iter-at-line (buffer line-number) - (aprog1 (make-instance 'text-iter) - (gtk-text-buffer-get-iter-at-line buffer it line-number))) + (let ((iter (make-instance 'text-iter))) + (gtk-text-buffer-get-iter-at-line buffer iter line-number) + iter)) (export 'text-buffet-get-iter-at-line) @@ -631,8 +634,9 @@ (defun text-buffer-get-iter-at-mark (buffer mark) (when (stringp mark) (setf mark (text-buffer-get-mark buffer mark))) - (aprog1 (make-instance 'text-iter) - (gtk-text-buffer-get-iter-at-mark buffer it mark))) + (let ((iter (make-instance 'text-iter))) + (gtk-text-buffer-get-iter-at-mark buffer iter mark) + iter)) (export 'text-buffer-get-iter-at-mark) @@ -642,8 +646,9 @@ (anchor (g-object text-child-anchor))) (defun text-buffer-get-iter-at-child-anchor (buffer anchor) - (aprog1 (make-instance 'text-iter) - (gtk-text-buffer-get-iter-at-child-anchor buffer it anchor))) + (let ((iter (make-instance 'text-iter))) + (gtk-text-buffer-get-iter-at-child-anchor buffer iter anchor) + iter)) (export 'text-buffer-get-iter-at-child-anchor) @@ -652,8 +657,9 @@ (iter (g-boxed-ref text-iter))) (defun text-buffer-get-start-iter (buffer) - (aprog1 (make-instance 'text-iter) - (gtk-text-buffer-get-start-iter buffer it))) + (let ((iter (make-instance 'text-iter))) + (gtk-text-buffer-get-start-iter buffer iter) + iter)) (export 'text-buffer-get-start-iter) @@ -662,8 +668,9 @@ (iter (g-boxed-ref text-iter))) (defun text-buffer-get-end-iter (buffer) - (aprog1 (make-instance 'text-iter) - (gtk-text-buffer-get-end-iter buffer it))) + (let ((iter (make-instance 'text-iter))) + (gtk-text-buffer-get-end-iter buffer iter) + iter)) (export 'text-buffer-get-end-iter) @@ -914,8 +921,9 @@ (visible-rect (g-boxed-ptr rectangle :in-out))) (defun text-view-visible-rect (text-view) - (aprog1 (make-rectangle :x 0 :y 0 :width 0 :height 0) - (gtk-text-view-get-visible-rect text-view it))) + (let ((rect (make-rectangle :x 0 :y 0 :width 0 :height 0))) + (gtk-text-view-get-visible-rect text-view rect) + rect)) (export 'text-view-visible-rect) @@ -925,8 +933,9 @@ (location (g-boxed-ptr rectangle :in-out))) (defun text-view-iter-location (text-view iter) - (aprog1 (make-rectangle :x 0 :y 0 :width 0 :height 0) - (gtk-text-view-get-iter-location text-view iter it))) + (let ((rect (make-rectangle :x 0 :y 0 :width 0 :height 0))) + (gtk-text-view-get-iter-location text-view iter rect) + rect)) (export 'text-view-iter-location) diff --git a/gtk/gtk.tree-model.lisp b/gtk/gtk.tree-model.lisp index 6a805eb..4ada311 100644 --- a/gtk/gtk.tree-model.lisp +++ b/gtk/gtk.tree-model.lisp @@ -118,9 +118,10 @@ (defmethod tree-model-get-path-impl ((model array-list-store) iter) (using* (iter) - (anaphora:aprog1 (make-instance 'tree-path) - (setf (tree-path-indices anaphora:it) (list (tree-iter-user-data iter))) - (disown-boxed-ref anaphora:it)))) + (let ((path (make-instance 'tree-path))) + (setf (tree-path-indices path) (list (tree-iter-user-data iter))) + (disown-boxed-ref path) + path))) (defmethod tree-model-iter-has-child-impl ((model array-list-store) iter) (release iter) diff --git a/gtk/gtk.tree-view.lisp b/gtk/gtk.tree-view.lisp index dedd435..42664e5 100644 --- a/gtk/gtk.tree-view.lisp +++ b/gtk/gtk.tree-view.lisp @@ -191,8 +191,9 @@ (rectangle (g-boxed-ptr rectangle))) (defun tree-view-get-cell-area (tree-view path column) - (aprog1 (make-rectangle :x 0 :y 0 :width 0 :height 0) - (gtk-tree-view-get-cell-area tree-view path column it))) + (let ((rect (make-rectangle :x 0 :y 0 :width 0 :height 0))) + (gtk-tree-view-get-cell-area tree-view path column rect) + rect)) (export 'tree-view-get-cell-area) @@ -203,8 +204,9 @@ (rectangle (g-boxed-ptr rectangle))) (defun tree-view-get-background-area (tree-view path column) - (aprog1 (make-rectangle :x 0 :y 0 :width 0 :height 0) - (gtk-tree-view-get-background-area tree-view path column it))) + (let ((rect (make-rectangle :x 0 :y 0 :width 0 :height 0))) + (gtk-tree-view-get-background-area tree-view path column rect) + rect)) (export 'tree-view-get-background-area) @@ -213,8 +215,9 @@ (rectangle (g-boxed-ptr rectangle))) (defun tree-view-get-visible-rect (tree-view) - (aprog1 (make-rectangle :x 0 :y 0 :width 0 :height 0) - (gtk-tree-view-get-visible-rect tree-view it))) + (let ((rect (make-rectangle :x 0 :y 0 :width 0 :height 0))) + (gtk-tree-view-get-visible-rect tree-view rect) + rect)) (export 'tree-view-get-visible-rect) diff --git a/subtest.lisp b/subtest.lisp index 4978b8a..c422022 100644 --- a/subtest.lisp +++ b/subtest.lisp @@ -142,9 +142,10 @@ (defmethod tree-model-get-path-impl ((model array-list-store) iter) (gobject:using* (iter) - (anaphora:aprog1 (make-instance 'tree-path) - (setf (tree-path-indices anaphora:it) (list (tree-iter-user-data iter))) - (gobject:disown-boxed-ref anaphora:it)))) + (let ((path (make-instance 'tree-path))) + (setf (tree-path-indices path) (list (tree-iter-user-data iter))) + (gobject:disown-boxed-ref path) + path))) (defmethod tree-model-iter-has-child-impl ((model array-list-store) iter) (gobject:release iter) -- 1.7.10.4