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