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 (/show
"starting early-low.lisp")
31 ;;; The PCL package is internal and is used by code in potential
32 ;;; bottlenecks. And since it's internal, no one should be
33 ;;; doing things like deleting and recreating it in a running target Lisp.
34 (define-symbol-macro *pcl-package
* (load-time-value (find-package "SB-PCL") t
))
36 (declaim (inline defstruct-classoid-p
))
37 (defun defstruct-classoid-p (classoid)
38 ;; It is non-obvious to me why STRUCTURE-CLASSOID-P doesn't
39 ;; work instead of this. -- NS 2008-03-14
40 (typep (layout-info (classoid-layout classoid
)) 'defstruct-description
))
42 ;;; This excludes structure types created with the :TYPE option to
43 ;;; DEFSTRUCT. It also doesn't try to deal with types created by
44 ;;; hairy DEFTYPEs, e.g.
45 ;;; (DEFTYPE CACHE-STRUCTURE (SIZE)
46 ;;; (IF (> SIZE 11) 'BIG-CS 'SMALL-CS)).
47 ;;; KLUDGE: In fact, it doesn't seem to deal with DEFTYPEs at all. Perhaps
48 ;;; it needs a more mnemonic name. -- WHN 19991204
49 (defun structure-type-p (type)
51 (let ((classoid (find-classoid type nil
)))
53 (not (condition-classoid-p classoid
))
54 (defstruct-classoid-p classoid
)))))
56 ;;; Symbol contruction utilities
57 (defun format-symbol (package format-string
&rest format-arguments
)
58 (without-package-locks
59 (intern (apply #'format nil format-string format-arguments
) package
)))
61 (defun make-class-symbol (class-name)
62 (format-symbol *pcl-package
* "*THE-CLASS-~A*" (symbol-name class-name
)))
64 (defun make-wrapper-symbol (class-name)
65 (format-symbol *pcl-package
* "*THE-WRAPPER-~A*" (symbol-name class-name
)))
67 (defun condition-type-p (type)
69 (condition-classoid-p (find-classoid type nil
))))
71 (declaim (special *the-class-t
*
72 *the-class-vector
* *the-class-symbol
*
73 *the-class-string
* *the-class-sequence
*
74 *the-class-rational
* *the-class-ratio
*
75 *the-class-number
* *the-class-null
* *the-class-list
*
76 *the-class-integer
* *the-class-float
* *the-class-cons
*
77 *the-class-complex
* *the-class-character
*
78 *the-class-bit-vector
* *the-class-array
*
79 *the-class-stream
* *the-class-file-stream
*
80 *the-class-string-stream
*
82 *the-class-slot-object
*
83 *the-class-structure-object
*
84 *the-class-standard-object
*
85 *the-class-funcallable-standard-object
*
87 *the-class-generic-function
*
88 *the-class-system-class
*
89 *the-class-built-in-class
*
90 *the-class-slot-class
*
91 *the-class-condition-class
*
92 *the-class-structure-class
*
94 *the-class-standard-class
*
95 *the-class-funcallable-standard-class
*
96 *the-class-forward-referenced-class
*
98 *the-class-standard-method
*
99 *the-class-standard-reader-method
*
100 *the-class-standard-writer-method
*
101 *the-class-standard-boundp-method
*
102 *the-class-global-reader-method
*
103 *the-class-global-writer-method
*
104 *the-class-global-boundp-method
*
105 *the-class-standard-generic-function
*
106 *the-class-standard-direct-slot-definition
*
107 *the-class-standard-effective-slot-definition
*
108 *the-class-standard-specializer
*
110 *the-eslotd-standard-class-slots
*
111 *the-eslotd-funcallable-standard-class-slots
*))
113 (declaim (special *the-wrapper-of-t
*
114 *the-wrapper-of-vector
* *the-wrapper-of-symbol
*
115 *the-wrapper-of-string
* *the-wrapper-of-sequence
*
116 *the-wrapper-of-rational
* *the-wrapper-of-ratio
*
117 *the-wrapper-of-number
* *the-wrapper-of-null
*
118 *the-wrapper-of-list
* *the-wrapper-of-integer
*
119 *the-wrapper-of-float
* *the-wrapper-of-cons
*
120 *the-wrapper-of-complex
* *the-wrapper-of-character
*
121 *the-wrapper-of-bit-vector
* *the-wrapper-of-array
*))
123 (/show
"finished with early-low.lisp")