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