(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"))
(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))
(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))
(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)))
(values ,@(values-refs)))
(t
,@(when *profile-hash-cache*
- `((incf ,(symbolicate "*" name "-CACHE-MISSES*"))))
+ `((incf ,misses-name)))
,default))))))
(let ((fun-name (symbolicate name "-CACHE-ENTER")))
`(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))
;;; 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 nil)
- (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