set-logical.cl

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          set-logical.cl
   6 ;;;; Purpose:       Sets a logical host for src/binaries based on a pathname.
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Feb 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
  18 ;;; Setup logical pathname translaton with separate binary directories
  19 ;;; for each implementation
  20
  21 ;; push allegro case sensitivity on *features*
  22 #+allegro
  23 (eval-when (:compile-toplevel :load-toplevel :execute)
  24   (if (or (eq excl:*current-case-mode* :case-sensitive-lower)
  25           (eq excl:*current-case-mode* :case-sensitive-upper))
  26       (pushnew :case-sensitive cl:*features*)
  27     (pushnew :case-insensitive cl:*features*)))
  28
  29 (defconstant +set-logical-compiler-name+
  30     #+(and allegro ics case-sensitive) "acl-modern"
  31     #+(and allegro (not ics) case-sensitive) "acl-modern8"
  32     #+(and allegro ics (not case-sensitive)) "acl-ansi"
  33     #+(and allegro (not ics) (not case-sensitive)) "acl-ansi8"
  34     #+lispworks "lispworks"
  35     #+clisp "clisp"
  36     #+cmu "cmucl"
  37     #+sbcl "sbcl"
  38     #+corman "corman"
  39     #+mcl "mcl"
  40     #+openmcl "openmcl"
  41     #-(or allegro lispworks clisp cmu sbcl corman mcl openmcl) "unknown")
  42
  43 (defun set-logical-host-for-pathname (host base-pathname)
  44   (setf (logical-pathname-translations host)
  45     `(("ROOT;" ,(make-pathname
  46                 :host (pathname-host base-pathname)
  47                 :device (pathname-device base-pathname)
  48                 :directory (pathname-directory base-pathname)))
  49       ("**;*.cl.*" ,(merge-pathnames
  50                     (make-pathname
  51                      :name :wild
  52                      :type :wild
  53                      :directory '(:relative :wild-inferiors))
  54                     base-pathname))
  55       ("**;*.lisp.*" ,(merge-pathnames
  56                     (make-pathname
  57                      :name :wild
  58                      :type :wild
  59                      :directory '(:relative :wild-inferiors))
  60                     base-pathname))
  61       ("**;*.c.*" ,(merge-pathnames
  62                     (make-pathname
  63                      :name :wild
  64                      :type :wild
  65                      :directory '(:relative :wild-inferiors))
  66                     base-pathname))
  67       ("**;*.h.*" ,(merge-pathnames
  68                     (make-pathname
  69                      :name :wild
  70                      :type :wild
  71                      :directory '(:relative :wild-inferiors))
  72                     base-pathname))
  73       ("**;bin;*.*.*" ,(merge-pathnames
  74                         (make-pathname
  75                          :name :wild
  76                          :type :wild
  77                          :directory
  78                          (append '(:relative :wild-inferiors
  79                                              ".bin" #.+set-logical-compiler-name+)))
  80                         base-pathname))
  81       ;; default is to place in .bin/<compiler> directory
  82       ("**;*.*.*" ,(merge-pathnames
  83                     (make-pathname
  84                      :name :wild
  85                      :type :wild
  86                      :directory
  87                      (append '(:relative :wild-inferiors
  88                                          ".bin" #.+set-logical-compiler-name+)))
  89                     base-pathname)))))
  90