X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.generating.lisp;h=5ac99de55dc99894f3fe9a11f5def838eb582ec4;hb=fa09303681fef160cc4340fd5059321ff5d98776;hp=5fe1cfaca807dbd2f19ed968fb9f707c20d1ada7;hpb=4c22e03a95b43c06f3518c27df8ebccae04cb2c6;p=cl-gtk2.git

diff --git a/glib/gobject.generating.lisp b/glib/gobject.generating.lisp
index 5fe1cfa..5ac99de 100644
--- a/glib/gobject.generating.lisp
+++ b/glib/gobject.generating.lisp
@@ -1,6 +1,7 @@
 (in-package :gobject)
 
-(defvar *lisp-name-package* (find-package :gobject))
+(defvar *lisp-name-package* nil
+  "For internal use (used by class definitions generator). Specifies the package in which symbols are interned.")
 (defvar *strip-prefix* "")
 (defvar *lisp-name-exceptions* nil)
 (defvar *generation-exclusions* nil)
@@ -135,7 +136,9 @@
 
 (defun type-initializer-call (type-initializer)
   (etypecase type-initializer
-    (string `(foreign-funcall ,type-initializer g-type))
+    (string `(if (foreign-symbol-pointer ,type-initializer)
+                 (foreign-funcall ,type-initializer g-type)
+                 (warn "Type initializer '~A' is not available" ,type-initializer)))
     (symbol `(funcall ',type-initializer))))
 
 (defun meta-property->slot (class-name property)
@@ -230,8 +233,13 @@
           (write-char (char-downcase c) stream))
     (write-string "_get_type" stream)))
 
-(defun get-g-class-definition (type)
-  (let* ((g-type (ensure-g-type type))
+(defun get-g-class-definition (type &optional lisp-name-package)
+  (when (and (stringp type) (zerop (g-type-numeric type)))
+    (let ((type-init-name (probable-type-init-name type)))
+      (when (foreign-symbol-pointer type-init-name)
+        (foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
+  (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
+         (g-type (ensure-g-type type))
          (g-name (g-type-name g-type))
          (name (g-name->name g-name))
          (superclass-g-type (g-type-parent g-type))
@@ -241,8 +249,7 @@
          (type-init-name (probable-type-init-name g-name))
          (own-properties
           (remove-if-not (lambda (property)
-                           (= g-type
-                              (g-class-property-definition-owner-type property)))
+                           (g-type= g-type (g-class-property-definition-owner-type property)))
                          properties)))
     `(define-g-object-class ,g-name ,name 
          (:superclass ,superclass-name
@@ -256,8 +263,9 @@
                   own-properties)
           ,@(cdr (find g-name *additional-properties* :key 'car :test 'string=))))))
 
-(defun get-g-interface-definition (interface)
-  (let* ((type (ensure-g-type interface))
+(defun get-g-interface-definition (interface &optional lisp-name-package)
+  (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
+         (type (ensure-g-type interface))
          (g-name (g-type-name type))
          (name (g-name->name g-name))
          (properties (interface-properties type))
@@ -272,7 +280,7 @@
                  (cdr (find g-name *additional-properties* :key 'car :test 'string=))))))
 
 (defun get-g-class-definitions-for-root-1 (type)
-  (unless (member (ensure-g-type type) *generation-exclusions* :test '=)
+  (unless (member type *generation-exclusions* :test 'g-type=)
     (cons (get-g-class-definition type)
           (reduce #'append
                   (mapcar #'get-g-class-definitions-for-root-1
@@ -287,23 +295,24 @@
 (defun class-or-interface-properties (type)
   (setf type (ensure-g-type type))
   (cond 
-    ((= (g-type-fundamental type) +g-type-object+) (class-properties type))
-    ((= (g-type-fundamental type) +g-type-interface+) (interface-properties type))))
+    ((g-type= (g-type-fundamental type) +g-type-object+) (class-properties type))
+    ((g-type= (g-type-fundamental type) +g-type-interface+) (interface-properties type))))
 
 (defun get-shallow-referenced-types (type)
   (setf type (ensure-g-type type))
   (remove-duplicates (sort (loop
                               for property in (class-or-interface-properties type)
-                              when (= type (g-class-property-definition-owner-type property))
+                              when (g-type= type (g-class-property-definition-owner-type property))
                               collect (g-class-property-definition-type property))
-                           #'<)
+                           #'<
+                           :key #'g-type-numeric)
                      :test 'equal))
 
 (defun get-referenced-types-1 (type)
   (setf type (ensure-g-type type))
   (loop
      for property-type in (get-shallow-referenced-types type)
-     do (pushnew property-type *referenced-types* :test '=))
+     do (pushnew property-type *referenced-types* :test 'g-type=))
   (loop
      for type in (g-type-children type)
      do (get-referenced-types-1 type)))
@@ -326,14 +335,29 @@
      (equal (g-type-fundamental (ensure-g-type type)) fund-type))
    types))
 
-(defmacro define-g-enum (g-name name (&key (export t) type-initializer)  &body values)
+(defmacro define-g-enum (g-name name (&key (export t) type-initializer) &body values)
+  "Defines a GEnum type for enumeration. Generates corresponding CFFI definition.
+
+Example:
+@begin{pre}
+\(define-g-enum \"GdkGrabStatus\" grab-status () :success :already-grabbed :invalid-time :not-viewable :frozen)
+\(define-g-enum \"GdkExtensionMode\" gdk-extension-mode (:export t :type-initializer \"gdk_extension_mode_get_type\")
+  (:none 0) (:all 1) (:cursor 2))
+@end{pre}
+@arg[g-name]{a string. Specifies the GEnum name}
+@arg[name]{a symbol. Names the enumeration type.}
+@arg[export]{a boolean. If true, @code{name} will be exported.}
+@arg[type-initializer]{a @code{NIL} or a string or a function designator.
+
+If non-@code{NIL}, specifies the function that initializes the type: string specifies a C function that returns the GType value and function designator specifies the Lisp function.}
+@arg[values]{values for enum. Each value is a keyword or a list @code{(keyword integer-value)}. @code{keyword} corresponds to Lisp value of enumeration, and @code{integer-value} is an C integer for enumeration item. If @code{integer-value} is not specified, it is generated automatically (see CFFI manual)}"
   `(progn
      (defcenum ,name ,@values)
      (register-enum-type ,g-name ',name)
      ,@(when export
              (list `(export ',name (find-package ,(package-name (symbol-package name))))))
      ,@(when type-initializer
-             (list (type-initializer-call type-initializer)))))
+             (list `(at-init () ,(type-initializer-call type-initializer))))))
 
 (defun enum-value->definition (enum-value)
   (let ((value-name (intern (lispify-name (enum-item-nick enum-value))
@@ -341,8 +365,9 @@
         (numeric-value (enum-item-value enum-value)))
     `(,value-name ,numeric-value)))
 
-(defun get-g-enum-definition (type)
-  (let* ((g-type (ensure-g-type type))
+(defun get-g-enum-definition (type &optional lisp-name-package)
+  (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
+         (g-type (ensure-g-type type))
          (g-name (g-type-name g-type))
          (name (g-name->name g-name))
          (items (get-enum-items g-type))
@@ -355,13 +380,29 @@
        ,@(mapcar #'enum-value->definition items))))
 
 (defmacro define-g-flags (g-name name (&key (export t) type-initializer) &body values)
+  "Defines a GFlags type for enumeration that can combine its values. Generates corresponding CFFI definition. Values of this type are lists of keywords that are combined.
+
+Example:
+@begin{pre}
+\(define-g-flags \"GdkWindowState\" window-state ()
+  (:withdrawn 1)
+  (:iconified 2) (:maximized 4) (:sticky 8) (:fullscreen 16)
+  (:above 32) (:below 64))
+@end{pre}
+@arg[g-name]{a string. Specifies the GEnum name}
+@arg[name]{a symbol. Names the enumeration type.}
+@arg[export]{a boolean. If true, @code{name} will be exported.}
+@arg[type-initializer]{a @code{NIL} or a string or a function designator.
+
+If non-@code{NIL}, specifies the function that initializes the type: string specifies a C function that returns the GType value and function designator specifies the Lisp function.}
+@arg[values]{values for flags. Each value is a keyword or a list @code{(keyword integer-value)}. @code{keyword} corresponds to Lisp value of a flag, and @code{integer-value} is an C integer for flag. If @code{integer-value} is not specified, it is generated automatically (see CFFI manual)}"
   `(progn
      (defbitfield ,name ,@values)
-     (register-enum-type ,g-name ',name)
+     (register-flags-type ,g-name ',name)
      ,@(when export
              (list `(export ',name (find-package ,(package-name (symbol-package name))))))
      ,@(when type-initializer
-             (list (type-initializer-call type-initializer)))))
+             (list `(at-init () ,(type-initializer-call type-initializer))))))
 
 (defun flags-value->definition (flags-value)
   (let ((value-name (intern (lispify-name (flags-item-nick flags-value))
@@ -369,8 +410,9 @@
         (numeric-value (flags-item-value flags-value)))
     `(,value-name ,numeric-value)))
 
-(defun get-g-flags-definition (type)
-  (let* ((g-type (ensure-g-type type))
+(defun get-g-flags-definition (type &optional lisp-name-package)
+  (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
+         (g-type (ensure-g-type type))
          (g-name (g-type-name g-type))
          (name (g-name->name g-name))
          (items (get-flags-items g-type))
@@ -417,24 +459,24 @@
              for interface in interfaces
              do (loop
                    for referenced-type in (get-shallow-referenced-types interface)
-                   do (pushnew referenced-type referenced-types :test 'equal)))
+                   do (pushnew referenced-type referenced-types :test 'g-type=)))
           (loop
              for object in objects
              do (loop
                    for referenced-type in (get-shallow-referenced-types object)
-                   do (pushnew referenced-type referenced-types :test 'equal)))
+                   do (pushnew referenced-type referenced-types :test 'g-type=)))
           (loop
              for enum-type in (filter-types-by-fund-type
                                referenced-types "GEnum")
              for def = (get-g-enum-definition enum-type)
-             unless (member (ensure-g-type enum-type) exclusions :test '=)
+             unless (member enum-type exclusions :test 'g-type=)
              do (format file "~S~%~%" def))
             
           (loop
              for flags-type in (filter-types-by-fund-type
                                 referenced-types "GFlags")
              for def = (get-g-flags-definition flags-type)
-             unless (member (ensure-g-type flags-type) exclusions :test '=)
+             unless (member flags-type exclusions :test 'g-type=)
              do (format file "~S~%~%" def)))
         (loop
            with auto-enums = (and include-referenced
@@ -442,7 +484,7 @@
                                    referenced-types "GEnum"))
            for enum in enums
            for def = (get-g-enum-definition enum)
-           unless (find (ensure-g-type enum) auto-enums :test 'equal)
+           unless (find enum auto-enums :test 'g-type=)
            do (format file "~S~%~%" def))
         (loop
            with auto-flags = (and include-referenced
@@ -450,7 +492,7 @@
                                    referenced-types "GFlags"))
            for flags-type in flags
            for def = (get-g-flags-definition flags-type)
-           unless (find (ensure-g-type flags-type) auto-flags :test 'equal)
+           unless (find flags-type auto-flags :test 'g-type=)
            do (format file "~S~%~%" def))
         (loop
            for interface in interfaces