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