Don't go through fdefn when referencing #'known-functions.
[sbcl.git] / src / pcl / dlisp3.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
8 ;;;; information.
9
10 ;;;; copyright information from original PCL sources:
11 ;;;;
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
14 ;;;;
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
18 ;;;; control laws.
19 ;;;;
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
22 ;;;; specification.
23
24 (in-package "SB-PCL")
25 \f
26 (eval-when (:compile-toplevel :load-toplevel :execute)
27 (defparameter *checking-or-caching-list*
28   '((t nil (class) nil)
29     (t nil (class class) nil)
30     (t nil (class class class) nil)
31     (t nil (class class t) nil)
32     (t nil (class class t t) nil)
33     (t nil (class class t t t) nil)
34     (t nil (class t) nil)
35     (t nil (class t t) nil)
36     (t nil (class t t t) nil)
37     (t nil (class t t t t) nil)
38     (t nil (class t t t t t) nil)
39     (t nil (class t t t t t t) nil)
40     (t nil (t class) nil)
41     (t nil (t class t) nil)
42     (t nil (t t class) nil)
43     (t nil (class) t)
44     (t nil (class class) t)
45     (t nil (class t) t)
46     (t nil (class t t) t)
47     (t nil (class t t t) t)
48     (t nil (t class) t)
49     (t t (class) nil)
50     (t t (class class) nil)
51     (t t (class class class) nil)
52     (nil nil (class) nil)
53     (nil nil (class class) nil)
54     (nil nil (class class t) nil)
55     (nil nil (class class t t) nil)
56     (nil nil (class t) nil)
57     (nil nil (t class t) nil)
58     (nil nil (class) t)
59     (nil nil (class class) t)))
60 ) ; EVAL-WHEN
61
62 ;;; Rather than compiling the constructors here, just tickle the range
63 ;;; of shapes defined above, leaving the generation of the
64 ;;; constructors to precompile-dfun-constructors.
65 (dolist (key *checking-or-caching-list*)
66   (destructuring-bind (cached-emf-p return-value-p metatypes applyp) key
67     (multiple-value-bind (args generator)
68         (if cached-emf-p
69             (if return-value-p
70                 (values (list metatypes) 'emit-constant-value)
71                 (values (list metatypes applyp) 'emit-caching))
72             (if return-value-p
73                 (values (list metatypes) 'emit-in-checking-p)
74                 (values (list metatypes applyp) 'emit-checking)))
75       (apply #'get-dfun-constructor generator args))))