(let* ((name (first spec))
(exp-temp (gensym "ONCE-ONLY")))
`(let ((,exp-temp ,(second spec))
- (,name (gensym ,(symbol-name name))))
+ (,name (sb!xc:gensym ,(symbol-name name))))
`(let ((,,name ,,exp-temp))
,,(frob (rest specs) body))))))))
\f
(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))))
+ (doc
+ (let ((*package* (find-package :keyword))
+ (*print-pretty* nil))
+ (apply #'format nil
+ "~S has been deprecated as of SBCL ~A.~
+ ~#[~;~2%Use ~S instead.~;~2%~
+ Use ~S or ~S instead.~:;~2%~
+ Use~@{~#[~; or~] ~S~^,~} instead.~]"
+ name since replacements))))
`(progn
,(ecase state
((:early :late)
- `(defun ,name ,lambda-list
- ,doc
- ,@body))
+ `(progn
+ (defun ,name ,lambda-list
+ ,doc
+ ,@body)))
((:final)
`(progn
(declaim (ftype (function * nil) ,name))
(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))))
-
;;; Signalling an error when trying to print an error condition is
;;; generally a PITA, so whatever the failure encountered when
;;; wondering about FILE-POSITION within a condition printer, 'tis