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 (outs 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 outs "~T~A~%" (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 outs "( ~A " (s-xml:xml-element-attribute parameter :|name|))
  21                     (format outs " ~A )~%"
  22                             (resolve-type (xml-element-attribute (car (s-xml:xml-element-children parameter)) 'GIR-C::|type|))))))))
  23
  24 (defun parse-signal-types (outs gsignal)
  25   (let ((name (s-xml:xml-element-attribute gsignal :|name|)))
  26         (format outs "~%; ----------------- ~A ----------------~%" name)
  27         (format outs "(defmacro make-~A-callback (name &rest body) ~%" (lispize name))
  28         (format outs "~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 outs "~T~A~%" (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 outs "( ~A " (s-xml:xml-element-attribute parameter :|name|))
  40                      (format outs " ~A )~%"
  41                              (resolve-type (xml-element-attribute (car (s-xml:xml-element-children parameter)) 'GIR-C::|type|))))))))
  42         (format outs "))~%")))
  43
  44
  45
  46 (defun parse-record (outs 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     (add-type name :struct)
  51         (unless (is-object-record name)
  52           (format outs "~%; ----------------- ~A ----------------~%" name)
  53           (format outs  "~%(defcstruct ~A ~%" name)
  54           (iterate
  55                 (for field in (s-xml:xml-element-children record))
  56                 (when (eql  (s-xml:xml-element-name field) 'GIR-CORE::|field|)
  57                   (format outs "~T(~A ~A)~%"
  58                                   (lispize (s-xml:xml-element-attribute field :|name|))
  59                                   (resolve-type (s-xml:xml-element-attribute field :|value|)))))
  60           (format outs ")~%")
  61           (iterate
  62                 (for method in (s-xml:xml-element-children record))
  63                 (when (eql (s-xml:xml-element-name method) 'GIR-CORE::|callback|)
  64                   (let ((name (s-xml:xml-element-attribute method :|name|)))
  65                         (format outs "(defcfun (~S ~A) " name (lispize name))
  66                         ;; to do -- still need to parse callbacks as methods!
  67                         (parse-function-types outs  method))))
  68           (format outs ")~%"))))
  69
  70
  71 (defun parse-function (outs 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 outs "~%; ----------------- ~A ---------------- " name)
  75         (format outs "~%(defcfun (~S ~A) ~%" c-identifier (lispize name))
  76     (parse-function-types outs function)
  77         (format outs ")~%")))
  78
  79 (defun parse-constructor (outs 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 outs "~%; ----------------- ~A ---------------- " (lispize c-identifier))
  83         (format outs "~%(defcfun (~S ~A) ~%" c-identifier (lispize c-identifier))
  84     (parse-function-types  outs constructor)
  85         (format outs ")~%")))
  86
  87 ;; callbacks associated with the records are actually methods
  88
  89
  90 (defun parse-enum-members (outs enum)
  91   (iterate
  92    (for member in (s-xml:xml-element-children enum))
  93    (when (eql (s-xml:xml-element-name member) 'GIR-CORE::|member|)
  94          (format outs "~T(:~A ~S)~%"
  95              (string-upcase (s-xml:xml-element-attribute member :|name|))
  96                          (parse-integer (s-xml:xml-element-attribute member :|value|))))))
  97
  98 (defun parse-enumeration (outs enum)
  99   (let ((c-type (s-xml:xml-element-attribute enum  'GIR-C::|type|))
 100         (name (s-xml:xml-element-attribute enum :|name|)))
 101     (format outs "~%; ----------------- ~A ----------------~%" (lispize c-type))
 102         (add-type (string c-type) :unsigned-int)
 103         (format outs "(defcenum ~A ~% " name)
 104         (parse-enum-members outs  enum)
 105         (format outs ")~%")))
 106
 107 (defun parse-bitfield (outs bitfield)
 108   (let ((c-type (s-xml:xml-element-attribute bitfield 'GIR-C::|type|))
 109         (name (s-xml:xml-element-attribute bitfield :|name|)))
 110     (format outs "~%; ----------------- ~A ----------------~%" (lispize c-type))
 111         (format outs "(defcenum ~A ~% " name)
 112         (add-type (string c-type) :unsigned-int)
 113         (parse-enum-members outs  bitfield)
 114         (format outs ")~%")))
 115
 116 (defun parse-class (outs gclass)
 117   (iterate
 118    (for method in (s-xml:xml-element-children gclass))
 119    (when (s-xml::xml-element-p method)
 120      (case (s-xml:xml-element-name method)
 121        (GIR-CORE::|constructor| (parse-constructor outs method))
 122        (GIR-CORE::|method|  (parse-function outs  method))
 123        (GIR-CORE::|callback| (parse-signal-types outs method))))))
 124
 125 (defun parse-boxed (outs boxed)
 126   (iterate
 127    (for method in (s-xml:xml-element-children boxed))
 128    (when (s-xml::xml-element-p method)
 129      (case (s-xml:xml-element-name method)
 130        (GIR-CORE::|constructor| (parse-constructor outs method))
 131        (GIR-CORE::|method|  (parse-function outs method))
 132        (GIR-CORE::|callback| (parse-signal-types outs method))))))
 133
 134 (defun parse-callback (outs callback)
 135   (let ((name (s-xml:xml-element-attribute callback :|name|)))
 136         (add-type name :pointer)
 137         (parse-signal-types outs callback)))
 138
 139 (defparameter *gir-top-level-type-elements*
 140   ;; first pass --
 141   '((GIR-CORE::|bitfield| . parse-bitfield)
 142     (GIR-CORE::|enumeration| . parse-enumeration)
 143     (GIR-CORE::|record|  . parse-record)))
 144
 145 (defparameter *gir-top-level-function-elements*
 146   ;; second pass
 147   '((GIR-CORE::|callback| . parse-callback)
 148     (GIR-CORE::|function| . parse-function)
 149     (GIR-CORE::|class| . parse-class)
 150     (GIR-GLIB::|boxed| . parse-boxed)))
 151
 152
 153 (defun parse-element (outs elements entry)
 154   (let ((name (s-xml:xml-element-name entry)))
 155     (let ((fun (cdr (assoc name elements))))
 156       (if fun
 157         (funcall fun outs entry)))))
 158
 159
 160 (defun parse-namespace (outs namespace elements)
 161   (let ((namespace-name
 162          (alexandria::make-keyword
 163           (string-upcase (s-xml:xml-element-attribute namespace :|name|)))))
 164 ;;   (format outs "(defpackage ~S (:use :common-lisp :cffi :iterate))~%~%" namespace-name)
 165     (format outs "(in-package ~S)~%" namespace-name)
 166     (iterate
 167       (for entry in (xml-element-children namespace))
 168       (parse-element outs elements entry))))
 169
 170 (defun parse-repository (outs repository elements)
 171   (iterate
 172     (for namespace in (s-xml:xml-element-children repository))
 173     (parse-namespace outs namespace elements)))