1;;;; In support of PCL we compile some things into the cold image.
2;;;; Not only does this simplify the PCL bootstrap ever so slightly,
3;;;; it is nice to be able to test for types SB!PCL::%METHOD-FUNCTION
4;;;; and CLASS (neither of which will have any instances too early).
5
6;;;; This software is part of the SBCL system. See the README file for more
7;;;; information.
8
9;;;; This software is derived from software originally released by Xerox
10;;;; Corporation. Copyright and release statements follow. Later modifications
11;;;; to the software are in the public domain and are provided with
12;;;; absolutely no warranty. See the COPYING and CREDITS files for more
13;;;; information.
14
15;;;; copyright information from original PCL sources:
16;;;;
17;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
18;;;; All rights reserved.
19;;;;
20;;;; Use and copying of this software and preparation of derivative works based
21;;;; upon this software are permitted. Any distribution of this software or
22;;;; derivative works must comply with all applicable United States export
23;;;; control laws.
24;;;;
25;;;; This software is made available AS IS, and Xerox Corporation makes no
26;;;; warranty about the software, its performance or its conformity to any
27;;;; specification.
28
29(in-package "SB!PCL")
30
31
32;;; method function stuff.
33;;;
34;;; PCL historically included a so-called method-fast-function, which
35;;; is essentially a method function but with (a) a precomputed
36;;; continuation for CALL-NEXT-METHOD and (b) a permutation vector for
37;;; slot access.  [ FIXME: see if we can understand these two
38;;; optimizations before commit. ]  However, the presence of the
39;;; fast-function meant that we violated AMOP and the effect of the
40;;; :FUNCTION initarg, and furthermore got to potentially confusing
41;;; situations where the function and the fast-function got out of
42;;; sync, so that calling (method-function method) with the defined
43;;; protocol would do different things from (call-method method) in
44;;; method combination.
45;;;
46;;; So we define this internal method function structure, which we use
47;;; when we create a method function ourselves.  This means that we
48;;; can hang the various bits of information that we want off the
49;;; method function itself, and also that if a user overrides method
50;;; function creation there is no danger of having the system get
51;;; confused.
52#-sb-xc-host ; host doesn't need
53(!defstruct-with-alternate-metaclass %method-function
54  :slot-names (fast-function name)
55  :boa-constructor %make-method-function
56  :superclass-name function
57  :metaclass-name static-classoid
58  :metaclass-constructor make-static-classoid
59  :dd-type funcallable-structure)
60
61;;; Set up fake standard-classes.
62;;; This is enough to fool the compiler into optimizing TYPEP into
63;;; %INSTANCE-TYPEP.
64;;; I'll bet that at least half of these we don't need at all.
65(defparameter *!early-class-predicates*
66  '((specializer specializerp)
67    (standard-specializer standard-specializer-p)
68    (exact-class-specializer exact-class-specializer-p)
69    (class-eq-specializer class-eq-specializer-p)
70    (eql-specializer eql-specializer-p)
71    (class classp)
72    (slot-class slot-class-p)
73    (std-class std-class-p)
74    (standard-class standard-class-p)
75    (funcallable-standard-class funcallable-standard-class-p)
76    (condition-class condition-class-p)
77    (structure-class structure-class-p)
78    (forward-referenced-class forward-referenced-class-p)
79    (method method-p) ; shouldn't this be spelled METHODP? (like CLASSP)
80    (standard-method standard-method-p)
81    (accessor-method accessor-method-p)
82    (standard-accessor-method standard-accessor-method-p)
83    (standard-reader-method standard-reader-method-p)
84    (standard-writer-method standard-writer-method-p)
85    (standard-boundp-method standard-boundp-method-p)
86    (global-reader-method global-reader-method-p)
87    (global-writer-method global-writer-method-p)
88    (global-boundp-method global-boundp-method-p)
89    (generic-function generic-function-p)
90    (standard-generic-function standard-generic-function-p)
91    (method-combination method-combination-p)
92    (long-method-combination long-method-combination-p)
93    (short-method-combination short-method-combination-p)))
94
95#+sb-xc-host
96(flet ((create-fake-classoid (name fun-p)
97         (let* ((classoid (make-standard-classoid :name name))
98                (cell (sb!kernel::make-classoid-cell name classoid))
99                (layout
100                 (make-layout
101                  :classoid classoid
102                  :inherits (map 'vector #'find-layout
103                                 (cons t (if fun-p '(function))))
104                  :length 0 ; don't care
105                  :depthoid -1
106                  :invalid nil)))
107           (setf (classoid-layout classoid) layout
108                 (info :type :classoid-cell name) cell
109                 (info :type :kind name) :instance))))
110  ;; Because we don't wire into %INSTANCE-TYPEP any assumptions about
111  ;; the superclass/subclass relationships, these can all trivially be faked.
112  (dolist (x *!early-class-predicates*)
113    (let ((name (car x)))
114      ;; GENERIC-FUNCTION and STANDARD-GENERIC-FUNCTION must contain
115      ;; FUNCTION in their layouts so that their type predicates
116      ;; optimize into FUNCALLABLE-INSTANCE-P (followed by a layout check),
117      ;; rather than testing both that and INSTANCEP.
118      (create-fake-classoid name
119                            (memq name '(standard-generic-function
120                                         generic-function))))))
121
122;;; BIG FAT WARNING: These predicates can't in general be called prior to the
123;;; definition of the class which they test. However in carefully controlled
124;;; circumstances they can be called when their class under test is not defined.
125;;; The exact requirement is that the lowtag test must fail.
126;;; So for example you can call GENERIC-FUNCTION-P on a HASH-TABLE,
127;;; and CLASSP on a STRING, but you can't call CLASSP on anything that is either
128;;; a FUNCALLABLE-INSTANCE or INSTANCE.
129;;; With that caveat in mind, these are nifty things to have ASAP.
130#-sb-xc-host
131(macrolet ((define-class-predicates ()
132             `(progn
133                ,@(mapcar (lambda (x)
134                           (destructuring-bind (class-name predicate) x
135                             `(defun ,predicate (x) (typep x ',class-name))))
136                         *!early-class-predicates*))))
137  (define-class-predicates))
138