X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.generating.lisp;h=0560ddb42c4cf9f0334155f7fe311dfa63af4ced;hb=140e8f22e7a58c7b1eef05124b2929e73388c5f6;hp=203578487d7edcc6ef6ddb21001ad0cf304b285a;hpb=f552247edf212838f83fa57800531fcc4a9c5df8;p=cl-gtk2.git diff --git a/glib/gobject.generating.lisp b/glib/gobject.generating.lisp index 2035784..0560ddb 100644 --- a/glib/gobject.generating.lisp +++ b/glib/gobject.generating.lisp @@ -222,7 +222,7 @@ (let ((name (g-name->name (g-class-property-definition-name property))) (accessor-name (accessor-name class-name (g-class-property-definition-name property))) (g-name (g-class-property-definition-name property)) - (type (g-type-name (g-class-property-definition-type property))) + (type (gtype-name (g-class-property-definition-type property))) (readable (g-class-property-definition-readable property)) (writable (and (g-class-property-definition-writable property) (not (g-class-property-definition-constructor-only property))))) @@ -241,18 +241,18 @@ (write-string "_get_type" stream))) (defun get-g-class-definition (type &optional lisp-name-package) - (when (and (stringp type) (zerop (g-type-numeric type))) + (when (and (stringp type) (null (ignore-errors (gtype 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)))) (when *generated-types* - (setf (gethash (g-type-string type) *generated-types*) t)) + (setf (gethash (gtype-name (gtype 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)) + (g-type (gtype type)) + (g-name (gtype-name g-type)) (name (g-name->name g-name)) (superclass-g-type (g-type-parent g-type)) - (superclass-name (g-name->name (g-type-name superclass-g-type))) + (superclass-name (g-name->name (gtype-name superclass-g-type))) (interfaces (g-type-interfaces g-type)) (properties (class-properties g-type)) (type-init-name (probable-type-init-name g-name)) @@ -262,7 +262,7 @@ `(define-g-object-class ,g-name ,name (:superclass ,superclass-name :export t - :interfaces (,@(sort (mapcar #'g-type-name interfaces) 'string<)) + :interfaces (,@(sort (mapcar #'gtype-name interfaces) 'string<)) ,@(when (and (foreign-symbol-pointer type-init-name) (not (null-pointer-p (foreign-symbol-pointer type-init-name)))) `(:type-initializer ,type-init-name))) @@ -272,15 +272,15 @@ ,@(cdr (find g-name *additional-properties* :key 'car :test 'string=)))))) (defun get-g-interface-definition (interface &optional lisp-name-package) - (when (and (stringp interface) (zerop (g-type-numeric interface))) + (when (and (stringp interface) (null (ignore-errors (gtype interface)))) (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)) + (setf (gethash (gtype-name (gtype 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)) + (type (gtype interface)) + (g-name (gtype-name type)) (name (g-name->name g-name)) (properties (sort (copy-list (interface-properties type)) #'string< :key #'g-class-property-definition-name)) @@ -295,61 +295,61 @@ (cdr (find g-name *additional-properties* :key 'car :test 'string=)))))) (defun get-g-class-definitions-for-root-1 (type) - (unless (member type *generation-exclusions* :test 'g-type=) + (unless (member (gtype type) *generation-exclusions* :test 'g-type=) (iter (when (first-iteration-p) (unless (and *generated-types* - (gethash (g-type-string type) *generated-types*)) + (gethash (gtype-name (gtype 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)) + (for child-type in (sort (copy-list (g-type-children type)) #'string< :key #'gtype-name)) (appending (get-g-class-definitions-for-root-1 child-type))))) (defun get-g-class-definitions-for-root (type) - (setf type (ensure-g-type type)) + (setf type (gtype type)) (get-g-class-definitions-for-root-1 type)) (defvar *referenced-types*) (defun class-or-interface-properties (type) - (setf type (ensure-g-type type)) + (setf type (gtype type)) (cond - ((g-type= (g-type-fundamental type) +g-type-object+) (class-properties type)) - ((g-type= (g-type-fundamental type) +g-type-interface+) (interface-properties type)))) + ((g-type= (g-type-fundamental type) (gtype +g-type-object+)) (class-properties type)) + ((g-type= (g-type-fundamental type) (gtype +g-type-interface+)) (interface-properties type)))) (defun get-shallow-referenced-types (type) - (setf type (ensure-g-type type)) + (setf type (gtype type)) (remove-duplicates (sort (loop for property in (class-or-interface-properties type) when (g-type= type (g-class-property-definition-owner-type property)) collect (g-class-property-definition-type property)) #'string< - :key #'g-type-string) + :key #'gtype-name) :test 'equal)) (defun get-referenced-types-1 (type) - (setf type (ensure-g-type type)) + (setf type (gtype type)) (loop - for property-type in (sort (copy-list (get-shallow-referenced-types type)) #'string> :key #'g-type-string) + for property-type in (sort (copy-list (get-shallow-referenced-types type)) #'string> :key #'gtype-name) do (pushnew property-type *referenced-types* :test 'g-type=)) (loop - for type in (sort (copy-list (g-type-children type)) #'string< :key #'g-type-string) + for type in (sort (copy-list (g-type-children type)) #'string< :key #'gtype-name) do (get-referenced-types-1 type))) (defun get-referenced-types (root-type) (let (*referenced-types*) - (get-referenced-types-1 (ensure-g-type root-type)) + (get-referenced-types-1 (gtype root-type)) *referenced-types*)) (defun filter-types-by-prefix (types prefix) (remove-if-not (lambda (type) - (starts-with (g-type-name (ensure-g-type type)) prefix)) + (starts-with (gtype-name (gtype type)) prefix)) types)) (defun filter-types-by-fund-type (types fund-type) - (setf fund-type (ensure-g-type fund-type)) + (setf fund-type (gtype fund-type)) (remove-if-not (lambda (type) - (equal (g-type-fundamental (ensure-g-type type)) fund-type)) + (equal (g-type-fundamental (gtype type)) fund-type)) types)) (defmacro define-g-enum (g-name name (&key (export t) type-initializer) &body values) @@ -383,15 +383,15 @@ If non-@code{NIL}, specifies the function that initializes the type: string spec `(,value-name ,numeric-value))) (defun get-g-enum-definition (type &optional lisp-name-package) - (when (and (stringp type) (zerop (g-type-numeric type))) + (when (and (stringp type) (null (gtype 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)))) (when *generated-types* - (setf (gethash (g-type-string type) *generated-types*) t)) + (setf (gethash (gtype-name (gtype 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)) + (g-type (gtype type)) + (g-name (gtype-name g-type)) (name (g-name->name g-name)) (items (get-enum-items g-type)) (probable-type-initializer (probable-type-init-name g-name))) @@ -434,15 +434,15 @@ If non-@code{NIL}, specifies the function that initializes the type: string spec `(,value-name ,numeric-value))) (defun get-g-flags-definition (type &optional lisp-name-package) - (when (and (stringp type) (zerop (g-type-numeric type))) + (when (and (stringp type) (null (gtype 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)))) (when *generated-types* - (setf (gethash (g-type-string type) *generated-types*) t)) + (setf (gethash (gtype-name (gtype 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)) + (g-type (gtype type)) + (g-name (gtype-name g-type)) (name (g-name->name g-name)) (items (get-flags-items g-type)) (probable-type-initializer (probable-type-init-name g-name))) @@ -454,7 +454,7 @@ If non-@code{NIL}, specifies the function that initializes the type: string spec ,@(mapcar #'flags-value->definition items)))) (defun maybe-call-type-init (type) - (when (and (stringp type) (zerop (g-type-numeric type))) + (when (and (stringp type) (null (gtype 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))))) @@ -462,13 +462,13 @@ If non-@code{NIL}, specifies the function that initializes the type: string spec (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)) + ((g-type-is-a type (gtype +g-type-enum+)) (get-g-enum-definition type lisp-name-package)) + ((g-type-is-a type (gtype +g-type-flags+)) (get-g-flags-definition type lisp-name-package)) + ((g-type-is-a type (gtype +g-type-interface+)) (get-g-interface-definition type lisp-name-package)) + ((g-type-is-a type (gtype +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))))) + (gtype-name (g-type-fundamental type)) + (or (ignore-errors (gtype-name (gtype 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)) @@ -485,7 +485,7 @@ If non-@code{NIL}, specifies the function that initializes the type: string spec :objects objects :exclusions exclusions :additional-properties additional-properties)) - (let* ((*generation-exclusions* (mapcar #'ensure-g-type exclusions)) + (let* ((*generation-exclusions* (mapcar #'gtype exclusions)) (*lisp-name-package* (or package *package*)) (*package* *lisp-name-package*) (*strip-prefix* (or prefix "")) @@ -497,7 +497,7 @@ If non-@code{NIL}, specifies the function that initializes the type: string spec (filter-types-by-prefix (get-referenced-types root-type) prefix)))) - (setf exclusions (mapcar #'ensure-g-type exclusions)) + (setf exclusions (mapcar #'gtype exclusions)) (when prologue (write-string prologue file) (terpri file)) @@ -549,6 +549,6 @@ If non-@code{NIL}, specifies the function that initializes the type: string spec for def in (get-g-class-definitions-for-root root-type) do (format file "~S~%~%" def)) (iter (for object in objects) - (unless (gethash (g-type-string object) *generated-types*) + (unless (gethash (gtype-name (gtype object)) *generated-types*) (for def = (get-g-class-definition object)) (format file "~S~%~%" def)))))) \ No newline at end of file