mdw@git.distorted.org.uk Git - clg/blob - 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.1 2006-04-25 20:36:05 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          (stripped-name
  57           (cond
  58            ((and
  59              (char= (char name 0) #\%)
  60              (string= "_p" name :start2 (- (length name) 2)))
  61             (subseq name 1 (- (length name) 2)))
  62            ((char= (char name 0) #\%)
  63             (subseq name 1))
  64            ((string= "_p" name :start2 (- (length name) 2))
  65             (subseq name 0 (- (length name) 2)))
  66            (name)))
  67          (prefix (package-prefix *package*)))
  68     (if (or (not prefix) (string= prefix ""))
  69         stripped-name
  70       (format nil "~A_~A" prefix stripped-name))))
  71
  72 (defun default-alien-type-name (type-name)
  73   (let ((prefix (package-prefix *package*)))
  74     (apply
  75      #'concatenate
  76      'string
  77      (mapcar
  78       #'string-capitalize
  79       (cons prefix (split-string (symbol-name type-name) :delimiter #\-))))))
  80
  81 (defun default-type-name (alien-name)
  82   (let ((parts
  83          (mapcar
  84           #'string-upcase
  85           (split-string-if alien-name #'upper-case-p))))
  86     (intern
  87      (concatenate-strings (rest parts) #\-)
  88      (find-prefix-package (first parts)))))
  89
  90
  91 (defun in-arg-p (style)
  92   (find style '(:in :in/out :in/return :in-out :return)))
  93
  94 (defun out-arg-p (style)
  95   (find style '(:out :in/out :in-out)))
  96
  97 (defun return-arg-p (style)
  98   (find style '(:in/return :return)))
  99
 100 (defmacro defbinding (name lambda-list return-type &rest args)
 101   (multiple-value-bind (lisp-name c-name)
 102       (if (atom name)
 103           (values name (default-alien-fname name))
 104         (values-list name))
 105
 106     (let* ((lambda-list-supplied-p lambda-list)
 107            (lambda-list (unless (equal lambda-list '(nil)) lambda-list))
 108            (aux-vars ())
 109            (doc-string (when (stringp (first args)) (pop args)))
 110            (parsed-args
 111             (mapcar
 112              #'(lambda (arg)
 113                  (destructuring-bind
 114                      (expr type &optional (style :in) (out-type type)) arg
 115                    (cond
 116                     ((find style '(:in-out :return))
 117                      (warn "Deprecated argument style: ~S" style))
 118                     ((not (find style '(:in :out :in/out :in/return)))
 119                      (error "Bogus argument style: ~S" style)))
 120                    (when (and
 121                           (not lambda-list-supplied-p)
 122                           (namep expr) (in-arg-p style))
 123                      (push expr lambda-list))
 124                    (let ((aux (unless (or (not (in-arg-p style)) (namep expr))
 125                                 (gensym))))
 126                      (when aux
 127                        (push `(,aux ,expr) aux-vars))
 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        aux-vars return-type doc-string parsed-args))))
 139
 140
 141 #+(or cmu sbcl)
 142 (defun foreign-funcall (cname args return-type)
 143   (let ((fparams (loop
 144                   for (var expr type style out-type) in args
 145                   collect (if (out-arg-p style)
 146                               `(addr ,var)
 147                             var)))
 148         (ftypes (loop
 149                  for (var expr type style out-type) in args
 150                  collect (if (out-arg-p style)
 151                              `(* ,(alien-type out-type))
 152                            (alien-type out-type))))
 153         (fname (make-symbol cname)))
 154     `(with-alien ((,fname (function ,(alien-type return-type) ,@ftypes) :extern ,cname))
 155       (alien-funcall ,fname ,@fparams))))
 156
 157 #+clisp
 158 (defun foreign-funcall (cname args return-type)
 159   (let* ((fparams (loop
 160                    for (var expr type style out-type) in args
 161                    collect (if (out-arg-p style)
 162                                `(ffi:c-var-address ,var)
 163                              var)))
 164          (fargs (loop
 165                  for (var expr type style out-type) in args
 166                  collect (list var (if (out-arg-p style)
 167                                        'ffi:c-pointer
 168                                      (alien-type out-type)))))
 169          (c-function `(ffi:c-function
 170                        (:arguments ,@fargs)
 171                        (:return-type ,(alien-type return-type))
 172                        (:language :stdc))))
 173     `(funcall
 174       (load-time-value
 175        (ffi::foreign-library-function ,cname (ffi::foreign-library :default)
 176         nil (ffi:parse-c-type ',c-function)))
 177       ,@fparams)))
 178
 179
 180 ;; TODO: check if in and out types (if different) translates to same
 181 ;; alien type
 182 (defun %defbinding (cname lisp-name lambda-list aux-vars return-type doc args)
 183   (let ((out (loop
 184               for (var expr type style out-type) in args
 185               when (or (out-arg-p style) (return-arg-p style))
 186               collect (from-alien-form out-type var)))
 187         (fcall (from-alien-form return-type
 188                 (foreign-funcall cname args return-type))))
 189
 190     (labels ((create-wrapper (args body)
 191                (if args
 192                    (destructuring-bind (var expr type style out-type) (first args)
 193                      (declare (ignore out-type))
 194                      (alien-arg-wrapper type var expr style
 195                       (create-wrapper (rest args) body)))
 196                  body)))
 197        `(defun ,lisp-name ,lambda-list
 198           ,doc
 199           (let ,aux-vars
 200             ,(if return-type
 201                  (create-wrapper args `(values ,fcall ,@out))
 202                (create-wrapper args `(progn ,fcall (values ,@out)))))))))
 203
 204
 205
 206 ;;;; Dynamic (runtime) bindings
 207
 208 (defun mkbinding (name return-type &rest arg-types)
 209   #+cmu(declare (optimize (inhibit-warnings 3)))
 210   #+sbcl(declare (muffle-conditions compiler-note))
 211   (let* ((c-function
 212           #+(or cmu sbcl)
 213           `(function ,@(mapcar #'alien-type (cons return-type arg-types)))
 214           #+clisp
 215           `(ffi:c-function
 216             (:arguments ,@(mapcar
 217                            #'(lambda (type)
 218                                (list (gensym) (alien-type type)))
 219                            arg-types))
 220             (:return-type ,(alien-type return-type))
 221             (:language :stdc)))
 222          (foreign
 223           #+(or cmu sbcl)
 224           (handler-bind (#+sbcl(compiler-note #'(lambda (condition)
 225                                                   (declare (ignore condition))
 226                                                   (muffle-warning))))
 227             (%heap-alien
 228              (make-heap-alien-info
 229               :type (parse-alien-type c-function #+sbcl nil)
 230               :sap-form (let ((address (foreign-symbol-address name)))
 231                           (etypecase address
 232                             (integer (int-sap address))
 233                             (system-area-pointer address))))))
 234           #+clisp
 235           (ffi::foreign-library-function name
 236            (ffi::foreign-library :default)
 237            nil (ffi:parse-c-type c-function)))
 238          (return-value-translator (from-alien-function return-type)))
 239     (multiple-value-bind (arg-translators cleanup-funcs)
 240         (let ((translator/cleanup-pairs
 241                (mapcar
 242                 #'(lambda (type)
 243                     (multiple-value-list (to-alien-function type)))
 244                 arg-types)))
 245           (values
 246            (mapcar #'first translator/cleanup-pairs)
 247            (mapcar #'second translator/cleanup-pairs)))
 248       #'(lambda (&rest args)
 249           (let ((translated-args (mapcar #'funcall arg-translators args)))
 250             (prog1
 251                 (funcall return-value-translator
 252                  #+(or cmu sbcl)(apply #'alien-funcall foreign translated-args)
 253                  #+clisp(apply foreign translated-args))
 254               (mapc
 255                #'(lambda (cleanup arg translated-arg)
 256                    (when cleanup
 257                      (funcall cleanup arg translated-arg)))
 258                cleanup-funcs args translated-args)))))))
 259
 260
 261
 262 ;;;; C Callbacks
 263
 264 (defun callback-body (args return-type body)
 265   (labels ((create-wrappers (args body)
 266              (if args
 267                  (destructuring-bind (var type) (first args)
 268                    (callback-wrapper type var var
 269                     (create-wrappers (rest args) body)))
 270                body))
 271            (create-body (args body)
 272              (to-alien-form return-type
 273               (create-wrappers args `(progn ,@body)))))
 274     (if (and (consp (first body)) (eq (caar body) 'declare))
 275         (let ((ignored (loop
 276                         for declaration in (cdar body)
 277                         when (eq (first declaration) 'ignore)
 278                         nconc (rest declaration))))
 279           `(,(first body)
 280             ,(create-body
 281               (remove-if #'(lambda (arg)
 282                              (find (first arg) ignored))
 283                          args)
 284               (rest body))))
 285       (list (create-body args body)))))
 286
 287
 288 #+(or cmu sbcl)
 289 (defmacro define-callback (name return-type args &body body)
 290   (let ((define-callback
 291           #+cmu'alien:def-callback
 292           #+(and sbcl alien-callbacks)'sb-alien::define-alien-callback
 293           #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function))
 294     `(progn
 295        #+cmu(defparameter ,name nil)
 296        (,define-callback ,name
 297            #+(and sbcl alien-callbacks) ,(alien-type return-type)
 298            (#+(or cmu (and sbcl (not alien-callbacks))),(alien-type return-type)
 299             ,@(loop
 300                for (name type) in args
 301                collect `(,name ,(alien-type type))))
 302          ,@(callback-body args return-type body)))))
 303
 304 #+(or cmu sbcl)
 305 (defun callback-address (callback)
 306   #+cmu(alien::callback-trampoline callback)
 307   #+(and sbcl (not alien-callbacks))(sb-alien:alien-function-sap callback)
 308   #+(and sbcl alien-callbacks)(sb-alien:alien-sap callback))
 309
 310 #+sbcl
 311 (deftype callback ()
 312   #-alien-callbacks'sb-alien:alien-function
 313   #+alien-callbacks'sb-alien:alien)
 314
 315
 316 ;;; The callback code for CLISP is based on code from CFFI
 317 ;;; Copyright (C) 2005, James Bielman  <jamesjb@jamesjb.com>
 318 ;;;           (C) 2005, Joerg Hoehle  <hoehle@users.sourceforge.net>
 319
 320
 321 ;;; *CALLBACKS* contains the callbacks defined by the %DEFCALLBACK
 322 ;;; macro.  The symbol naming the callback is the key, and the value
 323 ;;; is a list containing a Lisp function, the parsed CLISP FFI type of
 324 ;;; the callback, and a saved pointer that should not persist across
 325 ;;; saved images.
 326 #+clisp
 327 (progn
 328   (defvar *callbacks* (make-hash-table))
 329
 330   ;;; Return a CLISP FFI function type for a CFFI callback function
 331   ;;; given a return type and list of argument names and types.
 332   (eval-when (:compile-toplevel :load-toplevel :execute)
 333     (defun callback-type (return-type arg-names arg-types)
 334       (ffi:parse-c-type
 335        `(ffi:c-function
 336          (:arguments ,@(mapcar (lambda (sym type)
 337                                  (list sym (alien-type type)))
 338                                arg-names arg-types))
 339          (:return-type ,(alien-type return-type))
 340          (:language :stdc)))))
 341
 342   ;;; Register and create a callback function.
 343   (defun register-callback (name function parsed-type)
 344     (setf (gethash name *callbacks*)
 345           (list function parsed-type
 346                 (ffi:with-foreign-object (ptr 'ffi:c-pointer)
 347                  ;; Create callback by converting Lisp function to foreign
 348                  (setf (ffi:memory-as ptr parsed-type) function)
 349                  (ffi:foreign-value ptr)))))
 350
 351   ;;; Restore all saved callback pointers when restarting the Lisp
 352   ;;; image.  This is pushed onto CUSTOM:*INIT-HOOKS*.
 353   ;;; Needs clisp > 2.35, bugfix 2005-09-29
 354   (defun restore-callback-pointers ()
 355     (maphash
 356      (lambda (name list)
 357        (register-callback name (first list) (second list)))
 358      *callbacks*))
 359
 360   ;;; Add RESTORE-CALLBACK-POINTERS to the lists of functions to run
 361   ;;; when an image is restarted.
 362   (eval-when (:load-toplevel :execute)
 363     (pushnew 'restore-callback-pointers custom:*init-hooks*))
 364
 365   ;;; Define a callback function NAME to run BODY with arguments
 366   ;;; ARG-NAMES translated according to ARG-TYPES and the return type
 367   ;;; translated according to RETTYPE.  Obtain a pointer that can be
 368   ;;; passed to C code for this callback by calling %CALLBACK.
 369   (defmacro define-callback (name return-type args &body body)
 370     (let ((arg-names (mapcar #'first args))
 371           (arg-types (mapcar #'second args)))
 372       `(progn
 373          (defvar ,name ',name)
 374          (register-callback ',name
 375           (lambda ,arg-names ,@(callback-body args return-type body))
 376           ,(callback-type return-type arg-names arg-types)))))
 377
 378   ;;; Look up the name of a callback and return a pointer that can be
 379   ;;; passed to a C function.  Signals an error if no callback is
 380   ;;; defined called NAME.
 381   (defun callback-address (name)
 382     (multiple-value-bind (list winp) (gethash name *callbacks*)
 383       (unless winp
 384         (error "Undefined callback: ~S" name))
 385       (third list)))
 386
 387   (deftype callback () 'symbol))
 388
 389
 390
 391 ;;;; Type expansion
 392
 393 (defun type-expand-1 (form)
 394   #+(or cmu sbcl)
 395   (let ((def (cond ((symbolp form)
 396                     #+cmu(kernel::info type expander form)
 397                     #+sbcl(sb-impl::info :type :expander form))
 398                    ((and (consp form) (symbolp (car form)))
 399                     #+cmu(kernel::info type expander (car form))
 400                     #+sbcl(sb-impl::info :type :expander (car form)))
 401                    (t nil))))
 402     (if def
 403         (values (funcall def (if (consp form) form (list form))) t)
 404       (values form nil)))
 405   #+clisp(ext:type-expand form t))
 406
 407 (defun type-expand-to (type form)
 408   (labels ((expand (form0)
 409              (if (eq (first (mklist form0)) type)
 410                  form0
 411                (multiple-value-bind (expanded-form expanded-p)
 412                    (type-expand-1 form0)
 413                  (if expanded-p
 414                      (expand expanded-form)
 415                    (error "~A can not be expanded to ~A" form type))))))
 416     (expand form)))
 417
 418
 419
 420 ;;;; Type methods
 421
 422 (defun find-next-type-method (name type-spec &optional (error-p t))
 423   (let ((type-methods (get name 'type-methods)))
 424     (labels ((search-method-in-cpl-order (classes)
 425                (when classes
 426                  (or
 427                   (gethash (class-name (first classes)) type-methods)
 428                   (search-method-in-cpl-order (rest classes)))))
 429              (lookup-method (type-spec)
 430                (if (and (symbolp type-spec) (find-class type-spec nil))
 431                    (let ((class (find-class type-spec)))
 432                      #+clisp
 433                      (unless (class-finalized-p class)
 434                        (finalize-inheritance class))
 435                      (search-method-in-cpl-order
 436                       (rest (class-precedence-list class))))
 437                  (multiple-value-bind (expanded-type expanded-p)
 438                       (type-expand-1 type-spec)
 439                    (when expanded-p
 440                      (or
 441                       (let ((specifier (etypecase expanded-type
 442                                          (symbol expanded-type)
 443                                          (list (first expanded-type)))))
 444                         (gethash specifier type-methods))
 445                       (lookup-method expanded-type))))))
 446              (search-built-in-type-hierarchy (sub-tree)
 447                (when (subtypep type-spec (first sub-tree))
 448                  (or
 449                   (search-nodes (cddr sub-tree))
 450                   (second sub-tree))))
 451              (search-nodes (nodes)
 452                (loop
 453                 for node in nodes
 454                 as method = (search-built-in-type-hierarchy node)
 455                 until method
 456                 finally (return method))))
 457       (or
 458        (lookup-method type-spec)
 459        ;; This is to handle unexpandable types whichs doesn't name a
 460        ;; class.  It may cause infinite loops with illegal
 461        ;; call-next-method calls
 462        (unless (and (symbolp type-spec) (find-class type-spec nil))
 463          (search-nodes (get name 'built-in-type-hierarchy)))
 464        (when error-p
 465          (error "No next type method ~A for type specifier ~A"
 466           name type-spec))))))
 467
 468 (defun find-applicable-type-method (name type-spec &optional (error-p t))
 469   (let ((type-methods (get name 'type-methods))
 470         (specifier (if (atom type-spec)
 471                        type-spec
 472                      (first type-spec))))
 473     (or
 474      (gethash specifier type-methods)
 475      (find-next-type-method name type-spec nil)
 476      (when error-p
 477        (error
 478         "No applicable type method for ~A when call width type specifier ~A"
 479         name type-spec)))))
 480
 481 (defun insert-type-in-hierarchy (specifier function nodes)
 482   (cond
 483    ((let ((node (find specifier nodes :key #'first)))
 484       (when node
 485         (setf (second node) function)
 486         nodes)))
 487    ((let ((node
 488            (find-if
 489             #'(lambda (node)
 490                 (subtypep specifier (first node)))
 491             nodes)))
 492       (when node
 493         (setf (cddr node)
 494               (insert-type-in-hierarchy specifier function (cddr node)))
 495         nodes)))
 496    ((let ((sub-nodes (remove-if-not
 497                       #'(lambda (node)
 498                           (subtypep (first node) specifier))
 499                       nodes)))
 500       (cons
 501        (list* specifier function sub-nodes)
 502        (nset-difference nodes sub-nodes))))))
 503
 504 (defun add-type-method (name specifier function)
 505   (setf (gethash specifier (get name 'type-methods)) function)
 506   (when (typep (find-class specifier nil) 'built-in-class)
 507     (setf (get name 'built-in-type-hierarchy)
 508      (insert-type-in-hierarchy specifier function
 509       (get name 'built-in-type-hierarchy)))))
 510
 511
 512 (defmacro define-type-generic (name lambda-list &optional documentation)
 513   (let ((type-spec (first lambda-list)))
 514     (if (or
 515          (not lambda-list)
 516          (find type-spec '(&optional &key &rest &allow-other-keys)))
 517         (error "A type generic needs at least one required argument")
 518       `(progn
 519          (unless (get ',name 'type-methods)
 520            (setf (get ',name 'type-methods) (make-hash-table))
 521            (setf (get ',name 'built-in-type-hierarchy) ()))
 522          ,(if (intersection '(&optional &key &rest &allow-other-keys) lambda-list)
 523               (let ((args (make-symbol "ARGS")))
 524                 `(defun ,name (,type-spec &rest ,args)
 525                    ,documentation
 526                    (apply
 527                     (find-applicable-type-method ',name ,type-spec)
 528                     ,type-spec ,args)))
 529             `(defun ,name ,lambda-list
 530                ,documentation
 531                (funcall
 532                 (find-applicable-type-method ',name ,type-spec)
 533                 ,@lambda-list)))))))
 534
 535
 536 (defmacro define-type-method (name lambda-list &body body)
 537   (let ((specifier (cadar lambda-list))
 538         (args (make-symbol "ARGS")))
 539     `(progn
 540        (add-type-method ',name ',specifier
 541         #'(lambda (&rest ,args)
 542             (flet ((call-next-method (&rest args)
 543                      (let ((next-method (find-next-type-method ',name ',specifier)))
 544                        (apply next-method (or args ,args)))))
 545               (destructuring-bind (,(caar lambda-list) ,@(rest lambda-list)) ,args
 546                 ,@body))))
 547        ',name)))
 548
 549
 550 ;;; Rules for auto-exporting symbols
 551
 552 (defexport defbinding (name &rest args)
 553   (declare (ignore args))
 554   (if (symbolp name)
 555       name
 556     (first name)))
 557
 558 (defexport define-type-generic (name &rest args)
 559   (declare (ignore args))
 560   name)