(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))
(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))
;;; If X is a symbol, see whether it is present in *FEATURES*. Also
;;; handle arbitrary combinations of atoms using NOT, AND, OR.
(defun featurep (x)
- (etypecase x
+ (typecase x
(cons
(case (car x)
((:not not)
((:or or) (some #'featurep (cdr x)))
(t
(error "unknown operator in feature expression: ~S." x))))
- (symbol (not (null (memq x *features*))))))
+ (symbol (not (null (memq x *features*))))
+ (t
+ (error "invalid feature expression: ~S" x))))
+
\f
;;;; utilities for two-VALUES predicates
(translate-logical-pathname possibly-logical-pathname)
possibly-logical-pathname))
-(defun deprecation-warning (bad-name &optional good-name)
- (warn "using deprecated ~S~@[, should use ~S instead~]"
- bad-name
- good-name))
+;;;; Deprecating stuff
+
+(defun deprecation-error (since name replacement)
+ (error 'deprecation-error
+ :name name
+ :replacement replacement
+ :since since))
+
+(defun deprecation-warning (state since name replacement
+ &key (runtime-error (neq :early state)))
+ (warn (ecase state
+ (:early 'early-deprecation-warning)
+ (:late 'late-deprecation-warning)
+ (:final 'final-deprecation-warning))
+ :name name
+ :replacement replacement
+ :since since
+ :runtime-error runtime-error))
+
+(defun deprecated-function (since name replacement)
+ (lambda (&rest deprecated-function-args)
+ (declare (ignore deprecated-function-args))
+ (deprecation-error since name replacement)))
+
+(defun deprecation-compiler-macro (state since name replacement)
+ (lambda (form env)
+ (declare (ignore env))
+ (deprecation-warning state since name replacement)
+ form))
+
+(defmacro define-deprecated-function (state since name replacement lambda-list &body body)
+ (let ((doc (let ((*package* (find-package :keyword)))
+ (format nil "~@<~S has been deprecated as of SBCL ~A~@[, use ~S instead~].~:>"
+ name since replacement))))
+ `(progn
+ ,(ecase state
+ ((:early :late)
+ `(defun ,name ,lambda-list
+ ,doc
+ ,@body))
+ ((:final)
+ `(progn
+ (declaim (ftype (function * nil) ,name))
+ (setf (fdefinition ',name)
+ (deprecated-function ',name ',replacement ,since))
+ (setf (documentation ',name 'function) ,doc))))
+ (setf (compiler-macro-function ',name)
+ (deprecation-compiler-macro ,state ,since ',name ',replacement)))))
;;; Anaphoric macros
(defmacro awhen (test &body body)