external/lift.darcs/dev/packages.lisp

   1 (in-package #:common-lisp-user)
   2
   3 (eval-when (:compile-toplevel :load-toplevel :execute)
   4   (unless (find-package '#:lift)
   5     (defpackage #:lift
   6       (:use #:common-lisp)
   7       (:import-from
   8        #+allegro #:mop
   9        #+clisp #:clos
  10        #+lispworks #:clos
  11        #+mcl #:ccl
  12        #+cmu #:clos-mop
  13        #+sbcl #:sb-mop
  14        #+scl #:clos
  15        #:class-direct-subclasses
  16        #:class-direct-superclasses
  17        #:class-precedence-list)
  18       (:export
  19        #:with-profile-report))))
  20
  21 (unless (and (find-package :asdf)
  22              (find-symbol (symbol-name 'system-relative-pathname) :asdf)
  23              (fboundp (find-symbol
  24                        (symbol-name 'system-relative-pathname) :asdf)))
  25   (warn "LIFT uses asdf:system-relative-pathname which your version of ASDF
  26 doesn't seem to include. LIFT will define these for now but you may want to consider updating to the most recent version of ASDF (see http://www.cliki.net/asdf for details).")
  27   (intern (symbol-name 'system-source-file) :asdf)
  28   (intern (symbol-name 'system-source-directory) :asdf)
  29   (intern (symbol-name 'system-relative-pathname) :asdf)
  30   (export 'asdf::system-relative-pathname :asdf)
  31   (defun asdf::system-source-file (system-name)
  32     (let ((system (asdf:find-system system-name)))
  33       (make-pathname
  34        :type "asd"
  35        :name (asdf:component-name system)
  36        :defaults (asdf:component-relative-pathname system))))
  37
  38   (defun asdf::system-source-directory (system-name)
  39     (make-pathname :name nil
  40                    :type nil
  41                    :defaults (asdf::system-source-file system-name)))
  42
  43   (defun asdf::system-relative-pathname (system pathname &key name type)
  44     (let ((directory (pathname-directory pathname)))
  45       (when (eq (car directory) :absolute)
  46         (setf (car directory) :relative))
  47       (merge-pathnames
  48        (make-pathname :name (or name (pathname-name pathname))
  49                       :type (or type (pathname-type pathname))
  50                       :directory directory)
  51        (asdf::system-source-directory system)))))
  52