From rklochkov at common-lisp.net Sat Jan 21 18:33:53 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sat, 21 Jan 2012 10:33:53 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi/gio Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/gio In directory tiger.common-lisp.net:/tmp/cvs-serv13413/gio Log Message: Directory /project/gtk-cffi/cvsroot/gtk-cffi/gio added to the repository From rklochkov at common-lisp.net Sat Jan 21 18:35:00 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sat, 21 Jan 2012 10:35:00 -0800 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-serv13474/cffi Modified Files: object.lisp Log Message: Refactored defslots/def*funs --- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp 2011/12/31 17:20:56 1.6 +++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp 2012/01/21 18:35:00 1.7 @@ -19,6 +19,7 @@ ;; by default object shouldn't be stored unless it is GtkObject (volatile :type boolean :accessor volatile :initarg :volatile :initform t) + (free-after :type boolean :initarg :free-after :initform t) (id :type symbol :accessor id :initarg :id :initform nil)) (:documentation "Lisp wrapper for any object. VOLATILE slot set when object shouldn't be stored in *OBJECTS*. Stored pointer GC'ed, if VOLATILE.")) @@ -26,8 +27,9 @@ (defmethod (setf pointer) :after (value (object object)) (declare (type foreign-pointer value)) (tg:cancel-finalization object) - (when (and (volatile object) (not (null-pointer-p value))) - (tg:finalize object (lambda () (foreign-free value)))) + (when (and (slot-value object 'free-after) (not (null-pointer-p value))) + (tg:finalize object (lambda () + (foreign-free value)))) (unless (or (volatile object) (null-pointer-p value)) (setf (gethash (pointer-address value) *objects*) object) (when (id object) @@ -47,7 +49,7 @@ (defmethod shared-initialize :after ((object object) slot-names &rest initargs &key pointer &allow-other-keys) - (unless pointer + (unless pointer (setf (pointer object) (apply #'gconstructor object initargs)))) (defmethod pointer (something-bad) From rklochkov at common-lisp.net Sat Jan 21 18:35:00 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sat, 21 Jan 2012 10:35:00 -0800 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-serv13474/examples Modified Files: ex9.lisp Added Files: ex10.lisp Log Message: Refactored defslots/def*funs --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex9.lisp 2011/09/10 16:26:10 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex9.lisp 2012/01/21 18:35:00 1.3 @@ -1,7 +1,7 @@ -(asdf:oos 'asdf:load-op :gtk-cffi) +(asdf:oos 'asdf:load-op :gtk-cffi-ext) ;(declaim (optimize speed)) (defpackage #:test - (:use #:common-lisp #:iter #:gtk-cffi #:g-object-cffi)) + (:use #:common-lisp #:iter #:gtk-cffi #:gtk-cffi-ext #:g-object-cffi)) (in-package #:test) (gtk-init) @@ -24,7 +24,7 @@ (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)) + (setf (larray (implementation *model*)) arr)) (defparameter *window* (gtk-model @@ -34,7 +34,7 @@ ('scrolled-window ('tree-view :model *model* :columns '("Test str" "Test int"))))); "Test int")))) -(show *window*) +;(show *window*) (show #(1 2 3 4 5)) (gtk-main) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex10.lisp 2012/01/21 18:35:00 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex10.lisp 2012/01/21 18:35:00 1.1 (asdf:oos 'asdf:load-op :gtk-cffi-ext) ;(declaim (optimize speed)) (defpackage #:test-10 (:use #:common-lisp #:iter #:gtk-cffi #:gtk-cffi-ext #:g-object-cffi)) (in-package #:test-10) (gtk-init) (defparameter *model* (make-instance 'lisp-model :implementation (make-instance 'lisp-model-tree-array :tree '((("ok" 1) (("Ok2" 2))) (("ok3" 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 (larray (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"))))) ;(show *window*) ;(show #(1 2 3 4 5)) (show (make-instance 'lisp-model-tree-array :tree '((("ok" 1) (("Ok2" 2))) (("ok3" 3))) :columns '(:string :int)) :columns '("str" "int")) (show '((1 2 3) 4)) (gtk-main) From rklochkov at common-lisp.net Sat Jan 21 18:35:00 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sat, 21 Jan 2012 10:35:00 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi/ext Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/ext In directory tiger.common-lisp.net:/tmp/cvs-serv13474/ext Modified Files: addons.lisp Log Message: Refactored defslots/def*funs --- /project/gtk-cffi/cvsroot/gtk-cffi/ext/addons.lisp 2011/12/31 17:20:56 1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/ext/addons.lisp 2012/01/21 18:35:00 1.2 @@ -1,21 +1,31 @@ -(in-package :gtk-cffi) +(in-package :gtk-cffi-ext) -(defmethod show ((seq sequence) &key &allow-other-keys) +(defmethod show ((model-impl lisp-model-impl) &key (columns '("List")) + &allow-other-keys) (show (gtk-model 'window ('scrolled-window - ('tree-view :model - (make-instance - 'lisp-model - :implementation - (make-instance 'lisp-model-array - :array (map 'vector - (compose #'list - #'princ-to-string) - seq) - :columns '(:string))) - :columns '("Array")))))) + ('tree-view :model (make-instance 'lisp-model + :implementation model-impl) + :columns columns))))) + +(defmethod show ((seq sequence) &key &allow-other-keys) + (show + (if (some #'consp seq) + (make-instance 'lisp-model-tree-array + :tree (labels ((process (x) + (if (consp x) + (cons (list (car x)) + (mapcar #'process (cdr x))) + (list (list x))))) + (mapcar #'process (coerce seq 'list))) + :columns '(:string)) + (make-instance 'lisp-model-array + :array (map 'vector + (compose #'list #'princ-to-string) + seq) + :columns '(:string))))) ;; (defun status-tree () ;; (let ((tree-model (make-instance 'tree-strore))) From rklochkov at common-lisp.net Sat Jan 21 18:35:00 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sat, 21 Jan 2012 10:35:00 -0800 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-serv13474/g-object Modified Files: defslots.lisp g-object.lisp Log Message: Refactored defslots/def*funs --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2011/10/23 08:39:53 1.6 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2012/01/21 18:35:00 1.7 @@ -7,11 +7,19 @@ (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))) +(defvar *gtk-prefixes* nil + "Assoc: lisp package -> C function prefix") + +(defun register-prefix (package prefix) + (push (cons package prefix) *gtk-prefixes*)) + +(defun pair (maybe-pair) + (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair))) + +(defun expand-defslot (prefix current-class slot-name slot-type) + (destructuring-bind (name-lisp . name-gtk) (pair slot-name) + (let ((getter (symbolicate prefix '- current-class '-get- name-gtk)) + (setter (symbolicate prefix '- current-class '-set- name-gtk))) `(progn (save-setter ,current-class ,name-lisp) (defcfun ,getter ,slot-type (object pobject)) @@ -24,29 +32,31 @@ (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)) +(template ((defgtkslot 'gtk) + (defgdkslot 'gdk) + (defslot (assoc *package* *gtk-prefixes*))) + (destructuring-bind (name prefix) param + `(defmacro ,name (current-class slot-name slot-type) + (expand-defslot ,prefix current-class slot-name slot-type)))) -(defun defslots (def-macro current-class slots) +(defun expand-defslots (prefix current-class slots) `(progn (clear-setters ,current-class) ,@(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)) + (collect + (expand-defslot prefix current-class (first x) (second x)))))) -(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 ((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)) +(template ((defgtkslots 'gtk) + (defgdkslots 'gdk) + (defslots (assoc *package* *gtk-prefixes*))) + (destructuring-bind (name prefix) param + `(defmacro ,name (current-class &rest slots) + (expand-defslots ,prefix current-class slots)))) + +(defun expand-deffun (prefix name res-type class params &key get) + (destructuring-bind (name-lisp . name-gtk) (pair 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) @@ -55,9 +65,24 @@ (defmethod ,name-lisp ((,class ,class) , at param-list) (,fun-name ,class , at param-list)))))) -(defun defsetter (prefix name slot-type class params last) - (let ((name-lisp (if (consp name) (car name) name)) - (name-gtk (if (consp name) (cdr name) name))) + +(template ((defgtkfun 'gtk) + (defgdkfun 'gdk) + (deffun (assoc *package* *gtk-prefixes*))) + (destructuring-bind (name prefix) param + `(defmacro ,name (name res-type class &rest params) + (expand-deffun ,prefix name res-type class params)))) + +(template ((defgtkgetter 'gtk) + (defgdkgetter 'gdk) + (defgetter (assoc *package* *gtk-prefixes*))) + (destructuring-bind (name prefix) param + `(defmacro ,name (name res-type class &rest params) + (expand-deffun ,prefix name res-type class params :get t)))) + + +(defun expand-defsetter (prefix name slot-type class params last) + (destructuring-bind (name-lisp . name-gtk) (pair name) (let ((setter (symbolicate prefix class '-set- name-gtk)) (param-list (mapcar #'car params))) `(progn @@ -72,52 +97,35 @@ (defmethod (setf ,name-lisp) (value (object ,class) , at param-list) (,setter object value , at param-list) 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 last &rest params) - (defsetter 'gtk- name slot-type class params last)) - -(defmacro defgdksetter (name slot-type class last &rest params) - (defsetter 'gdk- name slot-type class params last)) - -(flet ((inject-class (fun class) - (list* (first fun) (second fun) class (nthcdr 2 fun))) - (inject-class2 (fun class last) - (list* (first fun) (second fun) class last (nthcdr 2 fun)))) - (defmacro defgtkfuns (class &rest funs) - (cons 'progn - (mapcar (lambda (fun) +(template ((defgtksetter 'gtk) + (defgdksetter 'gdk) + (defsetter (assoc *package* *gtk-prefixes*))) + (destructuring-bind (name prefix) param + `(defmacro ,name (name slot-type class last &rest params) + (expand-defsetter ,prefix name slot-type class params last)))) + +(defun expand-deffuns (prefix class funs) + (cons 'progn + (mapcar (lambda (fun) + (destructuring-bind (name slot-type &rest params) + (if (keywordp (car fun)) (cdr fun) fun) (case (car fun) - (:set `(defgtksetter ,@(inject-class2 (cdr fun) - class nil))) - (:set-last `(defgtksetter ,@(inject-class2 (cdr fun) - class t))) - (:get `(defgtkgetter ,@(inject-class (cdr fun) class))) - (t `(defgtkfun ,@(inject-class fun class))))) + (:set (expand-defsetter prefix + name slot-type class params nil)) + (:set-last (expand-defsetter prefix + name slot-type class + params t)) + (:get (expand-deffun prefix + name slot-type class params :get t)) + (t (expand-deffun prefix name slot-type class params))))) funs))) - (defmacro defgdkfuns (class &rest funs) - (cons 'progn - (mapcar (lambda (fun) - (case (car fun) - (:set `(defgdksetter ,@(inject-class2 (cdr fun) - class nil))) - (:set-last `(defgdksetter ,@(inject-class2 (cdr fun) - class t))) - (:get `(defgdkgetter ,@(inject-class (cdr fun) class))) - (t `(defgdkfun ,@(inject-class fun class))))) - funs)))) - +(template ((defgtkfuns 'gtk) + (defgdkfuns 'gdk) + (deffuns (assoc *package* *gtk-prefixes*))) + (destructuring-bind (name prefix) param + `(defmacro ,name (class &rest funs) + (expand-deffuns ,prefix class funs)))) (defmacro with-object ((name &optional for-free) init &rest body) `(let ((,name ,init)) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2011/09/21 12:03:47 1.7 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2012/01/21 18:35:00 1.8 @@ -10,7 +10,8 @@ (defclass g-object (object) ((signals :accessor gsignals :initform nil) ;; redefining VOLATILE for saving in hash - (cffi-object::volatile :accessor volatile :initarg :volatile :initform nil) + (cffi-object::volatile :initform nil) + (cffi-object::free-after :initform nil) (%properties :accessor %properties :initform nil :allocation :class)) (:documentation "Lisp wrapper for GObject")) From rklochkov at common-lisp.net Sat Jan 21 18:35:00 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sat, 21 Jan 2012 10:35:00 -0800 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-serv13474/gtk Modified Files: gtk-cffi.asd package.lisp Log Message: Refactored defslots/def*funs --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2011/12/31 17:20:56 1.10 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2012/01/21 18:35:00 1.11 @@ -446,15 +446,6 @@ :components ((:file :image))) -(defsystem gtk-cffi-addons - :description "Useful bits for GTK" - :author "Roman Klochkov " - :version "0.1" - :license "GPL" - :depends-on (gtk-cffi-tree-model gtk-cffi-widget) - :components - ((:file addons))) - (defsystem gtk-cffi :description "Interface to GTK/Glib via CFFI" :author "Roman Klochkov " @@ -484,6 +475,5 @@ gtk-cffi-statusbar gtk-cffi-notebook gtk-cffi-image - gtk-cffi-text-view - gtk-cffi-addons)) + gtk-cffi-text-view)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2011/12/31 17:20:56 1.10 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2012/01/21 18:35:00 1.11 @@ -282,6 +282,7 @@ #:tree-iter #:iter->path #:path->iter + #:get-indices #:list-store ;; list-store methods @@ -603,6 +604,8 @@ #:image #:expander + + #:application )) (in-package #:gtk-cffi) From rklochkov at common-lisp.net Sat Jan 21 18:35:00 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sat, 21 Jan 2012 10:35:00 -0800 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-serv13474/utils Modified Files: package.lisp utils.lisp Log Message: Refactored defslots/def*funs --- /project/gtk-cffi/cvsroot/gtk-cffi/utils/package.lisp 2011/08/26 17:16:14 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/utils/package.lisp 2012/01/21 18:35:00 1.3 @@ -6,4 +6,7 @@ #:with-hash #:memo #:debug-out - #:bitmask)) + #:bitmask + + #:template + #:param)) --- /project/gtk-cffi/cvsroot/gtk-cffi/utils/utils.lisp 2011/08/28 15:38:31 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/utils/utils.lisp 2012/01/21 18:35:00 1.4 @@ -38,3 +38,11 @@ (collect `(when ,flag ,(make-keyword flag))))))) +(defmacro template (args &body body) + (with-gensyms (%template %do) + `(macrolet ((,%do () + (flet ((,%template (param) , at body)) + `(progn + ,@(mapcar #',%template ',args))))) + (,%do)))) + From rklochkov at common-lisp.net Sat Jan 21 18:37:52 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sat, 21 Jan 2012 10:37:52 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi/ext Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/ext In directory tiger.common-lisp.net:/tmp/cvs-serv14117/ext Added Files: gtk-cffi-ext.asd lisp-model.lisp package.lisp Log Message: Finished tree-model in lisp. Added directory for GIO --- /project/gtk-cffi/cvsroot/gtk-cffi/ext/gtk-cffi-ext.asd 2012/01/21 18:37:52 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/ext/gtk-cffi-ext.asd 2012/01/21 18:37:52 1.1 (defpackage #:gtk-cffi-ext-system (:use #:cl #:asdf)) (in-package #:gtk-cffi-ext-system) (defsystem gtk-cffi-ext :description "Extensions for GTK-CFFI" :author "Roman Klochkov " :version "0.1" :license "GPL" :depends-on (gtk-cffi) :components ((:file package) (:file lisp-model :depends-on (package)) (:file addons :depends-on (package)))) --- /project/gtk-cffi/cvsroot/gtk-cffi/ext/lisp-model.lisp 2012/01/21 18:37:52 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/ext/lisp-model.lisp 2012/01/21 18:37:52 1.1 (in-package #:gtk-cffi-ext) (defclass lisp-model-impl () ((columns :initarg :columns :accessor columns))) (defclass lisp-model-list (lisp-model-impl) ()) (defclass lisp-model-tree (lisp-model-impl) ()) ;; 1 1 ;; 2 1.1 ;; 3 1.2 ;; 4 2 ;; 5 2.1 ;; 6 2.1.1 ;; tree = (child*) ;; child = (row child*) ;; row = (field*) ;; path = (index*) ;; (((1) ((1.1)) ((1.2))) ((2) ((2.1) ((2.1.1))))) ;; ;; a[i] = (cons path child) (defstruct node (parent nil :type (or null node)) (children nil :type (or null (vector node))) (address "" :type string) (index 0 :type fixnum)) (defun make-tree-array (tree) (let (res arr-tree) (labels ((process-child (child) (declare (special i prefix)) (let ((address (concatenate 'string prefix ":" (princ-to-string i)))) (let ((index (length res))) (push (cons (subseq address 1) (car child)) res) (incf i) (let ((i 0) (prefix address)) (declare (special i prefix)) (cons index (process (cdr child))))))) (process (seq) (let ((l (mapcar #'process-child seq))) (when l (coerce l 'simple-vector))))) (let ((i 0) prefix) (declare (special i prefix)) (setf arr-tree (process tree)))) (values (coerce (nreverse res) 'simple-vector) arr-tree))) (defclass lisp-model-tree-array (lisp-model-tree) ((array :accessor larray :type (array tree-item)) (tree :accessor tree :type list)) (:documentation "ARRAY should contain lists with address as car and columns data as cdr")) (defmethod shared-initialize :after ((o lisp-model-tree-array) slot-names &key tree) (setf (values (larray o) (tree o)) (make-tree-array tree))) (defclass lisp-model-array (lisp-model-list) ((array :initarg :array :accessor larray :type (array list))) (:documentation "ARRAY should contain lists with columns data")) (defgeneric get-flags (lisp-model-impl) (:method ((lisp-model-list lisp-model-list)) 2) (:method ((lisp-model-tree lisp-model-tree)) 0)) (defgeneric get-n-columns (lisp-model-impl) (:method ((lisp-model-impl lisp-model-impl)) (length (columns lisp-model-impl)))) (defgeneric get-column-type (lisp-model-impl index) (:method ((lisp-model-impl lisp-model-impl) index) (keyword->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)))) (defmethod get-iter ((lisp-model-impl lisp-model-impl) iter path) (warn "Undefined implementation of GET-ITER for ~a" lisp-model-impl)) (defun set-iter (iter index) (with-foreign-slots ((stamp u1) iter tree-iter-struct) (setf stamp 0 u1 (make-pointer index))) t) (defmethod get-iter ((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)) (set-iter iter index)))) (defun descend (tree address) (when (> (length tree) (car address)) (let ((child (aref tree (car address)))) (if (cdr address) (descend (cdr child) (cdr address)) (values t (car child) (cdr child)))))) (defmethod get-iter ((lisp-model lisp-model-tree-array) iter path) (let ((address (get-indices (make-instance 'tree-path :pointer path)))) (multiple-value-bind (found index) (descend (tree lisp-model) address) (when found (set-iter iter index))))) (defun iter->index (iter) (pointer-address (foreign-slot-value iter 'tree-iter-struct 'u1))) (defun iter->aref (lisp-model iter) (aref (larray lisp-model) (iter->index iter))) (defgeneric get-path (lisp-model-impl iter) (:method ((lisp-model-list lisp-model-list) iter) (make-instance 'tree-path :indices (list (iter->index iter)) :free-after nil)) (:method ((lisp-model lisp-model-tree-array) iter) (make-instance 'tree-path :string (car (iter->aref lisp-model iter)) :free-after nil))) (defun set-value (g-value value-list n) (g-object-cffi::init-g-value g-value nil (nth n value-list) t)) (defgeneric get-value (lisp-model-impl iter n value) (:method ((lisp-model lisp-model-array) iter n value) (set-value value (iter->aref lisp-model iter) n)) (:method ((lisp-model lisp-model-tree-array) iter n value) (set-value value (cdr (iter->aref lisp-model iter)) n))) (defun set-iter-checked (lisp-model-list iter index) (when (and (>= index 0) (< index (lisp-model-length lisp-model-list))) (set-iter iter index))) (defun path-string->list (str) (let (res (buf "")) (iter (for ch in-string str) (if (char-equal ch #\:) (progn (push (parse-integer buf) res) (setf buf "")) (setf buf (concatenate 'string buf (make-string 1 :initial-element ch))))) (push (parse-integer buf) res) (nreverse res))) (defun iter->path-list (tree iter) (path-string->list (car (iter->aref tree iter)))) (defun move-tree-iter-checked (lisp-model-tree iter delta) (multiple-value-bind (found index) (descend (tree lisp-model-tree) (let ((r (iter->path-list lisp-model-tree iter))) (incf (car (last r)) delta) r)) (when found (set-iter iter index)))) (defgeneric iter-next (lisp-model-impl iter) (:method ((lisp-model-list lisp-model-list) iter) (set-iter-checked lisp-model-list iter (1+ (iter->index iter)))) (:method ((lisp-model lisp-model-tree-array) iter) (move-tree-iter-checked lisp-model iter 1))) (defgeneric iter-previous (lisp-model-impl iter) (:method ((lisp-model-list lisp-model-list) iter) (set-iter-checked lisp-model-list iter (1- (iter->index iter)))) (:method ((lisp-model lisp-model-tree-array) iter) (move-tree-iter-checked lisp-model iter -1))) (defgeneric iter-children (lisp-model-impl iter parent) (:method ((lisp-model-list lisp-model-list) iter parent) (when (null-pointer-p parent) (set-iter iter 0))) (:method ((lisp-model lisp-model-tree-array) iter parent) (multiple-value-bind (found index) (descend (tree lisp-model) (let ((r (iter->path-list lisp-model parent))) (append r '(0)))) (when found (set-iter iter index))))) (defgeneric iter-has-child (lisp-model-impl iter) (:method ((lisp-model-list lisp-model-list) iter) nil) (:method ((lisp-model lisp-model-tree-array) iter) (descend (tree lisp-model) (let ((r (iter->path-list lisp-model iter))) (append r '(0)))))) (defgeneric iter-n-children (lisp-model-impl iter) (:method ((lisp-model-list lisp-model-list) iter) 0) (:method ((lisp-model lisp-model-tree-array) iter) (multiple-value-bind (found index children) (descend (tree lisp-model) (iter->path-list lisp-model iter)) (length children)))) (defgeneric iter-nth-child (lisp-model-impl iter parent n) (:method ((lisp-model-list lisp-model-list) iter parent n) (when (and (null-pointer-p parent) (< n (lisp-model-length lisp-model-list))) (set-iter iter n))) (:method ((lisp-model lisp-model-tree-array) iter parent n) (multiple-value-bind (found index) (descend (tree lisp-model) (if (null-pointer-p parent) (list n) (let ((r (iter->path-list lisp-model parent))) (append r (list n))))) (when found (set-iter iter index))))) (defgeneric iter-parent (lisp-model-impl iter child) (:method ((lisp-model-list lisp-model-list) iter child) nil) (:method ((lisp-model lisp-model-tree-array) iter child) (multiple-value-bind (found index) (descend (tree lisp-model) (let ((r (iter->path-list lisp-model child))) (butlast r))) (when found (set-iter iter index))))) (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~%")) (defmacro init-interface (interface &rest callbacks) `(progn ,@(loop :for (callback args) :on callbacks :by #'cddr :collecting `(defcallback ,(symbolicate '#:cb- callback) ,(car args) ((object pobject) ,@(cdr args)) (,callback (implementation object) ,@(mapcar #'car (cdr args))))) (defcallback ,(symbolicate '#:cb-init- interface) :void ((class ,interface)) ,@(loop :for (callback args) :on callbacks :by #'cddr :collecting `(setf (foreign-slot-value class ',interface ',callback) (callback ,(symbolicate '#: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-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)) 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))) (defcstruct g-interface-info (init :pointer) (finalize :pointer) (data pdata)) (defcfun gtk-tree-model-get-type :uint) (let ((interface-info (foreign-alloc 'g-interface-info)) g-type) (setf (foreign-slot-value interface-info 'g-interface-info 'init) (callback cb-init-tree-model-iface)) (defmethod get-type ((lisp-model lisp-model)) (or g-type (prog1 (setf g-type (g-type-register-static-simple #.(keyword->g-type :object) (g-intern-static-string "GtkLispModel") (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 (gtk-tree-model-get-type) interface-info))))) (defmethod gconstructor ((lisp-model lisp-model) &rest initargs) (declare (ignore initargs)) (new (get-type lisp-model))) (import 'lisp-model "GTK-CFFI")--- /project/gtk-cffi/cvsroot/gtk-cffi/ext/package.lisp 2012/01/21 18:37:52 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/ext/package.lisp 2012/01/21 18:37:52 1.1 (in-package #:cl-user) (defpackage gtk-cffi-ext (:use #:common-lisp #:cffi #:alexandria #:iterate #:cffi-object #:g-object-cffi #:g-lib-cffi #:gdk-cffi #:gtk-cffi-utils #:gtk-cffi) (:shadowing-import-from #:gtk-cffi #:image #:window) (:import-from #:gtk-cffi #:tree-iter-struct #:u1 #:stamp #:tree-model-iface #:get-n-columns #:get-column-type #:get-iter #:get-path #:get-value #:iter-next #:iter-previous #:iter-children #:iter-has-child #:iter-n-children #:get-flags #:iter-nth-child #:iter-parent #:ref-node #:unref-node #:tree-path) (:export #:lisp-model #:implementation #:lisp-model-array #:lisp-model-tree-array #:larray)) From rklochkov at common-lisp.net Sat Jan 21 18:37:52 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sat, 21 Jan 2012 10:37:52 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi/gio Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/gio In directory tiger.common-lisp.net:/tmp/cvs-serv14117/gio Added Files: application.lisp package.lisp simple-action-group.lisp Log Message: Finished tree-model in lisp. Added directory for GIO --- /project/gtk-cffi/cvsroot/gtk-cffi/gio/application.lisp 2012/01/21 18:37:52 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gio/application.lisp 2012/01/21 18:37:52 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; application.lisp --- GApplication ;;; ;;; Copyright (C) 2012, Roman Klochkov ;;; (in-package :gio-cffi) (defclass application (g-object simple-action-group) ()) --- /project/gtk-cffi/cvsroot/gtk-cffi/gio/package.lisp 2012/01/21 18:37:52 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gio/package.lisp 2012/01/21 18:37:52 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; package.lisp --- Package definition for glib-cffi ;;; ;;; Copyright (C) 2012, Roman Klochkov ;;; (in-package #:cl-user) (defpackage #:gio-cffi (:nicknames #:gio) (:use #:common-lisp #:g-object #:g-lib))--- /project/gtk-cffi/cvsroot/gtk-cffi/gio/simple-action-group.lisp 2012/01/21 18:37:52 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gio/simple-action-group.lisp 2012/01/21 18:37:52 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; simple-action-group.lisp --- GSimpleActionGroup ;;; ;;; Copyright (C) 2012, Roman Klochkov ;;; (in-package :gio-cffi) (defclass simple-action-group (object) ()) From rklochkov at common-lisp.net Wed Jan 25 19:15:08 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Wed, 25 Jan 2012 11:15:08 -0800 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-serv31071/cffi Modified Files: object.lisp package.lisp struct.lisp Log Message: Refactored freeable Added loadlib to gio Fixed compilation without loading --- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp 2012/01/21 18:35:00 1.7 +++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp 2012/01/25 19:15:07 1.8 @@ -18,8 +18,10 @@ :initform (null-pointer) :type foreign-pointer) ;; by default object shouldn't be stored unless it is GtkObject (volatile :type boolean :accessor volatile - :initarg :volatile :initform t) - (free-after :type boolean :initarg :free-after :initform t) + :initarg :volatile :initform t + :documentation "Will not be saved in hash") + (free-after :type boolean :initarg :free-after :initform t + :documentation "Should be freed by finalizer") (id :type symbol :accessor id :initarg :id :initform nil)) (:documentation "Lisp wrapper for any object. VOLATILE slot set when object shouldn't be stored in *OBJECTS*. Stored pointer GC'ed, if VOLATILE.")) --- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/package.lisp 2011/09/18 18:10:47 1.6 +++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/package.lisp 2012/01/25 19:15:07 1.7 @@ -23,9 +23,9 @@ #:free ;; types - #:gtk-string - #:gtk-dyn-string - #:gtk-new-string + #:gtk-string ; deprecated + #:gtk-dyn-string ; deprecated + #:gtk-new-string ; deprecated #:pfunction #:cffi-object @@ -35,7 +35,9 @@ #:free-struct #:freeable - #:free-if-needed + #:freeable-base + #:free-sent-if-needed + #:free-returned-if-needed #:free-ptr #:defcstruct-accessors --- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp 2011/10/23 08:39:53 1.9 +++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp 2012/01/25 19:15:07 1.10 @@ -67,6 +67,8 @@ (struct-name (if (consp class) (cdr class) class))) `(progn (clear-setters ,class-name) + ;(eval-when (:compile-toplevel :load-toplevel :execute) + ; (setf (get ',class-name 'struct) ',struct-name)) ,@(mapcar (lambda (x) `(progn @@ -83,9 +85,10 @@ (if (slot-boundp ,class-name 'value) (push val (slot-value ,class-name 'value)) (setf (foreign-slot-value (pointer ,class-name) - ',struct-name ',x) val))) + ',struct-name ',x) + val))) (save-setter ,class-name ,x))) - (foreign-slot-names struct-name))))) + (foreign-slot-names `,struct-name))))) (defmacro defbitaccessors (class slot &rest fields) (let ((pos 0)) @@ -143,17 +146,40 @@ (foreign-slot-names class)) res)) -(define-foreign-type freeable () - ((free :accessor obj-free :initarg :free :initform nil - :documentation "Free returned value"))) +(define-foreign-type freeable-base () + ((free :accessor obj-free :initarg :free :initform :no-transfer + :type (member :none :all :no-transfer :transfer) + :documentation "Free returned or sent value"))) (defgeneric free-ptr (type ptr) - (:method ((type freeable) ptr) + (:method ((type freeable-base) ptr) (foreign-free ptr))) -(defgeneric free-if-needed (type ptr) - (:method ((type freeable) ptr) - (when (obj-free type) (free-ptr type ptr)))) +(defgeneric free-sent-ptr (type ptr) + (:method ((type freeable-base) ptr) + (free-ptr type ptr))) + +(defgeneric free-returned-ptr (type ptr) + (:method ((type freeable-base) ptr) + (free-ptr type ptr))) + +(defun free-sent-if-needed (type ptr) + (when (member (obj-free type) '(:all :no-transfer)) + (free-sent-ptr type ptr))) + +(defun free-returned-if-needed (type ptr) + (when (member (obj-free type) '(:all :transfer)) + (free-returned-ptr type ptr))) + +(defclass freeable (freeable-base) ()) + +(defmethod free-translated-object :after (ptr (type freeable) param) + (declare (ignore param)) + (free-sent-if-needed type ptr)) + +(defmethod translate-from-foreign :after (ptr (type freeable)) + (free-returned-if-needed type ptr)) + (define-foreign-type cffi-struct (cffi-object freeable) ((out :accessor obj-out :initarg :out @@ -167,10 +193,14 @@ "Return the size in bytes of a foreign typedef." (foreign-type-size (obj-class type))) -(defmethod cffi::aggregatep ((type cffi-struct)) t) +;(defmethod cffi::aggregatep ((type cffi-struct)) t) + +;(defmethod cffi::canonicalize ((type cffi-struct)) +; `(:struct ,(obj-class type))) (define-parse-method struct (class &key free out) - (make-instance 'cffi-struct :class class :free free :out out)) + (make-instance 'cffi-struct + :class class :free free :out out)) (defun %class (type value) (or (obj-class type) (class-name (class-of value)))) @@ -179,20 +209,16 @@ (values (clos->new-struct (%class type value) value) value)) (defmethod free-translated-object (value (type cffi-struct) (param struct)) - (let ((class (%class type param))) - (when (slot-boundp param 'value) - (when (obj-out type) - (struct->clos class value param)) - (free-struct class value)))) + (when (and (slot-boundp param 'value) + (obj-out type)) + (struct->clos (%class type param) value param))) (defmethod translate-from-foreign (value (type cffi-struct)) (let ((class (obj-class type))) - (prog1 - (struct->clos class value) - (free-if-needed type value)))) + (struct->clos class value))) ;;; for use with pobject designator -;; pobject == (struct nil :out t) +;; pobject == (struct nil :out t :free t) (defmethod free-translated-object (value (type cffi-object) (param struct)) (let ((class (%class type param))) @@ -202,16 +228,16 @@ -;; This is needed to get correct mem-aref, when used on array of structs (eval-when (:compile-toplevel :load-toplevel :execute) - (unless (get 'mem-ref 'struct) - (let ((old (fdefinition 'mem-ref))) - (defun mem-ref (ptr type &optional (offset 0)) - (let ((ptype (cffi::parse-type type))) - (if (subtypep (type-of ptype) 'cffi-struct) - (translate-from-foreign (inc-pointer ptr offset) ptype) - (funcall old ptr type offset))))) - (setf (get 'mem-ref 'struct) t))) + (unless (get 'mem-ref 'struct) + (let ((old (fdefinition 'mem-ref))) + (fmakunbound 'mem-ref) + (defun mem-ref (ptr type &optional (offset 0)) + (let ((ptype (cffi::parse-type type))) + (if (subtypep (type-of ptype) 'cffi-struct) + (translate-from-foreign (inc-pointer ptr offset) ptype) + (funcall old ptr type offset))))) + (setf (get 'mem-ref 'struct) t))) (defun from-foreign (var type count) "VAR - symbol; type - symbol or list -- CFFI type; count -- integer" From rklochkov at common-lisp.net Wed Jan 25 19:15:08 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Wed, 25 Jan 2012 11:15:08 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi/ext Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/ext In directory tiger.common-lisp.net:/tmp/cvs-serv31071/ext Modified Files: lisp-model.lisp Log Message: Refactored freeable Added loadlib to gio Fixed compilation without loading --- /project/gtk-cffi/cvsroot/gtk-cffi/ext/lisp-model.lisp 2012/01/21 18:37:52 1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/ext/lisp-model.lisp 2012/01/25 19:15:08 1.2 @@ -83,8 +83,9 @@ (:method ((lisp-model-array lisp-model-array)) (length (larray lisp-model-array)))) -(defmethod get-iter ((lisp-model-impl lisp-model-impl) iter path) - (warn "Undefined implementation of GET-ITER for ~a" lisp-model-impl)) +(defgeneric get-iter (lisp-model) + (:method get-iter ((lisp-model-impl lisp-model-impl) iter path) + (warn "Undefined implementation of GET-ITER for ~a" lisp-model-impl))) (defun set-iter (iter index) (with-foreign-slots ((stamp u1) iter tree-iter-struct) @@ -199,6 +200,7 @@ (multiple-value-bind (found index children) (descend (tree lisp-model) (iter->path-list lisp-model iter)) + (declare (ignore found index)) (length children)))) (defgeneric iter-nth-child (lisp-model-impl iter parent n) @@ -287,6 +289,7 @@ (defcfun gtk-tree-model-get-type :uint) +(defgeneric get-type (lisp-model)) (let ((interface-info (foreign-alloc 'g-interface-info)) g-type) (setf (foreign-slot-value interface-info 'g-interface-info 'init) From rklochkov at common-lisp.net Wed Jan 25 19:15:08 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Wed, 25 Jan 2012 11:15:08 -0800 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-serv31071/g-lib Modified Files: array.lisp list.lisp loadlib.lisp package.lisp Log Message: Refactored freeable Added loadlib to gio Fixed compilation without loading --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/array.lisp 2011/12/31 17:20:56 1.5 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/array.lisp 2012/01/25 19:15:08 1.6 @@ -10,12 +10,17 @@ (defvar *array-length* (foreign-alloc :uint)) ;; TODO: add with-pointer-to-vector-data optimization -(define-foreign-type cffi-array () +(define-foreign-type cffi-array (freeable) ((element-type :initarg :type :accessor element-type)) (:actual-type :pointer)) -(define-parse-method garray (type) - (make-instance 'cffi-array :type type)) +(define-parse-method garray (type &key free) + (make-instance 'cffi-array :type type :free free)) + +(defcfun g-free :void (var :pointer)) + +(defmethod free-ptr ((type cffi-array) ptr) + (g-free ptr)) (defmethod translate-to-foreign (value (cffi-array cffi-array)) (if (pointerp value) @@ -27,11 +32,10 @@ (setf (mem-aref res type i) (elt value i))) res))) -(defmethod free-translated-object (value (cffi-array cffi-array) param) - (declare (ignore param)) - (foreign-free value)) +;(defmethod free-translated-object (ptr (cffi-array cffi-array) param) +; (declare (ignore param)) +; (free-if-needed cffi-array ptr :free-func #'foreign-free)) -(defcfun g-free :void (var :pointer)) (defmethod translate-from-foreign (ptr (cffi-array cffi-array)) (let ((array-length (mem-ref *array-length* :uint))) @@ -41,5 +45,4 @@ (for i from 0 below array-length) (setf (aref res i) (mem-aref ptr el-type i))) - (g-free ptr) res))) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/list.lisp 2011/09/21 12:03:47 1.5 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/list.lisp 2012/01/25 19:15:08 1.6 @@ -35,13 +35,11 @@ (t (mem-ref data *list-type*))) *list*)) (define-foreign-type g-list (freeable) - ((list-type :initarg :type :accessor list-type + ((list-type :initarg :elt :accessor list-type :documentation "If null, then list is of pointers or GObjects")) + (:simple-parser g-list) (:actual-type :pointer)) -(define-parse-method g-list (&optional type &key free) - (make-instance 'g-list :type type :free free)) - (defmethod free-ptr ((type g-list) ptr) (g-list-free ptr)) @@ -50,7 +48,6 @@ (let ((*list* nil) (*list-type* (list-type g-list))) (g-list-foreach ptr (callback list-collect) (null-pointer)) - (g-list-free ptr) ;; FIXME: if exists GLists, that shouldn't be freed (nreverse *list*))) (defmethod translate-to-foreign (lisp-list (g-list g-list)) @@ -66,18 +63,14 @@ lisp-list) (g-list-reverse p)))) -(defmethod free-translated-object (ptr (type g-list) param) - (free-if-needed type ptr)) ;; Copy-paste fom g-list. Bad, but what to do? (define-foreign-type g-slist (freeable) - ((list-type :initarg :type :accessor list-type + ((list-type :initarg :elt :accessor list-type :documentation "If null, then list is of pointers or GObjects")) + (:simple-parser g-slist) (:actual-type :pointer)) -(define-parse-method g-slist (&optional type &key free) - (make-instance 'g-slist :type type :free free)) - (defcfun g-slist-free :void (g-slist :pointer)) (defcfun g-slist-foreach :void (g-list :pointer) (func :pointer) (data :pointer)) @@ -93,7 +86,6 @@ (let ((*list* nil) (*list-type* (list-type g-slist))) (g-slist-foreach ptr (callback list-collect) (null-pointer)) - (g-slist-free ptr) (nreverse *list*))) (defmethod translate-to-foreign (lisp-list (g-slist g-slist)) @@ -109,6 +101,20 @@ lisp-list) (g-slist-reverse p)))) -(defmethod free-translated-object (ptr (type g-slist) param) - (free-if-needed type ptr)) +(define-foreign-type string-list (freeable) + () + (:actual-type :pointer) + (:simple-parser string-list)) + +(defcfun g-strfreev :void (ptr :pointer)) +(defmethod free-ptr ((type string-list) ptr) + (g-strfreev ptr)) + +(defmethod translate-from-foreign (ptr (type string-list)) + (declare (type foreign-pointer ptr)) + (iter + (for i from 0) + (for pstr = (mem-aref ptr :pointer i)) + (while (not (null-pointer-p pstr))) + (collect (convert-from-foreign pstr :string)))) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/loadlib.lisp 2011/04/25 19:16:07 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/loadlib.lisp 2012/01/25 19:15:08 1.2 @@ -8,8 +8,11 @@ (in-package #:g-lib-cffi) -(define-foreign-library :g-lib - (:unix "libglib-2.0.so") - (:windows "libglib-2.0-0.dll")) +(eval-when (:compile-toplevel :load-toplevel :execute) + (define-foreign-library :g-lib + (:unix "libglib-2.0.so") + (:windows "libglib-2.0-0.dll")) -(load-foreign-library :g-lib) \ No newline at end of file + (load-foreign-library :g-lib)) + +(defctype gsize :int) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/package.lisp 2011/10/23 08:39:53 1.5 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/package.lisp 2012/01/25 19:15:08 1.6 @@ -18,6 +18,8 @@ #:g-list #:g-slist #:g-quark + #:string-list + #:variant-type #:g-error #:get-error From rklochkov at common-lisp.net Wed Jan 25 19:15:08 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Wed, 25 Jan 2012 11:15:08 -0800 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-serv31071/g-object Modified Files: defslots.lisp g-type.lisp loadlib.lisp package.lisp pobject.lisp Log Message: Refactored freeable Added loadlib to gio Fixed compilation without loading --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2012/01/21 18:35:00 1.7 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2012/01/25 19:15:08 1.8 @@ -13,6 +13,9 @@ (defun register-prefix (package prefix) (push (cons package prefix) *gtk-prefixes*)) +(defun get-prefix () + (cdr (assoc *package* *gtk-prefixes*))) + (defun pair (maybe-pair) (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair))) @@ -34,7 +37,7 @@ (template ((defgtkslot 'gtk) (defgdkslot 'gdk) - (defslot (assoc *package* *gtk-prefixes*))) + (defslot (get-prefix))) (destructuring-bind (name prefix) param `(defmacro ,name (current-class slot-name slot-type) (expand-defslot ,prefix current-class slot-name slot-type)))) @@ -49,7 +52,7 @@ (template ((defgtkslots 'gtk) (defgdkslots 'gdk) - (defslots (assoc *package* *gtk-prefixes*))) + (defslots (get-prefix))) (destructuring-bind (name prefix) param `(defmacro ,name (current-class &rest slots) (expand-defslots ,prefix current-class slots)))) @@ -68,14 +71,14 @@ (template ((defgtkfun 'gtk) (defgdkfun 'gdk) - (deffun (assoc *package* *gtk-prefixes*))) + (deffun (get-prefix))) (destructuring-bind (name prefix) param `(defmacro ,name (name res-type class &rest params) (expand-deffun ,prefix name res-type class params)))) (template ((defgtkgetter 'gtk) (defgdkgetter 'gdk) - (defgetter (assoc *package* *gtk-prefixes*))) + (defgetter (get-prefix))) (destructuring-bind (name prefix) param `(defmacro ,name (name res-type class &rest params) (expand-deffun ,prefix name res-type class params :get t)))) @@ -83,7 +86,7 @@ (defun expand-defsetter (prefix name slot-type class params last) (destructuring-bind (name-lisp . name-gtk) (pair name) - (let ((setter (symbolicate prefix class '-set- name-gtk)) + (let ((setter (symbolicate prefix '- class '-set- name-gtk)) (param-list (mapcar #'car params))) `(progn ,(unless params `(save-setter ,class ,name-lisp)) @@ -99,7 +102,7 @@ (template ((defgtksetter 'gtk) (defgdksetter 'gdk) - (defsetter (assoc *package* *gtk-prefixes*))) + (defsetter (get-prefix))) (destructuring-bind (name prefix) param `(defmacro ,name (name slot-type class last &rest params) (expand-defsetter ,prefix name slot-type class params last)))) @@ -122,7 +125,7 @@ (template ((defgtkfuns 'gtk) (defgdkfuns 'gdk) - (deffuns (assoc *package* *gtk-prefixes*))) + (deffuns (get-prefix))) (destructuring-bind (name prefix) param `(defmacro ,name (class &rest funs) (expand-deffuns ,prefix class funs)))) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-type.lisp 2011/09/10 16:26:10 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-type.lisp 2012/01/25 19:15:08 1.5 @@ -31,7 +31,7 @@ (defcstruct g-type-instance "GTypeInstance" - (g-class (:pointer g-type-class))) + (g-class g-type-class)) (defun g-type-from-instance (ptr) (foreign-slot-value --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/loadlib.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/loadlib.lisp 2012/01/25 19:15:08 1.2 @@ -8,8 +8,9 @@ (in-package #:g-object-cffi) -(define-foreign-library :g-object - (:unix "libgobject-2.0.so") - (:windows "libgobject-2.0-0.dll")) +(eval-when (:compile-toplevel :load-toplevel :execute) + (define-foreign-library :g-object + (:unix "libgobject-2.0.so") + (:windows "libgobject-2.0-0.dll")) -(load-foreign-library :g-object) \ No newline at end of file + (load-foreign-library :g-object)) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2011/10/23 08:39:53 1.7 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2012/01/25 19:15:08 1.8 @@ -61,6 +61,7 @@ #:register-type #:register-package + #:register-prefix #:ref #:unref @@ -75,16 +76,27 @@ #:make-closure ; utility functions + #:defslot + #:defgdkslot #:defgtkslot + + #:defslots #:defgtkslots - #:defgdkslot #:defgdkslots + + #:defgetter #:defgtkgetter #:defgdkgetter + + #:defsetter #:defgtksetter #:defgdksetter + + #:deffun #:defgtkfun #:defgdkfun + + #:deffuns #:defgtkfuns #:defgdkfuns --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp 2011/09/21 12:03:47 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp 2012/01/25 19:15:08 1.5 @@ -49,15 +49,13 @@ (foreign-free data))) -(define-foreign-type cffi-pdata (cffi-pobject freeable) +(define-foreign-type cffi-pdata (cffi-pobject freeable-base) () (:actual-type :pointer) + (:simple-parser pdata) (:documentation "PDATA lets send any data via a c-pointer. C-pointer used as an id for the data. NB! Don't forget to free pointers after use.")) -(define-parse-method pdata (&key free) - (make-instance 'cffi-pdata :free free)) - (defmethod free-ptr ((type cffi-pdata) object) ; it's not typo: ;we free object, not pointer @@ -68,7 +66,7 @@ (let ((obj (object ptr))) (if obj (typecase obj - (storage (prog1 (data obj) (free-if-needed type obj))) + (storage (prog1 (data obj) (free-returned-if-needed type obj))) (t obj)) ptr))) @@ -86,7 +84,7 @@ (defmethod free-translated-object (any-data (type cffi-pdata) param) (when param - (free-if-needed type param))) + (free-sent-if-needed type param))) ;; (defmethod translate-to-foreign :around ((any-data storage) (name cffi-pdata)) ;; (call-next-method any-data name)) @@ -102,7 +100,7 @@ ;; (mapcar (lambda (x) (convert-from-foreign x 'pobject)) ;; (call-next-method))) -(defctype g-list-object (g-list pobject)) +(defctype g-list-object (g-list :elt pobject)) (defcfun g-type-interface-peek-parent pobject (iface pobject)) From rklochkov at common-lisp.net Wed Jan 25 19:15:08 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Wed, 25 Jan 2012 11:15:08 -0800 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-serv31071/gdk Modified Files: color.lisp loadlib.lisp package.lisp pango.lisp rectangle.lisp Log Message: Refactored freeable Added loadlib to gio Fixed compilation without loading --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/color.lisp 2011/09/18 18:10:47 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/color.lisp 2012/01/25 19:15:08 1.4 @@ -26,12 +26,7 @@ color-st))) (defmethod translate-from-foreign (ptr (type color-cffi)) - (prog1 - (gdk-color-to-string ptr) - (free-if-needed type ptr))) - -(defmethod free-translated-object (value (name color-cffi) param) - (foreign-free value)) + (gdk-color-to-string ptr)) (defcfun (color-equal "gdk_color_equal") :boolean (color pcolor) (color2 pcolor)) @@ -63,9 +58,4 @@ color-st))) (defmethod translate-from-foreign (ptr (type rgba-cffi)) - (prog1 - (gdk-rgba-to-string ptr) - (free-if-needed type ptr))) - -(defmethod free-translated-object (value (name rgba-cffi) param) - (foreign-free value)) \ No newline at end of file + (gdk-rgba-to-string ptr)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/loadlib.lisp 2011/08/26 17:16:14 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/loadlib.lisp 2012/01/25 19:15:08 1.3 @@ -7,9 +7,10 @@ (in-package :gdk-cffi) -(define-foreign-library :gdk - (:unix "libgdk-3.so.0") - (:windows "libgdk-win32-3xs-0.dll")) +(eval-when (:compile-toplevel :load-toplevel :execute) + (define-foreign-library :gdk + (:unix "libgdk-3.so.0") + (:windows "libgdk-win32-3xs-0.dll")) -(load-foreign-library :gdk) + (load-foreign-library :gdk)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/package.lisp 2011/09/21 12:03:47 1.6 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/package.lisp 2012/01/25 19:15:08 1.7 @@ -71,3 +71,4 @@ (in-package #:gdk-cffi) (register-package "Gdk" *package*) +(register-package *package* 'gdk) --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/pango.lisp 2011/09/18 18:10:47 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/pango.lisp 2012/01/25 19:15:08 1.5 @@ -28,26 +28,18 @@ (define-foreign-type font (freeable) () - (:actual-type :pointer)) + (:actual-type :pointer) + (:simple-parser font)) (defmethod free-ptr ((type font) ptr) (pango-font-description-free ptr)) -(define-parse-method font (&key free) - (make-instance 'font :free free)) - (defmethod translate-to-foreign (value (type font)) (string->pango-font value)) -(defmethod free-translated-object (value (type font) param) - (declare (ignore param)) - (pango-font-description-free value)) - (defmethod translate-from-foreign (ptr (type font)) (unless (null-pointer-p ptr) - (prog1 - (pango-font->string ptr) - (free-if-needed type ptr)))) + (pango-font->string ptr))) (defcenum alignment :left :center :right) @@ -122,25 +114,23 @@ (fixnum (pango-tab-array-set-tab res index 0 tab-stop)))) res)) -(defmethod free-translated-object (value (type tab-array) param) - (declare (ignore param)) - (pango-tab-array-free value)) +;(defmethod free-translated-object (value (type tab-array) param) +; (declare (ignore param)) +; (pango-tab-array-free value)) (defmethod translate-from-foreign (ptr (type tab-array)) (unless (null-pointer-p ptr) - (prog1 - (cons (pango-tab-array-get-positions-in-pixels ptr) - (iter (for index from 0 below (pango-tab-array-get-size ptr)) - (collect - (destructuring-bind (alignment location) - (with-foreign-outs ((alignment 'tab-align) - (location :int)) :ignore - (pango-tab-array-get-tab ptr index - alignment location)) - (if (eq alignment :left) - location - (cons alignment location)))))) - (free-if-needed type ptr)))) + (cons (pango-tab-array-get-positions-in-pixels ptr) + (iter (for index from 0 below (pango-tab-array-get-size ptr)) + (collect + (destructuring-bind (alignment location) + (with-foreign-outs ((alignment 'tab-align) + (location :int)) :ignore + (pango-tab-array-get-tab ptr index + alignment location)) + (if (eq alignment :left) + location + (cons alignment location)))))))) (defctype language :pointer) --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/rectangle.lisp 2011/09/10 16:26:10 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/rectangle.lisp 2012/01/25 19:15:08 1.4 @@ -8,7 +8,7 @@ (defcstruct-accessors (rectangle . cairo_rectangle_t)) -(defcfun gdk-rectangle-intersect :boolean +(defcfun gdk-rectangle-intersect :boolean (src1 (struct rectangle)) (src2 (struct rectangle)) (dest (struct rectangle :out t))) From rklochkov at common-lisp.net Wed Jan 25 19:15:08 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Wed, 25 Jan 2012 11:15:08 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi/gio Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/gio In directory tiger.common-lisp.net:/tmp/cvs-serv31071/gio Modified Files: package.lisp simple-action-group.lisp Added Files: action-group.lisp loadlib.lisp Log Message: Refactored freeable Added loadlib to gio Fixed compilation without loading --- /project/gtk-cffi/cvsroot/gtk-cffi/gio/package.lisp 2012/01/21 18:37:52 1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gio/package.lisp 2012/01/25 19:15:08 1.2 @@ -9,4 +9,8 @@ (defpackage #:gio-cffi (:nicknames #:gio) - (:use #:common-lisp #:g-object #:g-lib)) \ No newline at end of file + (:use #:common-lisp #:cffi #:cffi-object #:g-object-cffi #:g-lib-cffi)) + +(in-package #:gio-cffi) +(register-package "G" *package*) +(register-prefix *package* 'g) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/gio/simple-action-group.lisp 2012/01/21 18:37:52 1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gio/simple-action-group.lisp 2012/01/25 19:15:08 1.2 @@ -7,5 +7,5 @@ (in-package :gio-cffi) -(defclass simple-action-group (object) ()) +(defclass simple-action-group (g-object action-group) ()) --- /project/gtk-cffi/cvsroot/gtk-cffi/gio/action-group.lisp 2012/01/25 19:15:08 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gio/action-group.lisp 2012/01/25 19:15:08 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; action-group.lisp --- GActionGroup ;;; ;;; Copyright (C) 2012, Roman Klochkov ;;; (in-package :gio-cffi) (defclass action-group (object) ()) (deffuns action-group (has-action :boolean (action-name gtk-string)) (list-actions (string-list :free t)) (:get action-enabled :boolean (action-name gtk-string))) ; (:get action-parameter-type variant-type (action-name gtk-string)) ; (:get action-state-type variant-type (action-name gtk-string))) --- /project/gtk-cffi/cvsroot/gtk-cffi/gio/loadlib.lisp 2012/01/25 19:15:08 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gio/loadlib.lisp 2012/01/25 19:15:08 1.1 (in-package #:gio-cffi) (eval-when (:compile-toplevel :load-toplevel :execute) (define-foreign-library :gio (:unix "libgio-2.0.so") (:windows "libgio-2.0-0.dll")) (load-foreign-library :gio)) From rklochkov at common-lisp.net Wed Jan 25 19:15:09 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Wed, 25 Jan 2012 11:15:09 -0800 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-serv31071/gtk Modified Files: css-provider.lisp gtk-cffi.asd package.lisp text-buffer.lisp widget.lisp Log Message: Refactored freeable Added loadlib to gio Fixed compilation without loading --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/css-provider.lisp 2011/08/26 17:16:14 1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/css-provider.lisp 2012/01/25 19:15:08 1.2 @@ -22,13 +22,13 @@ (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 +(defgeneric css-provider-load (css-provider &key data filename gfile) + (:method ((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)))) + (cerror "Continue" "CSS Provider load error: ~a" g-error))))) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2012/01/21 18:35:00 1.11 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2012/01/25 19:15:08 1.12 @@ -14,7 +14,7 @@ :author "Roman Klochkov " :version "0.5" :license "GPL" - :depends-on (gdk-cffi g-object-cffi g-lib-cffi gtk-cffi-utils) + :depends-on (gdk-cffi g-object-cffi g-lib-cffi gtk-cffi-utils gio-cffi) :components ((:file package) (:file enums :depends-on (package)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2012/01/21 18:35:00 1.11 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2012/01/25 19:15:08 1.12 @@ -24,7 +24,9 @@ #:object-by-id #:gsignal #:yield - + + #:css-provider + #:css-provider-load #:widget ;; widget slots @@ -610,3 +612,4 @@ (in-package #:gtk-cffi) (register-package "Gtk" *package*) +(register-prefix *package* 'gtk) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/text-buffer.lisp 2011/12/31 17:20:56 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/text-buffer.lisp 2012/01/25 19:15:08 1.5 @@ -59,14 +59,14 @@ (:get visible-slice gtk-string (end pobject)) (:get visible-text gtk-string (end pobject)) (:get pixbuf pobject) - (:get marks (g-slist pobject)) - (:get toggled-tags (g-slist pobject) (toggle-on :boolean)) + (:get marks (g-slist :elt pobject)) + (:get toggled-tags (g-slist :elt pobject) (toggle-on :boolean)) (:get child-anchor pobject) (begins-tag :boolean (tag pobject)) (ends-tag :boolean (tag pobject)) (toggles-tag :boolean (tag pobject)) (has-tag :boolean (tag pobject)) - (:get tags (g-slist pobject)) + (:get tags (g-slist :elt pobject)) ((text-iter-editable . editable) :boolean (default-setting :boolean)) (can-insert :boolean (default-editability :boolean)) (starts-word :boolean) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2011/09/17 20:04:56 1.6 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2012/01/25 19:15:08 1.7 @@ -363,7 +363,8 @@ (defmethod preferred-size ((widget widget)) "Returns (values minimum natural). Minimum and natural are requisition objects." - (with-foreign-outs ((minimum 'requisition) (natural 'requisition)) :ignore + (with-foreign-outs ((minimum 'requisition) (natural 'requisition)) + :ignore (gtk-widget-get-preferred-size widget minimum natural))) (defcstruct requested-size @@ -379,7 +380,8 @@ "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))) + (let ((sizes-struct (foreign-alloc 'requested-size + :count length))) (iter (for i from 0 below length) (for x in sizes) @@ -394,22 +396,22 @@ (init-slots widget nil) -(macrolet - ((from-style (name &optional type) - `(progn - (defmethod ,name ((widget widget) - &key ,@(when type '(type)) (state :normal)) - (,name (style-context widget) ,@(when type '(:type type)) - :state state)) - - (defmethod (setf ,name) (value (widget widget) - &key ,@(when type '(type)) (state :normal)) - (setf (,name (style-context widget) ,@(when type '(:type type)) - :state state) - value))))) - (from-style color t) - (from-style font) - (from-style bg-pixmap)) +(template + ((color t) + (font nil) + (bg-pixmap nil)) + (destructuring-bind (name with-type) param + `(progn + (defmethod ,name ((widget widget) + &key ,@(when with-type '(type)) (state :normal)) + (,name (style-context widget) ,@(when with-type '(:type type)) + :state state)) + + (defmethod (setf ,name) (value (widget widget) + &key ,@(when with-type '(type)) (state :normal)) + (setf (,name (style-context widget) ,@(when with-type '(:type type)) + :state state) + value))))) (defclass widget-class (g-object-class) From rklochkov at common-lisp.net Fri Jan 27 18:41:31 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Fri, 27 Jan 2012 10:41:31 -0800 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-serv29565/gdk Modified Files: loadlib.lisp pango.lisp Log Message: Added pango-attr-list --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/loadlib.lisp 2012/01/25 19:15:08 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/loadlib.lisp 2012/01/27 18:41:31 1.4 @@ -7,10 +7,10 @@ (in-package :gdk-cffi) -(eval-when (:compile-toplevel :load-toplevel :execute) - (define-foreign-library :gdk - (:unix "libgdk-3.so.0") - (:windows "libgdk-win32-3xs-0.dll")) +;(eval-when (:compile-toplevel :load-toplevel :execute) +(define-foreign-library :gdk + (:unix "libgdk-3.so.0") + (:windows "libgdk-win32-3xs-0.dll")) - (load-foreign-library :gdk)) +(use-foreign-library :gdk) --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/pango.lisp 2012/01/25 19:15:08 1.5 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/pango.lisp 2012/01/27 18:41:31 1.6 @@ -1,5 +1,6 @@ (defpackage #:pango-cffi - (:use #:common-lisp #:cffi-object #:cffi #:iterate) + (:use #:common-lisp #:cffi-object #:cffi #:iterate #:g-object-cffi + #:alexandria #:gtk-cffi-utils) (:export #:font #:tab-array @@ -11,11 +12,13 @@ #:underline #:variant #:wrap-mode - #:direction)) + #:direction + #:attr-list)) (in-package #:pango-cffi) -(g-object-cffi:register-package "Pango" *package*) +(register-package "Pango" *package*) +(register-prefix *package* 'pango) (defcfun ("pango_font_description_from_string" string->pango-font) @@ -73,6 +76,25 @@ (defcenum direction :ltr :rtl :ttb-ltr :ttb-rtl :weak-ltr :weak-rtl :neutral) +(defcenum gravity + :south :east :north :west :auto) + +(defcenum gravity-hint + :natural :strong :line) + +(defcenum weight + (:thin 100) + (:ultralight 200) + (:light 300) + (:book 380) + (:normal 400) + (:medium 500) + (:semibold 600) + (:bold 700) + (:ultrabold 800) + (:heavy 900) + (:ultraheavy 1000)) + (define-foreign-type tab-array (freeable) () (:actual-type :pointer)) @@ -141,3 +163,209 @@ (defcfun (language->string "pango_language_to_string") gtk-string (language language)) +(eval-when (:compile-toplevel :load-toplevel) + (defcenum attr-type + :invalid :language :family :style :weight :variant :stretch :size + :font-desc :foreground :background :underline :strikethrough + :rise :shape :scale :fallback :letter-spacing :underline-color + :strikethrough-color :absolute-size :gravity :gravity-hint)) + +(defcstruct attribute + (klass (:pointer attr-type)) + (start-index :uint) + (end-index :uint)) + +(defcstruct attr-string + (attr attribute) + (value :string)) + +(defcstruct attr-language + (attr attribute) + (value language)) + +(defcstruct color + (red :uint16) + (green :uint16) + (blue :uint16)) + +(defcstruct attr-color + (attr attribute) + (value color)) + +(defcstruct attr-int + (attr attribute) + (value :int)) + +(defcstruct attr-float + (attr attribute) + (value :float)) + +(defcstruct attr-font-desc + (attr attribute) + (value font)) + +(defcstruct rectangle + (x :int) (y :int) + (width :int) (height :int)) + +(defcstruct attr-shape + (attr attribute) + (ink rectangle) + (logical rectangle) + (data :pointer) + (copy-func :pointer) + (destroy-func :pointer)) + +(defcstruct attr-size + (attr attribute) + (size :int) + (absolute :uint)) + +(defun rect->list (rect) + (with-foreign-slots ((x y width height) rect rectangle) + (list x y width height))) + +(eval-when (:compile-toplevel :load-toplevel) + (defun attr->type (ktype) + (ecase ktype + (:language 'attr-language) + (:family 'attr-string) + ((:style :weight :variant :stretch + :underline :strikethrough + :rise :fallback :letter-spacing + :gravity :gravity-hint) 'attr-int) + ((:size :absolute-size) 'attr-size) + (:font-desc 'attr-font-desc) + (:shape 'attr-shape) + (:scale 'attr-float) + ((:foreground :background + :underline-color + :strikethrough-color) 'attr-color)))) + +(defun translate-to-enum (type value) + (case type + ((:style :weight :variant :stretch :underline :gravity :gravity-hint) + (convert-from-foreign value (intern (symbol-name type) #.*package*))) + ((:strikethrough :fallback) (convert-from-foreign value :boolean)) + (t value))) + + +(defun attr->list (attr) + (let* ((type (mem-ref (foreign-slot-value attr 'attribute 'klass) + 'attr-type)) + (tail-type (attr->type type))) + (with-foreign-slots ((start-index end-index) attr attribute) + (list* type start-index end-index + (ecase tail-type + ((attr-language attr-string attr-font-desc attr-float) + (list (foreign-slot-value attr tail-type 'value))) + (attr-int (list (translate-to-enum + type + (foreign-slot-value attr tail-type 'value)))) + (attr-color (with-foreign-slots + ((red green blue) + (foreign-slot-value attr 'attr-color 'value) + color) + (list red green blue))) + + (attr-size (list (foreign-slot-value attr tail-type 'size))) + (attr-shape + (with-foreign-slots ((ink logical) attr attr-shape) + (list (rect->list ink) (rect->list logical))))))))) + + + +(template (:language :family :style :variant :stretch :weight :size + :font-desc :strikethrough :underline :scale + :rise :letter-spacing :fallback :gravity + :gravity-hint) + (flet ((in-type (type) + (case type + (:family :string) + ((:size :rise :letter-spacing) :int) + (:font-desc 'font) + ((:strikethrough :fallback) :boolean) + (:scale :double) + (t (intern (symbol-name type) #.*package*))))) + `(defcfun ,(symbolicate 'pango-attr- param '-new) ,(attr->type param) + (value ,(in-type param))))) + +(template (:foreground :background :strikethrough-color :underline-color) + `(defcfun ,(symbolicate 'pango-attr- param '-new) attr-color + (red :uint16) (green :uint16) (blue :uint16))) + +(defcfun ("pango_attr_size_new_absolute" pango-attr-absolute-size-new) + attr-size (size :int)) + +(define-foreign-type rect-list (freeable) + () + (:simple-parser rect-list) + (:actual-type :pointer)) + +(defmethod translate-to-foreign (value (type rect-list)) + (let ((ptr (foreign-alloc 'rectangle))) + (with-foreign-slots ((x y width height) ptr rectangle) + (destructuring-bind (new-x new-y new-width new-height) value + (setf x new-x + y new-y + width new-width + height new-height))) + ptr)) + + +(defcfun pango-attr-shape-new attr-shape (ink rect-list) (logical rect-list)) + +(define-foreign-type attr-list (freeable) + ((free :initform t)) + (:simple-parser attr-list) + (:actual-type :pointer)) + +;; (deffuns attr-list +;; (ref :pointer) +;; (unref :void) +;; (filter :pointer (func :pointer) (data :pointer))) + +(defcfun pango-attr-list-unref :void (ptr :pointer)) +(defcfun pango-attr-list-filter :pointer + (ptr :pointer) (func :pointer) (data :pointer)) + +(defmethod free-ptr ((type attr-list) ptr) + (pango-attr-list-unref ptr)) + +(defvar *attr-list* nil) + +(defcallback cb-attr-list :boolean ((pattr :pointer) (data :pointer)) + (declare (ignore data)) + (push (attr->list pattr) *attr-list*) + t) + +(defmethod translate-from-foreign (ptr (type attr-list)) + (let (*attr-list*) + (pango-attr-list-filter ptr (callback cb-attr-list) (null-pointer)) + *attr-list*)) + +(defcfun pango-attr-list-new :pointer) +(defcfun pango-attr-list-insert :void (list :pointer) (attr :pointer)) + +(template (t) + (declare (ignore param)) + `(defun list->attr (l) + (destructuring-bind (type start-index end-index &rest params) l + (let ((ptr + (apply + (case type + ,@(mapcar (lambda (x) `(,x + (function ,(symbolicate + 'pango-attr- x '-new)))) + (cdr (foreign-enum-keyword-list 'attr-type)))) + params))) + (setf (foreign-slot-value ptr 'attribute 'start-index) start-index + (foreign-slot-value ptr 'attribute 'end-index) end-index) + ptr)))) + + +(defmethod translate-to-foreign (value (type attr-list)) + (let ((ptr (pango-attr-list-new))) + (mapc (lambda (x) (pango-attr-list-insert ptr (list->attr x))) + value) + ptr)) \ No newline at end of file From rklochkov at common-lisp.net Fri Jan 27 18:41:31 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Fri, 27 Jan 2012 10:41:31 -0800 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-serv29565/gtk Modified Files: label.lisp loadlib.lisp widget.lisp Log Message: Added pango-attr-list --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/label.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/label.lisp 2012/01/27 18:41:31 1.2 @@ -42,27 +42,9 @@ (if markup #'gtk-label-get-label #'gtk-label-get-text) label)) -(defcfun "gtk_label_set_mnemonic_widget" :void - (label pobject) (widget pobject)) - -(defmethod (setf mnemonic-widget) ((widget widget) (label label)) - (gtk-label-set-mnemonic-widget label widget)) - -(defcfun "gtk_label_get_mnemonic_widget" pobject (label pobject)) - -(defmethod mnemonic-widget ((label label)) - (gtk-label-get-mnemonic-widget label)) - -(defcfun "gtk_label_set_justify" :void (label pobject) (jtype justification)) - -(defmethod (setf justify) (justify (label label)) - (gtk-label-set-justify label justify)) - -(defcfun "gtk_label_get_justify" justification (label pobject)) - -(defmethod justify ((label label)) - (gtk-label-get-justify label)) - +(defslots label + mnemonic-widget pobject + justify justification) ;; taken from cells-gtk --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/loadlib.lisp 2011/12/31 17:20:56 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/loadlib.lisp 2012/01/27 18:41:31 1.4 @@ -17,12 +17,12 @@ ;; (t value))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (define-foreign-library :gtk - (:unix "libgtk-3.so.0") ;libgtk-x11-2.0.so") - (:windows "libgtk-win32-3-0.dll")) +;(eval-when (:compile-toplevel :load-toplevel :execute) +(define-foreign-library :gtk + (:unix "libgtk-3.so.0") ;libgtk-x11-2.0.so") + (:windows "libgtk-win32-3-0.dll")) - (load-foreign-library :gtk)) +(use-foreign-library :gtk) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2012/01/25 19:15:08 1.7 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2012/01/27 18:41:31 1.8 @@ -517,3 +517,6 @@ nil gtk-widget-style-get-property style-property-type widget-class find-style-property %style-properties) + +(defgeneric text (widget &key)) + From rklochkov at common-lisp.net Sat Jan 28 13:44:45 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sat, 28 Jan 2012 05:44:45 -0800 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-serv32508/g-lib Added Files: variant.lisp Log Message: Added GVariant --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/variant.lisp 2012/01/28 13:44:45 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/variant.lisp 2012/01/28 13:44:45 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; variant.lisp -- interface to GVariantType ;;; ;;; Copyright (C) 2012, Roman Klochkov ;;; (in-package #:g-lib-cffi) (define-foreign-type variant-type (freeable) ((free :initform t)) (:actual-type :pointer) (:simple-parser variant-type)) (defcfun g-variant-type-peek-string :pointer (ptr :pointer)) (defcfun g-variant-type-new :pointer (format :string)) (defcfun g-variant-type-free :void (ptr :pointer)) (defcfun g-variant-type-get-string-length gsize (ptr :pointer)) (defmethod free-ptr ((type variant-type) ptr) (g-variant-type-free ptr)) (defmethod translate-from-foreign (ptr (type variant-type)) (declare (type foreign-pointer ptr)) (when ptr (foreign-string-to-lisp (g-variant-type-peek-string ptr) :count (g-variant-type-get-string-length ptr)))) (defmethod translate-to-foreign (str (type variant-type)) (g-variant-type-new str)) From rklochkov at common-lisp.net Sat Jan 28 13:44:45 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sat, 28 Jan 2012 05:44:45 -0800 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-serv32508/gtk Added Files: application.lisp selections.lisp Log Message: Added GVariant --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/application.lisp 2012/01/28 13:44:45 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/application.lisp 2012/01/28 13:44:45 1.1 (in-package :gtk-cffi) (defclass application (g-application) ()) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/selections.lisp 2012/01/28 13:44:45 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/selections.lisp 2012/01/28 13:44:45 1.1 (in-package :gtk-cffi) (defclass target-list (object) ())