X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.generating.lisp;h=0560ddb42c4cf9f0334155f7fe311dfa63af4ced;hb=96aa7293addaacdfe29ce32e60e2feac7df6ffce;hp=7c3a807149cf153e99225e6250bdbc52f71940f6;hpb=c770ca4a913da887d7e9cec76c4343cc1dc4a8aa;p=cl-gtk2.git diff --git a/glib/gobject.generating.lisp b/glib/gobject.generating.lisp index 7c3a807..0560ddb 100644 --- a/glib/gobject.generating.lisp +++ b/glib/gobject.generating.lisp @@ -1,12 +1,13 @@ (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) (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)))) @@ -136,7 +137,11 @@ (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-pointer + (foreign-symbol-pointer ,type-initializer) () + g-type) + (warn "Type initializer '~A' is not available" ,type-initializer))) (symbol `(funcall ',type-initializer)))) (defun meta-property->slot (class-name property) @@ -144,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) @@ -158,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) @@ -213,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))))) @@ -231,24 +240,29 @@ (write-char (char-downcase c) stream)) (write-string "_get_type" stream))) -(defun get-g-class-definition (type) - (let* ((g-type (ensure-g-type type)) - (g-name (g-type-name g-type)) +(defun get-g-class-definition (type &optional lisp-name-package) + (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 (gtype-name (gtype type)) *generated-types*) t)) + (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*)) + (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)) (own-properties - (remove-if-not (lambda (property) - (= g-type - (g-class-property-definition-owner-type property))) - 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-name))) `(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))) @@ -257,11 +271,19 @@ own-properties) ,@(cdr (find g-name *additional-properties* :key 'car :test 'string=)))))) -(defun get-g-interface-definition (interface) - (let* ((type (ensure-g-type interface)) - (g-name (g-type-name type)) +(defun get-g-interface-definition (interface &optional lisp-name-package) + (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 (gtype-name (gtype interface)) *generated-types*) t)) + (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*)) + (type (gtype interface)) + (g-name (gtype-name type)) (name (g-name->name g-name)) - (properties (interface-properties type)) + (properties (sort (copy-list (interface-properties type)) + #'string< :key #'g-class-property-definition-name)) (probable-type-initializer (probable-type-init-name g-name))) `(define-g-interface ,g-name ,name (:export t @@ -273,58 +295,61 @@ (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 '=) - (cons (get-g-class-definition type) - (reduce #'append - (mapcar #'get-g-class-definitions-for-root-1 - (g-type-children type)))))) + (unless (member (gtype type) *generation-exclusions* :test 'g-type=) + (iter (when (first-iteration-p) + (unless (and *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 #'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-fundamental type) +g-type-object+) (class-properties 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 (= 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)) - #'<) + #'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 (get-shallow-referenced-types type) - do (pushnew property-type *referenced-types* :test '=)) + 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 (g-type-children type) + 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) @@ -357,9 +382,16 @@ If non-@code{NIL}, specifies the function that initializes the type: string spec (numeric-value (enum-item-value enum-value))) `(,value-name ,numeric-value))) -(defun get-g-enum-definition (type) - (let* ((g-type (ensure-g-type type)) - (g-name (g-type-name g-type)) +(defun get-g-enum-definition (type &optional lisp-name-package) + (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 (gtype-name (gtype type)) *generated-types*) t)) + (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*)) + (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))) @@ -401,9 +433,16 @@ If non-@code{NIL}, specifies the function that initializes the type: string spec (numeric-value (flags-item-value flags-value))) `(,value-name ,numeric-value))) -(defun get-g-flags-definition (type) - (let* ((g-type (ensure-g-type type)) - (g-name (g-type-name g-type)) +(defun get-g-flags-definition (type &optional lisp-name-package) + (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 (gtype-name (gtype type)) *generated-types*) t)) + (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*)) + (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))) @@ -414,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) (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))))) + +(defun get-g-type-definition (type &optional lisp-name-package) + (maybe-call-type-init type) + (cond + ((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" + (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)) (with-open-file (stream file :direction :output :if-exists :supersede) @@ -429,18 +485,19 @@ 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 "")) (*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) prefix)))) - (setf exclusions (mapcar #'ensure-g-type exclusions)) + (setf exclusions (mapcar #'gtype exclusions)) (when prologue (write-string prologue file) (terpri file)) @@ -449,24 +506,24 @@ If non-@code{NIL}, specifies the function that initializes the type: string spec 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 @@ -474,7 +531,7 @@ If non-@code{NIL}, specifies the function that initializes the type: string spec 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 @@ -482,7 +539,7 @@ If non-@code{NIL}, specifies the function that initializes the type: string spec 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 @@ -491,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 (gtype-name (gtype object)) *generated-types*) + (for def = (get-g-class-definition object)) + (format file "~S~%~%" def)))))) \ No newline at end of file