Some progress on cairo.
[trivial-gtk.git] / defs.lisp
blob837c5c034d7720af2d5199acc24c27dc2e6e294c
2 ;; typedef char gchar;
3 ;; typedef short gshort;
4 ;; typedef long glong;
5 ;; typedef int gint;
6 ;; typedef gint gboolean;
8 ;; typedef unsigned char guchar;
9 ;; typedef unsigned short gushort;
10 ;; typedef unsigned long gulong;
11 ;; typedef unsigned int guint;
13 ;; typedef float gfloat;
14 ;; typedef double gdouble;
16 ;; typedef gulong GType
17 ;; typedef guint32 GQuark
19 ;; TO DO 1 - expand enums
20 ;; 2 - resolve simple types, above
22 (asdf:oos 'asdf:load-op 'iterate)
23 (asdf:oos 'asdf:load-op 'alexandria)
24 (asdf:oos 'asdf:load-op 'cl-fad)
26 (defpackage :defs
27 (:use :cl :iterate))
29 (in-package :defs)
31 (defparameter *type-resolver-table* (make-hash-table :test 'equal))
33 (defun add-type (newtype basetype)
34 (setf (gethash newtype *type-resolver-table*) basetype))
36 (defun is-pointer (type)
37 (let ((type-string (string type)))
38 (char= (char type-string (1- (length type-string))) #\*)))
40 (defun is-func-pointer (type)
41 (let* ((type-string (string type))
42 (type-string-len (length type-string)))
43 (or
44 (and (> type-string-len 4)
45 (string= "FUNC" (string-upcase (subseq type-string (- type-string-len 4)))))
46 (and (> type-string-len (length "Function"))
47 (string= "FUNCTION" (string-upcase (subseq type-string (- type-string-len (length "Function")))))))))
49 (defun resolve-type (type)
50 (cond
51 ((null type) :void)
52 ((or (is-pointer type) (is-func-pointer type))
53 :pointer)
55 (let ((result (gethash type *type-resolver-table* nil)))
56 (unless result
57 ;; offer restarts?
58 :pointer)
59 (unless (symbolp result)
60 (resolve-type result))
61 result))))
63 (add-type "gchar" :char)
64 (add-type "gshort" :short)
65 (add-type "glong" :long)
66 (add-type "gint" :int)
67 (add-type "guint32" :unsigned-int)
68 (add-type "gboolean" "gint")
69 (add-type "guchar" :unsigned-char)
70 (add-type "gushort" :unsigned-short)
71 (add-type "gulong" :unsigned-long)
72 (add-type "guint" :unsigned-int)
73 (add-type "gfloat" :float)
74 (add-type "gdouble" :double)
75 (add-type "gpointer" :pointer)
76 (add-type "none" :void)
77 (add-type "GType" "gulong") ;; actually its std::size_t - if it isn't gulong we lose :(
78 (add-type "GQuark" "guint")
79 (add-type "GdkDestroyNotify" :pointer)
80 (add-type "GtkDestroyNotify" :pointer)
82 ;; enum not declared
83 (add-type "GdkModifierType" :unsigned-long)
85 (add-type "GtkAccelMapForeach" :pointer)
86 (add-type "GCallback" :pointer)
87 (add-type "GdkAtom" :pointer)
89 ;; void (*GDestroyNotify) (gpointer data)
91 ;; Specifies the type of function which is called when a data element
92 ;; is destroyed. It is passed the pointer to the data element and
93 ;; should free any memory and resources allocated for it.
95 (add-type "GDestroyNotify" :pointer)
97 (defmacro with-gensyms ((&rest names) &body body)
98 `(let ,(loop for n in names collect `(,n (gensym)))
99 ,@body))
101 (defmacro once-only ((&rest names) &body body)
102 (let ((gensyms (loop for n in names collect (gensym))))
103 `(let (,@(loop for g in gensyms collect `(,g (gensym))))
104 `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
105 ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
106 ,@body)))))
108 (defun remove-prefix (prefix string)
109 (let ((result
110 (if (equalp (subseq string 0 (1- (length prefix))) prefix)
111 (subseq string 0 (1- (length prefix)))
112 string)))
113 (if (member (char result 0) '( #\_ #\-))
114 (subseq result 1)
115 result)))
117 (defun dequote (l)
118 "If the first element of a list is a quote, strip it away"
119 (when (list l)
120 (if (eql (first l) 'quote)
121 (rest l)
122 l)))
124 (defmacro format-with-properties (property-sym &body properties)
125 (mapcar
126 #'(lambda (x)
127 `(format t ,(cadr x)
128 (remove-prefix ,(getf property-sym 'in-module) ,(getf property-sym (car x)))))
129 properties))
131 ;; defs
133 (defparameter *def-table* (make-hash-table :test 'equal))
135 (defun add-def-type (def-name def-fn)
136 (setf (gethash def-name *def-table*) def-fn))
138 (defun call-def-fn (def-name form)
139 (let ((exec-fn (gethash def-name *def-table*)))
140 (when exec-fn
141 (funcall exec-fn form))))
143 (defparameter *read-and-discard* nil)
144 (defparameter *top-level-defs-file* nil)
146 (defun read-defs-file (fname)
147 (progn
148 (set-dispatch-macro-character #\# #\t
149 #'(lambda (s c n)
150 (declare (ignore s c n))
151 't))
152 (set-dispatch-macro-character #\# #\f
153 #'(lambda (s c n)
154 (declare (ignore s c n))
155 'nil))
156 (setf *top-level-defs-file* fname)
157 (with-open-file (ins fname)
158 (iterate
159 (for item in-stream ins)
160 (call-def-fn (first item) item)))))
162 ;; include
164 (defun exec-def-include (&rest form)
165 (let ((fname
166 (merge-pathnames (cadar form)
167 (directory-namestring *top-level-defs-file*))))
168 (when (cl-fad::file-exists-p fname)
169 (format t ";; including ~A ~%" fname)
170 (read-defs-file fname))))
172 (add-def-type 'INCLUDE 'exec-def-include)
174 (defun destructure-def-form (form)
175 (let*
176 ((real-form (car form))
177 (name (cadr real-form))
178 (info (cddr real-form))
179 (result (make-hash-table :test 'eql)))
180 (setf (gethash 'NAME result) name)
181 (format t "Name is ~A~%" name)
182 (format t "Destructuring ~A~%" info)
183 (iterate
184 (for item in info)
185 (format t "processing item ~A~%" item)
186 (setf (gethash (car item) result) (cdr item)))
187 result))
189 ;; enum
190 (defun exec-def-enum (&rest form)
191 (let ((properties (destructure-def-form form)))
192 (format t ";; enum ~A (~A) " (gethash 'NAME properties) (gethash 'C-NAME properties))
193 (when (gethash 'C-NAME properties)
194 (add-type (gethash 'C-NAME properties) :unsigned-long))))
196 (add-def-type 'DEFINE-ENUM 'exec-def-enum)
198 ;; ,(mapcar #'(lambda (x) `(format *debug-io* "Param : ~S~%" ,(car x))) params)))
201 ;; (with-gensyms (boxed-props)
202 ;; (setf (symbol-plist ,boxed-props) ',@params)
203 ;; (format-with-properties
204 ;; ,boxed-props
205 ;; (gtype-id "(defconstant +~A+~%")
206 ;; (copy-func "(cffi:defcfun ~A :pointer (:pointer fresh-copy))")
207 ;; (free-func "(cffi:defcfun ~A :void (:pointer this))")))))
210 ;; flags
212 ;; (defmacro define-flags (name &rest params)
213 ;; `(with-gtk-def gtk-def
214 ;; ("flags" ',name ,params)
215 ;; (let* ((gtk-params (cddddr gtk-def))
216 ;; (flag-values (find-if #'(lambda (x) (equalp (cadr x) "VALUES"))
217 ;; (cdr gtk-params)))
218 ;; (c-name (find-if #'(lambda (x) (equalp (cadr x) "C-NAME"))
219 ;; (cdr gtk-params))))
220 ;; ;; to do -- define a bunch of constants for each flag value
221 ;; (add-type (cadddr c-name) :unsigned-long))))
223 (defun exec-def-flags (&rest form)
224 (let ((properties (destructure-def-form form)))
225 (format t ";; flags ~A (~A) " (gethash 'NAME properties) (gethash 'C-NAME properties))
226 (when (gethash 'C-NAME properties)
227 (add-type (gethash 'C-NAME properties) :unsigned-long))))
229 (add-def-type 'DEFINE-FLAGS 'exec-def-flags)
231 ;; probably the silliest name ..
232 (defmacro def-def-exec ((name params) &body forms)
233 `(add-def-type ',name
234 (lambda (&rest ,params)
235 ,@forms)))
237 (def-def-exec (DEFINE-OBJECT params)
238 (let ((properties (destructure-def-form params)))
239 (format t ";; object ~A ~A " (gethash 'NAME properties)
240 (gethash 'C-NAME properties))))
242 (def-def-exec (DEFINE-INTERFACE params)
243 (let ((properties (destructure-def-form params)))
244 (format t ";; interface ~A ~A " (gethash 'NAME properties)
245 (gethash 'C-NAME properties))))
247 (def-def-exec (DEFINE-BOXED params)
248 (let ((properties (destructure-def-form params)))
249 (format t ";; boxed ~A ~A " (gethash 'NAME properties)
250 (gethash 'C-NAME properties))))
252 (def-def-exec (DEFINE-VIRTUAL params)
253 (let ((properties (destructure-def-form params)))
254 (format t ";; virtual ~A ~A " (gethash 'NAME properties)
255 (gethash 'C-NAME properties))))
257 (def-def-exec (DEFINE-TYPE params)
258 (let ((properties (destructure-def-form params)))
259 (format t ";; type ~A ~A " (gethash 'NAME properties)
260 (gethash 'C-NAME properties))))
262 (def-def-exec (DEFINE-STRUCT params)
263 (let ((properties (destructure-def-form params)))
264 (format t ";; struct ~A ~A " (gethash 'NAME properties)
265 (gethash 'C-NAME properties))))
267 (def-def-exec (DEFINE-TYPEDEF params)
268 (let ((properties (destructure-def-form params)))
269 (format t ";; typedef ~A ~A " (gethash 'NAME properties)
270 (gethash 'C-NAME properties))))
273 (def-def-exec (DEFINE-POINTER params)
274 (let ((properties (destructure-def-form params)))
275 (format t ";; pointer ~A ~A " (gethash 'NAME properties)
276 (gethash 'C-NAME properties))))
278 ;;(TYPE function NAME ASSISTANT_NEW PARAMS (PARAM C-NAME VALUE gtk_assistant_new) (PARAM IS-CONSTRUCTOR-OF VALUE GtkAssistant) (PARAM RETURN-TYPE VALUE GtkWidget*))
280 ;;(TYPE function NAME LINK_BUTTON_GET_TYPE PARAMS (PARAM C-NAME VALUE gtk_link_button_get_type) (PARAM RETURN-TYPE VALUE GType))
282 ;;(TYPE function NAME PAPER_SIZE_NEW_FROM_PPD PARAMS (PARAM C-NAME VALUE gtk_paper_size_new_from_ppd) (PARAM RETURN-TYPE VALUE GtkPaperSize*) (PARAM PARAMETERS VALUE (const-gchar* ppd_name) (const-gchar* ppd_display_name) (gdouble width) (gdouble height)))
284 ;; (defmacro define-function (name &rest params)
285 ;; `(with-gtk-def gtk-def ("function" ',name ,params)
286 ;; (let* ((gtk-params (cddddr gtk-def))
287 ;; (return-type (find-if #'(lambda (x) (equalp (cadr x) "RETURN-TYPE"))
288 ;; (cdr gtk-params)))
289 ;; (c-name (find-if #'(lambda (x) (equalp (cadr x) "C-NAME"))
290 ;; (cdr gtk-params)))
291 ;; (fn-parameters (find-if #'(lambda (x) (equalp (cadr x) "PARAMETERS"))
292 ;; (cdr gtk-params))))
293 ;; (format *debug-io* "~%~%(defcfun ~A ~A" (cadddr c-name) (resolve-type (cadddr return-type)))
294 ;; (when fn-parameters
295 ;; (loop
296 ;; for fn-parameter in (cdddr fn-parameters)
297 ;; do (format *debug-io* "~&~T( ~A ~A )" (cadr fn-parameter) (resolve-type (car fn-parameter)))))
298 ;; (format *debug-io* ")~%"))))
301 (def-def-exec (DEFINE-FUNCTION params)
302 (let ((properties (destructure-def-form params)))
303 (format t ";; function ~A ~A " (gethash 'NAME properties)
304 (gethash 'C-NAME properties))))
307 ;; (defmacro define-method (name &rest params)
308 ;; `(with-gtk-def gtk-def ("method" ',name ,params)
309 ;; (let* ((gtk-params (cddddr gtk-def))
310 ;; (of-object (find-if #'(lambda (x) (equalp (cadr x) "OF-OBJECT"))
311 ;; (cdr gtk-params)))
312 ;; (return-type (find-if #'(lambda (x) (equalp (cadr x) "RETURN-TYPE"))
313 ;; (cdr gtk-params)))
314 ;; (c-name (find-if #'(lambda (x) (equalp (cadr x) "C-NAME"))
315 ;; (cdr gtk-params)))
316 ;; (fn-parameters (find-if #'(lambda (x) (equalp (cadr x) "PARAMETERS"))
317 ;; (cdr gtk-params))))
318 ;; (format *debug-io* "~%~%(defcfun ~A ~A" (cadddr c-name) (resolve-type (cadddr return-type)))
319 ;; ;; to do -- transforn name from "GtkAccelGroup" style to "gtk-accel-group"
320 ;; (format *debug-io* "~&~T(~A ~S)" (cadddr of-object) :pointer)
321 ;; (when fn-parameters
322 ;; (loop
323 ;; for fn-parameter in (cdddr fn-parameters)
324 ;; do (format *debug-io* "~&~T( ~A ~A )" (cadr fn-parameter) (resolve-type (car fn-parameter)))))
325 ;; (format *debug-io* ")~%"))))
327 (def-def-exec (DEFINE-METHOD params)
328 (let ((properties (destructure-def-form params)))
329 (format t ";; method ~A ~A " (gethash 'NAME properties)
330 (gethash 'C-NAME properties))))
332 (defparameter HAVE_GTK_2_12 t)
334 (def-def-exec (DEFINE-IFDEF params)
335 (destructuring-bind ((name symb &rest forms)) params
336 (when (ignore-errors (symbol-value (find-symbol (string symb))))
337 (iterate
338 (for form in forms)
339 (call-def-fn (first form) form)))))
341 (def-def-exec (DEFINE-IFNDEF params)
342 (destructuring-bind ((name symb &rest forms)) params
343 (unless (ignore-errors (symbol-value (find-symbol (string symb))))
344 (iterate
345 (for form in forms)
346 (call-def-fn (first form) form))))
350 (def-def-exec (DEFINE-PROPERTY params)
351 (let ((properties (destructure-def-form params)))
352 (format t ";; property ~A ~A " (gethash 'NAME properties)
353 (gethash 'C-NAME properties))))
355 ;; (defmacro define-property (name &rest params)
356 ;; `(with-gtk-def gtk-def ( "property" ',name ,params )
357 ;; (format *debug-io* "~A" gtk-def)))
359 (def-def-exec (DEFINE-SIGNAL params)
360 (let ((properties (destructure-def-form params)))
361 (format t ";; signal ~A ~A " (gethash 'NAME properties)
362 (gethash 'C-NAME properties))))
364 ;; (defmacro define-signal (name &rest params)
365 ;; `(with-gtk-def gtk-def ( "signal" ',name ,params )
366 ;; (format *debug-io* "~A" gtk-def)))
372 (read-defs-file "/usr/share/pygtk/2.0/defs/gtk.defs")
374 ;; (define-boxed PaperSize
375 ;; (in-module "Gtk")
376 ;; (c-name "GtkPaperSize")
377 ;; (gtype-id "GTK_TYPE_PAPER_SIZE")
378 ;; )