/[lambda-gtk]/lambda-gtk/lambda-gtk-openmcl.lisp
ViewVC logotype

Contents of /lambda-gtk/lambda-gtk-openmcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Wed Dec 21 13:39:33 2005 UTC (8 years, 4 months ago) by htaube
Branch: MAIN
CVS Tags: HEAD
Changes since 1.5: +11 -9 lines
changes to implement asdf loading
1 ;;; generates gtk interface file for Openmcl:
2 ;;; $ cd /path/to/lambda-gtk
3 ;;; $ openmcl
4 ;;; ? (load "lambda-gtk-openmcl")
5 ;;; ? (lambda-gtk "gtkffi-openmcl.lisp")
6 ;;; ? (compile-file "gtkffi-openmcl")
7 ;;; ? (load "gtkffi-openmcl")
8
9 (in-package :lambda-gtk)
10
11 ;; (eval-when (:load-toplevel :compile-toplevel :execute)
12 ;; (load (make-pathname :name "lambda-gtk-common" :type nil
13 ;; :defaults *load-pathname*)))
14
15 (defparameter alien-type-mappings
16 ;; map basic ffi types to OpenMCL foreign types
17 ;; (see ccl/lib/foreign-types.lisp)
18 `(
19 ( (void ()) :void)
20 ( (char ()) :char #+darwin ccl:%get-signed-byte
21 #-darwin ccl:%get-unsigned-byte)
22 ( (signed-char ()) :signed-char ccl:%get-signed-byte)
23 ( (short ()) :short ccl:%get-signed-word) ; 16
24 ( (int ()) :int ccl:%get-signed-long)
25 ( (long ()) :long ccl:%get-signed-long)
26 ( (unsigned-char ()) :unsigned-char ccl:%get-unsigned-byte)
27 ( (unsigned-short ()) :unsigned-short ccl:%get-unsigned-word)
28 ( (unsigned-int ()) :unsigned-int ccl:%get-unsigned-long)
29 ( (unsigned ()) :unsigned-int ccl:%get-unsigned-long)
30 ( (unsigned-long ()) :unsigned-long )
31 ( (float ()) :float ccl:%get-single-float)
32 ( (double ()) :double ccl:%get-double-float)
33 ( (long-long ()) :signed-double-word ccl::%%get-signed-longlong)
34 ( (unsigned-long-long ()) :unsigned-double-word
35 ccl::%%get-unsigned-longlong)
36 ;; handle these types specially
37 ( (typedef "gboolean") :boolean ccl:%get-signed-long)
38 ( (pointer (char ())) :char* ccl:%get-cstring)
39 ( (pointer (typedef "gchar")) :char* ccl:%get-cstring)
40 ( (pointer (typedef "guchar")) :char* ccl:%get-cstring)
41 ( (pointer (int ())) :int* ccl:%get-signed-long)
42 ( (pointer (typedef "gint")) :int* ccl:%get-signed-long)
43 ( (pointer (float ())) :float* ccl:%get-single-float)
44 ( (pointer (typedef "gfloat")) :float* ccl:%get-single-float)
45 ( (pointer (double ())) :double* ccl:%get-double-float)
46 ( (pointer (typedef "gdouble")) :double* ccl:%get-double-float)
47 ))
48
49 (defun openmcl-type (typ )
50 ;; return info for types built on basic openmcl types.
51 (labels ((findit (x)
52 (let ((y (find x alien-type-mappings
53 :key #'first :test #'equal)))
54 (cdr y))))
55 (or (findit typ )
56 (case (car typ)
57 (( typedef )
58 (if (stringp (cadr typ))
59 (let ((def (get-def (cadr typ))))
60 (and def
61 (if (struct-def? def)
62 '(:struct ccl:%inc-ptr)
63 (openmcl-type (def-data def)))))
64 (error "Nonstring typedef: ~s." typ)))
65 (( pointer )
66 (let ((x (openmcl-type (second typ))))
67 (let ((y (find x alien-type-mappings :key #'cdr
68 :test #'eq)))
69 ;(print (list :y-> y))
70 (if y
71 (or (findit `(pointer ,(first y)))
72 '(:address ccl:%get-ptr))
73 '(:address ccl:%get-ptr)))))
74 (( array )
75 (let ((x (openmcl-type (third typ))))
76 (if x
77 (cons ':array x)
78 nil)))
79 (( enum-ref )
80 (findit '(int ())))
81 ((struct-ref)
82 '(:struct ccl:%inc-ptr))
83 ((union-ref )
84 `(:union ccl:%inc-ptr))
85 (t nil)))))
86
87 (defun activate-entries ()
88 ;; mark entries in .api file for inclusion in interface file.
89 (maphash
90 (lambda (key entry)
91 (let* ((def (ffi-entry-def entry))
92 (nam (def-name def)))
93 (case (car def)
94 ((function )
95 (unless (or (upper-case-name? nam)
96 (internal-name? nam))
97 (when (gethash nam gtk-api)
98 (setf (ffi-entry-include entry) :api))))
99 (( type )
100 (when (gethash key gtk-api)
101 (when (enum-ref-def? def)
102 (let ((enum (get-entry (second (fourth def)))))
103 (setf (ffi-entry-include enum) ':api)))))
104 ((struct union)
105 (let ((x (gethash key gtk-api))
106 (i ()))
107 (when x
108 (let ((y (assoc ':accessors (cddr x))))
109 ;; activate if :accessors unspecified or if slots are
110 ;; actually listed
111 (when (or (not y) (cdr y))
112 (setf (ffi-entry-include entry) ':api)
113 ;; iterate slots and cache any that are structs.
114 ;; this info is used by make-accessor-def
115 (mapslots def
116 (lambda (name type bf?)
117 bf?
118 (let ((d (struct-slot? name type)))
119 (if d (push (list name d) i)))))
120 (when i
121 (push (cons ':included i)
122 (ffi-entry-data entry)))))))))))
123 gtk-ffi))
124
125 ;;;
126 ;;; functions ....
127
128 (defun function-arg-type (x) (openmcl-type x))
129
130 ; (function-arg-type '(pointer (typedef "GdkModifierType")))
131 ; (function-arg-type '(typedef "gdouble"))
132 ; (function-arg-type '(typedef "gboolean"))
133 ; (function-arg-type '(pointer (typedef "gint")))
134 ; (function-arg-type '(pointer (typedef "GList")))
135 ; (function-arg-type '(pointer (int ())))
136 ; (function-arg-type '(pointer (typedef "gint")))
137 ; (function-arg-type '(pointer (typedef "gdouble")))
138 ; (function-arg-type '(typedef "gint"))
139 ; (function-arg-type '(pointer (char ())))
140 ; (function-arg-type '(pointer (typedef "gchar")))
141 ; (function-arg-type '(char ()))
142 ; (function-arg-type '(typedef "gpointer"))
143 ; (function-arg-type '(pointer (pointer (typedef "PangoAttrList"))))
144 ; (function-arg-type '(pointer (pointer (char ()))))
145 ; (function-arg-type '(pointer (typedef "GdkAtom")))
146
147 (defun function-def-args (args)
148 ;; gather all args until the first 'void' arg
149 (let ((argnames '(a b c d e f g h i j k l m n o p q r s u v w x y)))
150 (loop for a in args
151 for p = (or (pop argnames)
152 (error "Fixme: not enuff argnames"))
153 for x = (openmcl-type a)
154 until (eql (car x) ':void)
155 collect (cons p x))))
156
157 (defun pass-value (arg &optional acc?)
158 ;; insure basic types are coerced to expected values.
159 (let ((typ (second arg)))
160 (cond ((eql typ ':boolean)
161 (gtk-boolean (first arg)))
162 ((find typ '(:double :gdouble :double*))
163 (gtk-double (first arg)))
164 ((find typ '(:float :gfloat :float*))
165 (gtk-single (first arg)))
166 ((and acc? (eql typ ':char*))
167 `(ccl::make-cstring , (first arg)))
168 (t
169 (first arg)))))
170
171 (defun return-value (arg)
172 ;; arg is: (var type accessor)
173 (case (second arg)
174 ((:boolean)
175 `(if (= 1 ,(first arg)) t nil)) ; 1=+gtk-true+
176 ((:char* :int* :float* :double*)
177 (list (third arg) (first arg)))
178 (t arg)))
179
180 ;;;
181 ;;; wrapper-def returns api wrapper function
182
183 (defun wrapper-def (def)
184 (let* ((cname (third def))
185 (lname (lisp-name cname))
186 (args (function-def-args (second (fourth def))))
187 (pars (loop for a in args collect (first a)))
188 (retn (cons 'z (function-arg-type (third (fourth def)))))
189 (cstrs '()) ; with-cstr bindings
190 (frecs '()) ; rlet bindings
191 (fcall '()) ; vals passed in trap call
192 (rvals '()) ; return value(s) from ffi call
193 (forms '())
194 (recvs '(r1 r2 r3 r4 r5 r6 r7 r8 r9 r10))
195 (strvs '(s1 s2 s3 s4 s5 s6 s7 s8 s9 s10)))
196 (dolist (a args)
197 ;; a = (param type accessor)
198 (case (second a)
199 ((:float :double :boolean)
200 (push (pass-value a) fcall))
201 ((:char*)
202 (let ((str (list (or (pop strvs)
203 (error "Fix me: not enuff str vars."))
204 (first a))))
205 (push str cstrs)
206 (push (first str) fcall)))
207 ((:int* :float* :double*)
208 (let ((rec (list (or (pop recvs)
209 (error "Fix me: not enuff rec vars."))
210 (getf '(:int* :int :float* :float
211 :double* :double)
212 (second a))
213 (pass-value a))))
214 ;; add to rlet bindings
215 (push rec frecs)
216 (push (first rec) fcall)
217 ;; subst in the cvariable
218 (push (return-value (cons (first rec) (cdr a)))
219 rvals)))
220 (t (push (pass-value a) fcall))))
221 (setq cstrs (nreverse cstrs))
222 (setq frecs (nreverse frecs))
223 (setq rvals (nreverse rvals))
224 (setq fcall (nreverse fcall))
225 (setq fcall (cons (format nil "#_~A" cname) fcall))
226 ;; retn is argtype of return value. possible wrap its value
227 ;; and add it to any pointer return values.
228 (let ((chk (return-value retn)))
229 (cond ((not (eql chk (return-value retn)))
230 (push chk rvals))
231 ((not (null rvals))
232 (push (first retn) rvals))))
233 (setq forms
234 (if rvals
235 `(let ((, (first retn) , fcall))
236 (values ,@ (loop for e in rvals collect e)))
237 fcall))
238 (when frecs (setf forms `(ccl:rlet (,@frecs) ,forms)))
239 (when cstrs (setf forms `(ccl:with-cstrs (,@cstrs) ,forms)))
240 `(defun ,lname ,pars ,forms)))
241
242 ; (pprint (wrapper-def (get-def "gtk_init")))
243 ; (pprint (wrapper-def (get-def "g_signal_connect_data")))
244 ; (pprint (wrapper-def (get-def "pango_layout_get_pixel_size")))
245 ; (pprint (wrapper-def (get-def "gdk_window_get_pointer")))
246 ; (pprint (wrapper-def (get-def "pango_glyph_string_index_to_x")))
247 ; (pprint (wrapper-def (get-def "pango_glyph_string_x_to_index")))
248 ; (pprint (wrapper-def (get-def "gdk_string_extents")))
249 ; (pprint (wrapper-def (get-def "gdk_window_get_geometry")))
250 ; (pprint (wrapper-def (get-def "gtk_ruler_get_range")))
251 ; (pprint (wrapper-def (get-def "pango_language_matches")))
252 ; (pprint (wrapper-def (get-def "gtk_menu_get_tearoff_state")))
253
254 ;;;
255 ;;; structs...
256
257 (defun ffi-case (name)
258 ;; respell typename as OpenMCL type symbol
259 (let* ((len (length name)))
260 (loop with m = :down and l = ()
261 for i below len
262 for c = (elt name i)
263 do (cond ((upper-case-p c)
264 (if (eql m :down)
265 (progn (setq m :up)
266 (push #\< l))))
267 (t (if (eql m :up)
268 (progn (push #\> l)
269 (setq m ':down)))))
270 (push c l)
271 finally
272 (progn (if (eql m :up)
273 (push #\> l))
274 (return (coerce (nreverse l) 'string))))))
275
276 (defun struct-slot-accessor (struct arry? slot &optional slot2)
277 ;; if arry? is true its the dimension of the array in slot
278 ;; slot = (name type wid)
279 (let* ((nam (if slot2
280 (struct-accessor-name struct (first slot) (first slot2))
281 (struct-accessor-name struct (first slot))))
282 ;; Make an openmcl slot reference from name, first
283 ;; substitiute _ for - back into slot string.
284 (acc (ffi-case (concatenate 'string ":"
285 (substitute #\_ #\- nam))))
286 (isa (function-arg-type (if slot2 (second slot2)
287 (second slot))))
288 ;; wrap optional value like other funtions in api.
289 (val (pass-value (cons 'val isa) t)))
290
291 (if (not arry?)
292 `(defun ,nam (ptr &optional (val nil vp))
293 (if vp
294 (progn (setf (pref ptr ,acc) ,val)
295 val)
296 (pref ptr ,acc)))
297 (let* ((wid (/ (third slot) arry?))
298 (max arry?)
299 (get `(,(car (last isa))
300 (ccl:pref ptr ,acc)
301 (* index ,wid)))
302 (err (format nil "\"~a[~~d]: index larger than ~d.\""
303 acc max)))
304 (if (eql (second isa) :struct)
305 (error "Fix me: don't know how to access arrays of structs.")
306 `(defun ,nam (ptr index &optional ,val)
307 (unless (< index ,max) (error ,err index))
308 (if ,val (progn (setf ,get ,val) val) , get)))))))
309
310 ; (pprint (cssym-list! (struct-accessor-defs (get-entry "GdkColor"))))
311 ; (cssym-list! (struct-accessor-defs (get-entry "GtkGammaCurve")))
312 ; (pprint (cssym-list! (struct-accessor-defs (get-entry "GtkAdjustment"))))
313 ; (pprint (cssym-list! (struct-accessor-defs (get-entry "GtkWidget"))))
314 ; (pprint (cssym-list! (struct-accessor-defs (get-entry "GtkStyle"))))
315
316 ;;;
317 ;;;
318 ;;;
319
320 (defparameter prelude-string "
321 (in-package :lambda-gtk)
322 (eval-when (:compile-toplevel :load-toplevel :execute)
323 (export '(*gtk-libdir* *gtk-libfiles*) :lambda-gtk)
324 (defvar *gtk-libdir* \"/sw/lib/\")
325 (defvar *gtk-libfiles* '(\"libgtk-x11-2.*.dylib\"))
326 (flet ((libpath (lib &aux p m)
327 (setq p (concatenate 'string *gtk-libdir* lib))
328 ;; sigh, apparently Fink's lib numbers can vary...
329 (setq m (directory p))
330 (cond ((null m)
331 (error \"Library ~S not found. Either GTK is not installed or else lambda-gtk:*gtk-libdir* needs to be set to the directory containing GTK on your machine.\" p))
332 ((cdr m)
333 (ccl::native-translated-namestring
334 (first (sort #'string-greaterp m
335 :key #'string))))
336 (t
337 (ccl::native-translated-namestring (car m))))))
338 (dolist (l *gtk-libfiles*)
339 (open-shared-library (libpath l)))))
340 (eval-when (:compile-toplevel :load-toplevel :execute)
341 (if (probe-file \"ccl:darwin-headers;gtk2;\" )
342 (use-interface-dir :gtk2)
343 (error \"Interface directory ccl:darwin-headers;gtk2; does not exist.\")))
344 ")
345
346 ;;;
347 ;;; define the gluecode. strings are replaced by cssyms.
348 ;;;
349
350 (defgluecode (:export :gtk) (defconstant "+gtk-false+" 0))
351 (defgluecode (:export :gtk) (defconstant "+gtk-true+" 1))
352 (defgluecode (:export :g) (defun "g-nullptr" () (%null-ptr)))
353 (defgluecode (:export :g) (defun "g-nullptr?" (x) (%null-ptr-p x)))
354 (defgluecode (:export nil) (defvar *gtk-init* nil))
355 (defgluecode (:export :gtk)
356 (defun "gtk-init-ensure" (&optional strings)
357 (declare (ignore strings))
358 (unless *gtk-init*
359 ("gtk-init" 0 ("g-nullptr"))
360 (setq *gtk-init* t))
361 *gtk-init*) )
362 (defgluecode (:export :gtk)
363 (defmacro struct-alloc (&rest args)
364 `(ccl::make-record ,@args)))
365 (defgluecode (:export :gtk)
366 (defun struct-free (x) ("#_free" x)))
367 (defgluecode (:export :gtk)
368 (defun string->cstring (str) (ccl::make-cstring str)))
369 (defgluecode (:export :gtk)
370 (defun cstring->string (cstr) (ccl:%get-cstring cstr)))
371 (defgluecode (:export :gtk)
372 (defun cstring-alloc (str) (ccl::make-cstring str)))
373 (defgluecode (:export :gtk)
374 (defun cstring-free (cstr) (ccl::free cstr) (values)))
375 (defgluecode (:export :gtk)
376 (defmacro define-signal-handler (name return params &body body)
377 `(ccl:defcallback ,name ,(nconc (loop for p in params
378 append
379 (if (consp p) (reverse p)
380 (list :address p)))
381 (list return))
382 ,@body)))
383 (defgluecode (:export :g) (defun "g-callback" (x) x))
384 (defgluecode (:export :g)
385 (defun "g-signal-connect" (instance detailed-signal c-handler data)
386 ("g-signal-connect-data" instance detailed-signal c-handler data
387 ("g-nullptr") 0)))
388 (defgluecode (:export :g)
389 (defun "g-signal-connect-after"
390 (instance detailed-signal c-handler data)
391 ("g-signal-connect-data" instance detailed-signal c-handler data
392 ("g-nullptr") 1)))
393 (defgluecode (:export :g)
394 (defun "g-signal-connect-swapped"
395 (instance detailed_signal c_handler data)
396 ("g-signal-connect-data" instance detailed_signal c_handler data
397 ("g-nullptr") 2)))
398
399 (defun lambda-gtk (p &optional (lib-packaging t))
400 (declare (ignore gtk-libdir))
401 (let ((*print-case* ':downcase))
402 (gtk-ffi-init)
403 (format t "~%loading api...")
404 (mapdefs #'doapi (make-pathname :directory (pathname-directory *lambda-gtk-directory*)
405 :name "gtk.api"))
406 (format t "~%loading ffi...")
407 (mapdefs #'dodef (make-pathname :directory (pathname-directory *lambda-gtk-directory*)
408 :name "gtk.ffi"))
409 (format t "~%generating entries...")
410 (activate-entries)
411 (progn (setf gtk-entries (gtk-entries)) t)
412 (when p
413 (format t "~%writing output in ~s..." p)
414 (outfile (f p)
415 (output-prelude f)
416 (output-packaging f)
417 (output-gluecode f)
418 (output-constants f)
419 (output-accessors f)
420 (output-functions f)
421 (output-postlude f)))
422 (format t "~%Done.")
423 t))
424

  ViewVC Help
Powered by ViewVC 1.1.5