source: branches/qres/ccl/lib/late-clos.lisp @ 14308

Last change on this file since 14308 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

File size: 3.0 KB
1;;;-*-Mode: LISP; Package: CCL -*-
3;;;   Copyright (C) 2007-2009 Clozure Associates and contributors.
4;;;   This file is part of Clozure CL. 
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;   The LLGPL is also available online at
17;;; Maybe compile specialized discriminating code (dcode) for generic
18;;; functions, if it seems likely that that might perform better than
19;;; the general generic-function-dispatch mechanism.
22;;; If the GF accepts a fixed number of arguments, return its
23;;; lambda list.
24(defun gf-fixed-arg-lambda-list (gf)
25  (let* ((lambda-list (generic-function-lambda-list gf)))
26    (dolist (arg lambda-list lambda-list)
27      (when (member arg lambda-list-keywords)
28        (return nil)))))
30(defun generate-conformance-test (arg-name specializer)
31  (cond ((typep specializer 'eql-specializer)
32         `(eql ,arg-name ',(eql-specializer-object specializer)))
33        ((eq specializer *t-class*))
34        ((typep specializer 'standard-class)
35         (let* ((wrapper (gensym)))
36           `(let* ((,wrapper (if (= (the fixnum (typecode ,arg-name))
37                                    target::subtag-instance)
38                               (instance.class-wrapper ,arg-name))))
39             (and ,wrapper
40              (memq ,specializer (or (%wrapper-cpl ,wrapper)
41                                                (%inited-class-cpl
42                                                 (%wrapper-class ,wrapper))))))))
43        (t `(typep ,arg-name ',(class-name specializer)))))
45(defun generate-conformance-clause (args method)
46  `((and ,@(mapcar #'generate-conformance-test args (method-specializers method)))
47     (funcall ,(method-function method) ,@args)))
49;;; Generate code to call the single fixed-arg primary method
50;;; defined on GF if all args are conformant, or to call
51;;; NO-APPLICABLE-METHOD otherwise.
52;;; Note that we can often do better than this for accessor
53;;; methods (especially reader methods) as a very late (delivery-time)
54;;; optimization.
55(defun dcode-for-fixed-arg-singleton-gf (gf)
56  (let* ((methods (generic-function-methods gf))
57         (method (car methods))
58         (args (gf-fixed-arg-lambda-list gf)))
59    (when (and method
60               args
61               (null (cdr methods))
62               (null (method-qualifiers method))
63               (dolist (spec (method-specializers method))
64                 (unless (eq spec *t-class*) (return t))))
65      (compile nil
66               `(lambda ,args
67                 (cond ,(generate-conformance-clause args method)
68                       (t (no-applicable-method ,gf ,@args))))))))
70(register-non-dt-dcode-function #'dcode-for-fixed-arg-singleton-gf)
Note: See TracBrowser for help on using the repository browser.