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 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)))) 76