From rklochkov at common-lisp.net Mon Aug 8 14:54:53 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 08 Aug 2011 07:54:53 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/utils Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/utils In directory tiger.common-lisp.net:/tmp/cvs-serv24379/utils Log Message: Directory /project/gtk-cffi/cvsroot/gtk-cffi/utils added to the repository From rklochkov at common-lisp.net Mon Aug 8 15:02:01 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 08 Aug 2011 08:02:01 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/cffi Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/cffi In directory tiger.common-lisp.net:/tmp/cvs-serv32663/cffi Modified Files: object.lisp Log Message: Major commit. Now all exerices ex*.lisp work perfectly. Added lisp-array model for tree-view (see ex9). --- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp 2011/08/08 15:02:01 1.2 @@ -93,9 +93,12 @@ ;; converts class object to pointer and vice versa (define-foreign-type cffi-object () - () - (:actual-type :pointer) - (:simple-parser object)) + ((class :initarg :class :accessor obj-class)) + (:actual-type :pointer)) +; (:simple-parser object)) + +(define-parse-method object (&optional class) + (make-instance 'cffi-object :class class)) (defmethod translate-to-foreign ((value null) (type cffi-object)) (null-pointer)) @@ -108,7 +111,7 @@ value) -(defmethod translate-from-foreign (ptr (name cffi-object)) - (object ptr)) +(defmethod translate-from-foreign (ptr (cffi-object cffi-object)) + (object ptr :class (obj-class cffi-object))) From rklochkov at common-lisp.net Mon Aug 8 15:02:01 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 08 Aug 2011 08:02:01 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/examples Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/examples In directory tiger.common-lisp.net:/tmp/cvs-serv32663/examples Modified Files: ex2.lisp ex5.lisp ex6.lisp ex7.lisp ex8.lisp Log Message: Major commit. Now all exerices ex*.lisp work perfectly. Added lisp-array model for tree-view (see ex9). --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex2.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex2.lisp 2011/08/08 15:02:01 1.2 @@ -31,7 +31,7 @@ (cffi:defcallback on-delete :boolean ((widget :pointer) (event :pointer) (module gtk-string)) - (declare (ignore widget)) + (declare (ignore widget event)) (unless (string= module "main") (hide (gethash module *apps*)) (show (gethash "main" *apps*) :all t) @@ -115,11 +115,15 @@ (setup-app module))) *mods*) (let ((main-dialog (gethash "main" *apps*))) - ;(show main-dialog :all t) + (show main-dialog :all t) (run main-dialog) (format t "here end~%") (destroy main-dialog)) +;; Cleanup after dialog +(g-object-cffi::timeout-add :idle #'gtk-main-quit) +(gtk-main) + ;(setf window (make-instance 'window)) ;(set-border-width window 6) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex5.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex5.lisp 2011/08/08 15:02:01 1.2 @@ -1,7 +1,7 @@ (asdf:oos 'asdf:load-op :gtk-cffi) (defpackage #:test - (:use #:common-lisp #:gtk-cffi #:gobject-cffi)) + (:use #:common-lisp #:gtk-cffi #:g-object-cffi)) (in-package #:test) (gtk-init) @@ -12,7 +12,7 @@ (size-request window) '(400 150)) -(setf (bg-pixmap window :normal) "/usr/share/pixmaps/gqview.png") +(setf (bg-pixmap window :normal) "/usr/share/pixmaps/gnome-color-browser.png") (show window) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex6.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex6.lisp 2011/08/08 15:02:01 1.2 @@ -3,7 +3,8 @@ (asdf:oos 'asdf:load-op :gtk-cffi) (defpackage #:test - (:use #:common-lisp #:gdk-cffi #:gtk-cffi #:gobject-cffi)) + (:use #:common-lisp #:gdk-cffi #:gtk-cffi #:g-object-cffi) + (:shadowing-import-from #:gtk-cffi #:image #:window)) (in-package #:test) (gtk-init) @@ -36,10 +37,10 @@ (format t "~a ~a ~a~%" widget event img) (let* ((pixbuf (make-instance 'pixbuf :file img)) (w (width pixbuf)) - (h (height pixbuf)) + ;(h (height pixbuf)) (dest-x (- (allocation-width (allocation widget)) w)) (dest-y 0)) - (draw-pixbuf (gdkwindow widget) + (draw-pixbuf (gdk-window widget) (style-field widget :bg-gc) pixbuf 0 0 dest-x dest-y) (let ((ch (child widget))) (when ch @@ -47,9 +48,10 @@ t)) -(let ((eventbox-left (make-instance 'event-box))) +(let ((eventbox-left (make-instance 'event-box)) + (vbox-left (make-instance 'v-box :homogeneous t))) (pack hbox eventbox-left :expand t :fill t) - (add eventbox-left (setf vbox-left (make-instance 'v-box :homogeneous t))) + (add eventbox-left vbox-left) (pack* vbox-left ((make-instance 'label :text "This is left eventbox.")) ((make-instance 'label :text "The green ball is the bg image.")) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex7.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex7.lisp 2011/08/08 15:02:01 1.2 @@ -1,8 +1,11 @@ (asdf:oos 'asdf:load-op :gtk-cffi) (declaim (optimize speed)) -(defpackage #:test - (:use #:common-lisp #:gtk-cffi #:gobject-cffi)) -(in-package #:test) +(defpackage #:ex7 + (:use #:common-lisp #:gtk-cffi #:g-object-cffi)) +(in-package #:ex7) + +(defvar *window*) +(defvar *cell-pix*) (defun main () (gtk-init) @@ -14,7 +17,7 @@ (let ((window (make-instance 'window :width 400 :height 280))) (setf (gsignal window :destroy) :gtk-main-quit) - (defvar *window* window) + (setf *window* window) (let ((v-box (make-instance 'v-box)) (data '(("01-01-08" "Some event") @@ -53,7 +56,7 @@ (when (= col 1) (setf (property cell-renderer :editable) t) - (defvar *cell-pix* (make-instance 'cell-renderer-pixbuf)) + (setf *cell-pix* (make-instance 'cell-renderer-pixbuf)) (pack column *cell-pix*) (setf (property *cell-pix* :pixbuf) (make-instance 'gdk-cffi:pixbuf @@ -62,6 +65,7 @@ (setf (gsignal cell-renderer :edited) (let ((%col col)) (lambda (cell path new-text) + (declare (ignore cell)) (path->iter model path) (setf (model-values model :col %col) @@ -73,7 +77,7 @@ (gsignal view :button-press-event) (lambda (view event) (when (and (eq (gdk-cffi:get-slot event :type) :button-press) - (= (gdk-cffi:get-slot event :button) 1)) + (= (the integer (gdk-cffi:get-slot event :button)) 1)) (with-path-at-pos view (round (gdk-cffi:get-slot event :x)) (round (gdk-cffi:get-slot event :y)) @@ -94,7 +98,7 @@ (defun set-bold (view column) (format t "set ~A~%" column) (loop :for col :in (columns view) - :for i :from 0 + :for i :from 0 :to 100 :do (progn (setf (font (widget col)) (if (equal col column) @@ -104,6 +108,7 @@ (defun on-click (view path-list) (destructuring-bind (path column x y) path-list + (declare (ignore y)) (let ((cell (get-cell-at column x))) (format t "cell: ~A~%" cell) (when (equal cell *cell-pix*) @@ -118,7 +123,7 @@ (let ((top-area (v-box dialog))) (pack top-area text-view :pack-fill t :expand t) (show text-view)) - (set-position dialog :center-on-parent) + (setf (win-position dialog) :center-on-parent) ;(pack top-area text-view :fill t :expand t)) (run dialog) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex8.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex8.lisp 2011/08/08 15:02:01 1.2 @@ -4,7 +4,7 @@ (asdf:oos 'asdf:load-op :closer-mop) (defpackage #:test - (:use #:common-lisp #:gtk-cffi #:gobject-cffi)) + (:use #:common-lisp #:gtk-cffi #:g-object-cffi)) (in-package #:test) (defun main () From rklochkov at common-lisp.net Mon Aug 8 15:02:01 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 08 Aug 2011 08:02:01 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/g-lib Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/g-lib In directory tiger.common-lisp.net:/tmp/cvs-serv32663/g-lib Modified Files: list.lisp Log Message: Major commit. Now all exerices ex*.lisp work perfectly. Added lisp-array model for tree-view (see ex9). --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/list.lisp 2011/04/25 19:16:07 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/list.lisp 2011/08/08 15:02:01 1.2 @@ -29,7 +29,7 @@ (defvar *list* nil) -(defcallback list-collect :void ((data object) (user-data :pointer)) +(defcallback list-collect :void ((data :pointer) (user-data :pointer)) (declare (ignore user-data)) (push data *list*)) From rklochkov at common-lisp.net Mon Aug 8 15:02:01 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 08 Aug 2011 08:02:01 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/g-object Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/g-object In directory tiger.common-lisp.net:/tmp/cvs-serv32663/g-object Modified Files: g-object-cffi.asd g-object-class.lisp g-object.lisp g-type.lisp package.lisp pobject.lisp subclass.lisp Log Message: Major commit. Now all exerices ex*.lisp work perfectly. Added lisp-array model for tree-view (see ex9). --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-cffi.asd 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-cffi.asd 2011/08/08 15:02:01 1.2 @@ -14,7 +14,7 @@ :author "Roman Klochkov " :version "0.3" :license "LGPL" - :depends-on (cffi-object g-lib-cffi) + :depends-on (cffi-object g-lib-cffi gtk-cffi-utils) :components ((:file :package) (:file :loadlib :depends-on (:package)) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-class.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-class.lisp 2011/08/08 15:02:01 1.2 @@ -10,6 +10,19 @@ (defclass g-object-class (object) ()) +(defcstruct g-object-class + (type-class g-type-class) + (construct-properties :pointer) + (constructor :pointer) + (set-property :pointer) + (get-property :pointer) + (dispose :pointer) + (finalize :pointer) + (dispatch-properties-changed :pointer) + (notify :pointer) + (constructed :pointer) + (pdummy :pointer :count 7)) + (defmethod gconstructor ((g-object-class g-object-class) &key object) (mem-ref (pointer object) :pointer)) @@ -17,7 +30,7 @@ (defcfun "g_object_class_list_properties" :pointer (obj-class pobject) (n-props :pointer)) -(defclass gparam-spec (object) +(defclass g-param-spec (object) ()) (defmethod list-properties ((g-object-class g-object-class)) @@ -26,7 +39,7 @@ (let ((res (g-object-class-list-properties g-object-class n-props))) (unwind-protect (loop :for i :below (mem-ref n-props :int) - :collect (make-instance 'gparam-spec + :collect (make-instance 'g-param-spec :pointer (mem-aref res :pointer i))) (foreign-free res))))) @@ -36,41 +49,41 @@ (defmethod find-property ((g-object-class g-object-class) key) (let ((ptr (g-object-class-find-property g-object-class key))) (unless (null-pointer-p ptr) - (make-instance 'gparam-spec :pointer ptr)))) + (make-instance 'g-param-spec :pointer ptr)))) (defcfun "g_param_spec_get_name" :string (param pobject)) -(defmethod name ((gparam-spec gparam-spec)) - (g-param-spec-get-name gparam-spec)) +(defmethod name ((g-param-spec g-param-spec)) + (g-param-spec-get-name g-param-spec)) (defcfun "g_param_spec_get_nick" gtk-string (param pobject)) -(defmethod nick ((gparam-spec gparam-spec)) - (g-param-spec-get-nick gparam-spec)) +(defmethod nick ((g-param-spec g-param-spec)) + (g-param-spec-get-nick g-param-spec)) (defcfun "g_param_spec_get_blurb" gtk-string (param pobject)) -(defmethod blurb ((gparam-spec gparam-spec)) - (g-param-spec-get-blurb gparam-spec)) +(defmethod blurb ((g-param-spec g-param-spec)) + (g-param-spec-get-blurb g-param-spec)) -(defbitfield gparam-flags +(defbitfield g-param-flags :readable :writable :construct :construct-only :lax-validation :static-name :static-nick :static-blurb) -(defcstruct gparam-spec - "GParamSpec" +(defcstruct g-param-spec + "GParamSpec" (g-type-instance :pointer) (name :string) - (flags gparam-flags) + (flags g-param-flags) (type :ulong) (owner-type :ulong)) -(defmethod flags ((gparam-spec gparam-spec)) - (foreign-slot-value (pointer gparam-spec) 'gparam-spec 'flags)) +(defmethod flags ((g-param-spec g-param-spec)) + (foreign-slot-value (pointer g-param-spec) 'g-param-spec 'flags)) -(defmethod g-type ((gparam-spec gparam-spec) &key owner) - (foreign-slot-value (pointer gparam-spec) 'gparam-spec (if owner 'owner-type - 'type))) +(defmethod g-type ((g-param-spec g-param-spec) &key owner) + (foreign-slot-value (pointer g-param-spec) + 'g-param-spec (if owner 'owner-type 'type))) (defun show-properties (g-object) (let ((gclass (make-instance 'g-object-class :object g-object))) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2011/08/08 15:02:01 1.2 @@ -299,4 +299,11 @@ (defcfun ("g_object_ref" ref) :pointer (obj pobject)) (defcfun ("g_object_unref" unref) :void (obj pobject)) -(defcfun g-object-new :pointer (class-type g-type)) \ No newline at end of file +(defcfun g-object-new :pointer (class-type g-type) (null :pointer)) + +(defun new (id) + (g-object-new id (null-pointer))) + +(defcfun g-object-newv :pointer (class-type g-type) + (n-params :uint) (params :pointer)) + \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-type.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-type.lisp 2011/08/08 15:02:01 1.2 @@ -20,7 +20,30 @@ (defctype g-type :ulong "GType") +(defcstruct g-type-interface + "GTypeInterface" + (g-type g-type) + (g-instance-type g-type)) + +(defcstruct g-type-class + "GTypeClass" + (g-type g-type)) + +(defcstruct g-type-instance + "GTypeInstance" + (g-class (:pointer g-type-class))) + (defcfun g-type-fundamental g-type (id g-type)) +(defcfun g-type-from-name g-type (name :string)) + +(defcstruct g-type-query + "GTypeQuery" + (type g-type) + (name :string) + (class-size :uint) + (instance-size :uint)) + +(defcfun g-type-query :void (type g-type) (query g-type-query)) (defun g-type->name (num) "Integer (GType) -> keyword from +fundamental-gtypes+" @@ -29,11 +52,11 @@ (defvar *types* (make-hash-table) "Hash table: GType num -> lisp object") -(defvar *typenames* (make-hash-table :test 'equal) - "Hash table: GTK type name (string) -> lisp object") +(defvar *typenames* nil + "Assoc: GTK type name (string) -> lisp object") (defun register-type (lisp-class gtk-typename) - (setf (gethash gtk-typename *typenames*) lisp-class)) + (setq *typenames* (acons gtk-typename lisp-class *typenames*))) (defvar *gtk-packages* nil ;; (mapcar @@ -48,13 +71,6 @@ (defcfun "g_type_name" :string (id :ulong)) -(defmacro with-hash (hash key &body body) - (let ((try (gensym))) - `(or (gethash ,key ,hash) - (let ((,try (progn , at body))) - (when ,try - (setf (gethash ,key ,hash) ,try)))))) - (defun g-type->lisp (g-type) "Returns lisp class for the gtype and caches result Ex.: GType of GtkWindow -> 'gtk-cffi:window" @@ -74,8 +90,7 @@ (with-hash *types* g-type (let ((typename (g-type-name g-type))) (when typename - (with-hash - *typenames* typename + (or (cdr (assoc typename *typenames* :test 'string=)) (let* ((pr-pos (loop :for c :across (subseq typename 1) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2011/08/08 15:02:01 1.2 @@ -8,7 +8,7 @@ (in-package #:cl-user) (defpackage #:g-object-cffi - (:use #:common-lisp #:cffi #:cffi-object #:g-lib-cffi) + (:use #:common-lisp #:cffi #:cffi-object #:g-lib-cffi #:gtk-cffi-utils) (:import-from #:cffi-object *objects*) (:export @@ -58,5 +58,16 @@ #:g-object-class #:gparam-spec - #:g-object-new)) + #:g-object-newv + #:new + + #:g-type-info + #:g-type-flags + #:g-type-register-static + #:g-type-register-static-simple + #:g-interface-info + #:g-type-add-interface-static + #:g-type-interface + #:g-type-class + #:g-type-instance)) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp 2011/08/08 15:02:01 1.2 @@ -44,7 +44,7 @@ (defmethod translate-from-foreign :around (ptr (name g-list-object)) (declare (ignorable ptr name)) (mapcar (lambda (x) (convert-from-foreign x 'pobject)) - (call-next-method))) + (call-next-method))) (defcfun g-type-interface-peek-parent pobject (iface pobject)) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/subclass.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/subclass.lisp 2011/08/08 15:02:01 1.2 @@ -1,4 +1,11 @@ -(in-package :g-object-cffi) +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; gtype.lisp --- GType functions +;;; +;;; Copyright (C) 2007, Roman Klochkov +;;; + +(in-package #:g-object-cffi) (defcstruct g-type-info "GTypeInfo" @@ -37,17 +44,5 @@ (defcfun g-type-add-interface-static :void (instance-type g-type) (interface-type g-type) (info g-interface-info)) -(defcstruct g-type-interface - "GTypeInterface" - (g-type g-type) - (g-instance-type g-type)) - -(defcstruct g-type-class - "GTypeClass" - (g-type g-type)) - -(defcstruct g-type-instance - "GTypeInstance" - (g-class (:pointer g-type-class))) \ No newline at end of file From rklochkov at common-lisp.net Mon Aug 8 15:02:02 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 08 Aug 2011 08:02:02 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/gdk Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/gdk In directory tiger.common-lisp.net:/tmp/cvs-serv32663/gdk Modified Files: drawable.lisp gc.lisp screen.lisp Log Message: Major commit. Now all exerices ex*.lisp work perfectly. Added lisp-array model for tree-view (see ex9). --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/drawable.lisp 2011/04/25 19:16:07 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/drawable.lisp 2011/08/08 15:02:02 1.2 @@ -1,6 +1,6 @@ (in-package :gdk-cffi) -(defclass drawable (gobject) +(defclass drawable (g-object) ()) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/gc.lisp 2011/04/25 19:16:07 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/gc.lisp 2011/08/08 15:02:02 1.2 @@ -1,6 +1,6 @@ (in-package :gdk-cffi) -(defclass gc (gobject) +(defclass gc (g-object) ()) (register-type 'gc "GdkGC") --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/screen.lisp 2011/04/25 19:16:07 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/screen.lisp 2011/08/08 15:02:02 1.2 @@ -1,6 +1,6 @@ (in-package :gdk-cffi) -(defclass screen (gobject) +(defclass screen (g-object) ()) (defcfun "gdk_screen_get_default" :pointer) From rklochkov at common-lisp.net Mon Aug 8 15:02:02 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 08 Aug 2011 08:02:02 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/gtk Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/gtk In directory tiger.common-lisp.net:/tmp/cvs-serv32663/gtk Modified Files: cell-renderer-pixbuf.lisp gtk-cffi.asd lisp-model.lisp package.lisp tree-model.lisp Log Message: Major commit. Now all exerices ex*.lisp work perfectly. Added lisp-array model for tree-view (see ex9). --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-renderer-pixbuf.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-renderer-pixbuf.lisp 2011/08/08 15:02:02 1.2 @@ -5,7 +5,6 @@ (defcfun "gtk_cell_renderer_pixbuf_new" :pointer) -(defmethod initialize-instance - :after ((cell-renderer-pixbuf cell-renderer-pixbuf) - &key &allow-other-keys) - (setf (pointer cell-renderer-pixbuf) (gtk-cell-renderer-pixbuf-new))) +(defmethod gconstructor ((cell-renderer-pixbuf cell-renderer-pixbuf) + &key &allow-other-keys) + (gtk-cell-renderer-pixbuf-new)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2011/08/08 15:02:02 1.2 @@ -447,6 +447,14 @@ :components ((:file :image))) +(defsystem gtk-cffi-lisp-model + :description "Interface to GTK/Glib via CFFI" + :author "Roman Klochkov " + :version "0.1" + :license "GPL" + :depends-on (gtk-cffi-tree-model) + :components + ((:file :lisp-model))) (defsystem gtk-cffi :description "Interface to GTK/Glib via CFFI" @@ -477,5 +485,6 @@ gtk-cffi-statusbar gtk-cffi-notebook gtk-cffi-image - gtk-cffi-text-view)) + gtk-cffi-text-view + gtk-cffi-lisp-model)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/lisp-model.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/lisp-model.lisp 2011/08/08 15:02:02 1.2 @@ -1,57 +1,198 @@ (in-package #:gtk-cffi) -(defclass lisp-model (g-object tree-model) - ((g-type :type fixnum))) +(defclass lisp-model-impl () + ((columns :initarg :columns :accessor columns))) -(defcallback cb-lisp-model-class-init :void ((class :pointer))) +(defclass lisp-model-list (lisp-model-impl) + ()) -(defcallback cb-lisp-model-init :void ((self :pointer))) +(defclass lisp-model-array (lisp-model-list) + ((array :initarg :array :accessor larray))) +(defgeneric get-flags (lisp-model-impl) + (:method ((lisp-model-list lisp-model-list)) + 0)) + +(defgeneric get-n-columns (lisp-model-impl) + (:method ((lisp-model-list lisp-model-list)) + 1)) + +(defgeneric get-column-type (lisp-model-impl index) + (:method ((lisp-model-impl lisp-model-impl) index) + (name->g-type (nth index (columns lisp-model-impl))))) + +(defgeneric lisp-model-length (lisp-model-list) + (:method ((lisp-model-array lisp-model-array)) + (length (larray lisp-model-array)))) + +(defgeneric get-iter (lisp-model-impl iter path) + (:method ((lisp-model-list lisp-model-list) iter path) + (let ((index (get-index (make-instance 'tree-path :pointer path)))) + (when (< index (lisp-model-length lisp-model-list)) + (with-foreign-slots ((stamp u1) iter tree-iter-struct) + (setf stamp 0 u1 (make-pointer index))))))) + + +(defgeneric get-path (lisp-model-impl iter) + (:method ((lisp-model-list lisp-model-list) iter) + (let ((index (pointer-address + (foreign-slot-value iter 'tree-iter-struct 'u1)))) + (make-instance 'tree-path :indices (list index))))) + +(defgeneric get-value (lisp-model-impl iter n value) + (:method ((lisp-model-array lisp-model-array) iter n value) + (debug-out "get-value~%") + (let* ((index (pointer-address (foreign-slot-value + iter 'tree-iter-struct 'u1))) + (lval (nth n (aref (larray lisp-model-array) index)))) + (g-object-cffi::init-g-value value nil lval t)))) + + +(defgeneric iter-next (lisp-model-impl iter) + (:method ((lisp-model-list lisp-model-list) iter) + (let ((index (pointer-address + (foreign-slot-value iter 'tree-iter-struct 'u1)))) + (when (< (1+ index) (lisp-model-length lisp-model-list)) + (setf (foreign-slot-value iter 'tree-iter-struct 'u1) + (make-pointer (1+ index))))))) + +(defgeneric iter-children (lisp-model-impl iter parent) + (:method ((lisp-model-list lisp-model-list) iter parent) + (when (null-pointer-p parent) + (setf (foreign-slot-value iter 'tree-iter-struct 'u1) + (make-pointer 0))))) + + +(defgeneric iter-has-child (lisp-model-impl iter) + (:method ((lisp-model-list lisp-model-list) iter) + nil)) + +(defgeneric iter-n-children (lisp-model-impl iter) + (:method ((lisp-model-list lisp-model-list) iter) + 0)) + +(defgeneric iter-nth-child (lisp-model-impl iter parent n) + (:method ((lisp-model-list lisp-model-list) iter parent n) + nil)) + +(defgeneric iter-parent (lisp-model-impl iter child) + (:method ((lisp-model-list lisp-model-list) iter child) + nil)) + +(defgeneric ref-node (lisp-model-impl iter) + (:method ((lisp-model-impl lisp-model-impl) iter) + nil)) + +(defgeneric unref-node (lisp-model-impl iter) + (:method ((lisp-model-impl lisp-model-impl) iter) + nil)) +(defclass lisp-model (g-object tree-model) + ((implementation :type standard-object + :initarg :implementation + :initform (error "Implementation not set") + :reader implementation))) + +(defcallback cb-lisp-model-class-init :void ((class :pointer)) + (declare (ignore class)) + (debug-out "Class init called~%")) + +(defcallback cb-lisp-model-init :void ((self :pointer)) + (declare (ignore self)) + (debug-out "Object init called~%")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun symb (&rest args) + (apply #'alexandria:symbolicate args))) + +(defmacro init-interface (interface &rest callbacks) + `(progn + ,@(loop :for (callback args) :on callbacks :by #'cddr + :collecting + `(defcallback ,(symb '#:cb- callback) ,(car args) + ((object pobject) ,@(cdr args)) + (,callback (implementation object) ,@(mapcar #'car (cdr args))))) + (defcallback ,(symb '#:cb-init- interface) :void ((class ,interface)) + ,@(loop :for (callback args) :on callbacks :by #'cddr + :collecting `(setf (foreign-slot-value class ',interface ',callback) + (callback ,(symb '#:cb- callback))))))) + +(init-interface + tree-model-iface + get-flags (:int) + get-n-columns (:int) + get-column-type (:int (index :int)) + get-iter (:boolean (iter tree-iter-struct) (path :pointer)) + get-path (pobject (iter tree-iter-struct)) + get-value (:void (iter tree-iter-struct) (n :int) (value :pointer)) + iter-next (:boolean (iter tree-iter-struct)) + iter-children (:boolean (iter tree-iter-struct) (parent tree-iter-struct)) + iter-has-child (:boolean (iter tree-iter-struct)) + iter-n-children (:int (iter tree-iter-struct)) + iter-nth-child (:boolean (iter tree-iter-struct) + (parent tree-iter-struct) (n :int)) + iter-parent (:boolean (iter tree-iter-struct) (child tree-iter-struct)) + ref-node (:void (iter tree-iter-struct)) + unref-node (:void (iter tree-iter-struct))) + + + +;(defcallback cb-init- :void ((class tree-model-iface) (data pdata)) +; (setf (foreign-slot-value class 'tree-model-iface 'get-flags) +; (callback cb-get-flags))) + ;; (init-iface class tree-model-iface + ;; get-flags + ;; get-column-type + ;; get-iter + ;; get-path + ;; get-value + ;; iter-next + ;; iter-children + ;; iter-has-child + ;; iter-n-children + ;; iter-nth-child + ;; iter-parent + ;; ref-node + ;; unref-node)) + + +; (check-type data symbol) +; (init-interface data +; (g-type->lisp +; (foreign-slot-value class 'tree-model-iface 'g-iface)) +; class)) -(defcallback cb-init-interface :void ((class :pointer) (data pdata)) - (check-type data symbol) - (init-interface data - (g-type->lisp - (foreign-slot-value class 'tree-model-iface 'g-iface)) - class)) -(defcallback cb-get-flags :int ((object :pointer)) - 0) -(defcallback cb-get-column-type :int ((object pobject) (index :int)) - (get-column-type object index)) (defcstruct g-interface-info (init :pointer) (finalize :pointer) (data pdata)) -(defcstruct lisp-model - (parent-instance g-object)) - -(defcstruct lisp-model-class - (parent-class g-object-class)) +(defcfun gtk-tree-model-get-type :uint) -(let ((interface-info (foreign-alloc 'g-interface-info))) +(let ((interface-info (foreign-alloc 'g-interface-info)) + g-type) (setf (foreign-slot-value interface-info 'g-interface-info 'init) - (callback cb-init-interface)) + (callback cb-init-tree-model-iface)) (defmethod get-type ((lisp-model lisp-model)) - (or (g-type lisp-model) + (or g-type (prog1 - (setf (g-type lisp-model) + (setf g-type (g-type-register-static-simple - (name->g-type :object) + #.(name->g-type :object) (g-intern-static-string "GtkLispModel") - (foreign-type-size 'lisp-model-class) - cb-lisp-model-class-init - (foreign-type-size 'lisp-model) - cb-lisp-model-init + (foreign-type-size 'g-object-class) + (callback cb-lisp-model-class-init) + (foreign-type-size 'g-object) + (callback cb-lisp-model-init) 0)) - (g-type-add-interface-static (g-type lisp-model) + (g-type-add-interface-static g-type (gtk-tree-model-get-type) interface-info))))) -(defmethod gconstructor ((lisp-model lisp-model)) - (g-object-new (get-type lisp-model)) \ No newline at end of file +(defmethod gconstructor ((lisp-model lisp-model) &rest initargs) + (declare (ignore initargs)) + (new (get-type lisp-model))) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2011/08/08 15:02:02 1.2 @@ -283,6 +283,10 @@ #:icon-source #:image + + #:lisp-model + #:lisp-model-array + #:larray )) (in-package #:gtk-cffi) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2011/08/08 15:02:02 1.2 @@ -101,11 +101,13 @@ (g-iface g-type-interface) (row-changed :pointer) (row-inserted :pointer) + (has-child-toggled :pointer) (row-deleted :pointer) (row-reordered :pointer) ; virtual methods (get-flags :pointer) + (get-n-columns :pointer) (get-column-type :pointer) (get-iter :pointer) (get-path :pointer) From rklochkov at common-lisp.net Mon Aug 8 15:02:02 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 08 Aug 2011 08:02:02 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/utils Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/utils In directory tiger.common-lisp.net:/tmp/cvs-serv32663/utils Added Files: gtk-cffi-utils.asd package.lisp utils.lisp Log Message: Major commit. Now all exerices ex*.lisp work perfectly. Added lisp-array model for tree-view (see ex9). --- /project/gtk-cffi/cvsroot/gtk-cffi/utils/gtk-cffi-utils.asd 2011/08/08 15:02:02 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/utils/gtk-cffi-utils.asd 2011/08/08 15:02:02 1.1 (defpackage #:gtk-cffi-utils-system (:use #:cl #:asdf)) (in-package #:gtk-cffi-utils-system) (defsystem gtk-cffi-utils :description "Different utils for gtk-cffi" :author "Roman Klochkov " :version "1.0" :license "LGPL" :components ((:file :package) (:file :utils :depends-on (:package))))--- /project/gtk-cffi/cvsroot/gtk-cffi/utils/package.lisp 2011/08/08 15:02:02 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/utils/package.lisp 2011/08/08 15:02:02 1.1 (in-package #:cl-user) (defpackage #:gtk-cffi-utils (:use #:common-lisp) (:export #:with-hash))--- /project/gtk-cffi/cvsroot/gtk-cffi/utils/utils.lisp 2011/08/08 15:02:02 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/utils/utils.lisp 2011/08/08 15:02:02 1.1 (in-package :gtk-cffi-utils) (defmacro with-hash (hash key &body body) (let ((try (gensym))) `(or (gethash ,key ,hash) (let ((,try (progn , at body))) (when ,try (setf (gethash ,key ,hash) ,try)))))) From rklochkov at common-lisp.net Fri Aug 26 17:16:13 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Fri, 26 Aug 2011 10:16:13 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/cffi Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/cffi In directory tiger.common-lisp.net:/tmp/cvs-serv16215/cffi Modified Files: cffi-object.asd object.lisp package.lisp string.lisp Log Message: Added GTK3 support. Dropped GTK2 support. Refactored CFFI layer. --- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/cffi-object.asd 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/cffi-object.asd 2011/08/26 17:16:13 1.2 @@ -14,9 +14,10 @@ :author "Roman Klochkov " :version "0.9" :license "BSD" - :depends-on (cffi) + :depends-on (cffi iterate gtk-cffi-utils) :components - ((:file :package) - (:file :object :depends-on (:package)) - (:file :pfunction :depends-on (:package)) - (:file :string :depends-on (:package)))) \ No newline at end of file + ((:file package) + (:file object :depends-on (package)) + (:file pfunction :depends-on (package)) + (:file string :depends-on (package)) + (:file struct :depends-on (package)))) --- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp 2011/08/08 15:02:01 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp 2011/08/26 17:16:13 1.3 @@ -7,11 +7,6 @@ (in-package :cffi-object) -(defmacro debug-out (&body body) -; (declare (ignore body)) - `(format t , at body) - ) - (defvar *objects* (make-hash-table) "Hash table: foreign-pointer address as integer -> lisp object") @@ -47,9 +42,10 @@ (format t "No constructor for ~a ~a~%" something-bad rest) nil) -(defmethod initialize-instance ((object object) &rest initargs - &key pointer &allow-other-keys) - (call-next-method) ;; should be here to initialize VOLATILE slot +(defmethod shared-initialize :after ((object object) slot-names + &rest initargs + &key pointer &allow-other-keys) +; (call-next-method) ;; should be here to initialize VOLATILE slot (setf (pointer object) (or pointer (apply #'gconstructor (cons object initargs))))) @@ -62,8 +58,8 @@ (:documentation "Removes object pointer from lisp hashes.")) (defmethod free ((object object)) - (debug-out "Freeing ~a~%" object) (when (pointer object) + (debug-out "Freeing ~a@~a~%" (type-of object) (pointer object)) (remhash (pointer-address (pointer object)) *objects*) (remhash (id object) *objects-ids*) (setf (pointer object) (null-pointer) @@ -95,7 +91,6 @@ (define-foreign-type cffi-object () ((class :initarg :class :accessor obj-class)) (:actual-type :pointer)) -; (:simple-parser object)) (define-parse-method object (&optional class) (make-instance 'cffi-object :class class)) @@ -106,11 +101,19 @@ (defmethod translate-to-foreign ((value object) (type cffi-object)) (pointer value)) +(defmethod translate-to-foreign ((value object) + (type cffi::foreign-pointer-type)) + (pointer value)) + +(defmethod translate-to-foreign ((value null) + (type cffi::foreign-pointer-type)) + (null-pointer)) + + (defmethod translate-to-foreign (value (type cffi-object)) (check-type value foreign-pointer) value) - (defmethod translate-from-foreign (ptr (cffi-object cffi-object)) (object ptr :class (obj-class cffi-object))) --- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/package.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/package.lisp 2011/08/26 17:16:13 1.2 @@ -10,11 +10,9 @@ (in-package #:cl-user) (defpackage #:cffi-object - (:use #:common-lisp #:cffi) + (:use #:iterate #:common-lisp #:cffi #:gtk-cffi-utils) (:export - #:debug-out - #:gconstructor #:object @@ -29,4 +27,7 @@ #:gtk-dyn-string #:gtk-new-string #:pfunction - #:cffi-object)) \ No newline at end of file + #:cffi-object + + #:defcstruct-accessors + #:defcstruct*)) --- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/string.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/string.lisp 2011/08/26 17:16:13 1.2 @@ -26,9 +26,9 @@ (defmethod translate-from-foreign (ptr (name gtk-string)) (foreign-string-to-lisp ptr :encoding :utf-8)) -(defmethod free-translated-object (value (name gtk-string) free-p) - (when free-p - (foreign-string-free value))) +(defmethod free-translated-object (value (name gtk-string) param) + (declare (ignore param)) + (foreign-string-free value)) (define-foreign-type gtk-dyn-string () () From rklochkov at common-lisp.net Fri Aug 26 17:16:13 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Fri, 26 Aug 2011 10:16:13 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/examples Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/examples In directory tiger.common-lisp.net:/tmp/cvs-serv16215/examples Modified Files: ex1-new.lisp ex1.lisp ex2.lisp ex3-flash-button.lisp ex4.lisp ex5.lisp ex7.lisp load-1c-txt.lisp Added Files: editor.lisp ex9.lisp paned.lisp Log Message: Added GTK3 support. Dropped GTK2 support. Refactored CFFI layer. --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex1-new.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex1-new.lisp 2011/08/26 17:16:13 1.2 @@ -5,11 +5,16 @@ (in-package #:test-ex1n) (gtk-init) -(defvar *window* +(defparameter *window* (gtk-model 'window :width 80 :title "Hello world!" - :signals '(:destroy :gtk-main-quit) + :signals `(:destroy + :gtk-main-quit + :enter-notify-event + ,(lambda (widget event) + (declare (ignore widget event)) + (format t "Entered~%"))) ('button :label "Hello!" :signals (list :clicked (let ((count 0)) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex1.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex1.lisp 2011/08/26 17:16:13 1.2 @@ -1,7 +1,7 @@ (asdf:oos 'asdf:load-op :gtk-cffi) (defpackage #:test-ex1 - (:use #:common-lisp #:gtk-cffi #:g-object-cffi)) + (:use #:common-lisp #:gtk-cffi #:g-object-cffi #:cffi)) (in-package #:test-ex1) (cffi:defcallback hello :void ((widget pobject) (data pdata)) @@ -14,9 +14,9 @@ (setf window (make-instance 'window :name "Example 1")) -(setf (bg-pixmap window) "/usr/share/pixmaps/gqview.png") +;(setf (bg-pixmap window) "/usr/share/pixmaps/gqview.png") -(setf (property window :resize-mode) :immediate) +;(setf (property window :resize-mode) :immediate) (setf (gsignal window "delete-event") (let ((i 0)) @@ -30,19 +30,22 @@ (setf (gsignal window :destroy) :gtk-main-quit) + (setf (border-width window) 25) (setf (default-size window) '(400 100)) -(setf button (make-instance 'button :label "gtk-index" :type :stock)) +;(setf button (make-instance 'button :label "gtk-ok" :type :stock)) -(setf (font button) "Times New Roman Italic 24") +(setf button (make-instance 'button :pointer (gtk-cffi::gtk-button-new-from-stock "gtk-ok"))) + +;(setf (color button :type :bg) "red") (setf (color button) "#0000ff") +(setf (font button) "Times New Roman Italic 24") (setf (gsignal button :clicked :data "????????????") (cffi:callback hello) - (gsignal button "clicked" :data window - :swapped t) "gtk-widget-destroy") + (gsignal button "clicked" :data window :swapped t) "gtk-widget-destroy") (add window button) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex2.lisp 2011/08/08 15:02:01 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex2.lisp 2011/08/26 17:16:13 1.3 @@ -23,7 +23,7 @@ (show (gethash activated-module *apps*) :all t) (mapcar (lambda (module) (unless (string= activated-module (car module)) - (hide (gethash (car module) *apps*) :all t))) + (hide (gethash (car module) *apps*)))) *mods*) (run (gethash activated-module *apps*))) @@ -79,10 +79,10 @@ (defun setup-app (module) (let ((dialog (make-instance 'dialog :title (car module) :flags :modal))) - (setf (win-position dialog) :center-always) + (setf (window-position dialog) :center-always) (setf (size-request dialog) (second module)) ;(setf (property dialog :content-area-border) 10) - (let ((top-area (v-box dialog))) + (let ((top-area (content-area dialog))) (flet ((print-out (str) (pack top-area (make-instance 'label :text str) @@ -98,7 +98,7 @@ (pack top-area (make-instance 'label) :fill t :expand t) (show-buttons top-area (car module))) - (setf (has-separator dialog) nil) + ;(setf (has-separator dialog) nil) (setf (gsignal dialog :delete-event :data (cffi:convert-to-foreign (car module) 'gtk-string)) (cffi:callback on-delete) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex3-flash-button.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex3-flash-button.lisp 2011/08/26 17:16:13 1.2 @@ -31,7 +31,7 @@ (setf button (make-instance 'button :label "Click Me!")) (setf (size-request button) '(80 32) - (color button :bg) "#FFCC66") + (color button :background t) "#FFCC66") (defvar *TIMEOUT*) @@ -46,11 +46,11 @@ (realize window) -(defparameter *ORG-BG* (color window :bg)) +(defparameter *ORG-BG* (color window :background t)) (let (i) (defun flash (button bgcolor) - (setf (color button :bg) (if i *ORG-BG* bgcolor)) + (setf (color button :background t) (if i *ORG-BG* bgcolor)) (setf i (not i)) t)) (setf *TIMEOUT* (timeout-add 200 #'flash :data (list button "#FFCC66"))) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex4.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex4.lisp 2011/08/26 17:16:13 1.2 @@ -1,7 +1,7 @@ (asdf:oos 'asdf:load-op :gtk-cffi) -(declaim (optimize speed)) +;(declaim (optimize speed)) (defpackage #:test - (:use #:common-lisp #:gtk-cffi #:gobject-cffi)) + (:use #:common-lisp #:gtk-cffi #:g-object-cffi)) (in-package #:test) (defun main () @@ -18,11 +18,12 @@ (setf (font title) "Times New Roman Italic 10" (color title) "#0000ff") (setf (size-request title) '(-1 40)) - (pack v-box title)) + (pack v-box title :expand nil)) (pack v-box (make-instance - 'label :text "Click on the options on the left pane.")) - (pack v-box (make-instance 'label)) + 'label :text "Click on the options on the left pane.") + :expand nil) + (pack v-box (make-instance 'label) :expand nil) (pack v-box hpane :fill t :expand t)) (let ((left-pane (make-instance 'frame)) @@ -49,7 +50,7 @@ (setf data (append data data)) (setf (shadow-type right-pane) :in) - (pack hpane right-pane :type 2 :resize t) + (pack hpane right-pane :pane-type 2 :resize t) (format t "parent of ~a is ~a~%" right-pane (property right-pane :parent)) (display-table right-pane data)) @@ -57,9 +58,14 @@ (show window :all t) (gtk-main))) +(defvar *model*) +(defvar *modelfilter1*) +(defvar *modelfilter2*) +(defvar *view*) + (defun display-table (container data) - (defparameter *model* + (setf *model* (make-instance 'list-store :columns '(:string :string :long :double :boolean :boolean ; filters @@ -67,15 +73,15 @@ :string ; third column ))) - (defparameter *modelfilter1* + (setf *modelfilter1* (make-instance 'tree-model-filter :model *model*)) (setf (visible-column *modelfilter1*) 4) - (defparameter *modelfilter2* + (setf *modelfilter2* (make-instance 'tree-model-filter :model *model*)) (setf (visible-column *modelfilter2*) 5) - (defparameter *view* + (setf *view* (make-instance 'tree-view :model *model*)) (let ((scrolled-win (make-instance 'scrolled-window))) @@ -104,9 +110,8 @@ (setf (widget column) label) (show label)) (if (/= col 0) (setf (reorderable column) t)) - (set-cell-data-func column cell-renderer - (cffi:callback format-col) - col) + (setf (cell-data-func column cell-renderer col) + (cffi:callback format-col)) (append-column *view* column))))) (setf (gsignal *model* :rows-reordered) (cffi:callback reorder)) @@ -119,7 +124,7 @@ (if (= (mod row 2) 1) "#dddddd" "#ffffff") (format nil "$~,2f" (fourth values))))) - (append-values *model* values))) + (append-values *model* values))) (let ((selection (get-selection *view*))) (setf (mode selection) :multiple) @@ -129,12 +134,12 @@ ;(format t "signals selection: ~a~%" (signals selection)) (format t "signals selection2: ~a~%" (gsignal selection :changed)) ;(setf (gsignal selection :changed) nil) - (format t "signals deleted: ~a~%" (signals selection)) + ;(format t "signals deleted: ~a~%" (gsignals selection)) ;(set-signal (get-selection *view*) :changed (cffi:callback on-selection)) )) +(defparameter *create-link-i* 0) (defun create-link (str) - (defvar *create-link-i* 0) (let ((event-box (make-instance 'event-box)) (label (make-instance 'label :text (format nil " ~a. ~a " @@ -166,7 +171,7 @@ ;; model iter)) :int 0))) ;(row-num (parse-integer (gtk-cffi::iter-string model iter)))) - (row-num (get-index (iter-path model iter)))) + (row-num (get-index (iter->path model iter)))) ; (format t "~a ~a ~a~%" row-num col-num cell-ptr) ;(format t "~a ~a ~a ~a ~a~%" column cell model iter col-num) @@ -177,8 +182,9 @@ (if (= col-num 3) (setf (property cell :text) (format nil "$~,2f" - (car (model-values model iter - 3))))) + (car (model-values model + :iter iter + :col 3))))) ; (if (and (= col-num 2) (> (cadr vals) 10)) ; (p-set cell :visible nil) ; (p-set cell :visible t))) @@ -201,44 +207,44 @@ ;; (when p (set-color m p iter data)))))))) (defun reformat-rows (model) - (tree-model-foreach + (gtk-cffi::foreach model (lambda (model path iter data) (let ((row-num (get-index path))) - (setf (model-values model iter 6) + (setf (model-values model :iter iter :col 6) (list (if (= (mod row-num 2) 1) - "#dddddd" "#ffffff"))))))) + "#dddddd" "#ffffff"))))))) -(cffi:defcallback reorder :void ((model-ptr pobject))) -; (reformat-rows model-ptr)) +(cffi:defcallback reorder :void ((model-ptr pobject)) + (reformat-rows model-ptr)) (cffi:defcallback link-clicked - :boolean ((widget :pointer) - (event :pointer) - (str pdata)) - (let* ((model (cond - ((string= str "Show All") *model*) - ((string= str "Qty > 10") *modelfilter1*) - ((string= str "Price < $10") - *modelfilter2*)))) - (format t "link clicked: ~a~%" str) - (when model - (setf (model *view*) model) - ;(reformat-rows model) - (setf (property *view* :headers-clickable) - (typep model 'list-store))))) - + :boolean ((widget :pointer) + (event :pointer) + (str pdata)) + (let* ((model (cond + ((string= str "Show All") *model*) + ((string= str "Qty > 10") *modelfilter1*) + ((string= str "Price < $10") + *modelfilter2*)))) + (format t "link clicked: ~a~%" str) + (when model + (setf (model *view*) model) + (reformat-rows model) + (setf (property *view* :headers-clickable) + (typep model 'list-store))))) + (cffi:defcallback on-selection - :void ((selection-ptr pobject) - (data-ptr :pointer)) - (with-selection selected selection-ptr - (when selected - (format - t "You have selected ~a~%" - (apply #'model-values - `(,@(subseq selected 0 2) - 1 2 7)))))) + :void ((selection-ptr pobject) + (data-ptr :pointer)) + (with-selection selected selection-ptr + (when selected + (format + t "You have selected ~a~%" + (model-values (first selected) + :iter (second selected) + :columns '(1 2 7)))))) -(main) \ No newline at end of file +(main) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex5.lisp 2011/08/08 15:02:01 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex5.lisp 2011/08/26 17:16:13 1.3 @@ -6,14 +6,14 @@ (gtk-init) -(setf window (make-instance 'window)) +(let ((window (make-instance 'window))) -(setf (gsignal window :destroy) :gtk-main-quit - (size-request window) '(400 150)) + (setf (gsignal window :destroy) :gtk-main-quit + (size-request window) '(400 150)) + + (setf (bg-pixmap window) "/usr/share/pixmaps/gnome-color-browser.png") -(setf (bg-pixmap window :normal) "/usr/share/pixmaps/gnome-color-browser.png") - -(show window) + (show window)) (gtk-main) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex7.lisp 2011/08/08 15:02:01 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex7.lisp 2011/08/26 17:16:13 1.3 @@ -29,7 +29,7 @@ (let ((title (make-instance 'label :text "Use of GtkCellEditable"))) (setf (font title) "Times New Roman Italic 12" (color title) "#0000ff" - (color title :bg) "#ff0000") + (color title :type :bg) "#ff0000") ;(setf (size-request title) '(-1 40)) (pack v-box title)) @@ -37,7 +37,7 @@ '(:string :string))) (frame (make-instance 'frame)) (view (make-instance 'tree-view :model model))) - ;(setf (color view :base :selected) "#ff0000") + (setf (color view :state :selected) "#ff0000") (pack v-box frame :pack-fill nil :expand t) (pack v-box (make-instance 'label) :pack-fill t :expand t) (add frame view) @@ -98,7 +98,7 @@ (defun set-bold (view column) (format t "set ~A~%" column) (loop :for col :in (columns view) - :for i :from 0 :to 100 + :for i :from 0 :to (length (columns view)) :do (progn (setf (font (widget col)) (if (equal col column) @@ -120,10 +120,10 @@ (iter (path->iter (model view) path))) (setf (text (buffer text-view)) (car (model-values (model view) :columns '(1) :iter iter))) - (let ((top-area (v-box dialog))) + (let ((top-area (content-area dialog))) (pack top-area text-view :pack-fill t :expand t) (show text-view)) - (setf (win-position dialog) :center-on-parent) + (setf (window-position dialog) :center-on-parent) ;(pack top-area text-view :fill t :expand t)) (run dialog) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/load-1c-txt.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/load-1c-txt.lisp 2011/08/26 17:16:13 1.2 @@ -10,7 +10,9 @@ (make-instance 'list-store :columns '(:string :string :string :boolean))) (defparameter *window* nil) -(defconstant +space+ '(#\Space #\Tab #\Newline)) +(defconstant +space+ + (if (boundp '+space+) +space+ + '(#\Space #\Tab #\Newline))) (defun empty (str) (string= @@ -109,6 +111,7 @@ (setf (text (object-by-id :filename)) (filename d))) (destroy d))) +;(import 'gtk-cffi::expand) (setf *window* (gtk-model 'window :width 800 @@ -133,7 +136,7 @@ :signals (list :file-set #'load-file) :id :filename) :expand t - ('v-paned + ('v-paned :vexpand t ('scrolled-window ('tree-view :model *model* :columns (list "?????? ????????????" "??????????" @@ -146,8 +149,8 @@ (setf (text (buffer (object-by-id :text))) (car (model-values model :iter iter :col 2)))))) - ('scrolled-window - ('text-view :id :text)))))) + ('scrolled-window :vexpand t + ('text-view :id :text :vexpand t)))))) (show *window* :all t) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/editor.lisp 2011/08/26 17:16:13 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/editor.lisp 2011/08/26 17:16:13 1.1 (asdf:oos 'asdf:load-op :gtk-cffi) (defpackage #:editor (:use #:common-lisp #:gtk-cffi #:g-object-cffi)) (in-package #:editor) (gtk-init) (defparameter *window* (gtk-model 'window :signals '(:destroy :gtk-main-quit) :width 400 :height 400 ('h-box :expand nil ; ('h-paned ('scrolled-window ('tree-view)) :expand t ('v-box :expand nil ('label :text "12323") :expand t ('scrolled-window ('text-view :id :text2))) ('scrolled-window ('text-view :id :text3))))) ;(setf ;(text (buffer (object-by-id :text1))) "1" ; (text (buffer (object-by-id :text2))) "2" ; (text (buffer (object-by-id :text3))) "3") (show *window*) (gtk-main) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex9.lisp 2011/08/26 17:16:13 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex9.lisp 2011/08/26 17:16:13 1.1 (asdf:oos 'asdf:load-op :gtk-cffi) ;(declaim (optimize speed)) (defpackage #:test (:use #:common-lisp #:iter #:gtk-cffi #:g-object-cffi)) (in-package #:test) (gtk-init) (defparameter *model* (make-instance 'lisp-model :implementation (make-instance 'lisp-model-array :array #((1) (2) (3)) :columns '(:string :int)))) ;:array #(("ok" 1)) ;:columns '(:string :int)))) (defparameter *model0* (make-instance 'list-store :columns '(:int))) (append-values *model0* '(1)) (append-values *model0* '(2)) (append-values *model0* '(3)) (let ((arr (make-array 0 :adjustable t :fill-pointer 0))) (iter (for i from 1 to 100000) (vector-push-extend (list (format nil "str ~a" i) i) arr)) (setf (gtk-cffi::larray (gtk-cffi::implementation *model*)) arr)) (defparameter *window* (gtk-model 'window :width 400 :height 400 :signals '(:destroy :gtk-main-quit) ('scrolled-window ('tree-view :model *model* :columns '("Test str" "Test int"))))); "Test int")))) (show *window*) (gtk-main) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/paned.lisp 2011/08/26 17:16:13 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/paned.lisp 2011/08/26 17:16:13 1.1 (asdf:oos 'asdf:load-op :gtk-cffi) (defpackage :test-paned (:use #:common-lisp #:gtk-cffi)) (in-package :test-paned) (gtk-init) ;; GtkWidget *hpaned = gtk_paned_new (GTK_ORIENTATION_HORIZONTAL); ;; GtkWidget *frame1 = gtk_frame_new (NULL); ;; GtkWidget *frame2 = gtk_frame_new (NULL); ;; gtk_frame_set_shadow_type (GTK_FRAME (frame1), GTK_SHADOW_IN); ;; gtk_frame_set_shadow_type (GTK_FRAME (frame2), GTK_SHADOW_IN); ;; gtk_widget_set_size_request (hpaned, 200, -1); ;; gtk_paned_pack1 (GTK_PANED (hpaned), frame1, TRUE, FALSE); ;; gtk_widget_set_size_request (frame1, 50, -1); ;; gtk_paned_pack2 (GTK_PANED (hpaned), frame2, FALSE, FALSE); ;; gtk_widget_set_size_request (frame2, 50, -1); (let ((window (make-instance 'window :width 200 :height 200 :signals '(:destroy :gtk-main-quit))) (hpaned (make-instance 'h-paned)) (frame1 (make-instance 'frame)) (frame2 (make-instance 'frame))) (setf (shadow-type frame1) :in (shadow-type frame2) :in (size-request hpaned) '(200 -1)) (pack hpaned frame1 :pane-type 1 :resize t :shrink nil) (setf (size-request frame1) '(50 -1)) (pack hpaned frame2 :resize nil :shrink nil) (setf (size-request frame2) '(50 -1)) (add window hpaned) (show window) (gtk-main)) From rklochkov at common-lisp.net Fri Aug 26 17:16:13 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Fri, 26 Aug 2011 10:16:13 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/g-lib Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/g-lib In directory tiger.common-lisp.net:/tmp/cvs-serv16215/g-lib Modified Files: g-lib-cffi.asd list.lisp package.lisp quark.lisp Added Files: array.lisp file.lisp Log Message: Added GTK3 support. Dropped GTK2 support. Refactored CFFI layer. --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/g-lib-cffi.asd 2011/04/25 19:16:07 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/g-lib-cffi.asd 2011/08/26 17:16:13 1.2 @@ -16,9 +16,11 @@ :license "BSD" :depends-on (cffi-object) :components - ((:file :package) - (:file :loadlib :depends-on (:package)) - (:file :list :depends-on (:loadlib)) - (:file :quark :depends-on (:loadlib)) - (:file :error :depends-on (:quark)) - (:file :mainloop :depends-on (:loadlib)))) \ No newline at end of file + ((:file package) + (:file loadlib :depends-on (package)) + (:file list :depends-on (loadlib)) + (:file quark :depends-on (loadlib)) + (:file array :depends-on (loadlib)) + (:file error :depends-on (quark)) + (:file file :depends-on (loadlib)) + (:file mainloop :depends-on (loadlib)))) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/list.lisp 2011/08/08 15:02:01 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/list.lisp 2011/08/26 17:16:13 1.3 @@ -11,44 +11,58 @@ ;; I don't see where one can use GList as is. So there is no such class. ;; Only convertors to and from lisp lists -(defcstruct g-list-struct - "GList" - (data object) - (next :pointer) - (prev :pointer)) +(defcfun "g_list_free" :void (g-list :pointer)) -(defcfun "g_list_free" :void (g-list g-list-struct)) +(defcfun "g_list_foreach" :void + (g-list :pointer) (func :pointer) (data :pointer)) -(defcfun "g_list_foreach" - :void (g-list g-list-struct) (func :pointer) (data object)) +(defcfun "g_list_prepend" :pointer (g-list :pointer) (data object)) -(defcfun "g_list_prepend" - g-list-struct (g-list g-list-struct) (data object)) +(defcfun "g_list_reverse" :pointer (glist :pointer)) -(defcfun "g_list_reverse" g-list-struct (glist g-list-struct)) +(defvar *list*) +(defvar *list-type*) -(defvar *list* nil) +(defgeneric object-type (type-name) + (:documentation "Tests is TYPE-NAME is member of object types") + (:method ((type-name (eql 'object))) t) + (:method (type-name) nil)) + (defcallback list-collect :void ((data :pointer) (user-data :pointer)) (declare (ignore user-data)) - (push data *list*)) + (push (cond + ((null *list-type*) data) + ((or (object-type *list-type*) + (and (consp *list-type*) (object-type (car *list-type*)))) + (convert-from-foreign data *list-type*)) + (t (mem-ref data *list-type*))) *list*)) (define-foreign-type g-list () - () - (:actual-type :pointer) - (:simple-parser g-list)) + ((list-type :initarg :type :accessor list-type + :documentation "If null, then list is of pointers or GObjects")) + (:actual-type :pointer)) -(defmethod translate-from-foreign (ptr (name g-list)) +(define-parse-method g-list (&optional type) + (make-instance 'g-list :type type)) + +(defmethod translate-from-foreign (ptr (g-list g-list)) (declare (type foreign-pointer ptr)) - (let ((*list* nil)) + (let ((*list* nil) + (*list-type* (list-type g-list))) (g-list-foreach ptr (callback list-collect) (null-pointer)) (g-list-free ptr) *list*)) -(defmethod translate-to-foreign (lisp-list (name g-list)) +(defmethod translate-to-foreign (lisp-list (g-list g-list)) (declare (type list lisp-list)) - (let ((p (null-pointer))) - (mapc (lambda (x) - (setf p (g-list-prepend p x))) - lisp-list) - (g-list-reverse p))) \ No newline at end of file + (let ((converter + (let ((list-type (list-type g-list))) + (if list-type + (lambda (x) (foreign-alloc list-type :initial-element x)) + #'identity)))) + (let ((p (null-pointer))) + (mapc (lambda (x) + (setf p (g-list-prepend p (apply converter x)))) + lisp-list) + (g-list-reverse p)))) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/package.lisp 2011/04/25 19:16:07 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/package.lisp 2011/08/26 17:16:13 1.2 @@ -9,7 +9,7 @@ (defpackage #:g-lib-cffi (:nicknames #:g-lib #:glib) - (:use #:common-lisp #:cffi #:cffi-object) + (:use #:common-lisp #:cffi #:cffi-object #:iterate) (:export ;; gerror macro #:with-g-error @@ -18,11 +18,16 @@ #:g-list #:g-quark #:g-error - + #:garray + #:with-array + #:*array-length* #:timeout-add #:timeout-remove #:yield #:g-intern-static-string + #:g-free + + #:g-file )) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/quark.lisp 2011/04/25 19:16:07 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/quark.lisp 2011/08/26 17:16:13 1.2 @@ -16,4 +16,5 @@ (defcfun g-intern-string :pointer (string gtk-string)) -(defcfun g-intern-static-string :pointer (string gtk-dyn-string)) \ No newline at end of file +(defcfun g-intern-static-string :pointer (string gtk-dyn-string)) + --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/array.lisp 2011/08/26 17:16:13 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/array.lisp 2011/08/26 17:16:13 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; array.lisp --- CFFI wrapper for arrays ;;; ;;; Copyright (C) 2011, Roman Klochkov ;;; (in-package :g-lib-cffi) (defvar *array-length*) (defmacro with-array (&body body) `(with-foreign-object (*array-length* :uint) , at body)) (define-foreign-type cffi-array () ((element-type :initarg :type :accessor element-type)) (:actual-type :pointer)) (define-parse-method garray (type) (make-instance 'cffi-array :type type)) (defmethod translate-to-foreign (value (cffi-array cffi-array)) value) (defcfun g-free :void (var :pointer)) (defmethod translate-from-foreign (ptr (cffi-array cffi-array)) (assert (boundp '*array-length*) nil "Array should be returned in WITH-ARRAY form") (let ((array-length (mem-ref *array-length* :uint))) (let ((res (make-array array-length))) (iter (for i from 0 below array-length) (setf (aref res i) (mem-aref ptr (element-type cffi-array) i))) (g-free ptr) res))) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/file.lisp 2011/08/26 17:16:13 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/file.lisp 2011/08/26 17:16:13 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; file.lisp -- interface to GFile ;;; ;;; Copyright (C) 2007, Roman Klochkov ;;; (in-package #:g-lib-cffi) (defclass g-file (object) ()) (define-foreign-type gfile (cffi-object) () (:actual-type :pointer) (:simple-parser g-file)) (defmethod translate-from-foreign (ptr (gfile gfile)) (declare (type foreign-pointer ptr)) (make-instance 'g-file :pointer ptr)) From rklochkov at common-lisp.net Fri Aug 26 17:16:13 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Fri, 26 Aug 2011 10:16:13 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/g-object Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/g-object In directory tiger.common-lisp.net:/tmp/cvs-serv16215/g-object Modified Files: g-object-cffi.asd g-object-class.lisp g-object.lisp g-type.lisp g-value.lisp generics.lisp package.lisp pobject.lisp Added Files: defslots.lisp Log Message: Added GTK3 support. Dropped GTK2 support. Refactored CFFI layer. --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-cffi.asd 2011/08/08 15:02:01 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-cffi.asd 2011/08/26 17:16:13 1.3 @@ -16,13 +16,14 @@ :license "LGPL" :depends-on (cffi-object g-lib-cffi gtk-cffi-utils) :components - ((:file :package) - (:file :loadlib :depends-on (:package)) - (:file :generics :depends-on (:package)) - (:file :g-type :depends-on (:loadlib :generics)) - (:file :pobject :depends-on (:g-type)) - (:file :g-value :depends-on (:pobject)) - (:file :g-object :depends-on (:g-value)) - (:file :g-object-class :depends-on (:g-object)) - (:file :subclass :depends-on (:g-object)))) + ((:file package) + (:file loadlib :depends-on (package)) + (:file generics :depends-on (package)) + (:file g-type :depends-on (loadlib generics)) + (:file pobject :depends-on (g-type)) + (:file defslots :depends-on (pobject)) + (:file g-value :depends-on (pobject)) + (:file g-object :depends-on (g-value)) + (:file g-object-class :depends-on (g-object)) + (:file subclass :depends-on (g-object)))) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-class.lisp 2011/08/08 15:02:01 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-class.lisp 2011/08/26 17:16:13 1.3 @@ -23,25 +23,18 @@ (constructed :pointer) (pdummy :pointer :count 7)) -(defmethod gconstructor ((g-object-class g-object-class) - &key object) +(defmethod gconstructor ((g-object-class g-object-class) &key object) (mem-ref (pointer object) :pointer)) (defcfun "g_object_class_list_properties" - :pointer (obj-class pobject) (n-props :pointer)) + (garray (object g-param-spec)) (obj-class pobject) (n-props :pointer)) (defclass g-param-spec (object) ()) (defmethod list-properties ((g-object-class g-object-class)) - (with-foreign-object - (n-props :int) - (let ((res (g-object-class-list-properties g-object-class n-props))) - (unwind-protect - (loop :for i :below (mem-ref n-props :int) - :collect (make-instance 'g-param-spec - :pointer (mem-aref res :pointer i))) - (foreign-free res))))) + (with-array + (g-object-class-list-properties g-object-class *array-length*))) (defcfun "g_object_class_find_property" :pointer (obj-class pobject) (key :string)) @@ -87,11 +80,11 @@ (defun show-properties (g-object) (let ((gclass (make-instance 'g-object-class :object g-object))) - (mapc - (lambda (param) - (format t "~A~% nick=~A~% blurb=~A~% type=~A + (map nil + (lambda (param) + (format t "~A~% nick=~A~% blurb=~A~% type=~A owner-type=~A~% flags=~A~%~%" - (name param) (nick param) (blurb param) - (g-type->name (g-type param)) - (g-type->name (g-type param :owner t)) (flags param))) - (list-properties gclass)))) \ No newline at end of file + (name param) (nick param) (blurb param) + (g-type->lisp (g-type param)) + (g-type->lisp (g-type param :owner t)) (flags param))) + (list-properties gclass)))) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2011/08/08 15:02:01 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2011/08/26 17:16:13 1.3 @@ -34,11 +34,11 @@ (format t "Creating ~a ~a~%" g-object value) (g-object-weak-ref value (callback destroy-object) (null-pointer)))) -(defcfun "g_object_set_property" :void (object pobject) - (name :string) (value pobject)) +(defcfun "g_object_set_property" :void + (object pobject) (name :string) (value pobject)) -(defcfun "g_object_get_property" :void (object pobject) - (name :string) (value pobject)) +(defcfun "g_object_get_property" :void + (object pobject) (name :string) (value pobject)) (defgeneric (setf property) (values g-object &rest keys)) @@ -47,8 +47,8 @@ (setf (property object :prop1 :prop2) (list value1 value2))" (mapc (lambda (key value) (declare (type (or symbol string) key)) - (debug-out "key: ~a, value: ~a, type: ~a~%" key value - (property-type g-object key)) + ;(debug-out "key: ~a, value: ~a, type: ~a~%" key value + ; (property-type g-object key)) (let ((skey (string-downcase key))) (with-g-value (:value value :g-type (property-type g-object skey)) (g-object-set-property g-object skey *g-value*)))) @@ -91,48 +91,15 @@ :swapped) -(defmacro bitmask (&rest flags) - "Returns list from lisp values as keywords: - Example: (bitmask after swapped) - -> nil, when after=nil and swapped=nil - -> (:after), when after=t and swapped=nil - -> (:swapped), when after=nil and swapped=t - -> (:after :swapped), when both are t" - `(mapcan - #'identity - ,(cons 'list - (loop :for flag :in flags - :collecting `(when ,flag - (list ,(intern (string flag) :keyword))))))) - - (defcfun "g_signal_connect_data" :ulong - (instance g-object) + (instance pobject) (detailed-signal :string) (c-handler pfunction) - (data :pointer) + (data pdata) (destroy-data pfunction) (connect-flags connect-flags)) -;;; Class STORAGE - -(defclass storage (object) - ((data :accessor data :initarg :data) - (cffi-object::volatile :initform nil :accessor volatile)) - (:documentation "A storage for any data for callbacks. - On make-instance it allocates one byte on heap and associates itself - with the address of that byte.")) - -(defmethod gconstructor ((storage storage) &key &allow-other-keys) - (foreign-alloc :char)) - -(defcallback free-storage :void ((data :pointer) (closure :pointer)) - (declare (ignore closure)) - (unless (null-pointer-p data) - (setf (pointer (object data)) (null-pointer)) - (remhash (pointer-address data) *objects*) - (foreign-free data))) ;; Closure staff: marshaller and callbacks @@ -151,7 +118,7 @@ (defcfun "g_closure_set_marshal" :void (closure :pointer) (marshal :pointer)) (defcfun "g_signal_connect_closure" :ulong - (instance g-object) + (instance pobject) (detailed-signal :string) (closure :pointer) (after :boolean)) @@ -164,11 +131,13 @@ (data :pointer)) (declare (ignore hint data)) (let ((lisp-func (object closure)) - (lisp-params (loop :for i :from 0 :below n-values :collecting - (value - (make-instance - 'g-value - :pointer (mem-aref params 'g-value-struct i))))) + (lisp-params + (iter + (for i from 0 below n-values) + (collect (value + (make-instance + 'g-value + :pointer (mem-aref params 'g-value-struct i)))))) (lisp-return (make-instance 'g-value :pointer return))) (let ((res (apply lisp-func lisp-params))) (when (/= (g-type lisp-return) 0) @@ -186,6 +155,30 @@ (defcfun "g_signal_handler_disconnect" :void (instance g-object) (id :ulong)) +(defmethod connect ((g-object g-object) c-handler + &key signal data after swapped) + (let* ((str-signal (string-downcase signal)) + (handler-id + (typecase c-handler + (function (g-signal-connect-closure + g-object str-signal + (make-closure + (if data + (lambda (&rest params) + (apply c-handler + (if swapped + (cons data params) + (nconc params (list data))))) + c-handler)) + after)) + (t (g-signal-connect-data + g-object str-signal c-handler data + (if (or (null data) (pointerp data) (typep data 'g-object)) + (null-pointer) (callback free-storage)) + ;; connect-flags + (bitmask after swapped)))))) + (push (cons str-signal handler-id) (gsignals g-object)))) + (defgeneric (setf gsignal) (c-handler g-object detailed-signal &rest flags)) (defmethod (setf gsignal) (c-handler @@ -205,49 +198,25 @@ If c-handler is null (or null pointer), this method removes signal. In this case detailed-string may be also id of the signal handler -being removed" +being removed + +Returns assoc: (id-of-handler . detailed-signal)" (if (or (null c-handler) (and (pointerp c-handler) (null-pointer-p c-handler))) + ;; remove handler (setf (gsignals g-object) (mapcan (lambda (x) - (if (if (numberp detailed-signal) (= detailed-signal (cdr x)) - (string= (string-downcase detailed-signal) - (car x))) - (g-signal-handler-disconnect - (pointer g-object) (cdr x)) x)) (gsignals g-object))) - (let* ((str-signal (string-downcase detailed-signal)) - (handler-id - (if (functionp c-handler) - - (g-signal-connect-closure - (pointer g-object) - str-signal - (make-closure - (if data - (lambda (&rest params) - (apply c-handler (if swapped - (cons data params) - (nconc params (list data))))) - c-handler)) - after) - - (g-signal-connect-data - (pointer g-object) - str-signal - c-handler - (cond - ((pointerp data) data) - ((null data) (null-pointer)) - ((typep data 'g-object) (pointer data)) - (t (pointer (make-instance 'storage :data data)))) - ;; destroy-notify - (if (or (null data) (pointerp data) (typep data 'g-object)) - (null-pointer) (callback free-storage)) - ;; connect-flags - (bitmask after swapped))))) - (push (cons str-signal handler-id) (gsignals g-object)) - handler-id))) + (if (if (numberp detailed-signal) + (= detailed-signal (cdr x)) + (string= (string-downcase detailed-signal) (car x))) + (g-signal-handler-disconnect g-object (cdr x)) + (list x))) + (gsignals g-object))) + (connect g-object c-handler + :signal detailed-signal + :swapped swapped :after after :data data))) + (defgeneric gsignal (g-object signal)) @@ -255,9 +224,9 @@ (defmethod gsignal ((g-object g-object) detailed-signal) "method GSIGNAL of class G-OBJECT returns list of IDs of setted signals" - (mapcan (lambda (x) (when (string= (string-downcase detailed-signal) - (car x)) - (list (cdr x)))) (gsignals g-object))) + (mapcan (lambda (x) (when (string= (string-downcase detailed-signal) (car x)) + (list (cdr x)))) + (gsignals g-object))) (defmethod (setf signals) (signals (g-object g-object)) "SIGNALS is a list (signal-id signal-value signal-id signal-value ...) @@ -277,19 +246,6 @@ (properties g-object) rest)) properties)) -(defmacro with-object ((name &optional for-free) init &rest body) - `(let ((,name ,init)) - (unwind-protect - (progn - , at body) - (free ,(or for-free name))))) - -(defmacro setf-init (object &rest fields) - "Should be used in constructors" - (cons 'progn - (mapcar (lambda (field) `(when ,field - (setf (,field ,object) ,field))) - fields))) (defmethod initialize-instance :after ((g-object g-object) &key signals properties @@ -306,4 +262,6 @@ (defcfun g-object-newv :pointer (class-type g-type) (n-params :uint) (params :pointer)) + + \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-type.lisp 2011/08/08 15:02:01 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-type.lisp 2011/08/26 17:16:13 1.3 @@ -13,7 +13,7 @@ :enum :flags :float :double :string :pointer :boxed :param :object)) -(defun name->g-type (type) +(defun keyword->g-type (type) "Keyword from +fundamental-gtypes+ -> integer" (* (or (position type +fundamental-g-types+) (position :object +fundamental-g-types+)) 4)) @@ -33,8 +33,14 @@ "GTypeInstance" (g-class (:pointer g-type-class))) +(defun g-type-from-instance (ptr) + (foreign-slot-value + (foreign-slot-value ptr 'g-type-instance 'g-class) + 'g-type-class 'g-type)) + (defcfun g-type-fundamental g-type (id g-type)) (defcfun g-type-from-name g-type (name :string)) +(defcfun g-type-name :string (id :ulong)) (defcstruct g-type-query "GTypeQuery" @@ -45,7 +51,7 @@ (defcfun g-type-query :void (type g-type) (query g-type-query)) -(defun g-type->name (num) +(defun g-type->keyword (num) "Integer (GType) -> keyword from +fundamental-gtypes+" (or (nth (/ (g-type-fundamental num) 4) +fundamental-g-types+) :object)) @@ -56,7 +62,7 @@ "Assoc: GTK type name (string) -> lisp object") (defun register-type (lisp-class gtk-typename) - (setq *typenames* (acons gtk-typename lisp-class *typenames*))) + (push (cons gtk-typename lisp-class) *typenames*)) (defvar *gtk-packages* nil ;; (mapcar @@ -69,7 +75,6 @@ (defun register-package (name package) (push (cons name package) *gtk-packages*)) -(defcfun "g_type_name" :string (id :ulong)) (defun g-type->lisp (g-type) "Returns lisp class for the gtype and caches result @@ -106,3 +111,8 @@ package))))))))) +(defcfun g-type-children (garray g-type) (type g-type) (n-children :pointer)) + +(defun children (type) + (with-array + (g-type-children type *array-length*))) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-value.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-value.lisp 2011/08/26 17:16:13 1.2 @@ -26,25 +26,25 @@ (g-type :ulong) (data g-value-data :count 2)) -(defcfun "g_value_init" :pointer (gvalue pobject) (type :int)) -(defcfun "g_value_set_boolean" :void (gvalue :pointer) (val :boolean)) -(defcfun "g_value_set_char" :void (gvalue :pointer) (val :char)) -(defcfun "g_value_set_uchar" :void (gvalue :pointer) (val :uchar)) -(defcfun "g_value_set_int" :void (gvalue :pointer) (val :int)) -(defcfun "g_value_set_uint" :void (gvalue :pointer) (val :uint)) -(defcfun "g_value_set_long" :void (gvalue :pointer) (val :long)) -(defcfun "g_value_set_ulong" :void (gvalue :pointer) (val :ulong)) -(defcfun "g_value_set_int64" :void (gvalue :pointer) (val :int64)) -(defcfun "g_value_set_uint64" :void (g-value :pointer) (val :uint64)) -(defcfun "g_value_set_float" :void (g-value :pointer) (val :float)) -(defcfun "g_value_set_double" :void (g-value :pointer) (val :double)) -(defcfun "g_value_set_enum" :void (g-value :pointer) (val :int)) -(defcfun "g_value_set_flags" :void (g-value :pointer) (val :uint)) -(defcfun "g_value_set_string" :void (g-value :pointer) (val gtk-string)) -(defcfun "g_value_set_param" :void (g-value :pointer) (val :pointer)) -(defcfun "g_value_set_boxed" :void (g-value :pointer) (val :pointer)) -(defcfun "g_value_set_pointer" :void (g-value :pointer) (val :pointer)) -(defcfun "g_value_set_object" :void (g-value :pointer) (val pobject)) +(defcfun "g_value_init" :pointer (g-value pobject) (type :int)) +(defcfun "g_value_set_boolean" :void (g-value pobject) (val :boolean)) +(defcfun "g_value_set_char" :void (g-value pobject) (val :char)) +(defcfun "g_value_set_uchar" :void (g-value pobject) (val :uchar)) +(defcfun "g_value_set_int" :void (g-value pobject) (val :int)) +(defcfun "g_value_set_uint" :void (g-value pobject) (val :uint)) +(defcfun "g_value_set_long" :void (g-value pobject) (val :long)) +(defcfun "g_value_set_ulong" :void (g-value pobject) (val :ulong)) +(defcfun "g_value_set_int64" :void (g-value pobject) (val :int64)) +(defcfun "g_value_set_uint64" :void (g-value pobject) (val :uint64)) +(defcfun "g_value_set_float" :void (g-value pobject) (val :float)) +(defcfun "g_value_set_double" :void (g-value pobject) (val :double)) +(defcfun "g_value_set_enum" :void (g-value pobject) (val :int)) +(defcfun "g_value_set_flags" :void (g-value pobject) (val :uint)) +(defcfun "g_value_set_string" :void (g-value pobject) (val gtk-string)) +(defcfun "g_value_set_param" :void (g-value pobject) (val :pointer)) +(defcfun "g_value_set_boxed" :void (g-value pobject) (val :pointer)) +(defcfun "g_value_set_pointer" :void (g-value pobject) (val :pointer)) +(defcfun "g_value_set_object" :void (g-value pobject) (val pobject)) (defmethod gconstructor ((g-value g-value) &key @@ -55,7 +55,7 @@ ptr)) (defmethod (setf value) (val (g-value g-value)) - (g-value-set (pointer g-value) val (g-type g-value))) + (g-value-set g-value val (g-type g-value))) (defcfun g-value-unset :void (g-value pobject)) @@ -67,20 +67,20 @@ (macrolet ((gtypecase (x &rest body) `(typecase ,x ,@(mapcar (lambda (x) (list (car x) - (name->g-type (cadr x)))) + (keyword->g-type (cdr x)))) body)))) (let ((%type (or type (when value-p (gtypecase value - (standard-char :char) - (fixnum :int) - (integer :int64) - (single-float :float) - (double-float :double) - (string :string) - (boolean :boolean) - (null :boolean) - (t :pointer)))))) + (standard-char . :char) + (fixnum . :int) + (integer . :int64) + (single-float . :float) + (double-float . :double) + (string . :string) + (boolean . :boolean) + (null . :boolean) + (t . :pointer)))))) (when %type (g-value-init ptr %type) (when value-p @@ -125,43 +125,53 @@ (macrolet ((select-accessor (type prefix) `(ecase ,type ,@(mapcar (lambda (x) - (list (name->g-type x) - (list 'function - (intern (format nil prefix x))))) + `(,(keyword->g-type x) + (function + ,(symbolicate prefix x)))) (remove-if - (lambda (item) (find item - '(:invalid :interface :void))) + (rcurry #'member '(:invalid :interface :void)) +fundamental-g-types+))))) (defun g-value-set (ptr value type) "PTR - foreign pointer, VALUE - lisp value, TYPE - GType id" - (let ((val (if (or (keywordp value) - (consp value)) - (convert-to-foreign value (g-type->lisp type)); enum|flags - value))) - (when (/= type 0) - (funcall (select-accessor - (g-type-fundamental type) "G-VALUE-SET-~A") ptr val)))) - +; (debug-out "g-value-set: ~a ~a~%" value (g-type->keyword type)) + (let ((ftype (g-type-fundamental type))) + (let ((val (case ftype + ((#.(keyword->g-type :enum) + #.(keyword->g-type :flags)) + (convert-to-foreign value (g-type->lisp type))) + (#.(keyword->g-type :double) (coerce value 'double-float)) + (#.(keyword->g-type :float) (coerce value 'single-float)) + ((#.(keyword->g-type :int) + #.(keyword->g-type :uint) + #.(keyword->g-type :long) + #.(keyword->g-type :ulong) + #.(keyword->g-type :int64) + #.(keyword->g-type :uint64)) (round value)) + (t value)))) +; (debug-out " converted value ~a~%" val) + (when (/= type 0) + (funcall (select-accessor ftype :g-value-set-) ptr val))))) + (defun g-value-get (value) (unless (null-pointer-p value) (let* ((g-type (type-g-value value)) (fundamental-type (g-type-fundamental g-type))) (case fundamental-type - (#.(name->g-type :boxed) + (#.(keyword->g-type :boxed) (object (g-value-get-boxed value) :class (g-type->lisp g-type))) - (#.(name->g-type :enum) + (#.(keyword->g-type :enum) (convert-from-foreign (g-value-get-enum value) (g-type->lisp g-type))) - (#.(name->g-type :flags) + (#.(keyword->g-type :flags) (convert-from-foreign (g-value-get-flags value) (g-type->lisp g-type))) - (#.(name->g-type :interface) + (#.(keyword->g-type :interface) (g-value-get-object value)) (t (funcall (select-accessor - fundamental-type "G-VALUE-GET-~A") value))))))) + fundamental-type :g-value-get-) value))))))) (defmethod value ((g-value g-value)) (g-value-get (pointer g-value))) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/generics.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/generics.lisp 2011/08/26 17:16:13 1.2 @@ -13,5 +13,6 @@ (defgeneric nick (g-object-class)) (defgeneric flags (g-object-class)) +(defgeneric connect (g-object handler &rest keys)) (defgeneric (setf signals) (signals g-object)) (defgeneric (setf properties) (properties g-object)) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2011/08/08 15:02:01 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2011/08/26 17:16:13 1.3 @@ -8,7 +8,8 @@ (in-package #:cl-user) (defpackage #:g-object-cffi - (:use #:common-lisp #:cffi #:cffi-object #:g-lib-cffi #:gtk-cffi-utils) + (:use #:common-lisp #:cffi #:alexandria #:iterate + #:cffi-object #:g-lib-cffi #:gtk-cffi-utils) (:import-from #:cffi-object *objects*) (:export @@ -17,6 +18,8 @@ #:signals #:property #:gsignal + + #:connect #:storage ;; slot @@ -29,9 +32,6 @@ #:pobject #:pdata #:g-list-object - #:g-type-interface - #:g-type-class - #:g-type-instance #:with-g-value #:*g-value* @@ -40,15 +40,29 @@ #:unset #:init - #:g-type->name +; #:g-type->name #:g-type->lisp - #:name->g-type + #:keyword->g-type #:g-type + #:g-type-name + #:g-type-from-name + #:g-type-from-instance + #:g-type-info + #:g-type-flags + #:g-type-register-static + #:g-type-register-static-simple + #:g-interface-info + #:g-type-add-interface-static + #:g-type-interface + #:g-type-class + #:g-type-instance + #:register-type #:register-package #:setf-init + #:init-slots #:ref #:unref @@ -57,17 +71,17 @@ #:find-child-property #:g-object-class - #:gparam-spec + #:g-param-spec #:g-object-newv #:new - #:g-type-info - #:g-type-flags - #:g-type-register-static - #:g-type-register-static-simple - #:g-interface-info - #:g-type-add-interface-static - #:g-type-interface - #:g-type-class - #:g-type-instance)) - + #:defgtkslot + #:defgtkslots + #:defgdkslot + #:defgdkslots + #:defgtkgetter + #:defgdkgetter + #:defgtksetter + #:defgdksetter + #:defgtkfun + #:defgdkfun)) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp 2011/08/08 15:02:01 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp 2011/08/26 17:16:13 1.3 @@ -9,17 +9,43 @@ (define-foreign-type cffi-pobject (cffi-object) () - (:actual-type :pointer) - (:simple-parser pobject)) + (:actual-type :pointer)) + +(define-parse-method pobject (&optional class) + (make-instance 'cffi-pobject :class class)) -(defmethod translate-from-foreign (ptr (name cffi-pobject)) +(defmethod translate-from-foreign (ptr (cffi-pobject cffi-pobject)) "The first int at GObject instance is its type pointer, take it and make up lisp object" (declare (type foreign-pointer ptr)) (unless (null-pointer-p ptr) - (let ((class (g-type->lisp (mem-ref (mem-ref ptr :pointer) :uint)))) + (let ((class (or (cffi-object::obj-class cffi-pobject) + (g-type->lisp (g-type-from-instance ptr))))) (object ptr :class class)))) +;; register as object type for g-list +(defmethod g-lib-cffi::object-type ((type-name (eql 'pobject))) t) + +;;; Class STORAGE + +(defclass storage (object) + ((data :accessor data :initarg :data) + (cffi-object::volatile :initform nil :accessor volatile)) + (:documentation "A storage for any data for callbacks. + On make-instance it allocates one byte on heap and associates itself + with the address of that byte.")) + +(defmethod gconstructor ((storage storage) &key &allow-other-keys) + (foreign-alloc :char)) + +(defcallback free-storage :void ((data :pointer) (closure :pointer)) + (declare (ignore closure)) + (unless (null-pointer-p data) + (setf (pointer (object data)) (null-pointer)) + (remhash (pointer-address data) *objects*) + (foreign-free data))) + + (define-foreign-type cffi-pdata (cffi-pobject) () (:actual-type :pointer) @@ -32,19 +58,30 @@ (let ((obj (object ptr :class 'storage))) (when obj (data obj)))) -(defmethod translate-to-foreign :around (any-data (name cffi-pdata)) - (call-next-method (make-instance 'storage :data any-data) name)) +(defmethod translate-to-foreign (any-data (name cffi-pdata)) + (if (or (null any-data) (pointerp any-data)) + (call-next-method) + (translate-to-foreign (make-instance 'storage :data any-data) name))) + +(defmethod translate-to-foreign ((any-data storage) (name cffi-pdata)) + (call-next-method)) + +(defmethod translate-to-foreign :around ((any-data storage) (name cffi-pdata)) + (call-next-method any-data name)) + +;; (define-foreign-type g-list-object (g-list) +;; () +;; (:actual-type :pointer) +;; (:simple-parser g-list-object) +;; (:documentation "GList with pointers to GObjects")) + +;; (defmethod translate-from-foreign :around (ptr (name g-list-object)) +;; (declare (ignorable ptr name)) +;; (mapcar (lambda (x) (convert-from-foreign x 'pobject)) +;; (call-next-method))) -(define-foreign-type g-list-object (g-list) - () - (:actual-type :pointer) - (:simple-parser g-list-object) - (:documentation "GList with pointers to GObjects")) +(defctype g-list-object (g-list pobject)) -(defmethod translate-from-foreign :around (ptr (name g-list-object)) - (declare (ignorable ptr name)) - (mapcar (lambda (x) (convert-from-foreign x 'pobject)) - (call-next-method))) (defcfun g-type-interface-peek-parent pobject (iface pobject)) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2011/08/26 17:16:14 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2011/08/26 17:16:14 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; defslots.lisp --- def*slot(s) macros for group binding setters and getters ;;; ;;; Copyright (C) 2011, Roman Klochkov ;;; (in-package #:g-object-cffi) (defun defslot (prefix current-class slot-name slot-type) (let ((name-lisp (if (consp slot-name) (car slot-name) slot-name)) (name-gtk (if (consp slot-name) (cdr slot-name) slot-name))) (let ((getter (symbolicate prefix current-class '-get- name-gtk)) (setter (symbolicate prefix current-class '-set- name-gtk))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (push ',name-lisp (get ',current-class 'slots))) (defcfun ,getter ,slot-type (object pobject)) (defcfun ,setter :void (widget pobject) (value ,slot-type)) (unless (fboundp ',name-lisp) (defgeneric ,name-lisp (,current-class))) (unless (fboundp '(setf ,name-lisp)) (defgeneric (setf ,name-lisp) (value ,current-class))) (defmethod ,name-lisp ((object ,current-class)) (,getter object)) (defmethod (setf ,name-lisp) (value (object ,current-class)) (,setter object value) value))))) (defmacro defgtkslot (current-class slot-name slot-type) (defslot 'gtk- current-class slot-name slot-type)) (defun defslots (def-macro current-class slots) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (setf (get ',current-class 'slots) nil)) ,@(iter (for x on slots by #'cddr) (collect (list def-macro current-class (first x) (second x)))))) (defmacro defgtkslots (current-class &rest slots) (defslots 'defgtkslot current-class slots)) (defmacro defgdkslot (current-class slot-name slot-type) (defslot 'gdk- current-class slot-name slot-type)) (defmacro defgdkslots (current-class &rest slots) (defslots 'defgdkslot current-class slots)) (defun def-fun (prefix name res-type class params &key get) (let ((fun-name (symbolicate prefix class (if get '-get- '-) name)) (param-list (mapcar #'car params))) `(progn (defcfun ,fun-name ,res-type (,class pobject) , at params) (unless (fboundp ',name) (defgeneric ,name (,class , at param-list))) (defmethod ,name ((,class ,class) , at param-list) (,fun-name ,class , at param-list))))) (defun defsetter (prefix name slot-type class) (let ((setter (symbolicate prefix class '-set- name))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (push ',name (get ',class 'slots))) (defcfun ,setter :void (widget pobject) (value ,slot-type)) (unless (fboundp '(setf ,name)) (defgeneric (setf ,name) (value ,class))) (defmethod (setf ,name) (value (object ,class)) (,setter object value) value)))) (defmacro defgtkfun (name res-type class &rest params) (def-fun 'gtk- name res-type class params)) (defmacro defgdkfun (name res-type class &rest params) (def-fun 'gdk- name res-type class params)) (defmacro defgtkgetter (name res-type class &rest params) (def-fun 'gtk- name res-type class params :get t)) (defmacro defgdkgetter (name res-type class &rest params) (def-fun 'gdk- name res-type class params :get t)) (defmacro defgtksetter (name slot-type class) (defsetter 'gtk- name slot-type class)) (defmacro defgdksetter (name slot-type class) (defsetter 'gdk- name slot-type class)) (defmacro with-object ((name &optional for-free) init &rest body) `(let ((,name ,init)) (unwind-protect (progn , at body) (free ,(or for-free name))))) (defmacro setf-init (object &rest fields) "Should be used in constructors" `(progn ,@(mapcar (lambda (field-all) (let ((field (if (consp field-all) (first field-all) field-all)) (field-p (if (consp field-all) (third field-all) field-all))) `(when ,field-p (setf (,field ,object) ,field)))) fields))) (defmacro init-slots (class add-keys &body body) "For DEFSLOTS* auto-constructor" (let ((slots (mapcar (lambda (x) (list x nil (symbolicate x '-p))) (get class 'slots)))) `(defmethod shared-initialize :after ((,class ,class) slot-names &key , at slots , at add-keys &allow-other-keys) (setf-init ,class , at slots) , at body))) From rklochkov at common-lisp.net Fri Aug 26 17:16:14 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Fri, 26 Aug 2011 10:16:14 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/gdk Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/gdk In directory tiger.common-lisp.net:/tmp/cvs-serv16215/gdk Modified Files: color.lisp gdk-cffi.asd image.lisp loadlib.lisp package.lisp pixbuf.lisp window.lisp Added Files: rectangle.lisp Log Message: Added GTK3 support. Dropped GTK2 support. Refactored CFFI layer. --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/color.lisp 2011/04/25 19:16:07 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/color.lisp 2011/08/26 17:16:14 1.2 @@ -1,7 +1,7 @@ (in-package :gdk-cffi) (defcstruct color-struct - "" + "GdkColor" (pixel :int32) (red :int16) (green :int16) @@ -24,6 +24,33 @@ (defmethod translate-from-foreign (ptr (type color-cffi)) (gdk-color-to-string ptr)) -(defmethod free-translated-object (value (name color-cffi) free-p) - (when free-p - (foreign-free value))) \ No newline at end of file +(defmethod free-translated-object (value (name color-cffi) param) + (foreign-free value)) + +(defcstruct rgba-struct + "GdkRGBA" + (red :double) + (green :double) + (blue :double) + (alpha :double)) + +(define-foreign-type rgba-cffi () + () + (:actual-type :pointer) + (:simple-parser prgba)) + +(defcfun gdk-rgba-parse :boolean (color rgba-struct) (str :string)) +(defcfun gdk-rgba-to-string :string (color rgba-struct)) + +(defmethod translate-to-foreign (value (type rgba-cffi)) + (if (pointerp value) value + (let ((color-st (foreign-alloc 'rgba-struct))) + (assert (gdk-rgba-parse color-st (string value)) (value) + "Bad RGBA color") + color-st))) + +(defmethod translate-from-foreign (ptr (type rgba-cffi)) + (gdk-rgba-to-string ptr)) + +(defmethod free-translated-object (value (name rgba-cffi) param) + (foreign-free value)) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/gdk-cffi.asd 2011/04/25 19:16:07 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/gdk-cffi.asd 2011/08/26 17:16:14 1.2 @@ -14,19 +14,19 @@ :author "Roman Klochkov " :version "0.1" :license "BSD" - :depends-on (g-object-cffi g-lib-cffi) + :depends-on (g-object-cffi g-lib-cffi cl-cairo2) :components - ((:file :package) - (:file :loadlib :depends-on (:package)) - (:file :generics :depends-on (:package)) - (:file :screen :depends-on (:loadlib :generics)) - (:file :keys :depends-on (:package)) - (:file :threads :depends-on (:package)) - (:file :event :depends-on (:loadlib :generics)) - (:file :color :depends-on (:loadlib :generics)) - (:file :drawable :depends-on (:loadlib :generics)) - (:file :window :depends-on (:drawable)) - (:file :gc :depends-on (:loadlib :generics)) - (:file :visual :depends-on (:loadlib :generics)) - (:file :image :depends-on (:visual)) - (:file :pixbuf :depends-on (:image :drawable :gc)))) + ((:file package) + (:file loadlib :depends-on (package)) + (:file generics :depends-on (package)) + (:file rectangle :depends-on (loadlib generics)) + (:file screen :depends-on (loadlib generics)) + (:file keys :depends-on (package)) + (:file threads :depends-on (package)) + (:file event :depends-on (loadlib generics)) + (:file color :depends-on (loadlib generics)) + (:file window :depends-on (loadlib generics)) + (:file gc :depends-on (loadlib generics)) + (:file visual :depends-on (loadlib generics)) + (:file image :depends-on (visual)) + (:file pixbuf :depends-on (image gc)))) --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/image.lisp 2011/04/25 19:16:07 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/image.lisp 2011/08/26 17:16:14 1.2 @@ -1,14 +1,14 @@ -(in-package :gdk-cffi) +;(in-package :gdk-cffi) +; +;(defclass image (gobject) +; ()) -(defclass image (gobject) - ()) +;(defcenum image-type +; :normal :shared :fastest) -(defcenum image-type - :normal :shared :fastest) +;(defcfun "gdk_image_new" :pointer +; (image-type image-type) (visual pobject) (width :int) (height :int)) -(defcfun "gdk_image_new" :pointer - (image-type image-type) (visual pobject) (width :int) (height :int)) - -(defmethod gconstructor ((image image) - &key (type :fastest) visual width height) - (gdk-image-new type (or visual (make-instance 'visual)) width height)) \ No newline at end of file +;(defmethod gconstructor ((image image) +; &key (type :fastest) visual width height) +; (gdk-image-new type (or visual (make-instance 'visual)) width height)) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/loadlib.lisp 2011/04/25 19:16:07 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/loadlib.lisp 2011/08/26 17:16:14 1.2 @@ -8,8 +8,8 @@ (in-package :gdk-cffi) (define-foreign-library :gdk - (:unix "libgdk-x11-2.0.so") - (:windows "libgdk-win32-2.0-0.dll")) + (:unix "libgdk-3.so.0") + (:windows "libgdk-win32-3xs-0.dll")) (load-foreign-library :gdk) --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/package.lisp 2011/04/25 19:16:07 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/package.lisp 2011/08/26 17:16:14 1.2 @@ -8,12 +8,15 @@ (in-package #:cl-user) (defpackage #:gdk-cffi - (:use #:common-lisp #:cffi #:cffi-object #:g-lib-cffi #:g-object-cffi) + (:use #:common-lisp + #:cffi #:cffi-object #:g-lib-cffi #:g-object-cffi) + (:import-from #:cl-cairo2 #:x #:y #:width #:height #:cairo_rectangle_t) (:export ; types #:event-mask #:extension-mode #:pcolor + #:prgba #:color-struct #:event ;; methods of event @@ -22,16 +25,17 @@ #:parse-event + #:rectangle + #:intersect + #:union + #:screen ;; slots of screen #:height #:width - #:drawable - #:draw-pixbuf - - #:window + #:modifier-type #:pixmap --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/pixbuf.lisp 2011/04/25 19:16:07 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/pixbuf.lisp 2011/08/26 17:16:14 1.2 @@ -21,25 +21,25 @@ (defgeneric new-from-image (image width height src-x src-y)) -(defcfun "gdk_pixbuf_get_from_image" :void (pixbuf pobject) (image pobject) - (colormap pobject) (src-x :int) (src-y :int) (dst-x :int) (dst-y :int) - (width :int) (height :int)) - -(defcfun "gdk_pixbuf_get_from_drawable" :void (pixbuf pobject) - (drawable pobject) (colormap pobject) - (src-x :int) (src-y :int) (dst-x :int) (dst-y :int) - (width :int) (height :int)) - -(defmethod new-from-image ((image image) width height src-x src-y) - (gdk-pixbuf-get-from-image (null-pointer) image (null-pointer) - src-x src-y 0 0 width height)) - -(defmethod new-from-image ((drawable drawable) width height src-x src-y) - (gdk-pixbuf-get-from-drawable (null-pointer) drawable (null-pointer) - src-x src-y 0 0 width height)) +;; (defcfun "gdk_pixbuf_get_from_image" :void (pixbuf pobject) (image pobject) +;; (colormap pobject) (src-x :int) (src-y :int) (dst-x :int) (dst-y :int) +;; (width :int) (height :int)) + +;; (defcfun "gdk_pixbuf_get_from_drawable" :void (pixbuf pobject) +;; (drawable pobject) (colormap pobject) +;; (src-x :int) (src-y :int) (dst-x :int) (dst-y :int) +;; (width :int) (height :int)) + +;(defmethod new-from-image ((image image) width height src-x src-y) +; (gdk-pixbuf-get-from-image (null-pointer) image (null-pointer) +; src-x src-y 0 0 width height)) + +;(defmethod new-from-image ((drawable drawable) width height src-x src-y) +; (gdk-pixbuf-get-from-drawable (null-pointer) drawable (null-pointer) +; src-x src-y 0 0 width height)) (defmethod gconstructor ((obj-pixbuf pixbuf) - &key image file loader pixbuf + &key file loader pixbuf height width has-alpha (bits-per-sample 8) (preserve-aspect-ratio t) @@ -56,7 +56,7 @@ (gdk-pixbuf-new-from-file file g-error)))) ;; from GdkImage or GdkDrawable - (image (new-from-image image width height src-x src-y)) +; (image (new-from-image image width height src-x src-y)) ;(loader (new-from-loader loader)) (pixbuf @@ -77,15 +77,15 @@ (defcenum rgb-dither :none :normal :max) -(defcfun "gdk_draw_pixbuf" :void (drawable pobject) (gc pobject) - (pixbuf pobject) (src-x :int) (src-y :int) (dst-x :int) (dst-y :int) - (width :int) (height :int) (dither rgb-dither) - (x-dither :int) (y-dither :int)) - -(defmethod draw-pixbuf ((drawable drawable) (gc gc) (pixbuf pixbuf) - &optional (src-x 0) (src-y 0) - (dst-x 0) (dst-y 0) (width -1) (height -1) - (dither :none) (x-dither 0) (y-dither 0)) - (gdk-draw-pixbuf drawable gc pixbuf src-x src-y dst-x dst-y - width height dither x-dither y-dither)) +;; (defcfun "gdk_draw_pixbuf" :void (drawable pobject) (gc pobject) +;; (pixbuf pobject) (src-x :int) (src-y :int) (dst-x :int) (dst-y :int) +;; (width :int) (height :int) (dither rgb-dither) +;; (x-dither :int) (y-dither :int)) + +;; (defmethod draw-pixbuf ((drawable drawable) (gc gc) (pixbuf pixbuf) +;; &optional (src-x 0) (src-y 0) +;; (dst-x 0) (dst-y 0) (width -1) (height -1) +;; (dither :none) (x-dither 0) (y-dither 0)) +;; (gdk-draw-pixbuf drawable gc pixbuf src-x src-y dst-x dst-y +;; width height dither x-dither y-dither)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/window.lisp 2011/04/25 19:16:07 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/window.lisp 2011/08/26 17:16:14 1.2 @@ -1,5 +1,12 @@ (in-package :gdk-cffi) -(defclass window (drawable) +(defclass window (g-object) ()) +(defclass x11-window (window) + ()) + +(defbitfield modifier-type + :shift :lock :control :mod1 :mod2 :mod3 :mod4 :mod5 + :button1 :button2 :button3 :button4 :button5 + (:super #.(ash 1 26)) :hyper :meta (:release #.(ash 1 30))) --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/rectangle.lisp 2011/08/26 17:16:14 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/rectangle.lisp 2011/08/26 17:16:14 1.1 (in-package :gdk-cffi) (defclass rectangle (object) ()) (defmacro with-rectangle (rect &body body) `(with-object (,rect) (make-instance 'rectangle) , at body)) (defmethod gconstructor ((rectangle rectangle) &key &allow-other-keys) (foreign-alloc 'cairo_rectangle_t)) (defmethod free :before ((rectangle rectangle)) (foreign-free (pointer rectangle))) (defcstruct-accessors (rectangle . cairo_rectangle_t) x y height width) (defcfun gdk-rectangle-intersect :boolean (src1 pobject) (src2 pobject) (dest pobject)) (defmethod intersect ((rect1 rectangle) (rect2 rectangle)) (let ((dest (make-instance 'rectangle))) (if (gdk-rectangle-intersect rect1 rect2 dest) dest (progn (free dest) nil)))) (defcfun gdk-rectangle-union :void (src1 pobject) (src2 pobject) (dest pobject)) (defmethod rectangle-union ((rect1 rectangle) (rect2 rectangle)) (let ((dest (make-instance 'rectangle))) (gdk-rectangle-union rect1 rect2 dest))) (defcfun gdk-rectangle-get-type g-type) From rklochkov at common-lisp.net Fri Aug 26 17:16:14 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Fri, 26 Aug 2011 10:16:14 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/utils Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/utils In directory tiger.common-lisp.net:/tmp/cvs-serv16215/utils Modified Files: gtk-cffi-utils.asd package.lisp utils.lisp Log Message: Added GTK3 support. Dropped GTK2 support. Refactored CFFI layer. --- /project/gtk-cffi/cvsroot/gtk-cffi/utils/gtk-cffi-utils.asd 2011/08/08 15:02:02 1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/utils/gtk-cffi-utils.asd 2011/08/26 17:16:14 1.2 @@ -8,6 +8,7 @@ :author "Roman Klochkov " :version "1.0" :license "LGPL" + :depends-on (alexandria iterate cffi) :components - ((:file :package) - (:file :utils :depends-on (:package)))) \ No newline at end of file + ((:file package) + (:file utils :depends-on (package)))) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/utils/package.lisp 2011/08/08 15:02:02 1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/utils/package.lisp 2011/08/26 17:16:14 1.2 @@ -1,6 +1,9 @@ (in-package #:cl-user) (defpackage #:gtk-cffi-utils - (:use #:common-lisp) + (:use #:common-lisp #:alexandria #:iterate) (:export - #:with-hash)) \ No newline at end of file + #:with-hash + #:memo + #:debug-out + #:bitmask)) --- /project/gtk-cffi/cvsroot/gtk-cffi/utils/utils.lisp 2011/08/08 15:02:02 1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/utils/utils.lisp 2011/08/26 17:16:14 1.2 @@ -1,8 +1,40 @@ (in-package :gtk-cffi-utils) +(defmacro debug-out (&body body) +; (declare (ignore body)) + `(format t , at body) + ) + +(defmacro memo (place &nody body) + `(or ,place + (setf ,place , at body))) + +(defun find-key (key seq) + (when seq + (if (eq key (car seq)) + (list (first seq) (second seq)) + (find-key key (cddr seq))))) + (defmacro with-hash (hash key &body body) + "If found KEY in HASH, return corresponding value, +else use BODY to calculate the value and save to HASH. +NIL values not saved" (let ((try (gensym))) `(or (gethash ,key ,hash) (let ((,try (progn , at body))) (when ,try - (setf (gethash ,key ,hash) ,try)))))) \ No newline at end of file + (setf (gethash ,key ,hash) ,try)))))) + +(defmacro bitmask (&rest flags) + "Returns list from lisp values as keywords: + Example: (bitmask after swapped) + -> nil, when after=nil and swapped=nil + -> (:after), when after=t and swapped=nil + -> (:swapped), when after=nil and swapped=t + -> (:after :swapped), when both are t" + `(flatten + (list ,@(iter + (for flag in flags) + (collect `(when ,flag + ,(make-keyword flag))))))) + From rklochkov at common-lisp.net Fri Aug 26 17:39:35 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Fri, 26 Aug 2011 10:39:35 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/cffi Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/cffi In directory tiger.common-lisp.net:/tmp/cvs-serv18903/cffi Added Files: struct.lisp Log Message: Forgot one file --- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp 2011/08/26 17:39:35 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp 2011/08/26 17:39:35 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; array.lisp --- CFFI wrapper for arrays ;;; ;;; Copyright (C) 2011, Roman Klochkov ;;; (in-package :cffi-object) (defmacro defcstruct-accessors (class &rest slots) "CLASS maybe symbol = class-name = struct name, or maybe cons (class-name . struct-name)" (let ((class-name (if (consp class) (car class) class)) (struct-name (if (consp class) (cdr class) class))) `(progn ,@(iter (for x in slots) (collect `(progn (defmethod ,x ((,class-name ,class-name)) (foreign-slot-value (pointer ,class-name) ',struct-name ',x)) (defmethod (setf ,x) (val (,class-name ,class-name)) (setf (foreign-slot-value (pointer ,class-name) ',struct-name ',x) val)))))))) (defmacro defcstruct* (class &body body) `(progn (defcstruct ,class , at body) (defcstruct-accessors ,class ,@(iter (for x in body) (when (consp x) (collect (car x))))))) From rklochkov at common-lisp.net Fri Aug 26 17:16:14 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Fri, 26 Aug 2011 10:16:14 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/gtk Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/gtk In directory tiger.common-lisp.net:/tmp/cvs-serv16215/gtk Modified Files: accel-group.lisp cell-renderer.lisp common.lisp container.lisp dialog.lisp entry.lisp file-chooser-button.lisp file-chooser-dialog.lisp generics.lisp gtk-cffi.asd icon.lisp lisp-model.lisp list-store.lisp loadlib.lisp package.lisp paned.lisp tree-model-filter.lisp tree-model.lisp widget.lisp window.lisp Added Files: css-provider.lisp enums.lisp expander.lisp style-context.lisp style-provider.lisp widget-path.lisp Removed Files: gtk-object.lisp Log Message: Added GTK3 support. Dropped GTK2 support. Refactored CFFI layer. --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/accel-group.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/accel-group.lisp 2011/08/26 17:16:14 1.2 @@ -10,8 +10,26 @@ (defclass accel-group (object) ()) +(defbitfield accel-flags + :visible :locked) + (defcfun "gtk_accel_group_new" :pointer) (defmethod gconstructor ((accel-group accel-group) &key &allow-other-keys) (gtk-accel-group-new)) +(defcfun gtk-accel-group-connect :void + (accel-group pobject) (accel-key :uint) (accel-mods modifier-type) + (accel-flags accel-flags) (closure :pointer)) + +(defcfun gtk-accel-group-connect-by-path :void + (accel-group pobject) (accel-path :string) (closure :pointer)) + +(defmethod connect ((accel-group accel-group) func + &key path key accel-mods accel-flags) + "FUNC should have args: (accel_group acceleratable, keyval, modifier)" + (let ((closure (g-object-cffi::make-closure func))) + (if path + (gtk-accel-group-connect-by-path accel-group path closure) + (gtk-accel-group-connect accel-group + key accel-mods accel-flags closure)))) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-renderer.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-renderer.lisp 2011/08/26 17:16:14 1.2 @@ -1,6 +1,6 @@ (in-package :gtk-cffi) -(defclass cell-renderer (gtk-object) +(defclass cell-renderer (g-object) ()) (defcenum cell-renderer-mode --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/common.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/common.lisp 2011/08/26 17:16:14 1.2 @@ -11,9 +11,11 @@ (defun gtk-init () ;(load-gtk) + #+sbcl (sb-ext::set-floating-point-modes :traps nil) (with-foreign-objects ((argc :int) (argv :pointer)) - (setf (mem-ref argc :int) 0 ) - (setf (mem-ref argv :pointer) (null-pointer)) + (setf (mem-ref argc :int) 0 + (mem-ref argv :pointer) (foreign-alloc :string + :initial-element "program")) (%gtk-init argc argv))) (defcfun "gtk_main" :void) @@ -99,27 +101,3 @@ (process body)))) -(defmacro defgtkslot (current-class slot-name slot-type) - (let ((getter (intern (format nil "GTK-~a-GET-~a" current-class slot-name))) - (setter (intern (format nil "GTK-~a-SET-~a" current-class slot-name)))) - `(progn - (defcfun ,getter ,slot-type (object pobject)) - (defcfun ,setter :void (widget pobject) (value ,slot-type)) - (unless (fboundp ',slot-name) - (defgeneric ,slot-name (,current-class))) - (unless (fboundp '(setf ,slot-name)) - (defgeneric (setf ,slot-name) (value ,current-class))) - (defmethod ,slot-name ((object ,current-class)) (,getter object)) - (defmethod (setf ,slot-name) (value (object ,current-class)) - (,setter object value))))) - -(defmacro defgtkslots (current-class &rest slots) - `(progn - ,@(loop :for x :on slots :by #'cddr - :collecting `(defgtkslot ,current-class ,(first x) ,(second x))))) - -(defun find-key (key seq) - (when seq - (if (eq key (car seq)) (list (car seq) (cadr seq)) - (find-key key (cddr seq))))) - --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/container.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/container.lisp 2011/08/26 17:16:14 1.2 @@ -9,11 +9,12 @@ (defcfun "gtk_container_add" :void (container pobject) (widget pobject)) -(defcfun "gtk_container_set_border_width" :void - (container pobject) (width :uint)) - -(defcfun "gtk_container_get_border_width" :uint - (container pobject)) +(defgtkslots container + border-width :uint + resize-mode resize-mode + focus-child pobject + focus-vadjustment pobject + focus-hadjustment pobject) (defmethod add ((container container) (widget widget)) (gtk-container-add container widget)) @@ -23,12 +24,11 @@ (add container widget)) (defmacro pack* (box &rest widgets) - (cons 'progn - (mapcar - (lambda (widget) (if (and widget (listp widget)) - `(pack ,box , at widget) - `(pack ,box ,widget))) - widgets))) + `(progn + ,@(mapcar + (lambda (widget) + `(pack ,box ,@(ensure-cons widget))) + widgets))) (defmethod (setf kids) (kids (container container)) (mapc (lambda (x) (setf (kid container) x)) kids)) @@ -36,24 +36,11 @@ (defmethod (setf kid) (kid (container container)) (pack container kid)) -(defmethod (setf border-width) (width (container container)) - (gtk-container-set-border-width (pointer container) width)) - -(defmethod border-width ((container container)) - (gtk-container-get-border-width (pointer container))) - (defcfun "gtk_widget_reparent" :void (widget pobject) (parent pobject)) (defmethod reparent ((widget widget) (new-parent container)) (gtk-widget-reparent widget new-parent)) -(defcfun "gtk_container_propagate_expose" :void (container pobject) - (child pobject) (event pobject)) - -(defmethod propagate-expose ((container container) (child widget) - (event event)) - (gtk-container-propagate-expose container child event)) - (defmethod initialize-instance :after ((container container) &key kid kids &allow-other-keys) @@ -62,9 +49,9 @@ (defmacro pack-with-param (container token cur-param keyword-list) "Handle to let user set (pack* box widget1 :expand t widget2 widget3) Here, widget2 and widget3 will be packed with expand." - `(if (find ,token ,keyword-list) ;'(:pack-fill :padding :expand)) + `(if (member ,token ,keyword-list) ;'(:pack-fill :padding :expand)) (setf (slot-value ,container ',cur-param) - (intern (string ,token) :gtk-cffi)) + (intern (string ,token) #.*package*)) (let ((param (slot-value ,container ',cur-param))) (when param (setf (slot-value ,container param) ,token))))) @@ -118,7 +105,8 @@ (let ((skey (string-downcase key))) (with-g-value (:value value :g-type (child-property-type parent skey)) - (gtk-container-child-set-property parent widget skey *g-value*)))) + (gtk-container-child-set-property parent widget + skey *g-value*)))) keys (if (listp values) values (list values)))) (defmethod (setf child-property) (values (widget widget) (parent null) @@ -131,4 +119,10 @@ (defmethod find-child-property ((container container) key) (let ((ptr (gtk-container-class-find-child-property container key))) (unless (null-pointer-p ptr) - (make-instance 'g-object-cffi:gparam-spec :pointer ptr)))) + (make-instance 'g-object-cffi:g-param-spec :pointer ptr)))) + +(defcfun gtk-container-remove :void (container pobject) (widget pobject)) + +(defmethod container-remove ((container container) (widget widget)) + (gtk-container-remove container widget)) + --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/dialog.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/dialog.lisp 2011/08/26 17:16:14 1.2 @@ -1,8 +1,7 @@ (in-package :gtk-cffi) (defclass dialog (window) - ((v-box :accessor v-box) - (action-area :accessor action-area))) + ()) (defbitfield dialog-flags :modal @@ -19,11 +18,6 @@ (defcfun "gtk_dialog_new" :pointer) -(defcstruct dialog - "" - (v-box :pointer :offset 148) - (action-area :pointer)) - (defmethod gconstructor ((dialog dialog) &key title parent (flags 0) &allow-other-keys) (if title @@ -32,22 +26,13 @@ (defmethod initialize-instance :after ((dialog dialog) - &key with-buttons &allow-other-keys) - + &key with-buttons &allow-other-keys) (mapcar (lambda (x) (destructuring-bind (str resp) x (add-button dialog str resp))) - with-buttons) + with-buttons)) - (setf (v-box dialog) - (make-instance 'v-box - :pointer (foreign-slot-value - (pointer dialog) 'dialog 'v-box)) - (action-area dialog) - (make-instance 'h-button-box - :pointer (foreign-slot-value - (pointer dialog) 'dialog 'action-area)))) (defcfun "gtk_dialog_run" dialog-response (dialog :pointer)) @@ -57,19 +42,72 @@ (destroy dialog)) resp)) -(defcfun "gtk_dialog_set_has_separator" :void (dialog :pointer) (has :boolean)) - -(defmethod (setf has-separator) (has (dialog dialog)) - (gtk-dialog-set-has-separator (pointer dialog) has)) - -(defcfun "gtk_dialog_get_has_separator" :boolean (dialog :pointer)) - -(defmethod has-separator ((dialog dialog)) - (gtk-dialog-get-has-separator (pointer dialog))) - (defcfun "gtk_dialog_add_button" pobject (dialog pobject) (str gtk-string) (resp dialog-response)) (defmethod add-button ((dialog dialog) str response) (gtk-dialog-add-button dialog (if (keywordp str) (string-downcase str) str) - response)) \ No newline at end of file + response)) + +(defcfun gtk-dialog-response :void (dialog pobject) (resp dialog-response)) + +(defmethod response ((dialog dialog) response) + (gtk-dialog-response dialog response)) + +(defcfun gtk-dialog-add-action-widget + :void (dialog pobject) (child pobject) (resp dialog-response)) + +(defmethod add-action-widget ((dialog dialog) (child widget) response) + (gtk-dialog-add-action-widget dialog child response)) + +(defcfun gtk-dialog-set-default-response + :void (dialog pobject) (resp dialog-response)) + +(defmethod (setf default-response) (response (dialog dialog)) + (gtk-dialog-set-default-response dialog response)) + +(defcfun gtk-dialog-set-response-sensitive + :void (dialog pobject) (resp dialog-response) (setting :boolean)) + +(defmethod (setf response-sensitive) (setting (dialog dialog) response) + (gtk-dialog-set-response-sensitive dialog response setting)) + +(defcfun gtk-dialog-get-response-for-widget + dialog-response (dialog pobject) (widget pobject)) + +(defmethod response-for-widget ((dialog dialog) (widget widget)) + (gtk-dialog-get-response-for-widget dialog widget)) + +(defcfun gtk-dialog-get-widget-for-response + pobject (dialog pobject) (response dialog-response)) + +(defmethod widget-for-response ((dialog dialog) response) + (gtk-dialog-get-widget-for-response dialog response)) + +(defcfun gtk-dialog-get-action-area pobject (dialog pobject)) + +(defmethod action-area ((dialog dialog)) + (gtk-dialog-get-action-area dialog)) + +(defcfun gtk-dialog-get-content-area pobject (dialog pobject)) + +(defmethod content-area ((dialog dialog)) + (gtk-dialog-get-content-area dialog)) + +(defcfun gtk-alternative-dialog-button-order :boolean (screen pobject)) + +(defmethod alternative-dialog-button-order ((screen screen)) + (gtk-alternative-dialog-button-order screen)) + +(defcfun gtk-dialog-set-alternative-button-order-from-array + :void (dialog pobject) (n-params :int) (new-order :pointer)) + +(defmethod (setf alternative-button-order) (order (dialog dialog)) + (let ((n-params (length order))) + (with-foreign-object (arr :int n-params) + (loop + :for i :from 0 :to n-params + :for l :in order + :do (setf (mem-aref arr :int i) l)) + (gtk-dialog-set-alternative-button-order-from-array dialog + n-params arr)))) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/entry.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/entry.lisp 2011/08/26 17:16:14 1.2 @@ -12,13 +12,11 @@ (defcfun "gtk_entry_new" :pointer) -(defcfun "gtk_entry_new_with_max_length" :pointer (max :int)) +;(defcfun "gtk_entry_new_with_max_length" :pointer (max :int)) (defmethod gconstructor ((entry entry) - &key max-length &allow-other-keys) - (if max-length - (gtk-entry-new-with-max-length (round max-length)) - (gtk-entry-new))) + &key &allow-other-keys) + (gtk-entry-new)) (defcfun gtk-entry-get-text gtk-string (entry pobject)) (defcfun gtk-entry-set-text :void (entry pobject) (text gtk-string)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/file-chooser-button.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/file-chooser-button.lisp 2011/08/26 17:16:14 1.2 @@ -6,14 +6,9 @@ (defcfun "gtk_file_chooser_button_new" :pointer (title gtk-string) (action file-chooser-action)) -(defcfun "gtk_file_chooser_button_new_with_backend" :pointer - (title gtk-string) (action file-chooser-action) (backend gtk-string)) +;(defcfun "gtk_file_chooser_button_new_with_backend" :pointer +; (title gtk-string) (action file-chooser-action) (backend gtk-string)) (defmethod gconstructor ((file-chooser-button file-chooser-button) - &key title action backend &allow-other-keys) - (apply - (if backend #'gtk-file-chooser-button-new-with-backend - #'gtk-file-chooser-button-new) - (append - (list title action) - (when backend (list backend))))) + &key title action &allow-other-keys) + (gtk-file-chooser-button-new title action)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/file-chooser-dialog.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/file-chooser-dialog.lisp 2011/08/26 17:16:14 1.2 @@ -9,23 +9,19 @@ (but2-text gtk-string) (but2-response dialog-response) (null :pointer)) -(defcfun "gtk_file_chooser_dialog_new_with_backend" :pointer - (title gtk-string) (parent pobject) (action file-chooser-action) - (backend gtk-string) - (but1-text gtk-string) (but1-response dialog-response) - (but2-text gtk-string) (but2-response dialog-response) - (null :pointer)) +;; (defcfun "gtk_file_chooser_dialog_new_with_backend" :pointer +;; (title gtk-string) (parent pobject) (action file-chooser-action) +;; (backend gtk-string) +;; (but1-text gtk-string) (but1-response dialog-response) +;; (but2-text gtk-string) (but2-response dialog-response) +;; (null :pointer)) (defmethod gconstructor ((file-chooser-dialog file-chooser-dialog) - &key title parent action backend &allow-other-keys) - (apply - (if backend #'gtk-file-chooser-dialog-new-with-backend - #'gtk-file-chooser-dialog-new) - (append - (list title parent action) - (when backend (list backend)) - (list "gtk-cancel" :cancel - (case action - ((:open :select-folder) "gtk-open") - ((:save :create-folder) "gtk-save")) :accept (null-pointer))))) + &key title parent action &allow-other-keys) + (gtk-file-chooser-dialog-new + title parent action + "gtk-cancel" :cancel + (case action + ((:open :select-folder) "gtk-open") + ((:save :create-folder) "gtk-save")) :accept (null-pointer))) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/generics.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/generics.lisp 2011/08/26 17:16:14 1.2 @@ -13,16 +13,16 @@ (defgeneric (setf size-request) (size widget)) (defgeneric style-field (widget field &optional state type)) (defgeneric (setf style-field) (value widget field &optional state type)) -(defgeneric color (widget &optional field state)) -(defgeneric (setf color) (color widget &optional field state)) -(defgeneric font (widget)) -(defgeneric (setf font) (font widget)) -(defgeneric bg-pixmap (widget &optional state)) -(defgeneric (setf bg-pixmap) (pixmap widget &optional state)) +(defgeneric color (widget &rest rest)) +(defgeneric (setf color) (color widget &rest rest)) +(defgeneric font (widget &rest rest)) +(defgeneric (setf font) (font widget &rest rest)) +(defgeneric bg-pixmap (widget &rest state)) +(defgeneric (setf bg-pixmap) (pixmap widget &rest rest)) (defgeneric allocation (widget)) (defgeneric (setf allocation) (value widget)) (defgeneric show (widget &rest flags)) -(defgeneric hide (widget &rest flags)) +(defgeneric hide (widget)) (defgeneric gdk-window (widget)) (defgeneric (setf justify) (justify label)) (defgeneric justify (label)) @@ -48,7 +48,7 @@ (defgeneric has-separator (dialog)) (defgeneric add-button (dialog string response)) -(defgeneric get-iter (text-buffer text-iter pos)) +;(defgeneric get-iter (text-buffer text-iter pos)) (defgeneric buffer (text-view)) (defgeneric (setf buffer) (buffer text-view)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2011/08/08 15:02:02 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2011/08/26 17:16:14 1.3 @@ -14,14 +14,19 @@ :author "Roman Klochkov " :version "0.5" :license "GPL" - :depends-on (gdk-cffi g-object-cffi g-lib-cffi) + :depends-on (gdk-cffi g-object-cffi g-lib-cffi gtk-cffi-utils) :components - ((:file :package) - (:file :loadlib :depends-on (:package)) - (:file :generics :depends-on (:package)) - (:file :common :depends-on (:loadlib :generics)) - (:file :gtk-object :depends-on (:loadlib)) - (:file :pango :depends-on (:loadlib)))) + ((:file package) + (:file enums :depends-on (package)) + (:file loadlib :depends-on (package)) + (:file generics :depends-on (package)) + (:file common :depends-on (loadlib generics)) + (:file pango :depends-on (loadlib)) + (:file accel-group :depends-on (loadlib)) + (:file style-context :depends-on (loadlib enums icon css-provider)) + (:file style-provider :depends-on (loadlib)) + (:file css-provider :depends-on (style-provider)) + (:file icon :depends-on (loadlib enums)))) (defsystem gtk-cffi-widget :description "Interface to GTK/Glib via CFFI" @@ -30,7 +35,7 @@ :license "GPL" :depends-on (gtk-cffi-core) :components - ((:file :widget))) + ((:file widget))) (defsystem gtk-cffi-misc :description "Interface to GTK/Glib via CFFI" @@ -39,7 +44,7 @@ :license "GPL" :depends-on (gtk-cffi-widget) :components - ((:file :misc))) + ((:file misc))) (defsystem gtk-cffi-label :description "Interface to GTK/Glib via CFFI" @@ -48,7 +53,7 @@ :license "GPL" :depends-on (gtk-cffi-misc) :components - ((:file :label))) + ((:file label))) (defsystem gtk-cffi-container :description "Interface to GTK/Glib via CFFI" @@ -57,7 +62,7 @@ :license "GPL" :depends-on (gtk-cffi-widget) :components - ((:file :container))) + ((:file container))) (defsystem gtk-cffi-bin :description "Interface to GTK/Glib via CFFI: GtkBin" @@ -66,7 +71,8 @@ :license "GPL" :depends-on (gtk-cffi-container) :components - ((:file :bin))) + ((:file bin) + (:file expander :depends-on (bin)))) (defsystem gtk-cffi-window :description "Interface to GTK/Glib via CFFI" @@ -80,7 +86,7 @@ (defsystem gtk-cffi-dialog :description "Interface to GTK/Glib via CFFI" :author "Roman Klochkov " - :version "0.1" + :version "0.99" :license "GPL" :depends-on (gtk-cffi-window gtk-cffi-vbox gtk-cffi-hbuttonbox) :components @@ -429,21 +435,12 @@ :components ((:file :statusbar))) -(defsystem gtk-cffi-icon - :description "Interface to GTK/Glib via CFFI" - :author "Roman Klochkov " - :version "0.1" - :license "GPL" - :depends-on (gtk-cffi-widget) - :components - ((:file :icon))) - (defsystem gtk-cffi-image :description "Interface to GTK/Glib via CFFI" :author "Roman Klochkov " :version "0.1" :license "GPL" - :depends-on (gtk-cffi-icon) + :depends-on (gtk-cffi-misc) :components ((:file :image))) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/icon.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/icon.lisp 2011/08/26 17:16:14 1.2 @@ -9,6 +9,9 @@ :dnd :dialog) +(defcenum state + :normal :active :prelight :selected :insensitive :inconsistent :focused) + (defclass icon-source (object) ()) (defcfun "gtk_icon_source_new" :pointer) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/lisp-model.lisp 2011/08/08 15:02:02 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/lisp-model.lisp 2011/08/26 17:16:14 1.3 @@ -15,11 +15,11 @@ (defgeneric get-n-columns (lisp-model-impl) (:method ((lisp-model-list lisp-model-list)) - 1)) + (length (columns lisp-model-list)))) (defgeneric get-column-type (lisp-model-impl index) (:method ((lisp-model-impl lisp-model-impl) index) - (name->g-type (nth index (columns lisp-model-impl))))) + (keyword->g-type (nth index (columns lisp-model-impl))))) (defgeneric lisp-model-length (lisp-model-list) (:method ((lisp-model-array lisp-model-array)) @@ -41,7 +41,7 @@ (defgeneric get-value (lisp-model-impl iter n value) (:method ((lisp-model-array lisp-model-array) iter n value) - (debug-out "get-value~%") + ;(debug-out "get-value~%") (let* ((index (pointer-address (foreign-slot-value iter 'tree-iter-struct 'u1))) (lval (nth n (aref (larray lisp-model-array) index)))) @@ -56,6 +56,15 @@ (setf (foreign-slot-value iter 'tree-iter-struct 'u1) (make-pointer (1+ index))))))) +(defgeneric iter-previous (lisp-model-impl iter) + (:method ((lisp-model-list lisp-model-list) iter) + (let ((index (pointer-address + (foreign-slot-value iter 'tree-iter-struct 'u1)))) + (when (> index 0) + (setf (foreign-slot-value iter 'tree-iter-struct 'u1) + (make-pointer (1- index))))))) + + (defgeneric iter-children (lisp-model-impl iter parent) (:method ((lisp-model-list lisp-model-list) iter parent) (when (null-pointer-p parent) @@ -126,6 +135,7 @@ get-path (pobject (iter tree-iter-struct)) get-value (:void (iter tree-iter-struct) (n :int) (value :pointer)) iter-next (:boolean (iter tree-iter-struct)) + iter-previous (:boolean (iter tree-iter-struct)) iter-children (:boolean (iter tree-iter-struct) (parent tree-iter-struct)) iter-has-child (:boolean (iter tree-iter-struct)) iter-n-children (:int (iter tree-iter-struct)) @@ -136,35 +146,6 @@ unref-node (:void (iter tree-iter-struct))) - -;(defcallback cb-init- :void ((class tree-model-iface) (data pdata)) -; (setf (foreign-slot-value class 'tree-model-iface 'get-flags) -; (callback cb-get-flags))) - ;; (init-iface class tree-model-iface - ;; get-flags - ;; get-column-type - ;; get-iter - ;; get-path - ;; get-value - ;; iter-next - ;; iter-children - ;; iter-has-child - ;; iter-n-children - ;; iter-nth-child - ;; iter-parent - ;; ref-node - ;; unref-node)) - - -; (check-type data symbol) -; (init-interface data -; (g-type->lisp -; (foreign-slot-value class 'tree-model-iface 'g-iface)) -; class)) - - - - (defcstruct g-interface-info (init :pointer) (finalize :pointer) @@ -181,7 +162,7 @@ (prog1 (setf g-type (g-type-register-static-simple - #.(name->g-type :object) + #.(keyword->g-type :object) (g-intern-static-string "GtkLispModel") (foreign-type-size 'g-object-class) (callback cb-lisp-model-class-init) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/list-store.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/list-store.lisp 2011/08/26 17:16:14 1.2 @@ -7,6 +7,7 @@ ;;; (in-package :gtk-cffi) +(declaim (optimize (speed 3))) (defclass list-store (g-object tree-model) ()) @@ -25,7 +26,7 @@ (with-foreign-object (arr :int n) (dotimes (i n) (setf (mem-aref arr :int i) - (name->g-type (nth i columns)))) + (keyword->g-type (nth i columns)))) (gtk-list-store-newv n arr))) (mapc (lambda (row) (append-values list-store row)) values))) @@ -33,7 +34,7 @@ (defcfun "gtk_list_store_append" :void (store pobject) (iter pobject)) (defmethod append-iter ((list-store list-store) &optional - (tree-iter (iter list-store))) + (tree-iter (tree-iter list-store))) (gtk-list-store-append list-store tree-iter)) (defcfun "gtk_list_store_set_value" :void (store pobject) (iter pobject) @@ -41,8 +42,9 @@ (defmethod (setf model-values) (values (list-store list-store) - &key (iter (iter list-store)) col (columns (when col (list col)))) + &key (iter (tree-iter list-store)) col (columns (when col (list col)))) "Example: (setf (model-values list-store :col 1) \"val1\")" + (declare (type list columns values)) (let ((%cols (append columns (loop :for i :from (length columns) :below (length values) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/loadlib.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/loadlib.lisp 2011/08/26 17:16:14 1.2 @@ -18,8 +18,8 @@ (define-foreign-library :gtk - (:unix "libgtk-x11-2.0.so") - (:windows "libgtk-win32-2.0-0.dll")) + (:unix "libgtk-3.so.0") ;libgtk-x11-2.0.so") + (:windows "libgtk-win32-3-0.dll")) (load-foreign-library :gtk) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2011/08/08 15:02:02 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2011/08/26 17:16:14 1.3 @@ -8,8 +8,9 @@ (in-package #:cl-user) (defpackage gtk-cffi - (:use #:common-lisp #:cffi - #:cffi-object #:g-object-cffi #:g-lib-cffi #:gdk-cffi) + (:use #:common-lisp #:cffi #:alexandria #:iterate + #:cffi-object #:g-object-cffi #:g-lib-cffi #:gdk-cffi + #:gtk-cffi-utils) (:shadow #:image #:window) (:export ;;;; common @@ -92,15 +93,22 @@ #:default-size #:screen #:transient-for - #:win-position + #:window-position ;; methods #:dialog - ;; dialog slots - #:has-separator ;;methods #:run + #:response #:add-button + #:default-response + #:add-action-widget + #:response-sensitive + #:response-for-widget + #:action-area + #:content-area + #:alternative-button-order + #:alternative-dialog-button-order #:entry ;; entry slots @@ -285,8 +293,11 @@ #:image #:lisp-model + #:implementation #:lisp-model-array #:larray + + #:expander )) (in-package #:gtk-cffi) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/paned.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/paned.lisp 2011/08/26 17:16:14 1.2 @@ -6,6 +6,8 @@ (pane-type :initform 1) (cur-param :initform nil :allocation :class))) +(defgtkslot paned (paned-position . position) :int) + (defcfun "gtk_paned_add1" :void (paned pobject) (widget pobject)) (defcfun "gtk_paned_add2" :void (paned pobject) (widget pobject)) @@ -17,7 +19,7 @@ (resize :boolean) (shrink :boolean)) (defmethod pack ((paned paned) (widget widget) - &key (pane-type 1) (resize :default) (shrink :default)) + &key (pane-type :default) (resize :default) (shrink :default)) (macrolet ((default (field) `(if (eq ,field :default) (slot-value paned ',field) ,field))) (case (default pane-type) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model-filter.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model-filter.lisp 2011/08/26 17:16:14 1.2 @@ -1,6 +1,6 @@ (in-package :gtk-cffi) -(defclass tree-model-filter (gobject tree-model) +(defclass tree-model-filter (g-object tree-model) ((model :accessor model :initarg :model))) (defcfun "gtk_tree_model_filter_new" :pointer (model pobject) (path pobject)) @@ -58,8 +58,8 @@ &key (iter (iter tree-model-filter)) col (columns (when col (list col)))) (with-child-iter child-iter tree-model-filter iter - (apply #'(setf model-values) - (append (list values (model tree-model-filter) - child-iter) columns)))) + (setf (model-values (model tree-model-filter) + :iter child-iter :columns columns) values))) + --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2011/08/08 15:02:02 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2011/08/26 17:16:14 1.3 @@ -94,7 +94,7 @@ (defclass tree-model (object) ((columns :accessor columns :initarg :columns) - (iter :accessor iter))) + (iter :accessor tree-iter))) (defcstruct tree-model-iface "GtkTreeModelIface" @@ -113,6 +113,7 @@ (get-path :pointer) (get-value :pointer) (iter-next :pointer) + (iter-previous :pointer) (iter-children :pointer) (iter-has-child :pointer) (iter-n-children :pointer) @@ -124,20 +125,20 @@ (defmethod initialize-instance :after ((tree-model tree-model) &key &allow-other-keys) - (setf (iter tree-model) (make-instance 'tree-iter))) + (setf (tree-iter tree-model) (make-instance 'tree-iter))) (defmethod free :before ((tree-model tree-model)) - (free (iter tree-model))) + (free (tree-iter tree-model))) (defvar *tree-model-foreach* nil) (defcallback cb-tree-model-foreach :boolean - ((model pobject) (path :pointer) (iter :pointer) (data pdata)) + ((model pobject) (path :pointer) (tree-iter :pointer) (data pdata)) (if *tree-model-foreach* (funcall *tree-model-foreach* model (make-instance 'tree-path :pointer path) - (make-instance 'tree-iter :pointer iter) + (make-instance 'tree-iter :pointer tree-iter) data) t)) @@ -165,7 +166,7 @@ (defmethod model-values ((tree-model tree-model) &key - (iter (iter tree-model)) col (columns (when col (list col)))) + (iter (tree-iter tree-model)) col (columns (when col (list col)))) "columns = num0 &optional num1 num2 ..." ;(format t "model-values: ~a ~a ~a~%" tree-model tree-iter cols) (mapcar @@ -186,7 +187,7 @@ (model pobject) (iter pobject) (path :string)) (defmethod path->iter ((tree-model tree-model) tree-path-string - &optional (tree-iter (iter tree-model))) + &optional (tree-iter (tree-iter tree-model))) (gtk-tree-model-get-iter-from-string tree-model tree-iter tree-path-string) tree-iter) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2011/08/26 17:16:14 1.2 @@ -1,70 +1,84 @@ (in-package :gtk-cffi) -(defclass widget (gtk-object) +(defclass widget (g-object) ()) -(defcstruct requisition - "GtkRequisition" - (width :int) - (height :int)) - -(defcstruct allocation - "GtkAllocation" - (x :int) (y :int) - (width :int) (height :int)) - -(defcstruct widget - "GtkWidget" - (object gtk-object) - (private-flags :uint16) - (state :uint8) - (saved-state :uint8) - (name :string) - (style :pointer) - (requisition requisition) - (allocation allocation) - (window pobject) - (parent pobject)) +(defclass requisition (object) + ()) +(defcfun gtk-requisition-new :pointer) -(defcfun "gtk_widget_activate" :boolean (widget pobject)) +(defmethod gconstructor ((requisition requisition) &key &allow-other-keys) + (gtk-requisition-new)) -(defmethod activate ((widget widget)) - (gtk-widget-activate widget)) +(defcfun gtk-requisition-copy :pointer (requisition pobject)) -(defcfun "gtk_widget_show" :boolean (widget pobject)) -(defcfun "gtk_widget_show_all" :boolean (widget pobject)) +(defmethod copy ((requisition requisition)) + (make-instance 'requisition :pointer (gtk-requisition-copy requisition))) -(defmethod show ((widget widget) &key (all t)) - (funcall (if all #'gtk-widget-show-all - #'gtk-widget-show) widget)) +(defcfun gtk-requisition-free :void (requisition pobject)) -(defcfun "gtk_widget_hide" :boolean (widget pobject)) -(defcfun "gtk_widget_hide_all" :boolean (widget pobject)) +(defmethod free ((requisition requisition)) + (gtk-requisition-free requisition)) -(defmethod hide ((widget widget) &key all) - (funcall (if all #'gtk-widget-hide-all - #'gtk-widget-hide) widget)) +(defcstruct* requisition + "GtkRequisition" + (width :int) + (height :int)) -(defcfun "gtk_widget_realize" :void (widget pobject)) +(defcstruct allocation + "GtkAllocation" + (x :int) (y :int) + (width :int) (height :int)) -(defmethod realize ((widget widget)) - (gtk-widget-realize widget)) +(defgtkfun activate :boolean widget) -(defstruct (size-request (:type list)) width height) +(defcfun gtk-widget-show :boolean (widget pobject)) +(defcfun gtk-widget-show-all :boolean (widget pobject)) +(defcfun gtk-widget-show-now :boolean (widget pobject)) + +(defmethod show ((widget widget) &key (all t) now) + (funcall (cond + (now #'gtk-widget-show-now) + (all #'gtk-widget-show-all) + (t #'gtk-widget-show)) widget)) + +(defgtkfun hide :boolean widget) + +(defgtkfun realize :void widget) + +(defcfun gtk-widget-draw :void (widget pobject) (context :pointer)) +(defmethod draw ((widget widget) &optional (context cl-cairo2:*context*)) + (cl-cairo2::with-context-pointer (context cntx-pointer) + (gtk-widget-draw widget cntx-pointer))) + +(defcfun gtk-widget-queue-draw-area :void + (widget pobject) (x :int) (y :int) (width :int) (height :int)) +(defcfun gtk-widget-queue-draw-region :void (widget pobject) (region pobject)) +(defcfun gtk-widget-queue-draw :void (widget pobject)) + +(defmethod queue-draw ((widget widget) &key area region) + (cond + (area (apply #'gtk-widget-queue-draw-area widget area)) + (region (gtk-widget-queue-draw-region widget region)) + (t (gtk-widget-queue-draw widget)))) + +(defcfun gtk-widget-queue-resize :void (widget pobject)) +(defcfun gtk-widget-queue-resize-no-redraw :void (widget pobject)) + +(defmethod queue-resize ((widget widget) &key no-redraw) + (if no-redraw + (gtk-widget-queue-resize-no-redraw widget) + (gtk-widget-queue-resize widget))) -(defcfun "gtk_widget_size_request" :void - (widget pobject) (req requisition)) +(defcfun "gtk_widget_get_size_request" :void + (widget pobject) (width :pointer) (height :pointer)) (defmethod size-request ((widget widget)) "returns (width height)" - (with-foreign-object (res 'requisition) - (gtk-widget-size-request widget res) - (with-foreign-slots - ((width height) res requisition) - (make-size-request :width width - :height height)))) - + (with-foreign-objects ((width :int) (height :int)) + (gtk-widget-get-size-request widget width height) + (list (mem-ref width :int) (mem-ref height :int)))) (defcfun "gtk_widget_set_size_request" :void (widget pobject) (w :int) (h :int)) @@ -72,142 +86,28 @@ (defmethod (setf size-request) (coords (widget widget)) "coords = (width height)" (gtk-widget-set-size-request widget - (size-request-width coords) - (size-request-height coords))) + (first coords) + (second coords))) + + + +(defgtkfun override-color :void widget (state state-flags) (color prgba)) + +(defgtkfun override-background-color :void + widget (state state-flags) (color prgba)) +(defgtkfun override-symbolic-color :void widget (name :string) (color prgba)) -(defcstruct style - (parent-instance g-object) - (fg color-struct :count 5) - (bg color-struct :count 5) - (light color-struct :count 5) - (dark color-struct :count 5) - (mid color-struct :count 5) - (text color-struct :count 5) - (base color-struct :count 5) - (text-aa color-struct :count 5) - (black color-struct :count 5) - (white color-struct :count 5) - (font-desc pango-cffi:font) - (xthickness :int) - (ythickness :int) - (fg-gc pobject :count 5) - (bg-gc pobject :count 5) - (light-gc pobject :count 5) - (dark-gc pobject :count 5) - (mid-gc pobject :count 5) - (text-gc pobject :count 5) - (base-gc pobject :count 5) - (text-aa-gc pobject :count 5) - (black-gc pobject :count 5) - (white-gc pobject :count 5) - (bg-pixmap pobject :count 5)) - -(defcstruct rcstyle - (parent-instance g-object) - (name gtk-dyn-string) - (bg-pixmap-name gtk-dyn-string :count 5) - (font-desc pango-cffi:font) - (color-flags :int :count 5) - (fg pcolor :count 5) - (bg pcolor :count 5) - (text pcolor :count 5) - (base pcolor :count 5) - (xthickness :int) - (ythickness :int)) - -(defcenum state - :normal :active :prelight :selected :insensitive) - -(defcfun "gtk_widget_modify_fg" - :void (widget pobject) (state state) (color pcolor)) - -(defcfun "gtk_widget_modify_bg" - :void (widget pobject) (state state) (color pcolor)) - -(defcfun "gtk_widget_modify_text" - :void (widget pobject) (state state) (color pcolor)) - -(defcfun "gtk_widget_modify_base" - :void (widget pobject) (state state) (color pcolor)) - -(macrolet ((select-accessor (type) - `(ccase ,type - ,@(mapcar (lambda (x) - (list x - (list 'function - (intern - (format nil - "GTK-WIDGET-MODIFY-~A" x))))) - '(:fg :bg :text :base))))) - - (defmethod (setf color) (color (widget widget) - &optional (type :fg) (state :normal)) - "TYPE may be :fg :bg :text :base, - STATE may be :normal :active :prelight :selected :insensitive" - (funcall (select-accessor type) widget state color))) - -(macrolet ((style-field-place - () - `(mem-aref - (foreign-slot-pointer (style widget) - 'style (intern (string field) #.*package*)) - type - (foreign-enum-value 'state state)))) - - (defmethod style-field ((widget widget) field - &optional (state :normal) (type 'pobject)) - (style-field-place)) - - (defmethod (setf style-field) (value (widget widget) field - &optional (state :normal) - (type :pointer)) - (setf (style-field-place) value))) - -(defmethod color ((widget widget) - &optional (field :fg) (state :normal)) - "TYPE may be :fg :bg :text :base, - STATE may be :normal :active :prelight :selected :insensitive" - (style-field widget field state 'color-struct)) - -(defcfun "gtk_widget_modify_font" :void (widget pobject) - (font pango-cffi:font)) - -(defmethod (setf font) (font (widget widget)) - (gtk-widget-modify-font widget font)) - -(defmethod font ((widget widget)) - (style-field widget :font-desc)) ;; = widget->get_style()->font_desc - - -(defcenum text-direction - :none :ltr :rtl) - -(defcfun "gtk_widget_get_modifier_style" rcstyle (widget pobject)) - -(defcfun "gtk_widget_modify_style" :void (widget pobject) (style rcstyle)) - -(defcfun ("gtk_rc_parse_string" rc-parse-string) :void (str gtk-string)) - -(defmethod (setf bg-pixmap) (pixmap-name (widget widget) - &optional (state :normal)) - (let ((rcstyle (gtk-widget-get-modifier-style widget))) - (setf (mem-aref - (foreign-slot-pointer rcstyle 'rcstyle 'bg-pixmap-name) - 'gtk-string - (foreign-enum-value 'state state)) - pixmap-name) - (gtk-widget-modify-style widget rcstyle) - (setf (app-paintable widget) t))) - -(defmethod bg-pixmap ((widget widget) &optional (state :normal)) - (let ((rcstyle (gtk-widget-get-modifier-style widget))) - (mem-aref - (foreign-slot-pointer rcstyle 'rcstyle 'bg-pixmap-name) - 'gtk-string - (foreign-enum-value 'state state)))) - +(defcfun gtk-widget-get-style-context pobject (widget pobject)) + +(defmethod style-context ((widget widget)) + (gtk-widget-get-style-context widget)) + +(defgtkfun override-font :void widget (font pango-cffi:font)) + +(defcenum align :fill :start :end :center) + (defgtkslots widget name gtk-string direction text-direction @@ -227,10 +127,21 @@ mapped :boolean realized :boolean no-show-all :boolean - colormap pobject sensitive :boolean - state state - style style + events event-mask + visual pobject + composite-name gtk-string + halign align + valign align + margin-left :int + margin-right :int + margin-top :int + margin-bottom :int + hexpand :boolean + hexpand-set :boolean + vexpand :boolean + allocation allocation + vexpand-set :boolean app-paintable :boolean) (defbitfield widget-flags @@ -255,36 +166,186 @@ :no-show-all) -(defcfun "gtk_widget_size_allocate" :void - (widget pobject) (allocation allocation)) +(defgtkfun destroy :void widget) + +(defgtkfun render-icon-pixbuf pobject widget + (stock-id :string) (size icon-size)) + +(defgtkfun add-events :void widget (events event-mask)) + +(defgtkgetter device-events event-mask widget (device pobject)) + +(defcfun gtk-widget-set-device-events :void + (widget pobject) (device pobject) (events event-mask)) + +(defmethod (setf device-events) (events (widget widget) device) + (gtk-widget-set-device-events widget device events)) + +(defgtkfun add-device-events :void widget + (device pobject) (events event-mask)) + +(defcfun gtk-widget-set-device-enabled :void + (widget pobject) (device pobject) (enabled :boolean)) + +(defmethod (setf device-enabled) (enabled (widget widget) device) + (gtk-widget-set-device-enabled widget device enabled)) + +(defgtkgetter device-enabled :boolean widget (device pobject)) + +(defgtkgetter toplevel pobject widget) +(defgtkgetter ancestor pobject widget (widget-type g-type)) + + +(defcfun ("gtk_widget_pop_composite_child" pop-composite-child) :void) +(defcfun ("gtk_widget_push_composite_child" push-composite-child) :void) + +(defcfun gtk-widget-get-pointer :void + (widget pobject) (x :pointer) (y :pointer)) + +(defmethod get-pointer ((widget widget)) + (with-foreign-objects ((x :int) (y :int)) + (gtk-widget-get-pointer widget x y) + (list (mem-ref x :int) (mem-ref y :int)))) + +(defgtkfun is-ancestor :boolean widget (ancestor pobject)) + +(defcfun gtk-widget-translate-coordinates :boolean + (src-widget pobject) (dst-widget pobject) (src-x :int) (src-y :int) + (dst-x :pointer) (dst-y :pointer)) + +(defmethod translate-coordinates ((src-widget widget) (dst-widget widget) + src-x src-y) + (with-foreign-objects ((dst-x :int) (dst-y :int)) + (gtk-widget-translate-coordinates src-widget dst-widget + src-x src-y dst-x dst-y) + (list (mem-ref dst-x :int) (mem-ref dst-y :int)))) + +(defgtkfun shape-combine-region :void widget (region pobject)) +(defgtkfun input-shape-combine-region :void widget (region pobject)) + +(defgtkgetter path (object widget-path) widget) +(defgtkfun is-composited :boolean widget) + +(defgtkfun override-cursor :void widget (cursor prgba) (secondary-cursor prgba)) + +(defgtkfun create-pango-context pobject widget) +(defgtkgetter pango-context pobject widget) +(defgtkfun create-pango-layout pobject widget) +(defgtksetter redraw-on-allocate :boolean widget) +(defgtkfun mnemonic-activate :boolean widget (group-cycling :boolean)) + +(defgtkgetter window pobject widget) +(defgtkgetter settings pobject widget) + [142 lines skipped] --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/window.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/window.lisp 2011/08/26 17:16:14 1.2 @@ -6,6 +6,15 @@ (defclass window (bin) ()) +(defmethod gconstructor ((window window) + &key (type :top-level) &allow-other-keys) + (gtk-window-new type)) + +(defgtkslots window + title gtk-string + screen pobject + transient-for pobject) + (defcfun "gtk_window_new" :pointer (type window-type)) (defcfun "gtk_window_set_default_size" @@ -14,19 +23,6 @@ (defcfun "gtk_window_get_default_size" :void (window pobject) (w :pointer) (h :pointer)) -(defmethod gconstructor ((window window) - &key (type :top-level) &allow-other-keys) - (gtk-window-new type)) - -(defmethod initialize-instance - :after ((window window) - &key (width -1) (height -1) title transient-for win-position - &allow-other-keys) - (when (or (/= width -1) (/= height -1)) - (gtk-window-set-default-size window width height)) - (setf-init window title transient-for win-position)) - - (defmethod (setf default-size) (coords (window window)) (let ((width (first coords)) (height (second coords))) @@ -38,17 +34,6 @@ (gtk-window-get-default-size window width height) (list (mem-ref width :int) (mem-ref height :int)))) -(defcfun "gtk_window_get_screen" :pointer (window pobject)) - -(defmethod screen ((window window)) - (make-instance 'gdk-cffi:screen - :pointer (gtk-window-get-screen window))) - -(defcfun "gtk_window_set_screen" :void (window pobject) (screen pobject)) - -(defmethod (setf screen) ((screen gdk-cffi:screen) (window window)) - (gtk-window-set-screen window screen)) - (defcenum position :none :center @@ -58,25 +43,11 @@ (defcfun "gtk_window_set_position" :void (window pobject) (pos position)) -(defmethod (setf win-position) (pos (window window)) +(defmethod (setf window-position) (pos (window window)) (gtk-window-set-position window pos)) -(defcfun "gtk_window_set_title" :void (window pobject) (title gtk-string)) -(defcfun "gtk_window_get_title" gtk-string (window pobject)) - -(defmethod title ((window window)) - (gtk-window-get-title window)) - -(defmethod (setf title) (title (window window)) - (gtk-window-set-title window title)) - -(defcfun "gtk_window_set_transient_for" :void - (window pobject) (parent pobject)) - -(defcfun "gtk_window_get_transient_for" pobject (window pobject)) - -(defmethod (setf transient-for) (parent (window window)) - (gtk-window-set-transient-for window parent)) +(init-slots window ((width -1) (height -1) position) + (when (or (/= width -1) (/= height -1)) + (gtk-window-set-default-size window width height)) + (when position (setf (window-position window) position))) -(defmethod transient-for ((window window)) - (gtk-window-get-transient-for window)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/css-provider.lisp 2011/08/26 17:16:14 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/css-provider.lisp 2011/08/26 17:16:14 1.1 (in-package :gtk-cffi) (defclass css-provider (g-object style-provider) ()) (defcfun gtk-css-provider-get-default :pointer) (defcfun gtk-css-provider-get-named :pointer (name :string) (variant :string)) (defcfun gtk-css-provider-new :pointer) (defmethod gconstructor ((css-provide css-provider) &key name variant default) (cond (default (gtk-css-provider-get-default)) (name (gtk-css-provider-get-named name variant)) (t (gtk-css-provider-new)))) (defcfun gtk-css-provider-load-from-data :boolean (css-provider pobject) (data :string) (length :int) (g-error object)) (defcfun gtk-css-provider-load-from-file :boolean (css-provider pobject) (file g-file) (g-error object)) (defcfun gtk-css-provider-load-from-path :boolean (css-provider pobject) (path :string) (g-error object)) (defmethod css-provider-load ((css-provider css-provider) &key data filename gfile) (with-g-error g-error (unless (cond (data (gtk-css-provider-load-from-data css-provider data -1 g-error)) (filename (gtk-css-provider-load-from-path css-provider filename g-error)) (gfile (gtk-css-provider-load-from-file css-provider gfile g-error))) (cerror "Continue" "CSS Provider load error: ~a" g-error)))) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/enums.lisp 2011/08/26 17:16:14 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/enums.lisp 2011/08/26 17:16:14 1.1 (in-package :gtk-cffi) (defcenum text-direction :none :ltr :rtl) (defbitfield junction-sides (:none 0) :corner-topleft :corner-topright :corner-bottomleft :corner-bottomright (:top #b0011) (:bottom #b1100) (:left #b0101) (:right #b1010)) (defbitfield state-flags (:normal 0) :active :prelight :selected :insensitive :inconsistent :focused) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/expander.lisp 2011/08/26 17:16:14 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/expander.lisp 2011/08/26 17:16:14 1.1 (in-package :gtk-cffi) (defclass expander (bin) ()) (defcfun gtk-expander-new-with-mnemonic :pointer (label gtk-string)) (defcfun gtk-expander-new :pointer (label gtk-string)) (defmethod gconstructor ((expander expander) &key label mnemonic &allow-other-keys) (if mnemonic (gtk-expander-new-with-mnemonic mnemonic) (gtk-expander-new label))) (defgtkslots expander label gtk-string spacing :int expanded :boolean use-underline :boolean use-markup :boolean label-widget pobject label-fill :boolean) (init-slots expander nil) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/style-context.lisp 2011/08/26 17:16:14 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/style-context.lisp 2011/08/26 17:16:14 1.1 (in-package :gtk-cffi) (defclass style-context (g-object) (provider (styles :initform nil))) (defcfun gtk-style-context-new :pointer) (defmethod gconstructor ((style-context style-context) &key &allow-other-keys) (gtk-style-context-new)) (defgtkgetter direction text-direction style-context) (defgtkgetter junction-sides junction-sides style-context) (defgtkgetter screen pobject style-context) (defgtkgetter state state-flags style-context) (defcfun gtk-style-context-get-color :void (style-context pobject) (state state-flags) (color :pointer)) (defcfun gtk-style-context-get-background-color :void (style-context pobject) (state state-flags) (color :pointer)) (defcfun gtk-style-context-get-border-color :void (style-context pobject) (state state-flags) (color :pointer)) (defmethod color ((style-context style-context) &key type (state :normal)) (with-foreign-object (color 'prgba) (funcall (case type (:bg #'gtk-style-context-get-background-color) (:border #'gtk-style-context-get-border-color) (t #'gtk-style-context-get-color)) style-context state color) (convert-from-foreign color 'prgba))) (defcfun gtk-style-context-get-font pango-cffi:font (style-context pobject) (state state-flags)) (defmethod font ((style-context style-context) &key (state :normal)) (gtk-style-context-get-font style-context state)) (defgtkfun add-provider :void style-context (style-provider pobject) (priority :uint)) (defmethod load-css ((style-context style-context) text) (if (slot-boundp style-context 'provider) (css-provider-load (slot-value style-context 'provider) :data text) (progn (let ((provider (make-instance 'css-provider))) (setf (slot-value style-context 'provider) provider) (css-provider-load provider :data text) (add-provider style-context provider 600))))) (defun make-css (style-context type state value) (let ((found (assoc (list type state) (slot-value style-context 'styles) :test #'equal))) (if found (setf (cdr found) value) (push (cons (list type state) value) (slot-value style-context 'styles)))) (with-output-to-string (s) (mapc (lambda (x) (destructuring-bind ((type state) . value) x (format s "~a {~a: ~a}" (if (eq state :normal) "*" state) (case type (:bg "background-color") (:border "border-color") (:font "font") ;(:bg-image "border-image") (:bg-image "background-image") (t "color")) value))) (slot-value style-context 'styles)))) (defmethod (setf color) (value (style-context style-context) &key type (state :normal)) (check-type type (member :bg :border nil)) (load-css style-context (make-css style-context type state value))) (defmethod (setf font) (value (style-context style-context) &key (state :normal)) (load-css style-context (make-css style-context :font state value))) (defmethod (setf bg-pixmap) (value (style-context style-context) &key (state :normal)) (load-css style-context (make-css style-context :bg-image state (format nil "url('~a')" value)))) (defmethod bg-pixmap ((style-context style-context) &key (state :normal)) (cdr (assoc (list :bg-image state) (slot-value style-context 'styles) :test #'equal)))--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/style-provider.lisp 2011/08/26 17:16:14 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/style-provider.lisp 2011/08/26 17:16:14 1.1 (in-package :gtk-cffi) (defclass style-provider (object) ())--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget-path.lisp 2011/08/26 17:16:14 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget-path.lisp 2011/08/26 17:16:14 1.1 (in-package :gtk-cffi) (defclass widget-path (object) ()) (defgtkfun free :void widget-path) (defcfun gtk-widget-path-new :pointer) (defmethod gconstructor ((widget-path widget-path) &key &allow-other-keys) (gtk-widget-path-new)) From rklochkov at common-lisp.net Sun Aug 28 10:30:13 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 28 Aug 2011 03:30:13 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/gtk Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/gtk In directory tiger.common-lisp.net:/tmp/cvs-serv21254 Modified Files: accel-group.lisp cell-layout.lisp enums.lisp gtk-cffi.asd menu-bar.lisp package.lisp widget.lisp Added Files: menu-item.lisp Log Message: GtkWidget is finished --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/accel-group.lisp 2011/08/26 17:16:14 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/accel-group.lisp 2011/08/28 10:30:13 1.3 @@ -27,9 +27,16 @@ (defmethod connect ((accel-group accel-group) func &key path key accel-mods accel-flags) - "FUNC should have args: (accel_group acceleratable, keyval, modifier)" - (let ((closure (g-object-cffi::make-closure func))) + "FUNC should have args: (accel-group acceleratable keyval modifier) +CONNECT returns foreign pointer to create GLib closure" + (let ((closure (make-closure func))) (if path (gtk-accel-group-connect-by-path accel-group path closure) (gtk-accel-group-connect accel-group - key accel-mods accel-flags closure)))) + key accel-mods accel-flags closure)) + closure)) + +(defgtkfun disconnect :boolean accel-group (closure object)) + +(defcfun ("gtk_accel_group_from_accel_closure" accel-group-from-accel-closure) + pobject (closure :pointer)) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-layout.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-layout.lisp 2011/08/28 10:30:13 1.2 @@ -55,14 +55,10 @@ (gtk-cell-layout-set-cell-data-func cell-layout cell-renderer c-handler - (cond - ((pointerp data) data) - ((null data) (null-pointer)) - ((typep data 'gobject) (pointer data)) - (t (pointer (make-instance 'storage :data data)))) + data ;; destroy-notify (or destroy-notify - (if (or (null data) (pointerp data) (typep data 'gobject)) + (if (or (null data) (pointerp data) (typep data 'g-object)) (null-pointer) (callback free-storage)))))) (defcfun "gtk_cell_layout_clear_attributes" :void --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/enums.lisp 2011/08/26 17:16:14 1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/enums.lisp 2011/08/28 10:30:13 1.2 @@ -10,3 +10,9 @@ (defbitfield state-flags (:normal 0) :active :prelight :selected :insensitive :inconsistent :focused) + +(defcenum direction-type + :tab-forward :tab-backward :up :down :left :right) + +(defcenum orientation + :horizontal :vertical) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2011/08/26 17:16:14 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2011/08/28 10:30:13 1.4 @@ -31,7 +31,7 @@ (defsystem gtk-cffi-widget :description "Interface to GTK/Glib via CFFI" :author "Roman Klochkov " - :version "0.1" + :version "0.99" :license "GPL" :depends-on (gtk-cffi-core) :components @@ -72,7 +72,8 @@ :depends-on (gtk-cffi-container) :components ((:file bin) - (:file expander :depends-on (bin)))) + (:file expander :depends-on (bin)) + (:file menu-item :depends-on (bin)))) (defsystem gtk-cffi-window :description "Interface to GTK/Glib via CFFI" --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/menu-bar.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/menu-bar.lisp 2011/08/28 10:30:13 1.2 @@ -5,6 +5,14 @@ (defcfun "gtk_menu_bar_new" :pointer) -(defmethod gconstructor ((menu-bar menu-bar) &rest rest) - (declare (ignore rest menu-bar)) - (gtk-menu-bar-new)) \ No newline at end of file +(defmethod gconstructor ((menu-bar menu-bar) &key &allow-other-keys) + (gtk-menu-bar-new)) + +(defcenum pack-direction + :ltr :rtl :ttb :btt) + +(defgtkslots menu-bar + pack-direction pack-direction + child-pack-direction pack-direction) + +(init-slots menu-bar nil) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2011/08/26 17:16:14 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2011/08/28 10:30:13 1.4 @@ -25,28 +25,31 @@ #:gsignal #:yield - ;; size-request structure - #:make-size-request - #:size-request-width - #:size-request-height - - ;; allocation structure - #:make-allocation - #:allocation-x - #:allocation-y - #:allocation-width - #:allocation-height - - #:gtk-object - ;; methods - #:destroy #:widget ;; widget slots #:name + #:direction + #:default-direction + #:parent-window + #:has-tooltip + #:can-focus + #:double-buffered + #:events + #:visual + #:composite-name + #:halign + #:valign + #:margin-left + #:margin-right + #:margin-top + #:margin-bottom + #:hexpand + #:hexpand-set + #:vexpand + #:vexpand-set + #:app-paintable #:size-request - #:style-field - #:style #:direction #:default-direction #:color @@ -69,13 +72,101 @@ #:no-show-all #:colormap #:sensitive + #:accel-path + #:style-context + #:device-events + #:device-enabled + #:toplevel + #:ancestor + #:is-ancestor + #:path + #:is-composited + #:pango-context + #:redraw-on-allocate ; setter only + #:accessible + #:settings + #:clipboard + #:display + #:root-window + #:screen + #:has-screen + #:allocated-width + #:allocated-height + #:is-sensitive + #:is-focus + #:state-flags + #:has-default + #:has-focus + #:has-grab + #:is-drawable + #:is-toplevel + #:device-is-shadowed + #:preferred-height + #:preferred-width + #:preferred-size ;; methods #:activate #:show #:hide - #:rc-parse-string + #:draw + #:queue-draw + #:queue-resize + #:size-allocate + #:add-accelerator + #:remove-accelerator + #:list-accel-closures + #:can-activate-accel + #:widget-event + #:send-expose + #:send-focus-change + #:intersect + #:grab-focus + #:grab-default + #:override-color + #:override-background-color + #:override-symbolic-color + #:override-font + #:override-cursor + #:render-icon-pixbuf + #:add-events + #:get-pointer + #:translate-coordinates + #:shape-combine-region + #:input-shape-combine-region + #:create-pango-context + #:create-pango-layout + #:mnemonic-activate + #:widget-map + #:unmap #:realize - #:gdk-window + #:unrealize + #:child-focus + #:child-notify + #:freeze-child-notify + #:thaw-child-notify + #:destroy + #:list-mnemonic-labels + #:add-mnemonic-label + #:remove-mnemonic-label + #:error-bell + #:keynav-failed + #:trigger-tooltip-query + #:reset-style + #:queue-compute-expand + #:compute-expand + + #:pop-composite-child + #:push-composite-child + #:cairo-should-draw-window + #:cairo-transform-to-window + #:distribute-natural-allocation + + #:widget-class + #:install-style-property + #:install-style-property-parser + #:list-style-properties + #:find-style-property + #:style-property #:bin ;; methods @@ -279,6 +370,14 @@ #:menu #:menu-bar + #:pack-direction + #:child-pack-direction + + #:menu-item + #:right-justified + #:use-underline + #:submenu + #:tool-shell --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2011/08/26 17:16:14 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2011/08/28 10:30:13 1.3 @@ -1,36 +1,46 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; widget.asd --- Wrapper for GtkWidget +;;; +;;; Copyright (C) 2007, Roman Klochkov +;;; + (in-package :gtk-cffi) (defclass widget (g-object) - ()) + ((%style-properties :accessor %style-properties + :initform nil :allocation :class))) -(defclass requisition (object) +(defclass requisition (struct) ()) (defcfun gtk-requisition-new :pointer) -(defmethod gconstructor ((requisition requisition) &key &allow-other-keys) +(defmethod new-struct ((class (eql 'requisition))) (gtk-requisition-new)) -(defcfun gtk-requisition-copy :pointer (requisition pobject)) - -(defmethod copy ((requisition requisition)) - (make-instance 'requisition :pointer (gtk-requisition-copy requisition))) - (defcfun gtk-requisition-free :void (requisition pobject)) -(defmethod free ((requisition requisition)) - (gtk-requisition-free requisition)) +(defmethod free-struct ((class (eql 'requisition)) value) + (gtk-requisition-free value)) (defcstruct* requisition "GtkRequisition" (width :int) (height :int)) -(defcstruct allocation +(init-slots requisition nil) + +(defclass allocation (struct) + ()) + +(defcstruct* allocation "GtkAllocation" (x :int) (y :int) (width :int) (height :int)) +(init-slots allocation nil) + (defgtkfun activate :boolean widget) (defcfun gtk-widget-show :boolean (widget pobject)) @@ -45,8 +55,6 @@ (defgtkfun hide :boolean widget) -(defgtkfun realize :void widget) - (defcfun gtk-widget-draw :void (widget pobject) (context :pointer)) (defmethod draw ((widget widget) &optional (context cl-cairo2:*context*)) (cl-cairo2::with-context-pointer (context cntx-pointer) @@ -76,9 +84,8 @@ (defmethod size-request ((widget widget)) "returns (width height)" - (with-foreign-objects ((width :int) (height :int)) - (gtk-widget-get-size-request widget width height) - (list (mem-ref width :int) (mem-ref height :int)))) + (with-foreign-outs-list ((width :int) (height :int)) + (gtk-widget-get-size-request widget width height))) (defcfun "gtk_widget_set_size_request" :void (widget pobject) (w :int) (h :int)) @@ -88,8 +95,40 @@ (gtk-widget-set-size-request widget (first coords) (second coords))) +(save-setter widget size-request) +(defgtkfun size-allocate :void widget (allocation (struct allocation))) +(defgtkfun add-accelerator :void widget + (accel-signal :string) (accel-group pobject) (accel-key key) + (accel-mods modifier-type) (accel-flags accel-flags)) + +(defgtkfun remove-accelerator :boolean widget + (accel-group pobject) (accel-key key) (accel-mods modifier-type)) + +(defcfun gtk-widget-set-accel-path :void + (widget pobject) (accel-path :string) (accel-group pobject)) + +(defmethod (setf accel-path) (value (widget widget) (accel-group accel-group)) + (gtk-widget-set-accel-path widget value accel-group)) + +(defgtkfun list-accel-closures g-list widget) +(defgtkfun can-activate-accel :boolean widget (signal-id :uint)) +(defgtkfun (widget-event . event) :boolean widget (event event)) +(defgtkfun send-expose :int widget (event event)) +(defgtkfun send-focus-change :boolean widget (event event)) + +(defcfun gtk-widget-intersect :boolean + (src1 pobject) (src2 (struct rectangle)) (dest (struct rectangle :out t))) + +(defmethod intersect ((rect1 widget) (rect2 rectangle)) + (let ((dest (make-instance 'rectangle))) + (when (gtk-widget-intersect rect1 rect2 dest) + dest))) + +(defgtkfun is-focus :boolean widget) +(defgtkfun grab-focus :void widget) +(defgtkfun grab-default :void widget) (defgtkfun override-color :void widget (state state-flags) (color prgba)) @@ -98,7 +137,6 @@ (defgtkfun override-symbolic-color :void widget (name :string) (color prgba)) - (defcfun gtk-widget-get-style-context pobject (widget pobject)) (defmethod style-context ((widget widget)) @@ -118,6 +156,7 @@ tooltip-markup gtk-string tooltip-text gtk-string tooltip-window pobject + has-tooltip :boolean can-default :boolean can-focus :boolean double-buffered :boolean @@ -140,8 +179,10 @@ hexpand :boolean hexpand-set :boolean vexpand :boolean - allocation allocation vexpand-set :boolean + allocation (struct allocation) + window pobject + support-multidevice :boolean app-paintable :boolean) (defbitfield widget-flags @@ -203,9 +244,8 @@ (widget pobject) (x :pointer) (y :pointer)) (defmethod get-pointer ((widget widget)) - (with-foreign-objects ((x :int) (y :int)) - (gtk-widget-get-pointer widget x y) - (list (mem-ref x :int) (mem-ref y :int)))) + (with-foreign-outs ((x :int) (y :int)) + (gtk-widget-get-pointer widget x y))) (defgtkfun is-ancestor :boolean widget (ancestor pobject)) @@ -215,11 +255,11 @@ (defmethod translate-coordinates ((src-widget widget) (dst-widget widget) src-x src-y) - (with-foreign-objects ((dst-x :int) (dst-y :int)) + (with-foreign-outs ((dst-x :int) (dst-y :int)) (gtk-widget-translate-coordinates src-widget dst-widget - src-x src-y dst-x dst-y) - (list (mem-ref dst-x :int) (mem-ref dst-y :int)))) + src-x src-y dst-x dst-y))) +;; region should be cairo_region_t, but it is not realized in cl-cairo2 yet (defgtkfun shape-combine-region :void widget (region pobject)) (defgtkfun input-shape-combine-region :void widget (region pobject)) @@ -231,11 +271,156 @@ (defgtkfun create-pango-context pobject widget) (defgtkgetter pango-context pobject widget) (defgtkfun create-pango-layout pobject widget) + (defgtksetter redraw-on-allocate :boolean widget) (defgtkfun mnemonic-activate :boolean widget (group-cycling :boolean)) -(defgtkgetter window pobject widget) +(defgtkfun unparent :void widget) +(defgtkfun (widget-map . map) :void widget) +(defgtkfun unmap :void widget) +(defgtkfun realize :void widget) +(defgtkfun unrealize :void widget) + +(defgtkgetter accessible pobject widget) +(defgtkfun child-focus :boolean widget (direction direction-type)) +(defgtkfun child-notify :void widget (child-property :string)) +(defgtkfun freeze-child-notify :void widget) + +;(defgtkgetter window pobject widget) (defgtkgetter settings pobject widget) +(defgtkgetter clipboard pobject widget (selection gatom)) +(setf (documentation 'clipboard 'function) + "SELECTION should be :PRIMARY or :CLIPOARD") + +(defgtkgetter display pobject widget) +(defgtkgetter root-window pobject widget) +(defgtkgetter screen pobject widget) +(defgtkfun has-screen :boolean widget) +(defgtkfun thaw-child-notify :void widget) +(defgtkfun list-mnemonic-labels g-list-object widget) +(defgtkfun add-mnemonic-label :void widget (label pobject)) +(defgtkfun remove-mnemonic-label :void widget (label pobject)) +(defgtkfun error-bell :void widget) +(defgtkfun keynav-failed :boolean widget (direction direction-type)) +(defgtkfun trigger-tooltip-query :void widget) + +(defcfun gtk-cairo-should-draw-window :boolean + (context :pointer) (gdk-window pobject)) + +(defmethod cairo-should-draw-window (window + &optional (context cl-cairo2:*context*)) + (cl-cairo2::with-context-pointer (context cntx-pointer) + (gtk-cairo-should-draw-window cntx-pointer window))) + +(defmethod cairo-should-draw-window ((widget widget) + &optional (context cl-cairo2:*context*)) + (cairo-should-draw-window (window widget) context)) + +(defcfun gtk-cairo-transform-to-window :void + (context :pointer) (widget pobject) (gdk-window pobject)) + +(defmethod cairo-transform-to-window ((widget widget) window + &optional (context cl-cairo2:*context*)) + (cl-cairo2::with-context-pointer (context cntx-pointer) + (gtk-cairo-transform-to-window cntx-pointer widget window))) + +(defmethod cairo-transform-to-window ((widget widget) (window widget) + &optional (context cl-cairo2:*context*)) + (cairo-transform-to-window widget (window window) context)) + + +(defgtkgetter allocated-width :int widget) +(defgtkgetter allocated-height :int widget) +(defgtkfun is-sensitive :boolean widget) +(defgtkgetter state-flags state-flags widget) + +(defcfun gtk-widget-set-state-flags :void + (widget pobject) (flags state-flags) (clear :boolean)) +(defcfun gtk-widget-unset-state-flags :void + (widget pobject) (flags state-flags)) + +(defmethod (setf state-flags) (value (widget widget) &key type) + "If TYPE = :CLEAR, clear state before set, :UNSET -- unset bits" + (case type + (:clear (gtk-widget-set-state-flags widget value t)) + (:unset (gtk-widget-unset-state-flags widget value)) + (t (gtk-widget-set-state-flags widget value nil)))) + +(defgtkfun has-default :boolean widget) +(defgtkfun has-focus :boolean widget) +(defgtkfun has-grab :boolean widget) +(defgtkfun is-drawable :boolean widget) +(defgtkfun is-toplevel :boolean widget) +(defgtkfun device-is-shadowed :boolean widget (device pobject)) +(defgtkfun reset-style :void widget) + +(defcfun gtk-widget-get-preferred-height :void + (widget pobject) (minimum :pointer) (natural :pointer)) +(defcfun gtk-widget-get-preferred-height-for-width :void + (widget pobject) (width :int) (minimum :pointer) (natural :pointer)) + +(defmethod preferred-height ((widget widget) &key for-width) + "Returns (values minimum natural)" + (with-foreign-outs ((minimum :int) (natural :int)) + (if for-width + (gtk-widget-get-preferred-height-for-width widget + for-width minimum natural) + (gtk-widget-get-preferred-height widget minimum natural)))) + +(defcfun gtk-widget-get-preferred-width :void + (widget pobject) (minimum :pointer) (natural :pointer)) +(defcfun gtk-widget-get-preferred-width-for-height :void + (widget pobject) (height :int) (minimum :pointer) (natural :pointer)) + +(defmethod preferred-width ((widget widget) &key for-height) + "Returns (values minimum natural)" + (with-foreign-outs ((minimum :int) (natural :int)) + (if for-height + (gtk-widget-get-preferred-width-for-height widget + for-height minimum natural) + (gtk-widget-get-preferred-width widget minimum natural)))) + +(defcenum size-request-mode + :height-for-width :width-for-height) + +(defgtkgetter request-mode size-request-mode widget) + +(defcfun gtk-widget-get-preferred-size :void + (widget pobject) (minimum :pointer) (natural :pointer)) + +(defmethod preferred-size ((widget widget)) + "Returns (values minimum natural). +Minimum and natural are requisition objects." + (with-foreign-outs ((minimum 'requisition) (natural 'requisition)) + (gtk-widget-get-preferred-size widget minimum natural))) + +(defcstruct requested-size + "GtkRequestedSize" + (data pobject) + (minimum-size :int) + (natural-size :int)) + +(defcfun gtk-distribute-natural-allocation :int + (extra-space :int) (n-requested-sizes :int) (sizes :pointer)) + +(defun distribute-natural-allocation (extra-space sizes) + "EXTRA-SPACE -- integer, extra space to redistribute among children. +SIZES -- {(widget minimum-size natural-size)}*" + (let ((length (length sizes))) + (let ((sizes-struct (foreign-alloc 'requested-size :count length))) + (iter + (for i from 0 below length) + (for x in sizes) + (let ((el (mem-aref sizes-struct 'requested-size i))) + (with-foreign-slots ((data minimum-size natural-size) + el requested-size) + (setf data (first x) + minimum-size (second x) + natural-size (third x))))) + (gtk-distribute-natural-allocation extra-space length sizes-struct)))) + +(defgtkfun queue-compute-expand :void widget) +(defgtkfun compute-expand :boolean widget (orientation orientation)) (init-slots widget nil) @@ -340,6 +525,9 @@ (gtk_reserved :pointer :count 8)) (defgtkfun install-style-property :void widget-class (pspec pobject)) +(defgtkfun install-style-property-parser :void widget-class + (pspec pobject) (parser pfunction)) + (defcfun gtk-widget-class-list-style-properties (garray (object g-param-spec)) (widget-class pobject) (n-properties :pointer)) @@ -349,3 +537,11 @@ (gtk-widget-class-list-style-properties widget-class *array-length*))) +(defgtkfun find-style-property (object g-param-spec) + widget-class (name :string)) + +(g-object-cffi::generate-property-accessors + style-property widget + nil gtk-widget-style-get-property + style-property-type + widget-class find-style-property %style-properties) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/menu-item.lisp 2011/08/28 10:30:13 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/menu-item.lisp 2011/08/28 10:30:13 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; menu-item.lisp --- GtkMenuItem ;;; ;;; Copyright (C) 2011, Roman Klochkov ;;; (in-package :gtk-cffi) (defclass menu-item (bin) ()) (defcfun gtk-menu-item-new :pointer) (defcfun gtk-menu-item-new-with-label :pointer (label gtk-string)) (defcfun gtk-menu-item-new-with-mnemonic :pointer (label gtk-string)) (defmethod gconstructor ((menu-item menu-item) &key label mnemonic &allow-other-keys) (if label (if mnemonic (gtk-menu-item-new-with-mnemonic label) (gtk-menu-item-new-with-label label)) (gtk-menu-bar-new))) (defgtkslots menu-item right-justified :boolean label gtk-string use-underline :boolean submenu pobject accel-path gtk-string reserve-indicator :boolean) (defgtkfun select :void menu-item) (defgtkfun deselect :void menu-item) (defgtkfun activate :void menu-item) (defgtkfun toggle-size-request :void menu-item (requisition :pointer)) (defgtkfun toggle-size-allocate :void menu-item (allocation :int)) (init-slots menu-item nil) From rklochkov at common-lisp.net Sun Aug 28 10:31:30 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 28 Aug 2011 03:31:30 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/cffi Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/cffi In directory tiger.common-lisp.net:/tmp/cvs-serv22502/cffi Modified Files: object.lisp package.lisp string.lisp struct.lisp Log Message: Refactored GBoxed structs. Now they can be garbage collected --- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp 2011/08/26 17:16:13 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp 2011/08/28 10:31:30 1.4 @@ -45,7 +45,6 @@ (defmethod shared-initialize :after ((object object) slot-names &rest initargs &key pointer &allow-other-keys) -; (call-next-method) ;; should be here to initialize VOLATILE slot (setf (pointer object) (or pointer (apply #'gconstructor (cons object initargs))))) @@ -101,20 +100,19 @@ (defmethod translate-to-foreign ((value object) (type cffi-object)) (pointer value)) -(defmethod translate-to-foreign ((value object) +;; Hack: redefine translater for :pointer to be able to use +;; objects or nulls instead of pointer +(defmethod translate-to-foreign ((value object) (type cffi::foreign-pointer-type)) (pointer value)) -(defmethod translate-to-foreign ((value null) +(defmethod translate-to-foreign ((value null) (type cffi::foreign-pointer-type)) (null-pointer)) - (defmethod translate-to-foreign (value (type cffi-object)) (check-type value foreign-pointer) value) (defmethod translate-from-foreign (ptr (cffi-object cffi-object)) - (object ptr :class (obj-class cffi-object))) - - + (object ptr :class (obj-class cffi-object))) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/package.lisp 2011/08/26 17:16:13 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/package.lisp 2011/08/28 10:31:30 1.3 @@ -10,7 +10,7 @@ (in-package #:cl-user) (defpackage #:cffi-object - (:use #:iterate #:common-lisp #:cffi #:gtk-cffi-utils) + (:use #:iterate #:common-lisp #:cffi #:gtk-cffi-utils #:alexandria) (:export #:gconstructor @@ -29,5 +29,19 @@ #:pfunction #:cffi-object + #:struct + #:cffi-struct + #:new-struct + #:free-struct + #:defcstruct-accessors - #:defcstruct*)) + #:defcstruct* + + #:with-foreign-out + #:with-foreign-outs + #:with-foreign-outs-list + + #:setf-init + #:init-slots + #:save-setter + #:clear-setters)) --- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/string.lisp 2011/08/26 17:16:13 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/string.lisp 2011/08/28 10:31:30 1.3 @@ -13,9 +13,6 @@ (:actual-type :pointer) (:simple-parser gtk-string)) -(defmethod translate-to-foreign (value (type gtk-string)) - (string->ptr value)) - (defun string->ptr (value) "string -> foreign pointer char*" (typecase value @@ -23,6 +20,9 @@ (foreign-pointer value) (t (foreign-string-alloc (string value) :encoding :utf-8)))) +(defmethod translate-to-foreign (value (type gtk-string)) + (string->ptr value)) + (defmethod translate-from-foreign (ptr (name gtk-string)) (foreign-string-to-lisp ptr :encoding :utf-8)) --- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp 2011/08/26 17:39:35 1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp 2011/08/28 10:31:30 1.2 @@ -1,32 +1,166 @@ ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; -;;; array.lisp --- CFFI wrapper for arrays +;;; struct.lisp --- CFFI wrapper for structs. We need to save on lisp +;;; side only values of struct field, not pointer on +;;; the struct to be able to garbage collect it ;;; ;;; Copyright (C) 2011, Roman Klochkov ;;; (in-package :cffi-object) -(defmacro defcstruct-accessors (class &rest slots) - "CLASS maybe symbol = class-name = struct name, -or maybe cons (class-name . struct-name)" +(defclass struct (object) + ((value :documentation "Assoc list (field-name . field-value)*")) + (:documentation "If value bound, use it, else use pointer. +Struct may be used in OBJECT cffi-type or STRUCT cffi-type")) + +(defmethod gconstructor ((struct struct) &key &allow-other-keys) + nil) + +(defmacro save-setter (class name) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (push ',name (get ',class 'slots)))) + +(defmacro clear-setters (class) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (get ',class 'slots) nil))) + +(defmacro setf-init (object &rest fields) + "Should be used in constructors" + `(progn + ,@(mapcar (lambda (field-all) + (let ((field (if (consp field-all) + (first field-all) field-all)) + (field-p (if (consp field-all) + (third field-all) field-all))) + `(when ,field-p + (setf (,field ,object) ,field)))) + fields))) + +(defmacro init-slots (class add-keys &body body) + "For SETF-INIT auto-constructor" + (let ((slots (mapcar (lambda (x) (list x nil (symbolicate x '-p))) + (get class 'slots)))) + `(defmethod shared-initialize :after ((,class ,class) slot-names + &key , at slots , at add-keys + &allow-other-keys) + (setf-init ,class , at slots) + , at body))) + + +(defmacro defcstruct-accessors (class) + "CLASS may be symbol = class-name = struct name, +or may be cons (class-name . struct-name)" (let ((class-name (if (consp class) (car class) class)) (struct-name (if (consp class) (cdr class) class))) `(progn - ,@(iter - (for x in slots) - (collect + (clear-setters ,class-name) + ,@(mapcar + (lambda (x) `(progn (defmethod ,x ((,class-name ,class-name)) - (foreign-slot-value (pointer ,class-name) ',struct-name ',x)) + (if (slot-boundp ,class-name 'value) + (cdr (assoc ',x (slot-value ,class-name 'value))) + (foreign-slot-value (pointer ,class-name) + ',struct-name ',x))) (defmethod (setf ,x) (val (,class-name ,class-name)) - (setf (foreign-slot-value (pointer ,class-name) - ',struct-name ',x) val)))))))) + (if (slot-boundp ,class-name 'value) + (push val (slot-value ,class-name 'value)) + (setf (foreign-slot-value (pointer ,class-name) + ',struct-name ',x) val))) + (save-setter ,class-name ,x))) + (foreign-slot-names struct-name))))) (defmacro defcstruct* (class &body body) - `(progn + `(progn (defcstruct ,class , at body) - (defcstruct-accessors ,class - ,@(iter - (for x in body) - (when (consp x) (collect (car x))))))) \ No newline at end of file + (defcstruct-accessors ,class))) + +(defgeneric new-struct (class) + (:method (class) + (foreign-alloc class))) + +(defgeneric free-struct (class value) + (:method (class value) + (declare (ignore class)) + (foreign-free value))) + +(defun clos->new-struct (class object) + (let ((res (new-struct class))) + (mapc (lambda (slot) (setf (foreign-slot-value res class slot) + (cdr (assoc slot (slot-value object 'value))))) + (foreign-slot-names class)) + res)) + +(defun struct->clos (class struct &optional object) + (let ((res (or object (make-instance class :pointer nil)))) + (setf (slot-value res 'value) nil) + (mapc (lambda (slot) + (push (foreign-slot-value struct class slot) + (slot-value res 'value))) + (foreign-slot-names class)) + res)) + +(define-foreign-type cffi-struct (cffi-object) + ((free :accessor obj-free :initarg :free + :documentation "Free returned value") + (out :accessor obj-out :initarg :out + :documentation "This is out param (for fill in gtk side)")) + (:actual-type :pointer)) + +(define-parse-method struct (class &key free out) + (make-instance 'cffi-struct :class class :free free :out out)) + +(defmethod translate-to-foreign ((value struct) (type cffi-struct)) + (values (clos->new-struct (obj-class type) value) value)) + +(defmethod free-translated-object (value (type cffi-struct) param) + (let ((class (obj-class type))) + (when (obj-out type) + (struct->clos class value param)) + (free-struct class value))) + +(defmethod translate-from-foreign (value (type cffi-struct)) + (let ((class (obj-class type))) + (prog1 + (struct->clos class value) + (when (obj-free type) (free-struct class value))))) + +(defun from-foreign (var type count) + (if count + (let ((res (make-array count))) + (if (subtypep type 'struct) + (dotimes (i count) + (setf (aref res i) + (struct->clos type (mem-aref var type i)))) + (dotimes (i count) + (setf (aref res i) + (mem-aref var type i)))) + res) + (if (subtypep type 'struct) + (struct->clos type var) + (mem-ref var type)))) + +(defmacro with-foreign-out ((var type &optional count) &body body) + "The same as WITH-FOREIGN-OBJECT, but returns value of object" + `(with-foreign-object (,var ,type ,@(when count count)) + , at body + (from-foreign ,var ,type ,count))) + +(defmacro with-foreign-outs (bindings &body body) + "The same as WITH-FOREIGN-OBJECTS, but returns (values ...) of binded vars" + `(with-foreign-objects ,bindings + , at body + (values ,@(mapcar (lambda (x) + (destructuring-bind (var type &optional count) x + `(from-foreign ,var ,type ,count))) + bindings)))) + +(defmacro with-foreign-outs-list (bindings &body body) + "The same as WITH-FOREIGN-OBJECTS, but returns list of binded vars" + `(with-foreign-objects ,bindings + , at body + (list ,@(mapcar (lambda (x) + (destructuring-bind (var type &optional count) x + `(from-foreign ,var ,type ,count))) + bindings)))) \ No newline at end of file From rklochkov at common-lisp.net Sun Aug 28 10:31:30 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 28 Aug 2011 03:31:30 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/examples Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/examples In directory tiger.common-lisp.net:/tmp/cvs-serv22502/examples Modified Files: editor.lisp Log Message: Refactored GBoxed structs. Now they can be garbage collected --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/editor.lisp 2011/08/26 17:16:13 1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/editor.lisp 2011/08/28 10:31:30 1.2 @@ -8,23 +8,29 @@ (defparameter *window* (gtk-model 'window :signals '(:destroy :gtk-main-quit) - :width 400 :height 400 - ('h-box + :width 400 :height 400 :title "Editor" + ('v-box :expand nil - - - ; ('h-paned - ('scrolled-window - ('tree-view)) + ('menu-bar) :expand t - ('v-box + ('h-box :expand nil - ('label :text "12323") + + + ; ('h-paned + ('scrolled-window + ('tree-view)) :expand t + ('v-box + :expand nil + ('label :text "12323") + :expand t + ('scrolled-window + ('text-view :id :text2))) ('scrolled-window - ('text-view :id :text2))) - ('scrolled-window - ('text-view :id :text3))))) + ('text-view :id :text3))) + :expand nil + ('statusbar)))) ;(setf ;(text (buffer (object-by-id :text1))) "1" ; (text (buffer (object-by-id :text2))) "2" From rklochkov at common-lisp.net Sun Aug 28 10:31:30 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 28 Aug 2011 03:31:30 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/g-lib Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/g-lib In directory tiger.common-lisp.net:/tmp/cvs-serv22502/g-lib Modified Files: array.lisp list.lisp Log Message: Refactored GBoxed structs. Now they can be garbage collected --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/array.lisp 2011/08/26 17:16:13 1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/array.lisp 2011/08/28 10:31:30 1.2 @@ -23,7 +23,17 @@ (make-instance 'cffi-array :type type)) (defmethod translate-to-foreign (value (cffi-array cffi-array)) - value) + (if (pointerp value) + value + (let ((length (length value)) + (type (element-type cffi-array))) + (let ((res (foreign-alloc type :count length))) + (dotimes (i length (values res t)) + (setf (mem-aref res type i) (elt value i))))))) + +(defmethod free-translated-object (value (cffi-array cffi-array) param) + (when param + (foreign-free value))) (defcfun g-free :void (var :pointer)) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/list.lisp 2011/08/26 17:16:13 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/list.lisp 2011/08/28 10:31:30 1.4 @@ -52,7 +52,7 @@ (*list-type* (list-type g-list))) (g-list-foreach ptr (callback list-collect) (null-pointer)) (g-list-free ptr) - *list*)) + (nreverse *list*))) (defmethod translate-to-foreign (lisp-list (g-list g-list)) (declare (type list lisp-list)) From rklochkov at common-lisp.net Sun Aug 28 10:31:30 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 28 Aug 2011 03:31:30 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/g-object Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/g-object In directory tiger.common-lisp.net:/tmp/cvs-serv22502/g-object Modified Files: defslots.lisp g-object.lisp package.lisp Log Message: Refactored GBoxed structs. Now they can be garbage collected --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2011/08/26 17:16:13 1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2011/08/28 10:31:30 1.2 @@ -13,8 +13,7 @@ (let ((getter (symbolicate prefix current-class '-get- name-gtk)) (setter (symbolicate prefix current-class '-set- name-gtk))) `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (push ',name-lisp (get ',current-class 'slots))) + (save-setter ,current-class ,name-lisp) (defcfun ,getter ,slot-type (object pobject)) (defcfun ,setter :void (widget pobject) (value ,slot-type)) (unless (fboundp ',name-lisp) @@ -30,8 +29,7 @@ (defun defslots (def-macro current-class slots) `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (get ',current-class 'slots) nil)) + (clear-setters ,current-class) ,@(iter (for x on slots by #'cddr) (collect (list def-macro current-class (first x) (second x)))))) @@ -46,20 +44,21 @@ (defslots 'defgdkslot current-class slots)) (defun def-fun (prefix name res-type class params &key get) - (let ((fun-name (symbolicate prefix class (if get '-get- '-) name)) - (param-list (mapcar #'car params))) - `(progn - (defcfun ,fun-name ,res-type (,class pobject) , at params) - (unless (fboundp ',name) - (defgeneric ,name (,class , at param-list))) - (defmethod ,name ((,class ,class) , at param-list) - (,fun-name ,class , at param-list))))) + (let ((name-lisp (if (consp name) (car name) name)) + (name-gtk (if (consp name) (cdr name) name))) + (let ((fun-name (symbolicate prefix class (if get '-get- '-) name-gtk)) + (param-list (mapcar #'car params))) + `(progn + (defcfun ,fun-name ,res-type (,class pobject) , at params) + (unless (fboundp ',name-lisp) + (defgeneric ,name-lisp (,class , at param-list))) + (defmethod ,name-lisp ((,class ,class) , at param-list) + (,fun-name ,class , at param-list)))))) (defun defsetter (prefix name slot-type class) (let ((setter (symbolicate prefix class '-set- name))) `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (push ',name (get ',class 'slots))) + (save-setter ,class ,name) (defcfun ,setter :void (widget pobject) (value ,slot-type)) (unless (fboundp '(setf ,name)) (defgeneric (setf ,name) (value ,class))) @@ -91,26 +90,5 @@ , at body) (free ,(or for-free name))))) -(defmacro setf-init (object &rest fields) - "Should be used in constructors" - `(progn - ,@(mapcar (lambda (field-all) - (let ((field (if (consp field-all) - (first field-all) field-all)) - (field-p (if (consp field-all) - (third field-all) field-all))) - `(when ,field-p - (setf (,field ,object) ,field)))) - fields))) - -(defmacro init-slots (class add-keys &body body) - "For DEFSLOTS* auto-constructor" - (let ((slots (mapcar (lambda (x) (list x nil (symbolicate x '-p))) - (get class 'slots)))) - `(defmethod shared-initialize :after ((,class ,class) slot-names - &key , at slots , at add-keys - &allow-other-keys) - (setf-init ,class , at slots) - , at body))) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2011/08/26 17:16:13 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2011/08/28 10:31:30 1.4 @@ -31,59 +31,113 @@ (defmethod (setf pointer) :after (value (g-object g-object)) (declare (type foreign-pointer value)) (unless (null-pointer-p value) - (format t "Creating ~a ~a~%" g-object value) + (debug-out "Creating ~a ~a~%" g-object value) (g-object-weak-ref value (callback destroy-object) (null-pointer)))) -(defcfun "g_object_set_property" :void - (object pobject) (name :string) (value pobject)) +;; (defcfun "g_object_set_property" :void +;; (object pobject) (name :string) (value pobject)) -(defcfun "g_object_get_property" :void - (object pobject) (name :string) (value pobject)) +;; (defcfun "g_object_get_property" :void +;; (object pobject) (name :string) (value pobject)) -(defgeneric (setf property) (values g-object &rest keys)) -(defmethod (setf property) (values (g-object g-object) &rest keys) - "Usage: (setf (property object :property) value) +(defmacro generate-property-accessors (name object set get type + class find prop-slot) + `(progn + (defgeneric ,type (,object key)) + (defmethod ,type ((,object ,object) (key symbol)) + (,type ,object (string-downcase key))) + (defmethod ,type ((,object ,object) (key string)) + "Should return GType of property KEY." + (or (cdr (assoc key (,prop-slot ,object))) + (let* ((gclass (make-instance ',class :object ,object)) + (prop (,find gclass key))) + (when prop + (let ((g-type (g-type prop))) + (setf (,prop-slot ,object) + (acons key g-type (,prop-slot ,object))) + g-type))) + (error "Incorrect property name ~a" key))) + + ,@(when set + `((defcfun ,set :void + (object pobject) (name :string) (value pobject)) + (defgeneric (setf ,name) (values ,object &rest keys)) + (defmethod (setf ,name) (values (,object ,object) &rest keys) + "Usage: + (setf (property object :property) value) (setf (property object :prop1 :prop2) (list value1 value2))" - (mapc (lambda (key value) - (declare (type (or symbol string) key)) - ;(debug-out "key: ~a, value: ~a, type: ~a~%" key value - ; (property-type g-object key)) - (let ((skey (string-downcase key))) - (with-g-value (:value value :g-type (property-type g-object skey)) - (g-object-set-property g-object skey *g-value*)))) - keys (if (listp values) values (list values)))) - -(defgeneric property (g-object &rest keys)) - -(defmethod property ((g-object g-object) &rest keys) - "Usage (property object :prop1) -> value1 + (mapc (lambda (key value) + (declare (type (or symbol string) key)) + (let ((skey (string-downcase key))) + (with-g-value (:value value :g-type (,type ,object skey)) + (,set ,object skey *g-value*)))) + keys (if (listp values) values (list values)))))) + + (defcfun ,get :void + (object pobject) (name :string) (value pobject)) + (defgeneric ,name (,object &rest keys)) + (defmethod ,name ((,object ,object) &rest keys) + "Usage + (property object :prop1) -> value1 (property object :prop1 :prop2 ...) -> (value1 value2 ...)" - (funcall (lambda (x) (if (cdr x) x (car x))) - (mapcar (lambda (key) - (let* ((skey (string-downcase key)) - (g-type (property-type g-object skey))) - (with-g-value - (:g-type g-type) - (g-object-get-property g-object skey *g-value*)))) - keys))) - -(defgeneric property-type (g-object key)) - -(defmethod property-type ((g-object g-object) (key symbol)) - (property-type g-object (string-downcase key))) - -(defmethod property-type ((g-object g-object) (key string)) - "Should return GType of property KEY." - (or (cdr (assoc key (%properties g-object))) - (let* ((gclass (make-instance 'g-object-class :object g-object)) - (prop (find-property gclass key))) - (when prop - (let ((g-type (g-type prop))) - (setf (%properties g-object) - (acons key g-type (%properties g-object))) - g-type))) - (error "Incorrect property name ~a" key))) + (funcall (lambda (x) (if (cdr x) x (car x))) + (mapcar (lambda (key) + (let* ((skey (string-downcase key)) + (g-type (,type ,object skey))) + (with-g-value + (:g-type g-type) + (,get ,object skey *g-value*)))) + keys))))) + +(generate-property-accessors property g-object + g-object-set-property g-object-get-property + property-type + g-object-class find-property %properties) + + +;; (defgeneric (setf property) (values g-object &rest keys)) + +;; (defmethod (setf property) (values (g-object g-object) &rest keys) +;; "Usage: (setf (property object :property) value) +;; (setf (property object :prop1 :prop2) (list value1 value2))" +;; (mapc (lambda (key value) +;; (declare (type (or symbol string) key)) +;; (let ((skey (string-downcase key))) +;; (with-g-value (:value value :g-type (property-type g-object skey)) +;; (g-object-set-property g-object skey *g-value*)))) +;; keys (if (listp values) values (list values)))) + +;; (defgeneric property (g-object &rest keys)) + +;; (defmethod property ((g-object g-object) &rest keys) +;; "Usage (property object :prop1) -> value1 +;; (property object :prop1 :prop2 ...) -> (value1 value2 ...)" +;; (funcall (lambda (x) (if (cdr x) x (car x))) +;; (mapcar (lambda (key) +;; (let* ((skey (string-downcase key)) +;; (g-type (property-type g-object skey))) +;; (with-g-value +;; (:g-type g-type) +;; (g-object-get-property g-object skey *g-value*)))) +;; keys))) + +;; (defgeneric property-type (g-object key)) + +;; (defmethod property-type ((g-object g-object) (key symbol)) +;; (property-type g-object (string-downcase key))) + +;; (defmethod property-type ((g-object g-object) (key string)) +;; "Should return GType of property KEY." +;; (or (cdr (assoc key (%properties g-object))) +;; (let* ((gclass (make-instance 'g-object-class :object g-object)) +;; (prop (find-property gclass key))) +;; (when prop +;; (let ((g-type (g-type prop))) +;; (setf (%properties g-object) +;; (acons key g-type (%properties g-object))) +;; g-type))) +;; (error "Incorrect property name ~a" key))) (defbitfield connect-flags (:none 0) @@ -105,11 +159,9 @@ (defcallback free-closure :void ((data :pointer) (closure :pointer)) (declare (ignore data)) - (when closure + (when (not (null-pointer-p closure)) (remhash (pointer-address closure) *objects*))) - - (defcfun "g_closure_add_finalize_notifier" :void (closure :pointer) (data :pointer) (func pfunction)) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2011/08/26 17:16:13 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2011/08/28 10:31:30 1.4 @@ -61,9 +61,6 @@ #:register-type #:register-package - #:setf-init - #:init-slots - #:ref #:unref @@ -74,6 +71,7 @@ #:g-param-spec #:g-object-newv #:new + #:make-closure #:defgtkslot #:defgtkslots From rklochkov at common-lisp.net Sun Aug 28 10:31:30 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 28 Aug 2011 03:31:30 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/gdk Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/gdk In directory tiger.common-lisp.net:/tmp/cvs-serv22502/gdk Modified Files: gdk-cffi.asd keys.lisp package.lisp rectangle.lisp Log Message: Refactored GBoxed structs. Now they can be garbage collected --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/gdk-cffi.asd 2011/08/26 17:16:14 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/gdk-cffi.asd 2011/08/28 10:31:30 1.3 @@ -29,4 +29,5 @@ (:file gc :depends-on (loadlib generics)) (:file visual :depends-on (loadlib generics)) (:file image :depends-on (visual)) + (:file atom :depends-on (loadlib)) (:file pixbuf :depends-on (image gc)))) --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/keys.lisp 2011/04/25 19:16:07 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/keys.lisp 2011/08/28 10:31:30 1.2 @@ -1,1714 +1,1733 @@ (in-package :gdk-cffi) -(defun key (val) - (foreign-enum-value 'keys val)) +;(defun key (val) +; (foreign-enum-value 'keys val)) -(defcenum keys - (:VoidSymbol #xffffff) - (:BackSpace #xff08) - (:Tab #xff09) - (:Linefeed #xff0a) - (:Clear #xff0b) - (:Return #xff0d) - (:Pause #xff13) - (:Scroll-Lock #xff14) - (:Sys-Req #xff15) - (:Escape #xff1b) - (:Delete #xffff) - (:Multi-key #xff20) - (:Codeinput #xff37) - (:SingleCandidate #xff3c) - (:MultipleCandidate #xff3d) - (:PreviousCandidate #xff3e) - (:Kanji #xff21) - (:Muhenkan #xff22) - (:Henkan-Mode #xff23) - (:Henkan #xff23) - (:Romaji #xff24) - (:Hiragana #xff25) - (:Katakana #xff26) - (:Hiragana-Katakana #xff27) - (:Zenkaku #xff28) - (:Hankaku #xff29) - (:Zenkaku-Hankaku #xff2a) - (:Touroku #xff2b) - (:Massyo #xff2c) - (:Kana-Lock #xff2d) - (:Kana-Shift #xff2e) - (:Eisu-Shift #xff2f) - (:Eisu-toggle #xff30) - (:Kanji-Bangou #xff37) - (:Zen-Koho #xff3d) - (:Mae-Koho #xff3e) - (:Home #xff50) - (:Left #xff51) - (:Up #xff52) - (:Right #xff53) - (:Down #xff54) - (:Prior #xff55) - (:Page-Up #xff55) - (:Next #xff56) - (:Page-Down #xff56) - (:End #xff57) - (:Begin #xff58) - (:Select #xff60) - (:Print #xff61) - (:Execute #xff62) - (:Insert #xff63) - (:Undo #xff65) - (:Redo #xff66) - (:Menu #xff67) - (:Find #xff68) - (:Cancel #xff69) - (:Help #xff6a) - (:Break #xff6b) - (:Mode-switch #xff7e) - (:script-switch #xff7e) - (:Num-Lock #xff7f) - (:KP-Space #xff80) - (:KP-Tab #xff89) - (:KP-Enter #xff8d) - (:KP-F1 #xff91) - (:KP-F2 #xff92) - (:KP-F3 #xff93) - (:KP-F4 #xff94) - (:KP-Home #xff95) - (:KP-Left #xff96) - (:KP-Up #xff97) - (:KP-Right #xff98) - (:KP-Down #xff99) - (:KP-Prior #xff9a) - (:KP-Page-Up #xff9a) - (:KP-Next #xff9b) - (:KP-Page-Down #xff9b) - (:KP-End #xff9c) - (:KP-Begin #xff9d) - (:KP-Insert #xff9e) - (:KP-Delete #xff9f) - (:KP-Equal #xffbd) - (:KP-Multiply #xffaa) - (:KP-Add #xffab) - (:KP-Separator #xffac) - (:KP-Subtract #xffad) - (:KP-Decimal #xffae) - (:KP-Divide #xffaf) - (:KP-0 #xffb0) - (:KP-1 #xffb1) - (:KP-2 #xffb2) - (:KP-3 #xffb3) - (:KP-4 #xffb4) - (:KP-5 #xffb5) - (:KP-6 #xffb6) - (:KP-7 #xffb7) - (:KP-8 #xffb8) - (:KP-9 #xffb9) - (:F1 #xffbe) - (:F2 #xffbf) - (:F3 #xffc0) - (:F4 #xffc1) - (:F5 #xffc2) - (:F6 #xffc3) - (:F7 #xffc4) - (:F8 #xffc5) - (:F9 #xffc6) - (:F10 #xffc7) - (:F11 #xffc8) - (:L1 #xffc8) - (:F12 #xffc9) - (:L2 #xffc9) - (:F13 #xffca) - (:L3 #xffca) - (:F14 #xffcb) - (:L4 #xffcb) - (:F15 #xffcc) - (:L5 #xffcc) - (:F16 #xffcd) - (:L6 #xffcd) - (:F17 #xffce) - (:L7 #xffce) - (:F18 #xffcf) - (:L8 #xffcf) - (:F19 #xffd0) - (:L9 #xffd0) - (:F20 #xffd1) - (:L10 #xffd1) - (:F21 #xffd2) - (:R1 #xffd2) - (:F22 #xffd3) - (:R2 #xffd3) - (:F23 #xffd4) - (:R3 #xffd4) - (:F24 #xffd5) - (:R4 #xffd5) - (:F25 #xffd6) - (:R5 #xffd6) - (:F26 #xffd7) - (:R6 #xffd7) - (:F27 #xffd8) - (:R7 #xffd8) - (:F28 #xffd9) - (:R8 #xffd9) - (:F29 #xffda) - (:R9 #xffda) - (:F30 #xffdb) - (:R10 #xffdb) - (:F31 #xffdc) - (:R11 #xffdc) - (:F32 #xffdd) - (:R12 #xffdd) - (:F33 #xffde) - (:R13 #xffde) - (:F34 #xffdf) - (:R14 #xffdf) - (:F35 #xffe0) - (:R15 #xffe0) - (:Shift-L #xffe1) - (:Shift-R #xffe2) - (:Control-L #xffe3) - (:Control-R #xffe4) - (:Caps-Lock #xffe5) - (:Shift-Lock #xffe6) - (:Meta-L #xffe7) - (:Meta-R #xffe8) - (:Alt-L #xffe9) - (:Alt-R #xffea) - (:Super-L #xffeb) - (:Super-R #xffec) - (:Hyper-L #xffed) - (:Hyper-R #xffee) - (:ISO-Lock #xfe01) - (:ISO-Level2-Latch #xfe02) - (:ISO-Level3-Shift #xfe03) - (:ISO-Level3-Latch #xfe04) - (:ISO-Level3-Lock #xfe05) - (:ISO-Group-Shift #xff7e) - (:ISO-Group-Latch #xfe06) - (:ISO-Group-Lock #xfe07) - (:ISO-Next-Group #xfe08) - (:ISO-Next-Group-Lock #xfe09) - (:ISO-Prev-Group #xfe0a) - (:ISO-Prev-Group-Lock #xfe0b) - (:ISO-First-Group #xfe0c) - (:ISO-First-Group-Lock #xfe0d) - (:ISO-Last-Group #xfe0e) - (:ISO-Last-Group-Lock #xfe0f) - (:ISO-Left-Tab #xfe20) - (:ISO-Move-Line-Up #xfe21) - (:ISO-Move-Line-Down #xfe22) - (:ISO-Partial-Line-Up #xfe23) - (:ISO-Partial-Line-Down #xfe24) - (:ISO-Partial-Space-Left #xfe25) - (:ISO-Partial-Space-Right #xfe26) - (:ISO-Set-Margin-Left #xfe27) - (:ISO-Set-Margin-Right #xfe28) - (:ISO-Release-Margin-Left #xfe29) - (:ISO-Release-Margin-Right #xfe2a) - (:ISO-Release-Both-Margins #xfe2b) - (:ISO-Fast-Cursor-Left #xfe2c) - (:ISO-Fast-Cursor-Right #xfe2d) - (:ISO-Fast-Cursor-Up #xfe2e) - (:ISO-Fast-Cursor-Down #xfe2f) - (:ISO-Continuous-Underline #xfe30) - (:ISO-Discontinuous-Underline #xfe31) - (:ISO-Emphasize #xfe32) - (:ISO-Center-Object #xfe33) - (:ISO-Enter #xfe34) - (:dead-grave #xfe50) - (:dead-acute #xfe51) - (:dead-circumflex #xfe52) - (:dead-tilde #xfe53) - (:dead-macron #xfe54) - (:dead-breve #xfe55) - (:dead-abovedot #xfe56) - (:dead-diaeresis #xfe57) - (:dead-abovering #xfe58) - (:dead-doubleacute #xfe59) - (:dead-caron #xfe5a) - (:dead-cedilla #xfe5b) - (:dead-ogonek #xfe5c) - (:dead-iota #xfe5d) - (:dead-voiced-sound #xfe5e) - (:dead-semivoiced-sound #xfe5f) - (:dead-belowdot #xfe60) - (:dead-hook #xfe61) - (:dead-horn #xfe62) - (:First-Virtual-Screen #xfed0) - (:Prev-Virtual-Screen #xfed1) - (:Next-Virtual-Screen #xfed2) - (:Last-Virtual-Screen #xfed4) - (:Terminate-Server #xfed5) - (:AccessX-Enable #xfe70) - (:AccessX-Feedback-Enable #xfe71) - (:RepeatKeys-Enable #xfe72) - (:SlowKeys-Enable #xfe73) - (:BounceKeys-Enable #xfe74) - (:StickyKeys-Enable #xfe75) - (:MouseKeys-Enable #xfe76) - (:MouseKeys-Accel-Enable #xfe77) - (:Overlay1-Enable #xfe78) - (:Overlay2-Enable #xfe79) - (:AudibleBell-Enable #xfe7a) - (:Pointer-Left #xfee0) - (:Pointer-Right #xfee1) - (:Pointer-Up #xfee2) - (:Pointer-Down #xfee3) - (:Pointer-UpLeft #xfee4) - (:Pointer-UpRight #xfee5) - (:Pointer-DownLeft #xfee6) - (:Pointer-DownRight #xfee7) - (:Pointer-Button-Dflt #xfee8) - (:Pointer-Button1 #xfee9) - (:Pointer-Button2 #xfeea) - (:Pointer-Button3 #xfeeb) - (:Pointer-Button4 #xfeec) - (:Pointer-Button5 #xfeed) - (:Pointer-DblClick-Dflt #xfeee) - (:Pointer-DblClick1 #xfeef) - (:Pointer-DblClick2 #xfef0) - (:Pointer-DblClick3 #xfef1) - (:Pointer-DblClick4 #xfef2) - (:Pointer-DblClick5 #xfef3) - (:Pointer-Drag-Dflt #xfef4) - (:Pointer-Drag1 #xfef5) - (:Pointer-Drag2 #xfef6) - (:Pointer-Drag3 #xfef7) - (:Pointer-Drag4 #xfef8) - (:Pointer-Drag5 #xfefd) - (:Pointer-EnableKeys #xfef9) - (:Pointer-Accelerate #xfefa) - (:Pointer-DfltBtnNext #xfefb) - (:Pointer-DfltBtnPrev #xfefc) - (:3270-Duplicate #xfd01) - (:3270-FieldMark #xfd02) - (:3270-Right2 #xfd03) - (:3270-Left2 #xfd04) - (:3270-BackTab #xfd05) - (:3270-EraseEOF #xfd06) - (:3270-EraseInput #xfd07) - (:3270-Reset #xfd08) - (:3270-Quit #xfd09) - (:3270-PA1 #xfd0a) - (:3270-PA2 #xfd0b) - (:3270-PA3 #xfd0c) - (:3270-Test #xfd0d) - (:3270-Attn #xfd0e) - (:3270-CursorBlink #xfd0f) - (:3270-AltCursor #xfd10) - (:3270-KeyClick #xfd11) - (:3270-Jump #xfd12) - (:3270-Ident #xfd13) - (:3270-Rule #xfd14) - (:3270-Copy #xfd15) - (:3270-Play #xfd16) - (:3270-Setup #xfd17) - (:3270-Record #xfd18) - (:3270-ChangeScreen #xfd19) - (:3270-DeleteWord #xfd1a) - (:3270-ExSelect #xfd1b) - (:3270-CursorSelect #xfd1c) - (:3270-PrintScreen #xfd1d) - (:3270-Enter #xfd1e) - (:space #x020) - (:exclam #x021) - (:quotedbl #x022) - (:numbersign #x023) - (:dollar #x024) - (:percent #x025) - (:ampersand #x026) - (:apostrophe #x027) - (:quoteright #x027) - (:parenleft #x028) - (:parenright #x029) - (:asterisk #x02a) - (:plus #x02b) - (:comma #x02c) - (:minus #x02d) - (:period #x02e) - (:slash #x02f) - (:0 #x030) - (:1 #x031) - (:2 #x032) - (:3 #x033) - (:4 #x034) - (:5 #x035) - (:6 #x036) - (:7 #x037) - (:8 #x038) - (:9 #x039) - (:colon #x03a) - (:semicolon #x03b) - (:less #x03c) - (:equal #x03d) - (:greater #x03e) - (:question #x03f) - (:at #x040) - (:caps-A #x041) - (:caps-B #x042) - (:caps-C #x043) - (:caps-D #x044) - (:caps-E #x045) - (:caps-F #x046) - (:caps-G #x047) - (:caps-H #x048) - (:caps-I #x049) - (:caps-J #x04a) - (:caps-K #x04b) - (:caps-L #x04c) - (:caps-M #x04d) - (:caps-N #x04e) - (:caps-O #x04f) - (:caps-P #x050) - (:caps-Q #x051) - (:caps-R #x052) - (:caps-S #x053) - (:caps-T #x054) - (:caps-U #x055) - (:caps-V #x056) - (:caps-W #x057) - (:caps-X #x058) - (:caps-Y #x059) - (:caps-Z #x05a) - (:bracketleft #x05b) - (:backslash #x05c) - (:bracketright #x05d) - (:asciicircum #x05e) - (:underscore #x05f) - (:grave #x060) - (:quoteleft #x060) - (:a #x061) - (:b #x062) - (:c #x063) - (:d #x064) - (:e #x065) - (:f #x066) - (:g #x067) - (:h #x068) - (:i #x069) - (:j #x06a) - (:k #x06b) - (:l #x06c) - (:m #x06d) - (:n #x06e) - (:o #x06f) - (:p #x070) - (:q #x071) - (:r #x072) [3047 lines skipped] --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/package.lisp 2011/08/26 17:16:14 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/package.lisp 2011/08/28 10:31:30 1.3 @@ -8,7 +8,7 @@ (in-package #:cl-user) (defpackage #:gdk-cffi - (:use #:common-lisp + (:use #:common-lisp #:alexandria #:cffi #:cffi-object #:g-lib-cffi #:g-object-cffi) (:import-from #:cl-cairo2 #:x #:y #:width #:height #:cairo_rectangle_t) (:export @@ -48,6 +48,8 @@ #:with-threads #:key + + #:gatom )) (in-package #:gdk-cffi) --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/rectangle.lisp 2011/08/26 17:16:14 1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/rectangle.lisp 2011/08/28 10:31:30 1.2 @@ -3,32 +3,27 @@ (defclass rectangle (object) ()) -(defmacro with-rectangle (rect &body body) - `(with-object (,rect) (make-instance 'rectangle) , at body)) - -(defmethod gconstructor ((rectangle rectangle) &key &allow-other-keys) +(defmethod new-struct ((class (eql 'rectangle))) (foreign-alloc 'cairo_rectangle_t)) -(defmethod free :before ((rectangle rectangle)) - (foreign-free (pointer rectangle))) - -(defcstruct-accessors (rectangle . cairo_rectangle_t) - x y height width) +(defcstruct-accessors (rectangle . cairo_rectangle_t)) (defcfun gdk-rectangle-intersect :boolean - (src1 pobject) (src2 pobject) (dest pobject)) + (src1 (struct rectangle)) (src2 (struct rectangle)) + (dest (struct rectangle :out t))) (defmethod intersect ((rect1 rectangle) (rect2 rectangle)) - (let ((dest (make-instance 'rectangle))) - (if (gdk-rectangle-intersect rect1 rect2 dest) - dest - (progn (free dest) nil)))) + "Returns new GdkRectangle: intersection of rect1 and rect2" + (let ((dest (make-instance 'rectangle))) + (when (gdk-rectangle-intersect rect1 rect2 dest) + dest))) (defcfun gdk-rectangle-union :void - (src1 pobject) (src2 pobject) (dest pobject)) + (src1 (struct rectangle)) (src2 (struct rectangle)) + (dest (struct rectangle :out t))) (defmethod rectangle-union ((rect1 rectangle) (rect2 rectangle)) - (let ((dest (make-instance 'rectangle))) - (gdk-rectangle-union rect1 rect2 dest))) + (let ((dest (make-instance 'rectangle))) + (gdk-rectangle-union rect1 rect2 dest))) (defcfun gdk-rectangle-get-type g-type) From rklochkov at common-lisp.net Sun Aug 28 10:32:37 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 28 Aug 2011 03:32:37 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/gdk Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/gdk In directory tiger.common-lisp.net:/tmp/cvs-serv22827 Added Files: atom.lisp Log Message: GdkAtom support --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/atom.lisp 2011/08/28 10:32:37 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/atom.lisp 2011/08/28 10:32:37 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; atom.lisp --- GdkAtom ;;; ;;; Copyright (C) 2007, Roman Klochkov ;;; (in-package :gdk-cffi) (defcfun gdk-atom-name :string (atom :pointer)) (defcfun gdk-atom-intern-static-string :pointer (val gtk-dyn-string)) (defcfun gdk-atom-intern :pointer (val :string) (only-if-exists :boolean)) (define-foreign-type gatom () () (:actual-type :pointer) (:simple-parser gatom)) (defmethod translate-to-foreign (value (gatom gatom)) (typecase value (foreign-pointer value) (integer (make-pointer value)) (t (gdk-atom-intern value nil)))) (defmethod translate-from-foreign (value (gatom gatom)) (make-keyword (gdk-atom-name value))) From rklochkov at common-lisp.net Sun Aug 28 15:38:31 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 28 Aug 2011 08:38:31 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/examples Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/examples In directory tiger.common-lisp.net:/tmp/cvs-serv2159/examples Modified Files: editor.lisp Log Message: Fixed name clash in widget and menu-item --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/editor.lisp 2011/08/28 10:31:30 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/editor.lisp 2011/08/28 15:38:31 1.3 @@ -15,9 +15,7 @@ :expand t ('h-box :expand nil - - - ; ('h-paned + ;('h-paned ('scrolled-window ('tree-view)) :expand t From rklochkov at common-lisp.net Sun Aug 28 15:38:31 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 28 Aug 2011 08:38:31 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/gtk Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/gtk In directory tiger.common-lisp.net:/tmp/cvs-serv2159/gtk Modified Files: package.lisp widget.lisp Log Message: Fixed name clash in widget and menu-item --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2011/08/28 10:30:13 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2011/08/28 15:38:31 1.5 @@ -72,7 +72,7 @@ #:no-show-all #:colormap #:sensitive - #:accel-path + #:widget-accel-path #:style-context #:device-events #:device-enabled @@ -377,7 +377,7 @@ #:right-justified #:use-underline #:submenu - + #:accel-path #:tool-shell --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2011/08/28 10:30:13 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2011/08/28 15:38:31 1.4 @@ -109,7 +109,8 @@ (defcfun gtk-widget-set-accel-path :void (widget pobject) (accel-path :string) (accel-group pobject)) -(defmethod (setf accel-path) (value (widget widget) (accel-group accel-group)) +(defmethod (setf widget-accel-path) (value (widget widget) + (accel-group accel-group)) (gtk-widget-set-accel-path widget value accel-group)) (defgtkfun list-accel-closures g-list widget) From rklochkov at common-lisp.net Sun Aug 28 15:38:31 2011 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 28 Aug 2011 08:38:31 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/utils Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/utils In directory tiger.common-lisp.net:/tmp/cvs-serv2159/utils Modified Files: utils.lisp Log Message: Fixed name clash in widget and menu-item --- /project/gtk-cffi/cvsroot/gtk-cffi/utils/utils.lisp 2011/08/26 17:16:14 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/utils/utils.lisp 2011/08/28 15:38:31 1.3 @@ -5,7 +5,7 @@ `(format t , at body) ) -(defmacro memo (place &nody body) +(defmacro memo (place &body body) `(or ,place (setf ,place , at body)))