chiark / gitweb /
Minor change to define-callback
[clg] / gffi / interface.lisp
1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 1999-2006 Espen S. Johnsen <espen@users.sf.net>
3 ;;
4 ;; Permission is hereby granted, free of charge, to any person obtaining
5 ;; a copy of this software and associated documentation files (the
6 ;; "Software"), to deal in the Software without restriction, including
7 ;; without limitation the rights to use, copy, modify, merge, publish,
8 ;; distribute, sublicense, and/or sell copies of the Software, and to
9 ;; permit persons to whom the Software is furnished to do so, subject to
10 ;; the following conditions:
11 ;;
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
14 ;;
15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22
23 ;; $Id: interface.lisp,v 1.7 2007-10-17 17:04:15 espen Exp $
24
25 (in-package "GFFI")
26
27
28 ;;;; Foreign function call interface
29
30 (defvar *package-prefix* nil)
31
32 (defun set-package-prefix (prefix &optional (package *package*))
33   (let ((package (find-package package)))
34     (setq *package-prefix* (delete package *package-prefix* :key #'car))
35     (push (cons package prefix) *package-prefix*))
36   prefix)
37
38 (defun package-prefix (&optional (package *package*))
39   (let ((package (find-package package)))
40     (or
41      (cdr (assoc package *package-prefix*))
42      (substitute #\_ #\- (string-downcase (package-name package))))))
43
44 (defun find-prefix-package (prefix)
45   (or
46    (car (rassoc (string-downcase prefix) *package-prefix* :test #'string=))
47    (find-package (string-upcase prefix))))
48
49 (defmacro use-prefix (prefix &optional (package *package*))
50   `(eval-when (:compile-toplevel :load-toplevel :execute)
51      (set-package-prefix ,prefix ,package)))
52
53
54 (defun default-alien-fname (lisp-name)
55   (let* ((name (substitute #\_ #\- (string-downcase lisp-name)))
56          (start (position-if-not #'(lambda (char) (char= char #\%)) name))
57          (end (if (string= "_p" name :start2 (- (length name) 2))
58                   (- (length name) 2)
59                 (length name)))
60          (stripped-name (subseq name start end))
61          (prefix (package-prefix *package*)))
62     (if (or (not prefix) (string= prefix ""))
63         stripped-name
64       (format nil "~A_~A" prefix stripped-name))))
65
66 (defun default-alien-type-name (type-name)
67   (let ((prefix (package-prefix *package*)))
68     (apply
69      #'concatenate
70      'string
71      (mapcar
72       #'string-capitalize    
73       (cons prefix (split-string (symbol-name type-name) :delimiter #\-))))))
74
75 (defun default-type-name (alien-name)
76   (let ((parts
77          (mapcar
78           #'string-upcase
79           (split-string-if alien-name #'upper-case-p))))
80     (intern
81      (concatenate-strings (rest parts) #\-)
82      (find-prefix-package (first parts)))))
83
84
85 (defun in-arg-p (style)
86   (find style '(:in :in/out :in/return :in-out :return)))
87
88 (defun out-arg-p (style)
89   (find style '(:out :in/out :in-out)))
90
91 (defun return-arg-p (style)
92   (find style '(:in/return :return)))
93
94 (defmacro defbinding (name lambda-list return-type &rest args)
95   (multiple-value-bind (lisp-name c-name)
96       (if (atom name)
97           (values name (default-alien-fname name))
98         (values-list name))
99                        
100     (let* ((lambda-list-supplied-p lambda-list)
101            (lambda-list (unless (equal lambda-list '(nil)) lambda-list))
102            (arg-types ())
103            (aux-bindings ())
104            (doc-string (when (stringp (first args)) (pop args)))
105            (parsed-args          
106             (mapcar 
107              #'(lambda (arg)
108                  (destructuring-bind 
109                      (expr type &optional (style :in) (out-type type)) 
110                      (if (atom arg) 
111                          (list arg arg)
112                        arg)
113                    (cond
114                     ((find style '(:in-out :return))
115                      (warn "Deprecated argument style: ~S" style))
116                     ((not (find style '(:in :out :in/out :in/return)))
117                      (error "Bogus argument style: ~S" style)))
118                    (when (and 
119                           (not lambda-list-supplied-p) 
120                           (namep expr) (in-arg-p style)
121                           (not (find expr lambda-list)))
122                      (push expr lambda-list)
123                      (push type arg-types))
124                    (let ((aux (unless (or (not (in-arg-p style)) (namep expr))
125                                 (gensym))))
126                      (when aux
127                        (push (list aux expr) aux-bindings))
128                      (list 
129                       (cond 
130                        ((and (namep expr) (not (in-arg-p style))) expr)
131                        ((namep expr) (make-symbol (string expr)))
132                        ((gensym)))
133                       (or aux expr) type style out-type))))
134              args)))
135   
136       (%defbinding c-name lisp-name
137        (if lambda-list-supplied-p lambda-list (nreverse lambda-list))
138        (not lambda-list-supplied-p) (nreverse arg-types)
139        aux-bindings return-type doc-string parsed-args))))
140
141
142 #+(or cmu sbcl)
143 (defun foreign-funcall (cname args return-type)
144   (let ((fparams (loop
145                   for (var expr type style out-type) in args
146                   collect (if (out-arg-p style)
147                               `(addr ,var)
148                             var)))
149         (ftypes (loop
150                  for (var expr type style out-type) in args
151                  collect (if (out-arg-p style)
152                              `(* ,(alien-type out-type))
153                            (alien-type out-type))))
154         (fname (make-symbol cname)))
155     `(with-alien ((,fname (function ,(alien-type return-type) ,@ftypes) :extern ,cname))
156       (alien-funcall ,fname ,@fparams))))
157
158 #+clisp
159 (defun foreign-funcall (cname args return-type)
160   (let* ((fparams (loop
161                    for (var expr type style out-type) in args
162                    collect (if (out-arg-p style)
163                                `(ffi:c-var-address ,var)
164                              var)))
165          (fargs (loop
166                  for (var expr type style out-type) in args
167                  collect (list var (if (out-arg-p style)
168                                        'ffi:c-pointer
169                                      (alien-type out-type)))))
170          (c-function `(ffi:c-function 
171                        (:arguments ,@fargs)
172                        (:return-type ,(alien-type return-type))
173                        (:language :stdc))))
174     `(funcall
175       (load-time-value
176        (ffi::foreign-library-function 
177         ,cname (ffi::foreign-library :default) #?(clisp>= 2 40)nil
178         nil (ffi:parse-c-type ',c-function)))
179       ,@fparams)))
180
181
182 ;; TODO: check if in and out types (if different) translates to same
183 ;; alien type
184 (defun %defbinding (cname lisp-name lambda-list declare-p arg-types aux-bindings return-type doc args)
185   (let ((out (loop
186               for (var expr type style out-type) in args
187               when (or (out-arg-p style) (return-arg-p style))
188               collect (from-alien-form out-type var)))
189         (fcall (from-alien-form return-type 
190                 (foreign-funcall cname args return-type))))
191
192     (labels ((create-wrapper (args body)
193                (if args
194                    (destructuring-bind (var expr type style out-type) (first args)
195                      (declare (ignore out-type))
196                      (alien-arg-wrapper type var expr style
197                       (create-wrapper (rest args) body)))
198                  body)))
199        `(progn
200           ,(when declare-p
201              `(declaim 
202                (ftype 
203                 (function 
204                  ,(mapcar #'argument-type arg-types)
205                  (values 
206                   ,@(when return-type (list (return-type return-type)))
207                   ,@(loop
208                      for (var expr type style out-type) in args
209                      when (out-arg-p style)
210                      collect (return-type out-type)
211                      when (return-arg-p style)
212                      collect (return-type type)))))))
213           (defun ,lisp-name ,lambda-list
214           ,doc
215           (let ,aux-bindings
216             ,(if return-type
217                  (create-wrapper args `(values ,fcall ,@out))
218                (create-wrapper args `(progn ,fcall (values ,@out))))))))))
219
220
221
222 ;;;; Dynamic (runtime) bindings
223
224 (defun mkbinding (name return-type &rest arg-types)
225   #+cmu(declare (optimize (inhibit-warnings 3)))
226   #+sbcl(declare (muffle-conditions compiler-note))
227   (let* ((c-function
228           #+(or cmu sbcl)
229           `(function ,@(mapcar #'alien-type (cons return-type arg-types)))
230           #+clisp
231           `(ffi:c-function 
232             (:arguments ,@(mapcar 
233                            #'(lambda (type)
234                                (list (gensym) (alien-type type)))
235                            arg-types)) 
236             (:return-type ,(alien-type return-type))
237             (:language :stdc)))
238          (foreign
239           #+(or cmu sbcl)
240           (handler-bind (#+sbcl(compiler-note #'(lambda (condition)
241                                                   (declare (ignore condition))
242                                                   (muffle-warning))))
243             (%heap-alien
244              (make-heap-alien-info
245               :type (parse-alien-type c-function #+sbcl nil)
246               :sap-form (let ((address (foreign-symbol-address name)))
247                           (etypecase address
248                             (integer (int-sap address))
249                             (system-area-pointer address))))))
250           #+clisp
251           (ffi::foreign-library-function name 
252            (ffi::foreign-library :default) #?(clisp>= 2 40)nil
253            nil (ffi:parse-c-type c-function)))
254          (return-value-translator (from-alien-function return-type)))
255     (multiple-value-bind (arg-translators cleanup-funcs)
256         (let ((translator/cleanup-pairs
257                (mapcar 
258                 #'(lambda (type)
259                     (multiple-value-list (to-alien-function type)))
260                 arg-types)))
261           (values 
262            (mapcar #'first translator/cleanup-pairs)
263            (mapcar #'second translator/cleanup-pairs)))
264       #'(lambda (&rest args)
265           (let ((translated-args (mapcar #'funcall arg-translators args)))
266             (prog1
267                 (funcall return-value-translator 
268                  #+(or cmu sbcl)(apply #'alien-funcall foreign translated-args)
269                  #+clisp(apply foreign translated-args))
270               (mapc 
271                #'(lambda (cleanup arg translated-arg)
272                    (when cleanup
273                      (funcall cleanup arg translated-arg)))
274                cleanup-funcs args translated-args)))))))
275
276
277
278 ;;;; C Callbacks
279
280 (defun callback-body (args return-type body)
281   (labels ((create-wrappers (args body)
282              (if args
283                  (destructuring-bind (var type) (first args)
284                    (callback-wrapper type var var
285                     (create-wrappers (rest args) body)))
286                body))
287            (create-body (args body)
288              (to-alien-form return-type 
289               (create-wrappers args `(progn ,@body)))))
290     (if (and (consp (first body)) (eq (caar body) 'declare))
291         (let ((ignored (loop
292                         for declaration in (cdar body)
293                         when (eq (first declaration) 'ignore)
294                         nconc (rest declaration))))
295           `(,(first body)
296             ,(create-body 
297               (remove-if #'(lambda (arg)
298                              (find (first arg) ignored))
299                          args)
300               (rest body))))
301       (list (create-body args body)))))
302
303
304 #+(or cmu sbcl)
305 (defmacro define-callback (name return-type args &body body)
306   (let ((define-callback 
307           #+cmu'alien:def-callback                    
308           #+(and sbcl alien-callbacks)'sb-alien::define-alien-callback
309           #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function)
310         (args (mapcar #'(lambda (arg)
311                           (if (atom arg) (list arg arg) arg))
312                       args)))
313     `(progn
314        #+cmu(defparameter ,name nil)
315        (,define-callback ,name 
316            #+(and sbcl alien-callbacks) ,(alien-type return-type) 
317            (#+(or cmu (and sbcl (not alien-callbacks))),(alien-type return-type)
318             ,@(loop
319                for (name type) in args
320                collect `(,name ,(alien-type type))))
321          ,@(callback-body args return-type body)))))
322
323 #+(or cmu sbcl)    
324 (defun callback-address (callback)
325   #+cmu(alien::callback-trampoline callback)
326   #+(and sbcl (not alien-callbacks))(sb-alien:alien-function-sap callback)
327   #+(and sbcl alien-callbacks)(sb-alien:alien-sap callback))
328
329 #+sbcl
330 (deftype callback () 
331   #-alien-callbacks'sb-alien:alien-function
332   #+alien-callbacks'sb-alien:alien)
333
334
335 ;;; The callback code for CLISP is based on code from CFFI
336 ;;; Copyright (C) 2005, James Bielman  <jamesjb@jamesjb.com>
337 ;;;           (C) 2005, Joerg Hoehle  <hoehle@users.sourceforge.net>
338
339
340 ;;; *CALLBACKS* contains the callbacks defined by the %DEFCALLBACK
341 ;;; macro.  The symbol naming the callback is the key, and the value
342 ;;; is a list containing a Lisp function, the parsed CLISP FFI type of
343 ;;; the callback, and a saved pointer that should not persist across
344 ;;; saved images.
345 #+clisp
346 (progn
347   (defvar *callbacks* (make-hash-table))
348
349   ;;; Return a CLISP FFI function type for a CFFI callback function
350   ;;; given a return type and list of argument names and types.
351   (eval-when (:compile-toplevel :load-toplevel :execute)
352     (defun callback-type (return-type arg-names arg-types)
353       (ffi:parse-c-type
354        `(ffi:c-function
355          (:arguments ,@(mapcar (lambda (sym type)
356                                  (list sym (alien-type type)))
357                                arg-names arg-types))
358          (:return-type ,(alien-type return-type))
359          (:language :stdc)))))
360   
361   ;;; Register and create a callback function.
362   (defun register-callback (name function parsed-type)
363     (setf (gethash name *callbacks*)
364           (list function parsed-type
365                 (ffi:with-foreign-object (ptr 'ffi:c-pointer)
366                  ;; Create callback by converting Lisp function to foreign
367                  (setf (ffi:memory-as ptr parsed-type) function)
368                  (ffi:foreign-value ptr)))))
369
370   ;;; Restore all saved callback pointers when restarting the Lisp
371   ;;; image.  This is pushed onto CUSTOM:*INIT-HOOKS*.
372   ;;; Needs clisp > 2.35, bugfix 2005-09-29
373   (defun restore-callback-pointers ()
374     (maphash
375      (lambda (name list)
376        (register-callback name (first list) (second list)))
377      *callbacks*))
378
379   ;;; Add RESTORE-CALLBACK-POINTERS to the lists of functions to run
380   ;;; when an image is restarted.
381   (eval-when (:load-toplevel :execute)
382     (pushnew 'restore-callback-pointers custom:*init-hooks*))
383
384   ;;; Define a callback function NAME to run BODY with arguments
385   ;;; ARG-NAMES translated according to ARG-TYPES and the return type
386   ;;; translated according to RETTYPE.  Obtain a pointer that can be
387   ;;; passed to C code for this callback by calling %CALLBACK.
388   (defmacro define-callback (name return-type args &body body)
389     (let* ((args (mapcar #'(lambda (arg)
390                              (if (atom arg) (list arg arg) arg))
391                          args))
392            (arg-names (mapcar #'first args))
393            (arg-types  (mapcar #'second args)))
394       `(progn
395          (defvar ,name ',name)
396          (register-callback ',name 
397           (lambda ,arg-names ,@(callback-body args return-type body))
398           ,(callback-type return-type arg-names arg-types)))))
399
400   ;;; Look up the name of a callback and return a pointer that can be
401   ;;; passed to a C function.  Signals an error if no callback is
402   ;;; defined called NAME.
403   (defun callback-address (name)
404     (multiple-value-bind (list winp) (gethash name *callbacks*)
405       (unless winp
406         (error "Undefined callback: ~S" name))
407       (third list)))
408
409   (deftype callback () 'symbol))
410
411
412
413 ;;;; Type expansion
414
415 (defun type-expand-1 (form)
416   #+(or cmu sbcl)
417   (let ((def (cond ((symbolp form)
418                     #+cmu(kernel::info type expander form)
419                     #+sbcl(sb-impl::info :type :expander form))
420                    ((and (consp form) (symbolp (car form)))
421                     #+cmu(kernel::info type expander (car form))
422                     #+sbcl(sb-impl::info :type :expander (car form)))
423                    (t nil))))
424     (if def
425         (values (funcall def (if (consp form) form (list form))) t)
426       (values form nil)))
427   #+clisp(ext:type-expand form t))
428
429 (defun type-expand-to (type form)
430   (labels ((expand (form0)
431              (if (eq (first (mklist form0)) type)
432                  form0
433                (multiple-value-bind (expanded-form expanded-p)
434                    (type-expand-1 form0)
435                  (if expanded-p
436                      (expand expanded-form)
437                    (error "~A can not be expanded to ~A" form type))))))
438     (expand form)))
439
440
441
442 ;;;; Type methods
443
444 (defun find-type-method (name type-spec &optional (error-p t))
445   (let ((type-methods (get name 'type-methods))
446         (specifier (if (atom type-spec)
447                        type-spec
448                      (first type-spec))))
449     (or
450      (gethash specifier type-methods)
451      (when error-p 
452        (error 
453         "No explicit type method for ~A when call width type specifier ~A found"
454         name type-spec)))))
455
456 (defun find-next-type-method (name type-spec &optional (error-p t))
457   (let ((type-methods (get name 'type-methods)))
458     (labels ((search-method-in-cpl-order (classes)
459                (when classes
460                  (or 
461                   (gethash (class-name (first classes)) type-methods)
462                   (search-method-in-cpl-order (rest classes)))))
463              (lookup-method (type-spec)
464                (if (and (symbolp type-spec) (find-class type-spec nil))
465                    (let ((class (find-class type-spec)))
466                      #?(or (sbcl>= 0 9 15) (featurep :clisp))
467                      (unless (class-finalized-p class)
468                        (finalize-inheritance class))
469                      (search-method-in-cpl-order 
470                       (rest (class-precedence-list class))))
471                  (multiple-value-bind (expanded-type expanded-p) 
472                       (type-expand-1 type-spec)
473                    (when expanded-p
474                      (or 
475                       (let ((specifier (etypecase expanded-type
476                                          (symbol expanded-type)
477                                          (list (first expanded-type)))))
478                         (gethash specifier type-methods))
479                       (lookup-method expanded-type))))))
480              (search-built-in-type-hierarchy (sub-tree)
481                (when (subtypep type-spec (first sub-tree))
482                  (or
483                   (search-nodes (cddr sub-tree))
484                   (second sub-tree))))
485              (search-nodes (nodes)
486                (loop
487                 for node in nodes
488                 as method = (search-built-in-type-hierarchy node)
489                 until method
490                 finally (return method))))
491       (or 
492        (lookup-method type-spec)
493        ;; This is to handle unexpandable types whichs doesn't name a
494        ;; class.  It may cause infinite loops with illegal
495        ;; call-next-method calls
496        (unless (or 
497                 (null type-spec)
498                 (and (symbolp type-spec) (find-class type-spec nil)))
499          (search-nodes (get name 'built-in-type-hierarchy)))
500        (when error-p
501          (error "No next type method ~A for type specifier ~A"
502           name type-spec))))))
503
504 (defun find-applicable-type-method (name type-spec &optional (error-p t))
505   (or
506    (find-type-method name type-spec nil)
507    (find-next-type-method name type-spec nil)
508    (when error-p 
509      (error 
510       "No applicable type method for ~A when call width type specifier ~A"
511       name type-spec))))
512
513
514 (defun insert-type-in-hierarchy (specifier function nodes)
515   (cond
516    ((let ((node (find specifier nodes :key #'first)))
517       (when node
518         (setf (second node) function)
519         nodes)))
520    ((let ((node
521            (find-if 
522             #'(lambda (node)
523                 (subtypep specifier (first node)))
524             nodes)))
525       (when node
526         (setf (cddr node) 
527               (insert-type-in-hierarchy specifier function (cddr node)))
528         nodes)))
529    ((let ((sub-nodes (remove-if-not 
530                       #'(lambda (node)
531                           (subtypep (first node) specifier))
532                       nodes)))
533       (cons
534        (list* specifier function sub-nodes)
535        (nset-difference nodes sub-nodes))))))
536
537 (defun add-type-method (name specifier function)
538   (setf (gethash specifier (get name 'type-methods)) function)
539   (when (typep (find-class specifier nil) 'built-in-class)
540     (setf (get name 'built-in-type-hierarchy)
541      (insert-type-in-hierarchy specifier function 
542       (get name 'built-in-type-hierarchy)))))
543   
544
545 (defmacro define-type-generic (name lambda-list &optional documentation)
546   (let ((type-spec (first lambda-list)))
547     (if (or 
548          (not lambda-list) 
549          (find type-spec '(&optional &key &rest &allow-other-keys)))
550         (error "A type generic needs at least one required argument")
551       `(progn 
552          (unless (get ',name 'type-methods)
553            (setf (get ',name 'type-methods) (make-hash-table))   
554            (setf (get ',name 'built-in-type-hierarchy) ()))
555          ,(if (intersection '(&optional &key &rest &allow-other-keys) lambda-list)
556               (let ((args (make-symbol "ARGS")))
557                 `(defun ,name (,type-spec &rest ,args)
558                    ,documentation
559                    (apply
560                     (find-applicable-type-method ',name ,type-spec)
561                     ,type-spec ,args)))
562             `(defun ,name ,lambda-list
563                ,documentation
564                (funcall 
565                 (find-applicable-type-method ',name ,type-spec)
566                 ,@lambda-list)))))))
567
568
569 (defmacro define-type-method (name lambda-list &body body)
570   (let ((specifier (cadar lambda-list)) 
571         (args (make-symbol "ARGS")))
572     `(progn
573        (add-type-method ',name ',specifier 
574         #'(lambda (&rest ,args)
575             (flet ((call-next-method (&rest args)
576                      (let ((next-method (find-next-type-method ',name ',specifier)))
577                        (apply next-method (or args ,args)))))
578               (destructuring-bind (,(caar lambda-list) ,@(rest lambda-list)) ,args
579                 ,@body))))
580        ',name)))
581
582
583 ;;; Rules for auto-exporting symbols
584
585 (defexport defbinding (name &rest args)
586   (declare (ignore args))
587   (if (symbolp name)
588       name
589     (first name)))
590
591 (defexport define-type-generic (name &rest args)
592   (declare (ignore args))
593   name)