gir-loader.lisp

   1 ;; Copyright (c) 2008 John Connors (johnc@yagc.ndo.remove.this.please.co.uk).
   2 ;;
   3 ;; Permission is hereby granted, free of charge, to any person obtaining a
   4 ;; copy of this software and associated documentation files (the "Software"), to
   5 ;; deal in the Software without restriction, including without limitation the
   6 ;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
   7 ;; sell copies of the Software, and to permit persons to whom the Software is
   8 ;; furnished to do so, subject to the following conditions:
   9 ;;
  10 ;; The above copyright notice and this permission notice shall be included in all
  11 ;; copies or substantial portions of the Software.
  12 ;;
  13 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  14 ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  15 ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  16 ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  17 ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  18 ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  19 ;; SOFTWARE.
  20
  21 (in-package :gir)
  22
  23 (defun lispize (fn-name)
  24   "Turn a c-gtk name into a lisp one"
  25   (intern (substitute #\- #\_
  26                       (if (symbolp fn-name)
  27                         (string  fn-name)
  28                         fn-name))))
  29
  30 (defparameter *type-resolver-table* (make-hash-table :test 'equal))
  31
  32 (defun add-type (newtype basetype)
  33   (setf (gethash newtype *type-resolver-table*) basetype))
  34
  35 (defun is-pointer (type)
  36   (let ((type-string (string type)))
  37         (char= (char type-string (1- (length type-string))) #\*)))
  38
  39 (defun dump-resolver-table ()
  40         (iterate
  41           (for (key val) in-hashtable  *type-resolver-table*)
  42           (format t "Type ~A~TResolution ~S~%" key val)))
  43
  44 (defun is-func-pointer (type)
  45   (let* ((type-string (string type))
  46                  (type-string-len (length type-string)))
  47     (or
  48      (and (> type-string-len 4)
  49           (string= "FUNC" (string-upcase (subseq  type-string (- type-string-len 4)))))
  50      (and (> type-string-len (length "Function"))
  51           (string= "FUNCTION" (string-upcase (subseq  type-string (- type-string-len (length "Function")))))))))
  52
  53 (defparameter *unknown-types* nil)
  54
  55 (defun resolve-type (type)
  56   (cond
  57     ((null type) ":void")
  58     ((is-pointer type) ":pointer")
  59         ((is-func-pointer type) ":pointer")
  60     (t
  61      (let ((result (gethash type *type-resolver-table* nil)))
  62        (if (or (null result) (symbolp result))
  63            (if (and  result (not (eql result :struct)))
  64                (format nil ":~A" result)
  65              (let ((typestring (string (intern type))))
  66                (unless (eql result :struct)
  67                                    (pushnew typestring *unknown-types*  :test 'equal)
  68                    (format nil ":pointer")
  69                    ;; (format t ";; ~S possibly unknown~%"  typestring)
  70                                    )
  71                (if (eql result :struct)
  72                    ;; if the type is a structure type, its probably composed into an object, return it
  73                    (format nil "~A"
  74                            typestring)
  75                    ;; otherwise just default to a pointer
  76                    (format nil ":pointer"))))
  77             (resolve-type result))))))
  78
  79 ;; instead of this, why not use defctype?
  80
  81 (add-type "gchar" :char)
  82 (add-type "gint8" :int8)
  83 (add-type "guint8" :uint8)
  84 (add-type "gshort" :short)
  85 (add-type "gint16" :int16)
  86 (add-type "guint16" :uint16)
  87 (add-type "glong" :long)
  88 (add-type "gint" :int)
  89 (add-type "int" :int)
  90 (add-type "guint32" :uint32)
  91 (add-type "gint32" :int32)
  92 (add-type "gint64" :int64)
  93 (add-type "guint64" :uint64)
  94 (add-type "gboolean" :int)
  95 (add-type "unsigned" :unsigned-int)
  96 (add-type "guchar" :unsigned-char)
  97 (add-type "gushort" :unsigned-short)
  98 (add-type "gulong" :unsigned-long)
  99 (add-type "guint" :unsigned-int)
 100 (add-type "gfloat" :float)
 101 (add-type "float" :float)
 102 (add-type "gdouble" :double)
 103 (add-type "double" :double)
 104 (add-type "gpointer" :pointer)
 105 (add-type "none" :void)
 106 (add-type "void" :void)
 107 (add-type "GType" :uint32) ;; might be  a problem on 64-bit platforms
 108 (add-type "GQuark" :uint32)
 109 (add-type "GdkAtom" :pointer)
 110 (add-type "Atom" :pointer)
 111 (add-type "GDestroyNotify" :pointer)
 112 (add-type "GCallback" :pointer)
 113 (add-type "gconstpointer" :pointer)
 114
 115 ;; X Types
 116 (add-type "XID" :uint32)
 117 (add-type "Mask" :uint32)
 118 (add-type "Atom" :uint32)
 119 (add-type "VisualID" :uint32)
 120 (add-type "Time" :uint32)
 121 (add-type "Window" :uint32)
 122 (add-type "Drawable" :uint32)
 123 (add-type "Font" :uint32)
 124 (add-type "Pixmap" :uint32)
 125 (add-type "Cursor" :uint32)
 126 (add-type "Colormap" :uint32)
 127 (add-type "GContext" :uint32)
 128 (add-type "KeySym" :uint32)
 129
 130 ;; missing enums
 131 (add-type "cairo_svg_version_t" :uint)
 132 (add-type "cairo_ps_level_t" :uint)
 133 (add-type "cairo_filter_t" :uint)
 134 (add-type "cairo_extend_t" :uint)
 135 (add-type "cairo_pattern_type_t" :uint)
 136 (add-type "cairo_format_t" :uint)
 137 (add-type "cairo_surface_type_t" :uint)
 138 (add-type "cairo_font_weight_t" :uint)
 139 (add-type "cairo_font_slant_t" :uint)
 140 (add-type "cairo_hint_metrics_t" :uint)
 141 (add-type "cairo_hint_style_t" :uint)
 142 (add-type "cairo_subpixel_order_t" :uint)
 143 (add-type "cairo_bool_t" :uint)
 144 (add-type "cairo_line_join_t" :uint)
 145 (add-type "cairo_line_cap_t" :uint)
 146 (add-type "cairo_fill_rule_t" :uint)
 147 (add-type "cairo_antialias_t" :uint)
 148 (add-type "cairo_operator_t" :uint)
 149 (add-type "cairo_content_t" :uint)
 150 (add-type "cairo_status_t" :uint)
 151
 152
 153
 154 (defun parse-gir (gir-in)
 155   (s-xml:parse-xml gir-in :output-type :xml-struct))
 156
 157 (defun parse-gir-file (pathname)
 158   (with-open-file (gir-in pathname)
 159     (parse-gir gir-in)))
 160
 161 (defparameter *repository-files* '("pango-1.0.gir"
 162                                    "cairo.gir"
 163                                                                    "atk.gir"
 164                                    "gdk-x11-2.0.gir"
 165                                    "gtk-x11-2.0.gir"))
 166
 167
 168 (defparameter *gir-files* nil)
 169
 170 (defun repository-name (filename)
 171   "Given the repository filname, pick out the lib name."
 172   (let ((firstdot (position #\. filename))
 173         (firstdash (position #\- filename)))
 174     (if firstdash
 175         (subseq filename 0 firstdash)
 176         (if firstdot
 177             (subseq filename 0 firstdot)
 178             filename))))
 179
 180 (defun load-gir-files ()
 181   (setf *gir-files*
 182         (iterate
 183          (for repository-file in *repository-files*)
 184          (collect (parse-gir-file  (merge-pathnames (cl-fad::pathname-as-file (concatenate 'string "gir-repository/gir/" repository-file))))))))
 185
 186