;;;; Deprecating stuff
-(defun deprecation-error (since name replacement)
+(defun normalize-deprecation-replacements (replacements)
+ (if (or (not (listp replacements))
+ (eq 'setf (car replacements)))
+ (list replacements)
+ replacements))
+
+(defun deprecation-error (since name replacements)
(error 'deprecation-error
:name name
- :replacement replacement
+ :replacements (normalize-deprecation-replacements replacements)
:since since))
-(defun deprecation-warning (state since name replacement
+(defun deprecation-warning (state since name replacements
&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
+ :replacements (normalize-deprecation-replacements replacements)
:since since
:runtime-error runtime-error))
-(defun deprecated-function (since name replacement)
+(defun deprecated-function (since name replacements)
(lambda (&rest deprecated-function-args)
(declare (ignore deprecated-function-args))
- (deprecation-error since name replacement)))
+ (deprecation-error since name replacements)))
-(defun deprecation-compiler-macro (state since name replacement)
+(defun deprecation-compiler-macro (state since name replacements)
(lambda (form env)
(declare (ignore env))
- (deprecation-warning state since name replacement)
+ (deprecation-warning state since name replacements)
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))))
+;;; STATE is one of
+;;;
+;;; :EARLY, for a compile-time style-warning.
+;;; :LATE, for a compile-time full warning.
+;;; :FINAL, for a compile-time full warning and runtime error.
+;;;
+;;; Suggested duration of each stage is one year, but some things can move faster,
+;;; and some widely used legacy APIs might need to move slower. Internals we don't
+;;; usually add deprecation notes for, but sometimes an internal API actually has
+;;; several external users, in which case we try to be nice about it.
+;;;
+;;; When you deprecate something, note it here till it is fully gone: makes it
+;;; easier to keep things progressing orderly. Also add the relevant section
+;;; (or update it when deprecation proceeds) in the manual, in
+;;; deprecated.texinfo.
+;;;
+;;; EARLY:
+;;; - SB-THREAD::GET-MUTEX, since 1.0.37.33 (04/2010) -> Late: 01/2013
+;;; ^- initially deprecated without compile-time warning, hence the schedule
+;;; - SB-THREAD::SPINLOCK (type), since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::MAKE-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::WITH-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::WITH-RECURSIVE-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::GET-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::RELEASE-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::SPINLOCK-VALUE, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-THREAD::SPINLOCK-NAME, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SETF SB-THREAD::SPINLOCK-NAME, since 1.0.53.11 (08/2011) -> Late: 08/2012
+;;; - SB-C::MERGE-TAIL-CALLS (policy), since 1.0.53.74 (11/2011) -> Late: 11/2012
+;;; - SB-EXT:QUIT, since 1.0.56.55 (05/2012) -> Late: 05/2013
+;;; - SB-UNIX:UNIX-EXIT, since 1.0.56.55 (05/2012) -> Late: 05/2013
+;;;
+;;; LATE:
+;;; - SB-SYS:OUTPUT-RAW-BYTES, since 1.0.8.16 (06/2007) -> Final: anytime
+;;; - SB-C::STACK-ALLOCATE-DYNAMIC-EXTENT (policy), since 1.0.19.7 -> Final: anytime
+;;; - SB-C::STACK-ALLOCATE-VECTOR (policy), since 1.0.19.7 -> Final: anytime
+;;; - SB-C::STACK-ALLOCATE-VALUE-CELLS (policy), since 1.0.19.7 -> Final: anytime
+;;; - SB-INTROSPECT:FUNCTION-ARGLIST, since 1.0.24.5 (01/2009) -> Final: anytime
+;;; - SB-THREAD:JOIN-THREAD-ERROR-THREAD, since 1.0.29.17 (06/2009) -> Final: 09/2012
+;;; - SB-THREAD:INTERRUPT-THREAD-ERROR-THREAD since 1.0.29.17 (06/2009) -> Final: 06/2012
+
+(defmacro define-deprecated-function (state since name replacements lambda-list &body body)
+ (let* ((replacements (normalize-deprecation-replacements replacements))
+ (doc (let ((*package* (find-package :keyword)))
+ (apply #'format nil
+ "~@<~S has been deprecated as of SBCL ~A.~
+ ~#[~; Use ~S instead.~; ~
+ Use ~S or ~S instead.~:; ~
+ Use~@{~#[~; or~] ~S~^,~} instead.~]~@:>"
+ name since replacements))))
`(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))))
+ ((:early :late)
+ `(defun ,name ,lambda-list
+ ,doc
+ ,@body))
+ ((:final)
+ `(progn
+ (declaim (ftype (function * nil) ,name))
+ (setf (fdefinition ',name)
+ (deprecated-function ',name ',replacements ,since))
+ (setf (documentation ',name 'function) ,doc))))
(setf (compiler-macro-function ',name)
- (deprecation-compiler-macro ,state ,since ',name ',replacement)))))
+ (deprecation-compiler-macro ,state ,since ',name ',replacements)))))
;;; Anaphoric macros
(defmacro awhen (test &body body)
(if (eql x 0.0l0)
(make-unportable-float :long-float-negative-zero)
0.0l0))))
+
+;;; Like DEFUN, but replaces &REST with &MORE while hiding that from the
+;;; lambda-list.
+(defmacro define-more-fun (name lambda-list &body body)
+ (let* ((p (position '&rest lambda-list))
+ (head (subseq lambda-list 0 p))
+ (tail (subseq lambda-list p))
+ (more-context (gensym "MORE-CONTEXT"))
+ (more-count (gensym "MORE-COUNT")))
+ (aver (= 2 (length tail)))
+ `(progn
+ (macrolet ((more-count ()
+ `(truly-the index ,',more-count))
+ (more-p ()
+ `(not (eql 0 ,',more-count)))
+ (more-arg (n)
+ `(sb!c:%more-arg ,',more-context ,n))
+ (do-more ((arg &optional (start 0)) &body body)
+ (let ((i (gensym "I")))
+ `(do ((,i (the index ,start) (truly-the index (1+ ,i))))
+ ((>= ,i (more-count)))
+ (declare (index ,i))
+ (let ((,arg (sb!c:%more-arg ,',more-context ,i)))
+ ,@body)))))
+ (defun ,name (,@head &more ,more-context ,more-count)
+ ,@body))
+ (setf (%simple-fun-arglist #',name) ',lambda-list))))
projects / sbcl.git / blobdiff