set-cl-library.cl

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   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
   9 ;;;;
  10 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
  11 ;;;;
  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 ;;;; *************************************************************************
  16
  17 ;; Set logical pathname CL-LIBRARY to be directory above *load-truename*
  18 ;; This mirrors the expectation of Common Lisp Controller's pathnames
  19
  20 (handler-case
  21     (logical-pathname-translations "CL-LIBRARY")
  22   (error ()
  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
  28             "CL-LIBRARY"
  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
  37                                   (concatenate 'string
  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"
  42                           base-dir (cdr dir)
  43                           (cdr (pathname-directory logical-dir))))))))