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-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)))