From 37426342462e6073031ca7919684639f60c6e894 Mon Sep 17 00:00:00 2001 From: John Connors Date: Sun, 29 Jun 2008 11:30:48 +0100 Subject: [PATCH] Modified to format nicely, and resolve types properly, with updated dir files. --- atk.asd | 1 - cairo.asd | 1 - gdk.asd | 3 +- gir-parser.lisp | 369 ++++++++++++++++++++++++++++++-------------------------- gtk.asd | 3 +- package.lisp | 3 +- pango.asd | 3 +- 7 files changed, 201 insertions(+), 182 deletions(-) rewrite gir-parser.lisp (61%) diff --git a/atk.asd b/atk.asd index c882249..4bac26a 100644 --- a/atk.asd +++ b/atk.asd @@ -5,6 +5,5 @@ :serial t :components ((:file "atk-package") - (:file "atk-loader") (:file "atk-types") (:file "atk-funcs"))) diff --git a/cairo.asd b/cairo.asd index e373ef8..6954133 100644 --- a/cairo.asd +++ b/cairo.asd @@ -4,6 +4,5 @@ :serial t :components ((:file "cairo-package") - (:file "cairo-loader") (:file "cairo-types") (:file "cairo-funcs"))) diff --git a/gdk.asd b/gdk.asd index c406c1f..c363a82 100644 --- a/gdk.asd +++ b/gdk.asd @@ -3,7 +3,6 @@ :depends-on (:iterate :cffi) :serial t :components - ((:file "gdk-package") - (:file "gdk-loader") + ((:file "gdk-package") (:file "gdk-types") (:file "gdk-funcs"))) diff --git a/gir-parser.lisp b/gir-parser.lisp dissimilarity index 61% index 19a222b..a48641b 100644 --- a/gir-parser.lisp +++ b/gir-parser.lisp @@ -1,173 +1,196 @@ -(in-package :gir) - -(defun is-object-record (record) - (let* ((record-string (string record)) - (record-string-len (length record-string))) - (or - (and (> record-string-len 6) - (string= "OBJECT" (string-upcase (subseq record-string (- record-string-len 6)))))))) - -(defun parse-function-types (outs method) - (iterate - (for item in (s-xml:xml-element-children method)) - (case (s-xml:xml-element-name item) - (GIR-CORE::|return-value| - (let ((return-type (first (xml-element-children item)))) - (format outs "~T~A~%" (resolve-type (s-xml:xml-element-attribute return-type 'GIR-C::|type|))))) - (GIR-CORE::|parameters| - (iterate - (for parameter in (s-xml:xml-element-children item)) - (format outs "( ~A " (s-xml:xml-element-attribute parameter :|name|)) - (format outs " ~A )~%" - (resolve-type (xml-element-attribute (car (s-xml:xml-element-children parameter)) 'GIR-C::|type|)))))))) - -(defun parse-signal-types (outs gsignal) - (let ((name (s-xml:xml-element-attribute gsignal :|name|))) - (format outs "~%; ----------------- ~A ----------------~%" name) - (format outs "(defmacro make-~A-callback (name &rest body) ~%" (lispize name)) - (format outs "~T(defcallback ,name ") - (iterate - (for item in (s-xml:xml-element-children gsignal)) - (when (s-xml::xml-element-p item) - (case (s-xml:xml-element-name item) - (GIR-CORE::|return-value| - (let ((return-type (first (xml-element-children item)))) - (format outs "~T~A~%" (resolve-type (s-xml:xml-element-attribute return-type 'GIR-C::|type|))))) - (GIR-CORE::|parameters| - (iterate - (for parameter in (s-xml:xml-element-children item)) - (format outs "( ~A " (s-xml:xml-element-attribute parameter :|name|)) - (format outs " ~A )~%" - (resolve-type (xml-element-attribute (car (s-xml:xml-element-children parameter)) 'GIR-C::|type|)))))))) - (format outs "))~%"))) - - - -(defun parse-record (outs record) - (let ((c-type (s-xml:xml-element-attribute record 'GIR-C::|type|)) - (name (s-xml:xml-element-attribute record :|name|))) - ;; we punt on object records (I think they are meant to be opaque) - (add-type name :struct) - (unless (is-object-record name) - (format outs "~%; ----------------- ~A ----------------~%" name) - (format outs "~%(defcstruct ~A ~%" name) - (iterate - (for field in (s-xml:xml-element-children record)) - (when (eql (s-xml:xml-element-name field) 'GIR-CORE::|field|) - (format outs "~T(~A ~A)~%" - (lispize (s-xml:xml-element-attribute field :|name|)) - (resolve-type (s-xml:xml-element-attribute field :|value|))))) - (format outs ")~%") - (iterate - (for method in (s-xml:xml-element-children record)) - (when (eql (s-xml:xml-element-name method) 'GIR-CORE::|callback|) - (let ((name (s-xml:xml-element-attribute method :|name|))) - (format outs "(defcfun (~S ~A) " name (lispize name)) - ;; to do -- still need to parse callbacks as methods! - (parse-function-types outs method)))) - (format outs ")~%")))) - - -(defun parse-function (outs function) - (let ((c-identifier (s-xml:xml-element-attribute function 'GIR-C::|identifier|)) - (name (s-xml:xml-element-attribute function :|name|))) - (format outs "~%; ----------------- ~A ---------------- " name) - (format outs "~%(defcfun (~S ~A) ~%" c-identifier (lispize name)) - (parse-function-types outs function) - (format outs ")~%"))) - -(defun parse-constructor (outs constructor) - (let ((c-identifier (s-xml:xml-element-attribute constructor 'GIR-C::|identifier|)) - (name (s-xml:xml-element-attribute constructor :|name|))) - (format outs "~%; ----------------- ~A ---------------- " (lispize c-identifier)) - (format outs "~%(defcfun (~S ~A) ~%" c-identifier (lispize c-identifier)) - (parse-function-types outs constructor) - (format outs ")~%"))) - -;; callbacks associated with the records are actually methods - - -(defun parse-enum-members (outs enum) - (iterate - (for member in (s-xml:xml-element-children enum)) - (when (eql (s-xml:xml-element-name member) 'GIR-CORE::|member|) - (format outs "~T(:~A ~S)~%" - (string-upcase (s-xml:xml-element-attribute member :|name|)) - (parse-integer (s-xml:xml-element-attribute member :|value|)))))) - -(defun parse-enumeration (outs enum) - (let ((c-type (s-xml:xml-element-attribute enum 'GIR-C::|type|)) - (name (s-xml:xml-element-attribute enum :|name|))) - (format outs "~%; ----------------- ~A ----------------~%" (lispize c-type)) - (add-type (string c-type) :unsigned-int) - (format outs "(defcenum ~A ~% " name) - (parse-enum-members outs enum) - (format outs ")~%"))) - -(defun parse-bitfield (outs bitfield) - (let ((c-type (s-xml:xml-element-attribute bitfield 'GIR-C::|type|)) - (name (s-xml:xml-element-attribute bitfield :|name|))) - (format outs "~%; ----------------- ~A ----------------~%" (lispize c-type)) - (format outs "(defcenum ~A ~% " name) - (add-type (string c-type) :unsigned-int) - (parse-enum-members outs bitfield) - (format outs ")~%"))) - -(defun parse-class (outs gclass) - (iterate - (for method in (s-xml:xml-element-children gclass)) - (when (s-xml::xml-element-p method) - (case (s-xml:xml-element-name method) - (GIR-CORE::|constructor| (parse-constructor outs method)) - (GIR-CORE::|method| (parse-function outs method)) - (GIR-CORE::|callback| (parse-signal-types outs method)))))) - -(defun parse-boxed (outs boxed) - (iterate - (for method in (s-xml:xml-element-children boxed)) - (when (s-xml::xml-element-p method) - (case (s-xml:xml-element-name method) - (GIR-CORE::|constructor| (parse-constructor outs method)) - (GIR-CORE::|method| (parse-function outs method)) - (GIR-CORE::|callback| (parse-signal-types outs method)))))) - -(defun parse-callback (outs callback) - (let ((name (s-xml:xml-element-attribute callback :|name|))) - (add-type name :pointer) - (parse-signal-types outs callback))) - -(defparameter *gir-top-level-type-elements* - ;; first pass -- - '((GIR-CORE::|bitfield| . parse-bitfield) - (GIR-CORE::|enumeration| . parse-enumeration) - (GIR-CORE::|record| . parse-record))) - -(defparameter *gir-top-level-function-elements* - ;; second pass - '((GIR-CORE::|callback| . parse-callback) - (GIR-CORE::|function| . parse-function) - (GIR-CORE::|class| . parse-class) - (GIR-GLIB::|boxed| . parse-boxed))) - - -(defun parse-element (outs elements entry) - (let ((name (s-xml:xml-element-name entry))) - (let ((fun (cdr (assoc name elements)))) - (if fun - (funcall fun outs entry))))) - - -(defun parse-namespace (outs namespace elements) - (let ((namespace-name - (alexandria::make-keyword - (string-upcase (s-xml:xml-element-attribute namespace :|name|))))) -;; (format outs "(defpackage ~S (:use :common-lisp :cffi :iterate))~%~%" namespace-name) - (format outs "(in-package ~S)~%" namespace-name) - (iterate - (for entry in (xml-element-children namespace)) - (parse-element outs elements entry)))) - -(defun parse-repository (outs repository elements) - (iterate - (for namespace in (s-xml:xml-element-children repository)) - (parse-namespace outs namespace elements))) +(in-package :gir) + +(defun named-xml-element-child (element name) + (find-if #'(lambda (x) + (and (s-xml::xml-element-p x) + (equal (s-xml::xml-element-name x) name))) + (s-xml::xml-element-children element))) + +(defun is-field-element-p (element) + (equal (s-xml:xml-element-name element) 'GIR-CORE::|field|)) + +(defun is-callback-element-p (element) + (equal (s-xml:xml-element-name element) 'GIR-CORE::|callback|)) + +(defun is-object-record (record) + (let* ((record-string (string record)) + (record-string-len (length record-string))) + (or + (and (> record-string-len 6) + (string= "OBJECT" (string-upcase (subseq record-string (- record-string-len 6)))))))) + +(defun parse-function-types (outs method) + (let ((return-value + (named-xml-element-child method 'GIR-CORE:|return-value|)) + (parameters + (named-xml-element-child method 'GIR-CORE:|parameters|))) + (let ((return-type (first (xml-element-children return-value)))) + (format outs " ~A~%" (resolve-type (s-xml:xml-element-attribute return-type 'GIR-C::|type|)))) + (when (s-xml::xml-element-p parameters) + (iterate + (for parameter in (s-xml:xml-element-children parameters)) + (format outs "~&~T( ~A " (s-xml:xml-element-attribute parameter :|name|)) + (format outs " ~A )" + (resolve-type (xml-element-attribute (car (s-xml:xml-element-children parameter)) 'GIR-C::|type|))))))) + +(defun parse-signal-types (outs gsignal) + (let ((name (s-xml:xml-element-attribute gsignal :|name|))) + (format outs "~%; ----------------- ~A ----------------~%" name) + (format outs "(defmacro make-~A (name &rest body) ~%" (lispize name)) + (format outs "~T(defcallback ,name ") + (let ((return-value (named-xml-element-child gsignal 'GIR-CORE::|return-value|))) + (let ((return-type (first (xml-element-children return-value)))) + (format outs "~&~T~A" (resolve-type (s-xml:xml-element-attribute return-type 'GIR-C::|type|)))) + (format outs "~T( ") + (iterate + (for item in (s-xml:xml-element-children gsignal)) + (when (s-xml::xml-element-p item) + (case (s-xml:xml-element-name item) + (GIR-CORE::|parameters| + (iterate + (for parameter in (s-xml:xml-element-children item)) + (format outs "( ~A " (s-xml:xml-element-attribute parameter :|name|)) + (format outs " ~A ) " + (resolve-type (xml-element-attribute (car (s-xml:xml-element-children parameter)) 'GIR-C::|type|)))))))) + (format outs ")")) + (format outs "~%~T,@body))~%"))) + + + +(defun parse-record (outs record) + (let ((c-type (s-xml:xml-element-attribute record 'GIR-C::|type|)) + (name (s-xml:xml-element-attribute record :|name|))) + ;; we punt on object records (I think they are meant to be opaque) + (add-type name :struct) + ;; if the struct is actually an object type, we aren't interested (they are supposed to be opaque!?) + (unless (is-object-record name) + (let + ((fields (remove-if-not #'is-field-element-p (s-xml::xml-element-children record))) + (callbacks (remove-if-not #'is-callback-element-p (s-xml::xml-element-children record)))) + (format outs "~%; ----------------- ~A ----------------~%" name) + (when (or (not (zerop (length fields))) (not (zerop (length callbacks)))) + (format outs "~%; ----------------- ~A : fields ----------------~%" name) + (when (not (zerop (length fields))) + (format outs "~%(defcstruct ~A ~%" name) + (iterate + (for field in fields) + (format outs "~&~T(~A ~A)" + (lispize (s-xml:xml-element-attribute field :|name|)) + (resolve-type (s-xml:xml-element-attribute + (named-xml-element-child field 'GIR-CORE:|type|) + 'GIR-C::|type|)))) + (format outs ")~%")) + (when (not (zerop (length callbacks))) + (format outs "~%; ----------------- ~A : methods ----------------~%" name) + (iterate + (for method in callbacks) + (let ((name (s-xml:xml-element-attribute method :|name|))) + (format outs "(defcfun (~S ~A) " name (lispize name)) + (parse-function-types outs method) + (format outs ")~%~%"))))))))) + + + +(defun parse-function (outs function) + (let ((c-identifier (s-xml:xml-element-attribute function 'GIR-C::|identifier|)) + (name (s-xml:xml-element-attribute function :|name|))) + (format outs "~%; ----------------- Function: ~A ---------------- " name) + (format outs "~%(defcfun (~S ~A)" c-identifier (lispize name)) + (parse-function-types outs function) + (format outs ")~%"))) + +(defun parse-constructor (outs constructor) + (let ((c-identifier (s-xml:xml-element-attribute constructor 'GIR-C::|identifier|)) + (name (s-xml:xml-element-attribute constructor :|name|))) + (format outs "~%; ----------------- Constructor: ~A ---------------- " (lispize c-identifier)) + (format outs "~%(defcfun (~S ~A) " c-identifier (lispize c-identifier)) + (parse-function-types outs constructor) + (format outs ")~%"))) + +;; callbacks associated with the records are actually methods + + +(defun parse-enum-members (outs enum) + (iterate + (for member in (s-xml:xml-element-children enum)) + (when (eql (s-xml:xml-element-name member) 'GIR-CORE::|member|) + (format outs "~&~T(:~A ~S)" + (string-upcase (s-xml:xml-element-attribute member :|name|)) + (parse-integer (s-xml:xml-element-attribute member :|value|)))))) + +(defun parse-enumeration (outs enum) + (let ((c-type (s-xml:xml-element-attribute enum 'GIR-C::|type|)) + (name (s-xml:xml-element-attribute enum :|name|))) + (format outs "~%; ----------------- Enumeration: ~A ----------------~%" (lispize c-type)) + (add-type (string c-type) :unsigned-int) + (format outs "(defcenum ~A " name) + (parse-enum-members outs enum) + (format outs ")~%"))) + +(defun parse-bitfield (outs bitfield) + (let ((c-type (s-xml:xml-element-attribute bitfield 'GIR-C::|type|)) + (name (s-xml:xml-element-attribute bitfield :|name|))) + (format outs "~%; ----------------- ~A ----------------~%" (lispize c-type)) + (format outs "(defcenum ~A " name) + (add-type (string c-type) :unsigned-int) + (parse-enum-members outs bitfield) + (format outs ")~%"))) + +(defun parse-class (outs gclass) + (iterate + (for method in (s-xml:xml-element-children gclass)) + (when (s-xml::xml-element-p method) + (case (s-xml:xml-element-name method) + (GIR-CORE::|constructor| (parse-constructor outs method)) + (GIR-CORE::|method| (parse-function outs method)) + (GIR-CORE::|callback| (parse-signal-types outs method)))))) + +(defun parse-boxed (outs boxed) + (iterate + (for method in (s-xml:xml-element-children boxed)) + (when (s-xml::xml-element-p method) + (case (s-xml:xml-element-name method) + (GIR-CORE::|constructor| (parse-constructor outs method)) + (GIR-CORE::|method| (parse-function outs method)) + (GIR-CORE::|callback| (parse-signal-types outs method)))))) + +(defun parse-callback (outs callback) + (let ((name (s-xml:xml-element-attribute callback :|name|))) + (add-type name :pointer) + (parse-signal-types outs callback))) + +(defparameter *gir-top-level-type-elements* + ;; first pass -- + '((GIR-CORE::|bitfield| . parse-bitfield) + (GIR-CORE::|enumeration| . parse-enumeration) + (GIR-CORE::|record| . parse-record))) + +(defparameter *gir-top-level-function-elements* + ;; second pass + '((GIR-CORE::|callback| . parse-callback) + (GIR-CORE::|function| . parse-function) + (GIR-CORE::|class| . parse-class) + (GIR-GLIB::|boxed| . parse-boxed))) + + +(defun parse-element (outs elements entry) + (let ((name (s-xml:xml-element-name entry))) + (let ((fun (cdr (assoc name elements)))) + (if fun + (funcall fun outs entry))))) + + +(defun parse-namespace (outs namespace elements) + (let ((namespace-name + (alexandria::make-keyword + (string-upcase (s-xml:xml-element-attribute namespace :|name|))))) + ;; (format outs "(defpackage ~S (:use :common-lisp :cffi :iterate))~%~%" namespace-name) + (format outs "(in-package ~S)~%" namespace-name) + (iterate + (for entry in (xml-element-children namespace)) + (parse-element outs elements entry)))) + +(defun parse-repository (outs repository elements) + (iterate + (for namespace in (s-xml:xml-element-children repository)) + (parse-namespace outs namespace elements))) diff --git a/gtk.asd b/gtk.asd index 8615539..ffabc48 100644 --- a/gtk.asd +++ b/gtk.asd @@ -3,8 +3,7 @@ :depends-on (:iterate :cffi) :serial t :components - ((:file "gtk-package") - (:file "gtk-loader") + ((:file "gtk-package") (:file "gtk-types") (:file "gtk-funcs"))) diff --git a/package.lisp b/package.lisp index 5ded312..743e5de 100644 --- a/package.lisp +++ b/package.lisp @@ -6,7 +6,8 @@ ;; (asdf:oos 'asdf:load-op 'cl-fad) (defpackage :gir - (:use :common-lisp :s-xml :iterate)) + (:use :common-lisp :s-xml :iterate) + (:export "produce-binding")) (in-package :gir) diff --git a/pango.asd b/pango.asd index 26b620e..d6f9acc 100644 --- a/pango.asd +++ b/pango.asd @@ -3,7 +3,6 @@ :depends-on (:iterate :cffi) :serial t :components - ((:file "pango-package") - (:file "pango-loader") + ((:file "pango-package") (:file "pango-types") (:file "pango-funcs"))) -- 2.11.4.GIT