1.0.30.41: Octets support for ebcdic-us

[sbcl.git] / src / code / early-extensions.lisp

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index ff13946..46bc505 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -13,6 +13,14 @@
 
 (in-package "SB!IMPL")
 
+(defvar *core-pathname* nil
+  #!+sb-doc
+  "The absolute pathname of the running SBCL core.")
+
+(defvar *runtime-pathname* nil
+  #!+sb-doc
+  "The absolute pathname of the running SBCL runtime.")
+
 ;;; something not EQ to anything we might legitimately READ
 (defparameter *eof-object* (make-symbol "EOF-OBJECT"))
 
@@ -516,6 +524,10 @@
                                   (init-wrapper 'progn)
                                   (values 1))
   (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
+         (probes-name (when *profile-hash-cache*
+                       (symbolicate "*" name "-CACHE-PROBES*")))
+         (misses-name (when *profile-hash-cache*
+                      (symbolicate "*" name "-CACHE-MISSES*")))
          (nargs (length args))
          (size (ash 1 hash-bits))
          (default-values (if (and (consp default) (eq (car default) 'values))
@@ -525,7 +537,7 @@
          (args-and-values-size (+ nargs values))
          (n-index (sb!xc:gensym "INDEX"))
          (n-cache (sb!xc:gensym "CACHE")))
-
+    (declare (ignorable probes-name misses-name))
     (unless (= (length default-values) values)
       (error "The number of default values ~S differs from :VALUES ~W."
              default values))
@@ -555,20 +567,16 @@
           (incf n)))
 
       (when *profile-hash-cache*
-        (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*"))
-              (n-miss (symbolicate "*" name "-CACHE-MISSES*")))
-          (inits `(setq ,n-probe 0))
-          (inits `(setq ,n-miss 0))
-          (forms `(defvar ,n-probe))
-          (forms `(defvar ,n-miss))
-          (forms `(declaim (fixnum ,n-miss ,n-probe)))))
+        (inits `(setq ,probes-name 0))
+        (inits `(setq ,misses-name 0))
+        (forms `(declaim (fixnum ,probes-name ,misses-name))))
 
       (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
         (inlines fun-name)
         (forms
          `(defun ,fun-name ,(arg-vars)
             ,@(when *profile-hash-cache*
-                `((incf ,(symbolicate  "*" name "-CACHE-PROBES*"))))
+                `((incf ,probes-name)))
             (let* ((,n-index (,hash-function ,@(arg-vars)))
                    (,n-cache ,var-name)
                    (,args-and-values (svref ,n-cache ,n-index)))
@@ -577,7 +585,7 @@
                      (values ,@(values-refs)))
                     (t
                      ,@(when *profile-hash-cache*
-                         `((incf ,(symbolicate  "*" name "-CACHE-MISSES*"))))
+                         `((incf ,misses-name)))
                      ,default))))))
 
       (let ((fun-name (symbolicate name "-CACHE-ENTER")))
@@ -603,6 +611,9 @@
 
       `(progn
          (defvar ,var-name)
+         ,@(when *profile-hash-cache*
+             `((defvar ,probes-name)
+               (defvar ,misses-name)))
          (declaim (type (simple-vector ,size) ,var-name))
          #!-sb-fluid (declaim (inline ,@(inlines)))
          (,init-wrapper ,@(inits))
@@ -802,8 +813,8 @@
             (unless (sb!kernel::%%typep new-value type nil)
               (let ((spec (type-specifier type)))
                 (error 'simple-type-error
-                       :format-control "Cannot ~@? to ~S (not of type ~S.)"
-                       :format-arguments (list action (describe-action) new-value spec)
+                       :format-control "~@<Cannot ~@? to ~S, not of type ~S.~:@>"
+                       :format-arguments (list (describe-action) symbol new-value spec)
                        :datum new-value
                        :expected-type spec))))))))
   (values))