;; This mirrors the expectation of Common Lisp Controller's pathnames
(handler-case
- (logical-pathname-translations "CL-LIBRARY")
+ (logical-pathname-translations "cl-library")
(error ()
- (let* ((dir (pathname-directory *load-truename*))
- (parent-dir (subseq dir 0 (1- (length dir)))))
- (load (make-pathname :name "set-logical" :type "cl"
- :defaults *load-truename*))
- (set-logical-host-for-pathname
- "CL-LIBRARY"
- (make-pathname :host (pathname-host *load-truename*)
- :device (pathname-device *load-truename*)
- :directory parent-dir)))))
+ (let* ((dir (pathname-directory *load-truename*))
+ (parent-dir (subseq dir 0 (1- (length dir)))))
+ (load (make-pathname :name "set-logical" :type "cl"
+ :defaults *load-truename*))
+ (set-logical-host-for-pathname
+ "CL-LIBRARY"
+ (make-pathname :host (pathname-host *load-truename*)
+ :device (pathname-device *load-truename*)
+ :directory parent-dir))))
+ (:no-error (translation)
+ ;; Make sure that cl-library points to this installation
+ (let* ((dir (pathname-directory *load-truename*))
+ (base-dir (car (last dir)))
+ (logical-dir (translate-logical-pathname
+ (concatenate 'string
+ "cl-library:" base-dir ";"))))
+ (unless (equalp dir (pathname-directory logical-dir))
+ (let ((*print-circle* nil))
+ (error "cl-library:~A; directory ~S does not equal *load-truename*'s directory ~S"
+ base-dir (cdr dir)
+ (cdr (pathname-directory logical-dir))))))))