SHARE
TWEET

Untitled

a guest Aug 14th, 2019 66 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. (defun component-equal (component other)
  2.   (string-equal (asdf:component-name component)
  3.                 (asdf:component-name other)))
  4.  
  5. (defun asdf-inferred-system-deps (system &optional (visited nil))
  6.   ;; A "proper-dep" is a dependency with the same primary system name (i.e., not an external library)
  7.   (flet ((proper-dep-p (dep) (string-equal (asdf:primary-system-name dep) (asdf:primary-system-name system)))
  8.          (recurse (prev dep) (asdf-inferred-system-deps dep prev)))
  9.     (let* ((proper-deps (remove-if-not #'proper-dep-p (mapcar #'asdf:find-system (asdf:system-depends-on system))))
  10.            (unvisited-deps (set-difference proper-deps visited :test #'component-equal)))
  11.       (reduce #'recurse unvisited-deps :initial-value (append unvisited-deps visited)))))
  12.  
  13. (defun asdf-inferred-system-files (system ending)
  14.   (let ((system-pathname (asdf:component-pathname system)))
  15.     (flet ((dep-pathname (dep)
  16.              (let ((name (asdf:component-name dep)))
  17.                (parse-namestring (concatenate
  18.                 'string
  19.                 (namestring system-pathname )
  20.                 (subseq name (1+ (position #\/ name)))
  21.                 ending)))))
  22.       (mapcar #'dep-pathname (asdf-inferred-system-deps system)))))
  23.  
  24.  
  25. (defun asdf-inferred-system-files (system ending)
  26.   (let ((system-pathname (asdf:component-pathname system)))
  27.     (flet ((dep-pathname (dep)
  28.              (let ((name (asdf:component-name dep)))
  29.                (parse-namestring (concatenate
  30.                 'string
  31.                 (namestring system-pathname )
  32.                 (subseq name (1+ (position #\/ name)))
  33.                 ending)))))
  34.       (mapcar #'dep-pathname (asdf-inferred-system-deps system)))))
  35.  
  36.  
  37. (defun asdf-component-source-files (component)
  38.   (if (and #+asdf3 (typep component 'asdf:package-inferred-system))
  39.       (asdf-inferred-system-files component ".lisp")
  40.       (let ((files ()))
  41.         (labels ((f (x)
  42.                    (typecase x
  43.                      (asdf:source-file
  44.                       (let ((truename (uiop:truenamize (asdf:component-pathname x))))
  45.                         (push truename files)))
  46.                      (asdf:module
  47.                       (map nil #'f (asdf:module-components x))))))
  48.           (f component))
  49.         files)))
  50.  
  51. (defun pathname-system (pathname)
  52.   "Find an `asdf:system' to which `pathname' belongs to, or nil if no such system exists."
  53.   (let ((pathname (uiop:ensure-absolute-pathname pathname *default-pathname-defaults*)))
  54.     (block nil
  55.       (asdf:map-systems
  56.        (lambda (system)
  57.          (when (find pathname (asdf-component-source-files system) :test #'uiop:pathname-equal)
  58.            (return system)))))))
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top