1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: set-cl-library.cl
6 ;;;; Purpose: Sets CL-LIBRARY logical host name if it does not exist
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: May 2002
10 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
12 ;;;; CLSQL users are granted the rights to distribute and use this software
13 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
14 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
15 ;;;; *************************************************************************
17 ;; Set logical pathname CL-LIBRARY to be directory above *load-truename*
18 ;; This mirrors the expectation of Common Lisp Controller's pathnames
21 (logical-pathname-translations "cl-library")
23 (let* ((dir (pathname-directory *load-truename*))
24 (parent-dir (subseq dir 0 (1- (length dir)))))
25 (load (make-pathname :name "set-logical" :type "cl"
26 :defaults *load-truename*))
27 (set-logical-host-for-pathname
29 (make-pathname :host (pathname-host *load-truename*)
30 :device (pathname-device *load-truename*)
31 :directory parent-dir))))
32 (:no-error (translation)
33 ;; Make sure that cl-library points to this installation
34 (let* ((dir (pathname-directory *load-truename*))
35 (base-dir (car (last dir)))
36 (logical-dir (translate-logical-pathname
38 "cl-library:" base-dir ";"))))
39 (unless (equalp dir (pathname-directory logical-dir))
40 (let ((*print-circle* nil))
41 (error "cl-library:~A; directory ~S does not equal *load-truename*'s directory ~S"
43 (cdr (pathname-directory logical-dir))))))))