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
4 ;;;; This software is part of the SBCL system. See the README file for
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
13 ;;;; copyright information from original PCL sources:
15 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
16 ;;;; All rights reserved.
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
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
29 (declaim (type (member nil early braid complete
) **boot-state
**))
30 (defglobal **boot-state
** nil
)
32 (/show0
"starting early-low.lisp")
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
))
42 (declaim (inline defstruct-classoid-p
))
43 (defun defstruct-classoid-p (classoid)
44 ;; It is non-obvious to me why STRUCTURE-CLASSOID-P doesn't
45 ;; work instead of this. -- NS 2008-03-14
46 (typep (layout-info (classoid-layout classoid
)) 'defstruct-description
))
48 ;;; This excludes structure types created with the :TYPE option to
49 ;;; DEFSTRUCT. It also doesn't try to deal with types created by
50 ;;; hairy DEFTYPEs, e.g.
51 ;;; (DEFTYPE CACHE-STRUCTURE (SIZE)
52 ;;; (IF (> SIZE 11) 'BIG-CS 'SMALL-CS)).
53 ;;; KLUDGE: In fact, it doesn't seem to deal with DEFTYPEs at all. Perhaps
54 ;;; it needs a more mnemonic name. -- WHN 19991204
55 (defun structure-type-p (type)
57 (let ((classoid (find-classoid type nil
)))
59 (not (condition-classoid-p classoid
))
60 (defstruct-classoid-p classoid
)))))
62 ;;; Symbol contruction utilities
63 (defun format-symbol (package format-string
&rest format-arguments
)
64 (without-package-locks
65 (intern (apply #'format nil format-string format-arguments
) package
)))
67 (defun make-class-symbol (class-name)
68 ;; Reference a package that is now SB!PCL but later SB-PCL
69 (format-symbol (load-time-value (find-package "SB!PCL") t
)
70 "*THE-CLASS-~A*" (symbol-name class-name
)))
72 (defun make-wrapper-symbol (class-name)
73 ;; Reference a package that is now SB!PCL but later SB-PCL
74 (format-symbol (load-time-value (find-package "SB!PCL") t
)
75 "*THE-WRAPPER-~A*" (symbol-name class-name
)))
77 (defun condition-type-p (type)
79 (condition-classoid-p (find-classoid type nil
))))
81 (declaim (special *the-class-t
*
82 *the-class-vector
* *the-class-symbol
*
83 *the-class-string
* *the-class-sequence
*
84 *the-class-rational
* *the-class-ratio
*
85 *the-class-number
* *the-class-null
* *the-class-list
*
86 *the-class-integer
* *the-class-float
* *the-class-cons
*
87 *the-class-complex
* *the-class-character
*
88 *the-class-bit-vector
* *the-class-array
*
89 *the-class-stream
* *the-class-file-stream
*
90 *the-class-string-stream
*
92 *the-class-slot-object
*
93 *the-class-structure-object
*
94 *the-class-standard-object
*
95 *the-class-funcallable-standard-object
*
97 *the-class-generic-function
*
98 *the-class-system-class
*
99 *the-class-built-in-class
*
100 *the-class-slot-class
*
101 *the-class-condition-class
*
102 *the-class-structure-class
*
103 *the-class-std-class
*
104 *the-class-standard-class
*
105 *the-class-funcallable-standard-class
*
106 *the-class-forward-referenced-class
*
108 *the-class-standard-method
*
109 *the-class-standard-reader-method
*
110 *the-class-standard-writer-method
*
111 *the-class-standard-boundp-method
*
112 *the-class-global-reader-method
*
113 *the-class-global-writer-method
*
114 *the-class-global-boundp-method
*
115 *the-class-standard-generic-function
*
116 *the-class-standard-direct-slot-definition
*
117 *the-class-standard-effective-slot-definition
*
118 *the-class-standard-specializer
*
120 *the-eslotd-standard-class-slots
*
121 *the-eslotd-funcallable-standard-class-slots
*))
123 (declaim (special *the-wrapper-of-t
*
124 *the-wrapper-of-vector
* *the-wrapper-of-symbol
*
125 *the-wrapper-of-string
* *the-wrapper-of-sequence
*
126 *the-wrapper-of-rational
* *the-wrapper-of-ratio
*
127 *the-wrapper-of-number
* *the-wrapper-of-null
*
128 *the-wrapper-of-list
* *the-wrapper-of-integer
*
129 *the-wrapper-of-float
* *the-wrapper-of-cons
*
130 *the-wrapper-of-complex
* *the-wrapper-of-character
*
131 *the-wrapper-of-bit-vector
* *the-wrapper-of-array
*))
133 (/show0
"finished with early-low.lisp")