1.0.37.4: robuster page table pickup
[sbcl.git] / src / cold / chill.lisp
1 ;;;; This file is not used at cold load time. Instead, it can be
2 ;;;; loaded into an initialized SBCL to get it into a nostalgic frame
3 ;;;; of mind, remembering the way things were in cold init, so that it
4 ;;;; can READ code which is ordinarily read only when bootstrapping.
5 ;;;; (This can be useful when debugging the system, since the debugger
6 ;;;; likes to be able to read the source for the code. It can also be
7 ;;;; useful when experimenting with patches on a running system.)
8
9 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; more information.
11 ;;;;
12 ;;;; This software is derived from the CMU CL system, which was
13 ;;;; written at Carnegie Mellon University and released into the
14 ;;;; public domain. The software is in the public domain and is
15 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
16 ;;;; files for more information.
17
18 (defpackage "SB-COLD"
19   (:use "CL"))
20 (in-package "SB-COLD")
21
22 ;;; We need the #! readtable modifications.
23 (load (merge-pathnames "shebang.lisp" *load-truename*))
24
25 ;;; #!+ and #!- now refer to *FEATURES* values (as opposed to the way
26 ;;; that they referred to special target-only *SHEBANG-FEATURES* values
27 ;;; during cold init).
28 (setf sb-cold:*shebang-features* *features*)
29 ;;; Just in case we want to play with the initial value of
30 ;;; backend-subfeatures
31 (setf sb-cold:*shebang-backend-subfeatures* sb-c:*backend-subfeatures*)
32
33 (handler-bind ((sb-ext:package-locked-error #'continue))
34   ;; The nickname SB!XC now refers to the CL package.
35   (rename-package "COMMON-LISP" "COMMON-LISP"
36                   (cons "SB!XC" (package-nicknames "CL")))
37   (sb-ext:unlock-package "CL")
38
39   ;; Any other name SB!FOO refers to the package now called SB-FOO.
40   (dolist (package (list-all-packages))
41     (let ((name (package-name package))
42           (nicknames (package-nicknames package))
43           (warm-name-prefix "SB-")
44           (cold-name-prefix "SB!"))
45       (when (and (> (length name) (length warm-name-prefix))
46                  (string= name warm-name-prefix
47                           :end1 (length warm-name-prefix)))
48         (let* ((stem (subseq name (length cold-name-prefix)))
49                (cold-name (concatenate 'simple-string cold-name-prefix stem)))
50           (rename-package package name (cons cold-name nicknames)))
51         (sb-ext:unlock-package package)))))