1 ;;;; This software is part of the SBCL system. See the README file for
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
10 ;;;; copyright information from original PCL sources:
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
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
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
29 (eval-when (:compile-toplevel :load-toplevel :execute)
30 (defparameter *checking-or-caching-list*
32 (t nil (class class) nil)
33 (t nil (class class class) nil)
34 (t nil (class class t) nil)
35 (t nil (class class t t) nil)
36 (t nil (class class t t t) nil)
38 (t nil (class t t) nil)
39 (t nil (class t t t) nil)
40 (t nil (class t t t t) nil)
41 (t nil (class t t t t t) nil)
42 (t nil (class t t t t t t) nil)
44 (t nil (t class t) nil)
45 (t nil (t t class) nil)
47 (t nil (class class) t)
50 (t nil (class t t t) t)
53 (t t (class class) nil)
54 (t t (class class class) nil)
56 (nil nil (class class) nil)
57 (nil nil (class class t) nil)
58 (nil nil (class class t t) nil)
59 (nil nil (class t) nil)
60 (nil nil (t class t) nil)
62 (nil nil (class class) t)))
65 (defmacro make-checking-or-caching-function-list ()
66 `(list ,@(mapcar #'(lambda (key)
67 `(cons ',key (emit-checking-or-caching-macro ,@key)))
68 *checking-or-caching-list*)))
70 ;;; Rather than compiling the constructors here, just tickle the range
71 ;;; of shapes defined above, leaving the generation of the
72 ;;; constructors to precompile-dfun-constructors.
73 (dolist (key *checking-or-caching-list*)
74 (destructuring-bind (cached-emf-p return-value-p metatypes applyp) key
75 (multiple-value-bind (args generator)
78 (values (list metatypes) 'emit-constant-value)
79 (values (list metatypes applyp) 'emit-caching))
81 (values (list metatypes) 'emit-in-checking-p)
82 (values (list metatypes applyp) 'emit-checking)))
83 (apply #'get-dfun-constructor generator args))))