external/lift.darcs/_darcs/pristine/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        #:*benchmark-log-path*
  20        #:*lift-report-detail-hook*
  21        #:*lift-report-header-hook*
  22        #:*lift-report-footer-hook*
  23        #:with-profile-report
  24        #:describe-test-result
  25        #:count-repetitions
  26        #:while-counting-repetitions
  27        #:with-timeout))))
  28
  29 (unless (and (find-package :asdf)
  30              (find-symbol (symbol-name 'system-relative-pathname) :asdf)
  31              (fboundp (find-symbol
  32                        (symbol-name 'system-relative-pathname) :asdf)))
  33   (warn "LIFT uses asdf:system-relative-pathname which your version of ASDF
  34 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).")
  35   (intern (symbol-name 'system-source-file) :asdf)
  36   (intern (symbol-name 'system-source-directory) :asdf)
  37   (intern (symbol-name 'system-relative-pathname) :asdf)
  38   (export 'asdf::system-relative-pathname :asdf)
  39   (defun asdf::system-source-file (system-name)
  40     (let ((system (asdf:find-system system-name)))
  41       (make-pathname
  42        :type "asd"
  43        :name (asdf:component-name system)
  44        :defaults (asdf:component-relative-pathname system))))
  45
  46   (defun asdf::system-source-directory (system-name)
  47     (make-pathname :name nil
  48                    :type nil
  49                    :defaults (asdf::system-source-file system-name)))
  50
  51   (defun asdf::system-relative-pathname (system pathname &key name type)
  52     (let ((directory (pathname-directory pathname)))
  53       (when (eq (car directory) :absolute)
  54         (setf (car directory) :relative))
  55       (merge-pathnames
  56        (make-pathname :name (or name (pathname-name pathname))
  57                       :type (or type (pathname-type pathname))
  58                       :directory directory)
  59        (asdf::system-source-directory system)))))
  60