Remove eXecute permissions from several .lisp files

[cl-gtk2.git] / glib / gobject.generating.lisp

diff --git a/glib/gobject.generating.lisp b/glib/gobject.generating.lisp
index 48c14d0..2035784 100644 (file)
--- a/glib/gobject.generating.lisp
+++ b/glib/gobject.generating.lisp
@@ -7,6 +7,7 @@
 (defvar *generation-exclusions* nil)
 (defvar *known-interfaces* (make-hash-table :test 'equal))
 (defvar *additional-properties* nil)
+(defvar *generated-types* nil)
 
 (defun name->supplied-p (name)
   (make-symbol (format nil "~A-SUPPLIED-P" (symbol-name name))))
@@ -137,7 +138,9 @@
 (defun type-initializer-call (type-initializer)
   (etypecase type-initializer
     (string `(if (foreign-symbol-pointer ,type-initializer)
-                 (foreign-funcall ,type-initializer g-type)
+                 (foreign-funcall-pointer
+                  (foreign-symbol-pointer ,type-initializer) ()
+                  g-type)
                  (warn "Type initializer '~A' is not available" ,type-initializer)))
     (symbol `(funcall ',type-initializer))))
 
@@ -146,11 +149,15 @@
      :allocation ,(if (gobject-property-p property) :gobject-property :gobject-fn)
      :g-property-type ,(if (gobject-property-p property) (gobject-property-type property) (cffi-property-type property))
      :accessor ,(intern (format nil "~A-~A" (symbol-name class-name) (property-name property)) (symbol-package class-name))
-     :initarg ,(intern (string-upcase (property-name property)) (find-package :keyword))
+     ,@(when (if (gobject-property-p property)
+                 t
+                 (not (null (cffi-property-writer property))))
+             `(:initarg
+               ,(intern (string-upcase (property-name property)) (find-package :keyword))))
      ,@(if (gobject-property-p property)
            `(:g-property-name ,(gobject-property-gname property))
            `(:g-getter ,(cffi-property-reader property)
-                                :g-setter ,(cffi-property-writer property)))))
+                       :g-setter ,(cffi-property-writer property)))))
 
 (defmacro define-g-object-class (g-type-name name
                                  (&key (superclass 'g-object)
@@ -160,7 +167,7 @@
                                  (&rest properties))
   (setf properties (mapcar #'parse-property properties))
   `(progn
-     (defclass ,name (,superclass ,@(mapcar #'interface->lisp-class-name interfaces))
+     (defclass ,name (,@(when (and superclass (not (eq superclass 'g-object))) (list superclass)) ,@(mapcar #'interface->lisp-class-name interfaces))
        (,@(mapcar (lambda (property) (meta-property->slot name property)) properties))
        (:metaclass gobject-class)
        (:g-type-name . ,g-type-name)
@@ -238,6 +245,8 @@
     (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))))
+  (when *generated-types*
+    (setf (gethash (g-type-string type) *generated-types*) t))
   (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))
@@ -249,7 +258,7 @@
          (type-init-name (probable-type-init-name g-name))
          (own-properties
           (sort (copy-list (remove g-type properties :key #'g-class-property-definition-owner-type :test-not #'g-type=))
-                #'string< :key #'g-class-property-definition-owner-type)))
+                #'string< :key #'g-class-property-definition-name)))
     `(define-g-object-class ,g-name ,name 
          (:superclass ,superclass-name
                       :export t
@@ -267,6 +276,8 @@
     (let ((type-init-name (probable-type-init-name interface)))
       (when (foreign-symbol-pointer type-init-name)
         (foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
+  (when *generated-types*
+    (setf (gethash (g-type-string interface) *generated-types*) t))
   (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
          (type (ensure-g-type interface))
          (g-name (g-type-name type))
@@ -285,10 +296,12 @@
 
 (defun get-g-class-definitions-for-root-1 (type)
   (unless (member type *generation-exclusions* :test 'g-type=)
-    (cons (get-g-class-definition type)
-          (reduce #'append
-                  (mapcar #'get-g-class-definitions-for-root-1
-                          (sort (copy-list (g-type-children type)) #'string< :key #'g-type-string))))))
+    (iter (when (first-iteration-p)
+            (unless (and *generated-types*
+                         (gethash (g-type-string type) *generated-types*))
+              (appending (list (get-g-class-definition type)))))
+          (for child-type in (sort (copy-list (g-type-children type)) #'string< :key #'g-type-string))
+          (appending (get-g-class-definitions-for-root-1 child-type)))))
 
 (defun get-g-class-definitions-for-root (type)
   (setf type (ensure-g-type type))
@@ -374,6 +387,8 @@ If non-@code{NIL}, specifies the function that initializes the type: string spec
     (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))))
+  (when *generated-types*
+    (setf (gethash (g-type-string type) *generated-types*) t))
   (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))
@@ -423,6 +438,8 @@ If non-@code{NIL}, specifies the function that initializes the type: string spec
     (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))))
+  (when *generated-types*
+    (setf (gethash (g-type-string type) *generated-types*) t))
   (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))
@@ -436,6 +453,23 @@ If non-@code{NIL}, specifies the function that initializes the type: string spec
                                 probable-type-initializer)))
        ,@(mapcar #'flags-value->definition items))))
 
+(defun maybe-call-type-init (type)
+  (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)))))
+
+(defun get-g-type-definition (type &optional lisp-name-package)
+  (maybe-call-type-init type)
+  (cond
+    ((g-type-is-a type +g-type-enum+) (get-g-enum-definition type lisp-name-package))
+    ((g-type-is-a type +g-type-flags+) (get-g-flags-definition type lisp-name-package))
+    ((g-type-is-a type +g-type-interface+) (get-g-interface-definition type lisp-name-package))
+    ((g-type-is-a type +g-type-object+) (get-g-class-definition type lisp-name-package))
+    (t (error "Do not know how to automatically generate type definition for ~A type ~A"
+              (g-type-string (g-type-fundamental type))
+              (or (g-type-string type) type)))))
+
 (defun generate-types-hierarchy-to-file (file root-type &key include-referenced prefix package exceptions prologue interfaces enums flags objects exclusions additional-properties)
   (if (not (streamp file))
       (with-open-file (stream file :direction :output :if-exists :supersede)
@@ -458,6 +492,7 @@ If non-@code{NIL}, specifies the function that initializes the type: string spec
              (*lisp-name-exceptions* exceptions)
              (*print-case* :downcase)
              (*additional-properties* additional-properties)
+             (*generated-types* (make-hash-table :test 'equalp))
              (referenced-types (and include-referenced
                                     (filter-types-by-prefix
                                      (get-referenced-types root-type)
@@ -513,7 +548,7 @@ If non-@code{NIL}, specifies the function that initializes the type: string spec
         (loop
            for def in (get-g-class-definitions-for-root root-type)
            do (format file "~S~%~%" def))
-        (loop
-           for object in objects
-           for def = (get-g-class-definition object)
-           do (format file "~S~%~%" def)))))
\ No newline at end of file
+        (iter (for object in objects)
+              (unless (gethash (g-type-string object) *generated-types*)
+                (for def = (get-g-class-definition object))
+                (format file "~S~%~%" def))))))
\ No newline at end of file