external/ch-asdf/src/asdf-util.cl

   1 ;;
   2 ;; file: asdf-util.cl
   3 ;; author: cyrus harmon
   4 ;;
   5
   6 (in-package :ch-asdf)
   7
   8 (defun unix-name (pathname)
   9   (namestring
  10    (typecase pathname
  11      (logical-pathname (translate-logical-pathname pathname))
  12      (t pathname))))
  13
  14 (defun absolute-path-p (path)
  15   (when (listp (pathname-directory path))
  16     (eql (car (car (pathname-directory path)))
  17          :absolute)))
  18
  19 (defun asdf-lookup (path)
  20   (cond ((and path (listp path))
  21          (reduce #'asdf:find-component (cdr path)
  22                  :initial-value (asdf:find-system (car path))))
  23         ((stringp path)
  24          (let ((uri (puri:parse-uri path)))
  25            (when uri
  26              (let ((scheme (puri:uri-scheme uri)))
  27                (when (and (or (null scheme)
  28                               (eql scheme :asdf))
  29                           (puri:uri-parsed-path uri))
  30                  (asdf-lookup (cdr (puri:uri-parsed-path uri))))))))))
  31
  32 (defun asdf-lookup-path (path)
  33   (component-pathname (asdf-lookup path)))
  34
  35 (defun merge-asdf-path (name path)
  36   (merge-pathnames name (asdf-lookup-path path)))
  37
  38 (defmacro with-component-directory ((component) &body body)
  39   `(ch-util::with-current-directory
  40        (make-pathname
  41         :directory (pathname-directory
  42                     (component-pathname ,component)))
  43      ,@body))
  44
  45 (flet ((asdf-op (op component)
  46          (typecase component
  47            (string
  48             (asdf:operate 'asdf:load-op (asdf-lookup component)))
  49            (t (asdf:operate 'asdf:load-op component)))))
  50   (defun asdf-load (component)
  51     (asdf-op 'asdf:load-op component))
  52   (defun asdf-compile (component)
  53     (asdf-op 'asdf:compile-op component)))
  54