X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fearly-extensions.lisp;h=c589ab9198335725c6b0c732f61b8665a6af9c56;hb=bb3994fcc9a556d1a26d35f6ff9386d01030821d;hp=ff139461cce695eb198dba09f458eb12c8acfb5e;hpb=79a8e51bf4b06a5bd57bc90233605f98fee3b041;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index ff13946..c589ab9 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)) @@ -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 "~@" + :format-arguments (list (describe-action) symbol new-value spec) :datum new-value :expected-type spec)))))))) (values)) @@ -952,7 +963,7 @@ ;;; 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) @@ -966,7 +977,10 @@ ((: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)))) + ;;;; utilities for two-VALUES predicates @@ -1115,10 +1129,54 @@ (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)