X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=46bc505266f8d5cd6ce284094c689915637cd6eb;hb=65b5ab7e713d04e0d76bc0ee196374f6e57b922f;hp=3d1a9b7fab987be41690479d383511d8bd24dd5b;hpb=6fc7d9db187e254b4963c9d7c3b3d0c001984212;p=sbcl.git

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 3d1a9b7..46bc505 100644
--- 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))
@@ -769,33 +780,43 @@
 ;;;   foo => 13, (constantp 'foo) => t
 ;;;
 ;;; ...in which case you frankly deserve to lose.
-(defun about-to-modify-symbol-value (symbol action &optional (new-value nil valuep))
+(defun about-to-modify-symbol-value (symbol action &optional (new-value nil valuep) bind)
   (declare (symbol symbol))
-  (multiple-value-bind (what continue)
-      (when (eq :constant (info :variable :kind symbol))
-        (cond ((eq symbol t)
-               (values "Veritas aeterna. (can't ~@?)" nil))
-              ((eq symbol nil)
-               (values "Nihil ex nihil. (can't ~@?)" nil))
-              ((keywordp symbol)
-               (values "Can't ~@?." nil))
-              (t
-               (values "Constant modification: attempt to ~@?." t))))
-    (when what
-      (if continue
-          (cerror "Modify the constant." what action symbol)
-          (error what action symbol)))
-    (when valuep
-      ;; :VARIABLE :TYPE is in the db only if it is declared, so no need to
-      ;; check.
-      (let ((type (info :variable :type symbol)))
-        (unless (sb!kernel::%%typep new-value type)
-          (let ((spec (type-specifier type)))
-            (error 'simple-type-error
-                   :format-control "Cannot ~@? to ~S (not of type ~S.)"
-                   :format-arguments (list action symbol new-value spec)
-                   :datum new-value
-                   :expected-type spec))))))
+  (flet ((describe-action ()
+           (ecase action
+             (set "set SYMBOL-VALUE of ~S")
+             (progv "bind ~S")
+             (compare-and-swap "compare-and-swap SYMBOL-VALUE of ~S")
+             (defconstant "define ~S as a constant")
+             (makunbound "make ~S unbound"))))
+    (let ((kind (info :variable :kind symbol)))
+      (multiple-value-bind (what continue)
+          (cond ((eq :constant kind)
+                 (cond ((eq symbol t)
+                        (values "Veritas aeterna. (can't ~@?)" nil))
+                       ((eq symbol nil)
+                        (values "Nihil ex nihil. (can't ~@?)" nil))
+                       ((keywordp symbol)
+                        (values "Can't ~@?." nil))
+                       (t
+                        (values "Constant modification: attempt to ~@?." t))))
+                ((and bind (eq :global kind))
+                 (values "Can't ~@? (global variable)." nil)))
+        (when what
+          (if continue
+              (cerror "Modify the constant." what (describe-action) symbol)
+              (error what (describe-action) symbol)))
+        (when valuep
+          ;; :VARIABLE :TYPE is in the db only if it is declared, so no need to
+          ;; check.
+          (let ((type (info :variable :type symbol)))
+            (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 (describe-action) symbol new-value spec)
+                       :datum new-value
+                       :expected-type spec))))))))
   (values))
 
 ;;; If COLD-FSET occurs not at top level, just treat it as an ordinary