From 1e95a883a92eb5eb09415f80ab05be8a735ae607 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Sat, 29 Oct 2011 14:36:09 -0400 Subject: [PATCH] 2.017.27: define, use and export a new function subpathname. --- asdf.asd | 2 +- asdf.lisp | 96 +++++++++++++++++++++++++++---------------------------- 2 files changed, 48 insertions(+), 50 deletions(-) diff --git a/asdf.asd b/asdf.asd index 528c07dc..4212d3f4 100644 --- a/asdf.asd +++ b/asdf.asd @@ -14,7 +14,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.017.26" ;; to be automatically updated by bin/bump-revision + :version "2.017.27" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:file "asdf") diff --git a/asdf.lisp b/asdf.lisp index 013f1f43..596fe58e 100755 --- a/asdf.lisp +++ b/asdf.lisp @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.017.26: Another System Definition Facility. +;;; This is ASDF 2.017.27: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. @@ -107,7 +107,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.017.26") + (asdf-version "2.017.27") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -348,6 +348,7 @@ ;; #:find-symbol* #:merge-pathnames* #:coerce-pathname + #:subpathname #:pathname-directory-pathname #:read-file-forms ;; #:remove-keys @@ -1868,6 +1869,17 @@ Host, device and version components are taken from DEFAULTS." :type (source-file-type component (component-system component)) :defaults (component-parent-pathname component))) +(defun* subpathname (pathname subpath &key type) + (and pathname (merge-pathnames* (coerce-pathname subpath :type type) + (pathname-directory-pathname pathname)))) + +(defun* try-subpathname (pathname subpath &key type) + (let* ((sp (and pathname (probe-file* pathname) + (subpathname pathname subpath :type type))) + (ts (and sp (probe-file* sp)))) + (and ts (values sp ts)))) + + ;;;; ------------------------------------------------------------------------- ;;;; Operations @@ -2656,7 +2668,7 @@ details." (defun* load-pathname () (resolve-symlinks* (or *load-pathname* *compile-file-pathname*))) -(defun* determine-system-pathname (pathname pathname-supplied-p) +(defun* determine-system-pathname (pathname) ;; The defsystem macro calls us to determine ;; the pathname of a system as follows: ;; 1. the one supplied, @@ -2664,9 +2676,7 @@ details." ;; 3. taken from the *default-pathname-defaults* via default-directory (let* ((file-pathname (load-pathname)) (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname)))) - (or (and pathname-supplied-p - (merge-pathnames* (coerce-pathname pathname :type :directory) - directory-pathname)) + (or (and pathname (subpathname directory-pathname pathname :type :directory)) directory-pathname (default-directory)))) @@ -2847,7 +2857,7 @@ Returns the new tree (which probably shares structure with the old one)" ret))) (defun* do-defsystem (name &rest options - &key (pathname nil pathname-arg-p) (class 'system) + &key pathname (class 'system) defsystem-depends-on &allow-other-keys) ;; The system must be registered before we parse the body, ;; otherwise we recur when trying to find an existing system @@ -2874,7 +2884,7 @@ Returns the new tree (which probably shares structure with the old one)" (parse-component-form nil (list* :module name - :pathname (determine-system-pathname pathname pathname-arg-p) + :pathname (determine-system-pathname pathname) component-options))))) (defmacro defsystem (name &body options) @@ -3054,9 +3064,7 @@ located." :defaults p))) (defun* system-relative-pathname (system name &key type) - (merge-pathnames* - (coerce-pathname name :type type) - (system-source-directory system))) + (subpathname (system-source-directory system) name :type type)) ;;; --------------------------------------------------------------------------- @@ -3152,40 +3160,33 @@ located." #+mcl (current-user-homedir-pathname) #-mcl (user-homedir-pathname)))) -(defun* try-directory-subpath (x sub &key type) - (let* ((p (and x (ensure-directory-pathname x))) - (tp (and p (probe-file* p))) - (sp (and tp (merge-pathnames* (coerce-pathname sub :type type) p))) - (ts (and sp (probe-file* sp)))) - (and ts (values sp ts)))) (defun* user-configuration-directories () (let ((dirs - (flet ((try (x sub) (try-directory-subpath x sub))) - `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/") - ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") - :for dir :in (split-string dirs :separator ":") - :collect (try dir "common-lisp/")) - ,@(when (os-windows-p) - `(,(try (or #+lispworks (sys:get-folder-path :local-appdata) - (getenv "LOCALAPPDATA")) - "common-lisp/config/") - ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData - ,(try (or #+lispworks (sys:get-folder-path :appdata) - (getenv "APPDATA")) - "common-lisp/config/"))) - ,(try (user-homedir) ".config/common-lisp/"))))) + `(,(try-subpathname (getenv "XDG_CONFIG_HOME") "common-lisp/") + ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") + :for dir :in (split-string dirs :separator ":") + :collect (try-subpathname dir "common-lisp/")) + ,@(when (os-windows-p) + `(,(try-subpathname (or #+lispworks (sys:get-folder-path :local-appdata) + (getenv "LOCALAPPDATA")) + "common-lisp/config/") + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData + ,(try-subpathname (or #+lispworks (sys:get-folder-path :appdata) + (getenv "APPDATA")) + "common-lisp/config/"))) + ,(try-subpathname (user-homedir) ".config/common-lisp/")))) (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal))) + (defun* system-configuration-directories () (cond ((os-unix-p) '(#p"/etc/common-lisp/")) ((os-windows-p) (aif - (flet ((try (x sub) (try-directory-subpath x sub))) - ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData - (try (or #+lispworks (sys:get-folder-path :common-appdata) - (getenv "ALLUSERSAPPDATA") - (try (getenv "ALLUSERSPROFILE") "Application Data/")) - "common-lisp/config/")) + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData + (try-subpathname (or #+lispworks (sys:get-folder-path :common-appdata) + (getenv "ALLUSERSAPPDATA") + (subpathname (getenv "ALLUSERSPROFILE") "Application Data/")) + "common-lisp/config/") (list it))))) (defun* in-first-directory (dirs x) @@ -3784,9 +3785,7 @@ call that function where you would otherwise have loaded and configured A-B-L.") (&key (centralize-lisp-binaries nil) (default-toplevel-directory - ;; Use ".cache/common-lisp" instead ??? - (merge-pathnames* (make-pathname :directory '(:relative ".fasls")) - (user-homedir))) + (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? (include-per-user-information nil) (map-all-source-files (or #+(or ecl clisp) t nil)) (source-to-target-mappings nil)) @@ -4021,14 +4020,13 @@ with a different configuration, so the configuration would be re-read then." #+cmu (:tree #p"modules:") #+scl (:tree #p"file://modules/"))) (defun* default-source-registry () - (flet ((try (x sub) (try-directory-subpath x sub))) - `(:source-registry - #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/")) - (:directory ,(default-directory)) + `(:source-registry + #+sbcl (:directory ,(try-subpathname (user-homedir) ".sbcl/systems/")) + (:directory ,(default-directory)) ,@(loop :for dir :in `(,@(when (os-unix-p) `(,(or (getenv "XDG_DATA_HOME") - (try (user-homedir) ".local/share/")) + (try-subpathname (user-homedir) ".local/share/")) ,@(split-string (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share") :separator ":"))) @@ -4039,10 +4037,10 @@ with a different configuration, so the configuration would be re-read then." (getenv "APPDATA")) ,(or #+lispworks (sys:get-folder-path :common-appdata) (getenv "ALLUSERSAPPDATA") - (try (getenv "ALLUSERSPROFILE") "Application Data/"))))) - :collect `(:directory ,(try dir "common-lisp/systems/")) - :collect `(:tree ,(try dir "common-lisp/source/"))) - :inherit-configuration))) + (try-subpathname (getenv "ALLUSERSPROFILE") "Application Data/"))))) + :collect `(:directory ,(try-subpathname dir "common-lisp/systems/")) + :collect `(:tree ,(try-subpathname dir "common-lisp/source/"))) + :inherit-configuration)) (defun* user-source-registry () (in-user-configuration-directory *source-registry-file*)) (defun* system-source-registry () -- GitLab