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-package-locks (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-package-locks (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-package-locks (sb-ext:unlock-package package)))))
52
53;; Reinstate the pre-cold-init variable-defining macros.
54(let ((*package* (find-package "SB-INT")))
55  (flet ((def (real-name)
56           (let ((alias (sb-int:symbolicate "!" real-name)))
57             (export alias)
58             (setf (macro-function alias) (macro-function real-name)))))
59    (def 'sb-ext:defglobal)
60    (def 'defparameter)
61    (def 'defvar)))
62
63(export '(sb-int::!cold-init-forms
64          sb-int::!coerce-to-specialized
65          sb-int::/show sb-int::/noshow sb-int::/show0 sb-int::/noshow0)
66        'sb-int)
67
68(defmacro sb-int:!cold-init-forms (&rest forms) `(progn ,@forms))
69
70;; This macro is never defined for the target Lisp,
71;; only the cross-compilation host (see "src/code/specializable-array")
72;; but it is needed to read x86-64/insts.lisp and other things.
73(defmacro sb-int:!coerce-to-specialized (a type)
74  (declare (ignore type))
75  a)
76
77;; If :sb-show is present, then these symbols are fboundp.
78;; Otherwise define them as no-ops.
79(unless (fboundp 'sb-int:/show)
80  (defmacro sb-int:/show (&rest junk) (declare (ignore junk)))
81  (setf (macro-function 'sb-int:/noshow) (macro-function 'sb-int:/show)
82        (macro-function 'sb-int:/show0) (macro-function 'sb-int:/show)
83        (macro-function 'sb-int:/noshow0) (macro-function 'sb-int:/show)))
84