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 UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
  11 ;;;;
  12 ;;;; UFFI 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     #-(or allegro lispworks clisp cmu sbcl corman mcl) "unknown")
  41
  42 (defun set-logical-host-for-pathname (host base-pathname)
  43   (setf (logical-pathname-translations host)
  44     `(("ROOT;" ,(make-pathname
  45                 :host (pathname-host base-pathname)
  46                 :device (pathname-device base-pathname)
  47                 :directory (pathname-directory base-pathname)))
  48       ("**;bin;*.*.*" ,(merge-pathnames
  49                         (make-pathname
  50                          :name :wild
  51                          :type :wild
  52                          :directory
  53                          (append '(:relative :wild-inferiors
  54                                    ".bin" #.+set-logical-compiler-name+)))
  55                         base-pathname))
  56       ("**;*.*.*" ,(merge-pathnames
  57                     (make-pathname
  58                      :name :wild
  59                      :type :wild
  60                      :directory '(:relative :wild-inferiors))
  61                     base-pathname))))
  62   )