Loading on win32 systems tested
[trivial-gtk.git] / gir-loader.lisp
blob082c2562d3775958877c498113b5a1873eaa445d
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.
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.
21 (in-package :gir)
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))))
30 (defparameter *type-resolver-table* (make-hash-table :test 'equal))
32 (defun add-type (newtype basetype)
33 (setf (gethash newtype *type-resolver-table*) basetype))
35 (defun is-pointer (type)
36 (let ((type-string (string type)))
37 (char= (char type-string (1- (length type-string))) #\*)))
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)))
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")))))))))
53 (defparameter *unknown-types* nil)
55 (defun resolve-type (type)
56 (cond
57 ((null type) ":void")
58 ((is-pointer type) ":pointer")
59 ((is-func-pointer type) ":pointer")
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)
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))))))
79 ;; instead of this, why not use defctype?
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)
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)
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)
154 (defun parse-gir (gir-in)
155 (s-xml:parse-xml gir-in :output-type :xml-struct))
157 (defun parse-gir-file (pathname)
158 (with-open-file (gir-in pathname)
159 (parse-gir gir-in)))
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"))
168 (defparameter *gir-files* nil)
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))))
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))))))))