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