gir-parser.lisp

   1 (in-package :gir)
   2
   3 (defun named-xml-element-child (element name)
   4   (find-if #'(lambda (x)
   5                (and (s-xml::xml-element-p x)
   6                     (equal (s-xml::xml-element-name x) name)))
   7            (s-xml::xml-element-children element)))
   8
   9 (defun is-field-element-p (element)
  10   (equal  (s-xml:xml-element-name element) 'GIR-CORE::|field|))
  11
  12 (defun is-callback-element-p (element)
  13   (equal  (s-xml:xml-element-name element) 'GIR-CORE::|callback|))
  14
  15 (defun is-object-record (record)
  16   (let* ((record-string (string record))
  17          (record-string-len (length record-string)))
  18     (or
  19      (and (> record-string-len 6)
  20           (string= "OBJECT" (string-upcase (subseq  record-string (- record-string-len 6))))))))
  21
  22 (defun parse-function-types (outs method)
  23   (let ((return-value
  24          (named-xml-element-child method 'GIR-CORE:|return-value|))
  25         (parameters
  26          (named-xml-element-child method 'GIR-CORE:|parameters|)))
  27     (let ((return-type (first (xml-element-children return-value))))
  28         (format outs " ~A~%" (resolve-type (s-xml:xml-element-attribute return-type 'GIR-C::|type|))))
  29     (when (s-xml::xml-element-p parameters)
  30       (iterate
  31         (for parameter in (s-xml:xml-element-children parameters))
  32         (format outs "~&~T( ~A " (s-xml:xml-element-attribute parameter :|name|))
  33         (format outs " ~A )"
  34                 (resolve-type (xml-element-attribute (car (s-xml:xml-element-children parameter)) 'GIR-C::|type|)))))))
  35
  36 (defun parse-signal-types (outs gsignal)
  37   (let ((name (s-xml:xml-element-attribute gsignal :|name|)))
  38     (format outs "~%; ----------------- ~A ----------------~%" name)
  39     (format outs "(defmacro make-~A (name &rest body) ~%" (lispize name))
  40     (format outs "~T(defcallback ,name ")
  41     (let ((return-value (named-xml-element-child gsignal 'GIR-CORE::|return-value|)))
  42       (let ((return-type (first (xml-element-children return-value))))
  43         (format outs "~&~T~A" (resolve-type (s-xml:xml-element-attribute return-type 'GIR-C::|type|))))
  44       (format outs "~T( ")
  45       (iterate
  46         (for item in (s-xml:xml-element-children gsignal))
  47         (when (s-xml::xml-element-p item)
  48           (case (s-xml:xml-element-name item)
  49             (GIR-CORE::|parameters|
  50                        (iterate
  51                          (for parameter in (s-xml:xml-element-children item))
  52                          (format outs "( ~A " (s-xml:xml-element-attribute parameter :|name|))
  53                          (format outs " ~A ) "
  54                                  (resolve-type (xml-element-attribute (car (s-xml:xml-element-children parameter)) 'GIR-C::|type|))))))))
  55       (format outs ")"))
  56     (format outs "~%~T,@body))~%")))
  57
  58
  59
  60 (defun parse-record (outs record)
  61   (let ((c-type (s-xml:xml-element-attribute record  'GIR-C::|type|))
  62         (name (s-xml:xml-element-attribute record :|name|)))
  63     ;; we punt on object records (I think they are meant to be opaque)
  64     (add-type name :struct)
  65     ;; if the struct is actually an object type, we aren't interested (they are supposed to be opaque!?)
  66     (unless (is-object-record name)
  67       (let
  68           ((fields (remove-if-not #'is-field-element-p (s-xml::xml-element-children record)))
  69            (callbacks (remove-if-not #'is-callback-element-p (s-xml::xml-element-children record))))
  70         (format outs "~%; ----------------- ~A ----------------~%" name)
  71         (when (or (not (zerop (length fields))) (not (zerop (length callbacks))))
  72           (format outs "~%; ----------------- ~A : fields ----------------~%" name)
  73           (when (not (zerop (length fields)))
  74             (format outs  "~%(defcstruct ~A ~%" name)
  75             (iterate
  76               (for field in fields)
  77               (format outs "~&~T(~A ~A)"
  78                       (lispize (s-xml:xml-element-attribute field :|name|))
  79                       (resolve-type (s-xml:xml-element-attribute
  80                                      (named-xml-element-child field 'GIR-CORE:|type|)
  81                                      'GIR-C::|type|))))
  82               (format outs ")~%"))
  83           (when (not (zerop (length callbacks)))
  84             (format outs "~%; ----------------- ~A : methods ----------------~%" name)
  85             (iterate
  86               (for method in callbacks)
  87               (let ((name (s-xml:xml-element-attribute method :|name|)))
  88                 (format outs "(defcfun (~S ~A) " name (lispize name))
  89                 (parse-function-types outs  method)
  90                 (format outs ")~%~%")))))))))
  91
  92
  93
  94 (defun parse-function (outs function)
  95   (let ((c-identifier (s-xml:xml-element-attribute function  'GIR-C::|identifier|))
  96         (name (s-xml:xml-element-attribute function :|name|)))
  97     (format outs "~%; ----------------- Function: ~A ---------------- " name)
  98     (format outs "~%(defcfun (~S ~A)" c-identifier (lispize name))
  99     (parse-function-types outs function)
 100     (format outs ")~%")))
 101
 102 (defun parse-constructor (outs constructor)
 103   (let ((c-identifier (s-xml:xml-element-attribute constructor  'GIR-C::|identifier|))
 104         (name (s-xml:xml-element-attribute constructor :|name|)))
 105     (format outs "~%; ----------------- Constructor: ~A ---------------- " (lispize c-identifier))
 106     (format outs "~%(defcfun (~S ~A) " c-identifier (lispize c-identifier))
 107     (parse-function-types  outs constructor)
 108     (format outs ")~%")))
 109
 110 ;; callbacks associated with the records are actually methods
 111
 112
 113 (defun parse-enum-members (outs enum)
 114   (iterate
 115     (for member in (s-xml:xml-element-children enum))
 116     (when (eql (s-xml:xml-element-name member) 'GIR-CORE::|member|)
 117       (format outs "~&~T(:~A ~S)"
 118               (string-upcase (s-xml:xml-element-attribute member :|name|))
 119               (parse-integer (s-xml:xml-element-attribute member :|value|))))))
 120
 121 (defun parse-enumeration (outs enum)
 122   (let ((c-type (s-xml:xml-element-attribute enum  'GIR-C::|type|))
 123         (name (s-xml:xml-element-attribute enum :|name|)))
 124     (format outs "~%; ----------------- Enumeration: ~A ----------------~%" (lispize c-type))
 125     (add-type (string c-type) :unsigned-int)
 126     (format outs "(defcenum ~A " name)
 127     (parse-enum-members outs  enum)
 128     (format outs ")~%")))
 129
 130 (defun parse-bitfield (outs bitfield)
 131   (let ((c-type (s-xml:xml-element-attribute bitfield 'GIR-C::|type|))
 132         (name (s-xml:xml-element-attribute bitfield :|name|)))
 133     (format outs "~%; ----------------- ~A ----------------~%" (lispize c-type))
 134     (format outs "(defcenum ~A  " name)
 135     (add-type (string c-type) :unsigned-int)
 136     (parse-enum-members outs  bitfield)
 137     (format outs ")~%")))
 138
 139 (defun parse-class (outs gclass)
 140   (iterate
 141     (for method in (s-xml:xml-element-children gclass))
 142     (when (s-xml::xml-element-p method)
 143       (case (s-xml:xml-element-name method)
 144         (GIR-CORE::|constructor| (parse-constructor outs method))
 145         (GIR-CORE::|method|  (parse-function outs  method))
 146         (GIR-CORE::|callback| (parse-signal-types outs method))))))
 147
 148 (defun parse-boxed (outs boxed)
 149   (iterate
 150     (for method in (s-xml:xml-element-children boxed))
 151     (when (s-xml::xml-element-p method)
 152       (case (s-xml:xml-element-name method)
 153         (GIR-CORE::|constructor| (parse-constructor outs method))
 154         (GIR-CORE::|method|  (parse-function outs method))
 155         (GIR-CORE::|callback| (parse-signal-types outs method))))))
 156
 157 (defun parse-callback (outs callback)
 158   (let ((name (s-xml:xml-element-attribute callback :|name|)))
 159     (add-type name :pointer)
 160     (parse-signal-types outs callback)))
 161
 162 (defparameter *gir-top-level-type-elements*
 163   ;; first pass --
 164   '((GIR-CORE::|bitfield| . parse-bitfield)
 165     (GIR-CORE::|enumeration| . parse-enumeration)
 166     (GIR-CORE::|record|  . parse-record)))
 167
 168 (defparameter *gir-top-level-function-elements*
 169   ;; second pass
 170   '((GIR-CORE::|callback| . parse-callback)
 171     (GIR-CORE::|function| . parse-function)
 172     (GIR-CORE::|class| . parse-class)
 173     (GIR-GLIB::|boxed| . parse-boxed)))
 174
 175
 176 (defun parse-element (outs elements entry)
 177   (let ((name (s-xml:xml-element-name entry)))
 178     (let ((fun (cdr (assoc name elements))))
 179       (if fun
 180           (funcall fun outs entry)))))
 181
 182
 183 (defun parse-namespace (outs namespace elements)
 184   (let ((namespace-name
 185          (alexandria::make-keyword
 186           (string-upcase (s-xml:xml-element-attribute namespace :|name|)))))
 187     ;;   (format outs "(defpackage ~S (:use :common-lisp :cffi :iterate))~%~%" namespace-name)
 188     (format outs "(in-package ~S)~%" namespace-name)
 189     (iterate
 190       (for entry in (xml-element-children namespace))
 191       (parse-element outs elements entry))))
 192
 193 (defun parse-repository (outs repository elements)
 194   (iterate
 195     (for namespace in (s-xml:xml-element-children repository))
 196     (parse-namespace outs namespace elements)))