X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=b35eb8e15348f05ed0410f3d437172f844f65755;hb=408ed62925d643c163f0e9fc7b3fd41cce65fbea;hp=9891317beabdcf76ffb6ca6dd066535790091a74;hpb=d25e3478acccec70402ff32554669a982be8e281;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 9891317..b35eb8e 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")) @@ -453,7 +461,7 @@ ,@forms))))) `(let ((,n-table ,table)) ,(if locked - `(with-locked-hash-table (,n-table) + `(with-locked-system-table (,n-table) ,iter-form) iter-form)))))) @@ -512,14 +520,20 @@ ;;; the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS ;;; in type system definitions so that caches will be created ;;; before top level forms run.) +(defvar *cache-vector-symbols* nil) + +(defun drop-all-hash-caches () + (dolist (name *cache-vector-symbols*) + (set name nil))) + (defmacro define-hash-cache (name args &key hash-function hash-bits default (init-wrapper 'progn) (values 1)) - (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*")) + (let* ((var-name (symbolicate "**" name "-CACHE-VECTOR**")) (probes-name (when *profile-hash-cache* - (symbolicate "*" name "-CACHE-PROBES*"))) + (symbolicate "**" name "-CACHE-PROBES**"))) (misses-name (when *profile-hash-cache* - (symbolicate "*" name "-CACHE-MISSES*"))) + (symbolicate "**" name "-CACHE-MISSES**"))) (nargs (length args)) (size (ash 1 hash-bits)) (default-values (if (and (consp default) (eq (car default) 'values)) @@ -569,23 +583,26 @@ `(defun ,fun-name ,(arg-vars) ,@(when *profile-hash-cache* `((incf ,probes-name))) - (let* ((,n-index (,hash-function ,@(arg-vars))) - (,n-cache ,var-name) - (,args-and-values (svref ,n-cache ,n-index))) - (cond ((and ,args-and-values - ,@(tests)) - (values ,@(values-refs))) - (t + (flet ((miss () ,@(when *profile-hash-cache* `((incf ,misses-name))) - ,default)))))) + (return-from ,fun-name ,default))) + (let* ((,n-index (,hash-function ,@(arg-vars))) + (,n-cache (or ,var-name (miss))) + (,args-and-values (svref ,n-cache ,n-index))) + (cond ((and (not (eql 0 ,args-and-values)) + ,@(tests)) + (values ,@(values-refs))) + (t + (miss)))))))) (let ((fun-name (symbolicate name "-CACHE-ENTER"))) (inlines fun-name) (forms `(defun ,fun-name (,@(arg-vars) ,@(values-names)) (let ((,n-index (,hash-function ,@(arg-vars))) - (,n-cache ,var-name) + (,n-cache (or ,var-name + (setq ,var-name (make-array ,size :initial-element 0)))) (,args-and-values (make-array ,args-and-values-size))) ,@(sets) (setf (svref ,n-cache ,n-index) ,args-and-values)) @@ -594,19 +611,19 @@ (let ((fun-name (symbolicate name "-CACHE-CLEAR"))) (forms `(defun ,fun-name () - (fill ,var-name nil))) - (forms `(,fun-name))) + (setq ,var-name nil)))) - (inits `(unless (boundp ',var-name) - (setq ,var-name (make-array ,size :initial-element nil)))) + ;; Needed for cold init! + (inits `(setq ,var-name nil)) #!+sb-show (inits `(setq *hash-caches-initialized-p* t)) `(progn - (defvar ,var-name) + (pushnew ',var-name *cache-vector-symbols*) + (defglobal ,var-name nil) ,@(when *profile-hash-cache* - `((defvar ,probes-name) - (defvar ,misses-name))) - (declaim (type (simple-vector ,size) ,var-name)) + `((defglobal ,probes-name 0) + (defglobal ,misses-name 0))) + (declaim (type (or null (simple-vector ,size)) ,var-name)) #!-sb-fluid (declaim (inline ,@(inlines))) (,init-wrapper ,@(inits)) ,@(forms) @@ -805,8 +822,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)) @@ -955,7 +972,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) @@ -969,7 +986,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 @@ -1118,10 +1138,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)