1;;;; some code pulled out of CMU CL's low.lisp to solve build order problems, 2;;;; and some other stuff that just plain needs to be done early 3 4;;;; This software is part of the SBCL system. See the README file for 5;;;; more information. 6 7;;;; This software is derived from software originally released by Xerox 8;;;; Corporation. Copyright and release statements follow. Later modifications 9;;;; to the software are in the public domain and are provided with 10;;;; absolutely no warranty. See the COPYING and CREDITS files for more 11;;;; information. 12 13;;;; copyright information from original PCL sources: 14;;;; 15;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. 16;;;; All rights reserved. 17;;;; 18;;;; Use and copying of this software and preparation of derivative works based 19;;;; upon this software are permitted. Any distribution of this software or 20;;;; derivative works must comply with all applicable United States export 21;;;; control laws. 22;;;; 23;;;; This software is made available AS IS, and Xerox Corporation makes no 24;;;; warranty about the software, its performance or its conformity to any 25;;;; specification. 26 27(in-package "SB!PCL") 28 29(declaim (type (member nil early braid complete) **boot-state**)) 30(defglobal **boot-state** nil) 31 32(/show0 "starting early-low.lisp") 33 34;;; The PCL package is internal and is used by code in potential 35;;; bottlenecks. And since it's internal, no one should be 36;;; doing things like deleting and recreating it in a running target Lisp. 37;;; By the time we get to compiling the rest of PCL, 38;;; the package will have been renamed, 39;;; so subsequently compiled code should refer to "SB-PCL", not "SB!PCL". 40(define-symbol-macro *pcl-package* (load-time-value (find-package "SB-PCL") t)) 41 42(declaim (inline class-classoid)) 43(defun class-classoid (class) 44 (layout-classoid (class-wrapper class))) 45 46(declaim (inline defstruct-classoid-p)) 47(defun defstruct-classoid-p (classoid) 48 ;; It is non-obvious to me why STRUCTURE-CLASSOID-P doesn't 49 ;; work instead of this. -- NS 2008-03-14 50 (typep (layout-info (classoid-layout classoid)) 'defstruct-description)) 51 52;;; This excludes structure types created with the :TYPE option to 53;;; DEFSTRUCT. It also doesn't try to deal with types created by 54;;; hairy DEFTYPEs, e.g. 55;;; (DEFTYPE CACHE-STRUCTURE (SIZE) 56;;; (IF (> SIZE 11) 'BIG-CS 'SMALL-CS)). 57;;; KLUDGE: In fact, it doesn't seem to deal with DEFTYPEs at all. Perhaps 58;;; it needs a more mnemonic name. -- WHN 19991204 59(defun structure-type-p (type) 60 (and (symbolp type) 61 (let ((classoid (find-classoid type nil))) 62 (and classoid 63 (not (condition-classoid-p classoid)) 64 (defstruct-classoid-p classoid))))) 65 66;;; Symbol contruction utilities 67(defun format-symbol (package format-string &rest format-arguments) 68 (without-package-locks 69 (intern (possibly-base-stringize 70 (apply #'format nil format-string format-arguments)) 71 package))) 72 73(defun make-class-symbol (class-name) 74 ;; Reference a package that is now SB!PCL but later SB-PCL 75 (format-symbol (load-time-value (find-package "SB!PCL") t) 76 "*THE-CLASS-~A*" (symbol-name class-name))) 77 78(defun condition-type-p (type) 79 (and (symbolp type) 80 (condition-classoid-p (find-classoid type nil)))) 81 82(declaim (special *the-class-t* 83 *the-class-vector* *the-class-symbol* 84 *the-class-string* *the-class-sequence* 85 *the-class-rational* *the-class-ratio* 86 *the-class-number* *the-class-null* *the-class-list* 87 *the-class-integer* *the-class-float* *the-class-cons* 88 *the-class-complex* *the-class-character* 89 *the-class-bit-vector* *the-class-array* 90 *the-class-stream* *the-class-file-stream* 91 *the-class-string-stream* 92 93 *the-class-slot-object* 94 *the-class-structure-object* 95 *the-class-standard-object* 96 *the-class-function* 97 *the-class-funcallable-standard-object* 98 *the-class-class* 99 *the-class-generic-function* 100 *the-class-system-class* 101 *the-class-built-in-class* 102 *the-class-slot-class* 103 *the-class-condition-class* 104 *the-class-structure-class* 105 *the-class-std-class* 106 *the-class-standard-class* 107 *the-class-funcallable-standard-class* 108 *the-class-forward-referenced-class* 109 *the-class-method* 110 *the-class-standard-method* 111 *the-class-standard-reader-method* 112 *the-class-standard-writer-method* 113 *the-class-standard-boundp-method* 114 *the-class-global-reader-method* 115 *the-class-global-writer-method* 116 *the-class-global-boundp-method* 117 *the-class-standard-generic-function* 118 *the-class-standard-direct-slot-definition* 119 *the-class-standard-effective-slot-definition* 120 *the-class-standard-specializer* 121 122 *the-eslotd-standard-class-slots* 123 *the-eslotd-funcallable-standard-class-slots*)) 124;;;; PCL instances 125 126(sb!kernel::!defstruct-with-alternate-metaclass standard-instance 127 ;; KLUDGE: arm64 needs to have CAS-HEADER-DATA-HIGH implemented 128 :slot-names (slots #!-(and compact-instance-header x86-64) hash-code) 129 :boa-constructor %make-standard-instance 130 :superclass-name t 131 :metaclass-name standard-classoid 132 :metaclass-constructor make-standard-classoid 133 :dd-type structure 134 :runtime-type-checks-p nil) 135 136(sb!kernel::!defstruct-with-alternate-metaclass standard-funcallable-instance 137 ;; KLUDGE: Note that neither of these slots is ever accessed by its 138 ;; accessor name as of sbcl-0.pre7.63. Presumably everything works 139 ;; by puns based on absolute locations. Fun fun fun.. -- WHN 2001-10-30 140 :slot-names (clos-slots hash-code) 141 :boa-constructor %make-standard-funcallable-instance 142 :superclass-name function 143 :metaclass-name standard-classoid 144 :metaclass-constructor make-standard-classoid 145 :dd-type funcallable-structure 146 ;; Only internal implementation code will access these, and these 147 ;; accesses (slot readers in particular) could easily be a 148 ;; bottleneck, so it seems reasonable to suppress runtime type 149 ;; checks. 150 ;; 151 ;; (Except note KLUDGE above that these accessors aren't used at all 152 ;; (!) as of sbcl-0.pre7.63, so for now it's academic.) 153 :runtime-type-checks-p nil) 154 155#!+(and compact-instance-header (not x86-64)) 156(defconstant std-instance-hash-slot-index 1) 157#!-compact-instance-header 158(defconstant std-instance-hash-slot-index 2) 159;; The first data slot (either index 0 or 1) in the primitive funcallable 160;; instance is the vector of CLOS slots. Following that is the hash. 161(defconstant fsc-instance-hash-slot-index (1+ sb!vm:instance-data-start)) 162 163(/show0 "finished with early-low.lisp") 164