From 79a718d8b7ff62f016c74a096c78b0192dd4c292 Mon Sep 17 00:00:00 2001 From: "Robert P. Goldman" <rpgoldman@real-time.com> Date: Tue, 23 Nov 2010 21:59:21 -0600 Subject: [PATCH] Better approach to having :here directive --- treat it like :home or :user-cache. --- asdf.lisp | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/asdf.lisp b/asdf.lisp index c8ee9e08..f58676e6 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -2769,6 +2769,11 @@ with a different configuration, so the configuration would be re-read then." (error "pathname ~S is not relative to ~S" s super)) (merge-pathnames* s super))) +(defvar *here-directory* nil + "This special variable is bound to the currect directory during calls to +PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here +directive.") + (defun* resolve-absolute-location-component (x &key directory wilden) (let* ((r (etypecase x @@ -2791,6 +2796,13 @@ with a different configuration, so the configuration would be re-read then." (let ((p (make-pathname :directory '(:relative)))) (if wilden (wilden p) p)))) ((eql :home) (user-homedir)) + ((eql :here) (resolve-location + (aif *here-directory* + it + ;; this is used to give semantics to :here when used + ;; interactively. + *default-pathname-defaults*) + :directory t :wilden nil)) ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil)) ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil)) ((eql :default-directory) (default-directory)))) @@ -3473,11 +3485,6 @@ with a different configuration, so the configuration would be re-read then." (declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t) process-source-registry-directive)) -(defvar *here-directory* nil - "This special variable is bound to the currect directory during calls to -PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here -directive.") - (defmethod process-source-registry ((x symbol) &key inherit register) (process-source-registry (funcall x) :inherit inherit :register register)) (defmethod process-source-registry ((pathname pathname) &key inherit register) -- GitLab