[gtk-cffi-cvs] CVS gtk-cffi/g-object
CVS User rklochkov
rklochkov at common-lisp.net
Mon Aug 8 15:02:01 UTC 2011
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 <kalimehtar at mail.ru>"
: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 <kalimehtar at mail.ru>
+;;;
+
+(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
More information about the gtk-cffi-cvs
mailing list