gir-parser.lisp

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