X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=c589ab9198335725c6b0c732f61b8665a6af9c56;hb=bb3994fcc9a556d1a26d35f6ff9386d01030821d;hp=0e1d52a906f359e55bc080e486e674e17b37e526;hpb=75f37cd646778cc8d4bed86d79309b7161bd41dc;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 0e1d52a..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)) @@ -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 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 "~@" + :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 @@ -942,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) @@ -956,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 @@ -1105,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)