- ;; For good measure, we also catch the problem of
- ;; *PACKAGE* being bound to a deleted package.
- ;; Technically, this is not undefined behavior in itself,
- ;; but it will immediately lead to undefined to behavior,
- ;; since almost any operation on a deleted package is
- ;; undefined.
- (package-name maybe-package))
- maybe-package)
- (t
- ;; We're in the undefined behavior zone. First, munge the
- ;; system back into a defined state.
- (let ((really-package (find-package :cl-user)))
- (setf *package* really-package)
- ;; Then complain.
- (error 'simple-type-error
- :datum maybe-package
- :expected-type 'package
- :format-control
- "~S can't be a ~S:~% ~S has been reset to ~S"
- :format-arguments (list '*package* (type-of maybe-package)
- '*package* really-package)))))))
+ ;; For good measure, we also catch the problem of
+ ;; *PACKAGE* being bound to a deleted package.
+ ;; Technically, this is not undefined behavior in itself,
+ ;; but it will immediately lead to undefined to behavior,
+ ;; since almost any operation on a deleted package is
+ ;; undefined.
+ (package-name maybe-package))
+ maybe-package)
+ (t
+ ;; We're in the undefined behavior zone. First, munge the
+ ;; system back into a defined state.
+ (let ((really-package (find-package :cl-user)))
+ (setf *package* really-package)
+ ;; Then complain.
+ (error 'simple-type-error
+ :datum maybe-package
+ :expected-type '(and package (satisfies package-name))
+ :format-control
+ "~@<~S can't be a ~A: ~2I~_~S has been reset to ~S.~:>"
+ :format-arguments (list '*package*
+ (if (packagep maybe-package)
+ "deleted package"
+ (type-of maybe-package))
+ '*package* really-package)))))))
+
+;;; Access *DEFAULT-PATHNAME-DEFAULTS*, issuing a warning if its value
+;;; is silly. (Unlike the vaguely-analogous SANE-PACKAGE, we don't
+;;; actually need to reset the variable when it's silly, since even
+;;; crazy values of *DEFAULT-PATHNAME-DEFAULTS* don't leave the system
+;;; in a state where it's hard to recover interactively.)
+(defun sane-default-pathname-defaults ()
+ (let* ((dfd *default-pathname-defaults*)
+ (dfd-dir (pathname-directory dfd)))
+ ;; It's generally not good to use a relative pathname for
+ ;; *DEFAULT-PATHNAME-DEFAULTS*, since relative pathnames
+ ;; are defined by merging into a default pathname (which is,
+ ;; by default, *DEFAULT-PATHNAME-DEFAULTS*).
+ (when (and (consp dfd-dir)
+ (eql (first dfd-dir) :relative))
+ (warn
+ "~@<~S is a relative pathname. (But we'll try using it anyway.)~@:>"
+ '*default-pathname-defaults*))
+ dfd))