source: branches/working-0711/ccl/lib/late-clos.lisp @ 12955

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

Add this unused file, because I'm tired of seeing it in diffs

File size: 3.0 KB
1;;;-*-Mode: LISP; Package: CCL -*-
3;;;   Copyright (C) 2007, Clozure Associates and contributors.
4;;;   This file is part of OpenMCL. 
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
12;;;   OpenMCL 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.