+ #+sbcl
+ (sb-ext:process-exit-code
+ (apply 'sb-ext:run-program
+ #+win32 "sh" #-win32 "/bin/sh"
+ (list "-c" command)
+ :input nil :output *verbose-out*
+ #+win32 '(:search t) #-win32 nil))
+
+ #+xcl
+ (ext:run-shell-command command)
+
+ #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl mkcl sbcl scl xcl)
+ (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
+
+#+clisp
+(defun* parse-clisp-shell-output (stream)
+ "Helper function for running shell commands under clisp. Parses a specially-
+crafted output string to recover the exit status of the shell command and a
+list of lines of output."
+ (loop :with status-prefix = "ASDF-EXIT-STATUS "
+ :with prefix-length = (length status-prefix)
+ :with exit-status = -1 :with lines = ()
+ :for line = (read-line stream nil nil)
+ :while line :do (push line lines) :finally
+ (let* ((last (car lines))
+ (status (and last (>= (length last) prefix-length)
+ (string-equal last status-prefix :end1 prefix-length)
+ (parse-integer last :start prefix-length :junk-allowed t))))
+ (when status
+ (setf exit-status status)
+ (pop lines) (when (equal "" (car lines)) (pop lines)))
+ (return (values exit-status (reverse lines))))))
+
+;;;; ---------------------------------------------------------------------------
+;;;; system-relative-pathname
+
+(defun* system-definition-pathname (x)
+ ;; As of 2.014.8, we mean to make this function obsolete,
+ ;; but that won't happen until all clients have been updated.
+ ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
+ "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
+It used to expose ASDF internals with subtle differences with respect to
+user expectations, that have been refactored away since.
+We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
+for a mostly compatible replacement that we're supporting,
+or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
+if that's whay you mean." ;;)
+ (system-source-file x))
+
+(defmethod system-source-file ((system system))
+ ;; might be missing when upgrading from ASDF 1 and u-i-f-r-c failed
+ (unless (slot-boundp system 'source-file)
+ (%set-system-source-file
+ (probe-asd (component-name system) (component-pathname system)) system))
+ (%system-source-file system))
+(defmethod system-source-file ((system-name string))
+ (%system-source-file (find-system system-name)))
+(defmethod system-source-file ((system-name symbol))
+ (%system-source-file (find-system system-name)))
+
+(defun* system-source-directory (system-designator)
+ "Return a pathname object corresponding to the
+directory in which the system specification (.asd file) is
+located."
+ (pathname-directory-pathname (system-source-file system-designator)))
+
+(defun* relativize-directory (directory)
+ (cond
+ ((stringp directory)
+ (list :relative directory))
+ ((eq (car directory) :absolute)
+ (cons :relative (cdr directory)))
+ (t
+ directory)))
+
+(defun* relativize-pathname-directory (pathspec)
+ (let ((p (pathname pathspec)))
+ (make-pathname
+ :directory (relativize-directory (pathname-directory p))
+ :defaults p)))
+
+(defun* system-relative-pathname (system name &key type)
+ (subpathname (system-source-directory system) name :type type))
+
+
+;;; ---------------------------------------------------------------------------
+;;; implementation-identifier
+;;;
+;;; produce a string to identify current implementation.
+;;; Initially stolen from SLIME's SWANK, rewritten since.
+;;; We're back to runtime checking, for the sake of e.g. ABCL.
+
+(defun* first-feature (features)
+ (dolist (x features)
+ (multiple-value-bind (val feature)
+ (if (consp x) (values (first x) (cons :or (rest x))) (values x x))
+ (when (featurep feature) (return val)))))
+
+(defun implementation-type ()
+ (first-feature
+ '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu
+ :ecl :gcl (:lw :lispworks) :mcl :mkcl :sbcl :scl :symbolics :xcl)))
+
+(defun operating-system ()
+ (first-feature
+ '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
+ (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
+ (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
+ (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
+ :genera)))
+
+(defun architecture ()
+ (first-feature
+ '((:x64 :amd64 :x86-64 :x86_64 :x8664-target (:and :word-size=64 :pc386))
+ (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
+ (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
+ :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
+ :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
+ ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
+ ;; we may have to segregate the code still by architecture.
+ (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
+
+#+clozure
+(defun* ccl-fasl-version ()
+ ;; the fasl version is target-dependent from CCL 1.8 on.
+ (or (let ((s 'ccl::target-fasl-version))
+ (and (fboundp s) (funcall s)))
+ (and (boundp 'ccl::fasl-version)
+ (symbol-value 'ccl::fasl-version))
+ (error "Can't determine fasl version.")))
+
+(defun lisp-version-string ()
+ (let ((s (lisp-implementation-version)))
+ (car ; as opposed to OR, this idiom prevents some unreachable code warning
+ (list
+ #+allegro
+ (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
+ excl::*common-lisp-version-number*
+ ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default)
+ (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
+ ;; Note if not using International ACL
+ ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
+ (excl:ics-target-case (:-ics "8"))
+ (and (member :smp *features*) "S"))
+ #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
+ #+clisp
+ (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
+ #+clozure
+ (format nil "~d.~d-f~d" ; shorten for windows
+ ccl::*openmcl-major-version*
+ ccl::*openmcl-minor-version*
+ (logand (ccl-fasl-version) #xFF))
+ #+cmu (substitute #\- #\/ s)
+ #+scl (format nil "~A~A" s
+ ;; ANSI upper case vs lower case.
+ (ecase ext:*case-mode* (:upper "") (:lower "l")))
+ #+ecl (format nil "~A~@[-~A~]" s
+ (let ((vcs-id (ext:lisp-implementation-vcs-id)))
+ (subseq vcs-id 0 (min (length vcs-id) 8))))
+ #+gcl (subseq s (1+ (position #\space s)))
+ #+genera
+ (multiple-value-bind (major minor) (sct:get-system-version "System")
+ (format nil "~D.~D" major minor))
+ #+mcl (subseq s 8) ; strip the leading "Version "
+ s))))
+
+(defun* implementation-identifier ()
+ (substitute-if
+ #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
+ (format nil "~(~a~@{~@[-~a~]~}~)"
+ (or (implementation-type) (lisp-implementation-type))
+ (or (lisp-version-string) (lisp-implementation-version))
+ (or (operating-system) (software-type))
+ (or (architecture) (machine-type)))))
+
+(defun* hostname ()
+ ;; Note: untested on RMCL
+ #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
+ #+cormanlisp "localhost" ;; is there a better way? Does it matter?
+ #+allegro (excl.osi:gethostname)
+ #+clisp (first (split-string (machine-instance) :separator " "))
+ #+gcl (system:gethostname))
+
+
+;;; ---------------------------------------------------------------------------
+;;; Generic support for configuration files
+
+(defun inter-directory-separator ()
+ (if (os-unix-p) #\: #\;))
+
+(defun* user-homedir ()
+ (truenamize
+ (pathname-directory-pathname
+ #+cormanlisp (ensure-directory-pathname (user-homedir-pathname))
+ #+mcl (current-user-homedir-pathname)
+ #-(or cormanlisp mcl) (user-homedir-pathname))))
+
+(defun* ensure-pathname* (x want-absolute want-directory fmt &rest args)
+ (when (plusp (length x))
+ (let ((p (if want-directory (ensure-directory-pathname x) (pathname x))))
+ (when want-absolute
+ (unless (absolute-pathname-p p)
+ (cerror "ignore relative pathname"
+ "Invalid relative pathname ~A~@[ ~?~]" x fmt args)
+ (return-from ensure-pathname* nil)))
+ p)))
+(defun* split-pathnames* (x want-absolute want-directory fmt &rest args)
+ (loop :for dir :in (split-string
+ x :separator (string (inter-directory-separator)))
+ :collect (apply 'ensure-pathname* dir want-absolute want-directory fmt args)))
+(defun* getenv-pathname (x &key want-absolute want-directory &aux (s (getenv x)))
+ (ensure-pathname* s want-absolute want-directory "from (getenv ~S)" x))
+(defun* getenv-pathnames (x &key want-absolute want-directory &aux (s (getenv x)))
+ (and (plusp (length s))
+ (split-pathnames* s want-absolute want-directory "from (getenv ~S) = ~S" x s)))
+(defun* getenv-absolute-directory (x)
+ (getenv-pathname x :want-absolute t :want-directory t))
+(defun* getenv-absolute-directories (x)
+ (getenv-pathnames x :want-absolute t :want-directory t))
+
+(defun* get-folder-path (folder)
+ (or ;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path
+ #+(and lispworks mswindows) (sys:get-folder-path folder)
+ ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
+ (ecase folder
+ (:local-appdata (getenv-absolute-directory "LOCALAPPDATA"))
+ (:appdata (getenv-absolute-directory "APPDATA"))
+ (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
+ (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
+
+(defun* user-configuration-directories ()
+ (let ((dirs
+ `(,@(when (os-unix-p)
+ (cons
+ (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/")
+ (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS")
+ :collect (subpathname* dir "common-lisp/"))))
+ ,@(when (os-windows-p)
+ `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/")
+ ,(subpathname* (get-folder-path :appdata) "common-lisp/config/")))
+ ,(subpathname (user-homedir) ".config/common-lisp/"))))
+ (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
+ :from-end t :test 'equal)))
+
+(defun* system-configuration-directories ()
+ (cond
+ ((os-unix-p) '(#p"/etc/common-lisp/"))
+ ((os-windows-p)
+ (aif
+ ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
+ (subpathname* (get-folder-path :common-appdata) "common-lisp/config/")
+ (list it)))))
+
+(defun* in-first-directory (dirs x &key (direction :input))
+ (loop :with fun = (ecase direction
+ ((nil :input :probe) 'probe-file*)
+ ((:output :io) 'identity))
+ :for dir :in dirs
+ :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
+
+(defun* in-user-configuration-directory (x &key (direction :input))
+ (in-first-directory (user-configuration-directories) x :direction direction))
+(defun* in-system-configuration-directory (x &key (direction :input))
+ (in-first-directory (system-configuration-directories) x :direction direction))
+
+(defun* configuration-inheritance-directive-p (x)
+ (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
+ (or (member x kw)
+ (and (length=n-p x 1) (member (car x) kw)))))
+
+(defun* report-invalid-form (reporter &rest args)
+ (etypecase reporter
+ (null
+ (apply 'error 'invalid-configuration args))
+ (function
+ (apply reporter args))
+ ((or symbol string)
+ (apply 'error reporter args))
+ (cons
+ (apply 'apply (append reporter args)))))
+
+(defvar *ignored-configuration-form* nil)
+
+(defun* validate-configuration-form (form tag directive-validator
+ &key location invalid-form-reporter)
+ (unless (and (consp form) (eq (car form) tag))
+ (setf *ignored-configuration-form* t)
+ (report-invalid-form invalid-form-reporter :form form :location location)
+ (return-from validate-configuration-form nil))
+ (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
+ :for directive :in (cdr form)
+ :when (cond
+ ((configuration-inheritance-directive-p directive)
+ (incf inherit) t)
+ ((eq directive :ignore-invalid-entries)
+ (setf ignore-invalid-p t) t)
+ ((funcall directive-validator directive)
+ t)
+ (ignore-invalid-p
+ nil)
+ (t
+ (setf *ignored-configuration-form* t)
+ (report-invalid-form invalid-form-reporter :form directive :location location)
+ nil))
+ :do (push directive x)
+ :finally
+ (unless (= inherit 1)
+ (report-invalid-form invalid-form-reporter
+ :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>")
+ :inherit-configuration :ignore-inherited-configuration)))
+ (return (nreverse x))))
+
+(defun* validate-configuration-file (file validator &key description)
+ (let ((forms (read-file-forms file)))
+ (unless (length=n-p forms 1)
+ (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
+ description forms))
+ (funcall validator (car forms) :location file)))
+
+(defun* hidden-file-p (pathname)
+ (equal (first-char (pathname-name pathname)) #\.))
+
+(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
+ (apply 'directory pathname-spec
+ (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
+ #+clozure '(:follow-links nil)
+ #+clisp '(:circle t :if-does-not-exist :ignore)
+ #+(or cmu scl) '(:follow-links nil :truenamep nil)
+ #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl)
+ '(:resolve-symlinks nil))))))
+
+(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)
+ "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
+be applied to the results to yield a configuration form. Current
+values of TAG include :source-registry and :output-translations."
+ (let ((files (sort (ignore-errors
+ (remove-if
+ 'hidden-file-p
+ (directory* (make-pathname :name :wild :type "conf" :defaults directory))))
+ #'string< :key #'namestring)))
+ `(,tag
+ ,@(loop :for file :in files :append
+ (loop :with ignore-invalid-p = nil
+ :for form :in (read-file-forms file)
+ :when (eq form :ignore-invalid-entries)
+ :do (setf ignore-invalid-p t)
+ :else
+ :when (funcall validator form)
+ :collect form
+ :else
+ :when ignore-invalid-p
+ :do (setf *ignored-configuration-form* t)
+ :else
+ :do (report-invalid-form invalid-form-reporter :form form :location file)))
+ :inherit-configuration)))
+
+
+;;; ---------------------------------------------------------------------------
+;;; asdf-output-translations
+;;;
+;;; this code is heavily inspired from
+;;; asdf-binary-translations, common-lisp-controller and cl-launch.
+;;; ---------------------------------------------------------------------------
+
+(defvar *output-translations* ()
+ "Either NIL (for uninitialized), or a list of one element,
+said element itself being a sorted list of mappings.
+Each mapping is a pair of a source pathname and destination pathname,
+and the order is by decreasing length of namestring of the source pathname.")
+
+(defvar *user-cache*
+ (flet ((try (x &rest sub) (and x `(,x ,@sub))))
+ (or
+ (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
+ (when (os-windows-p)
+ (try (or (get-folder-path :local-appdata)
+ (get-folder-path :appdata))
+ "common-lisp" "cache" :implementation))
+ '(:home ".cache" "common-lisp" :implementation))))
+
+(defun* output-translations ()
+ (car *output-translations*))
+
+(defun* (setf output-translations) (new-value)
+ (setf *output-translations*
+ (list
+ (stable-sort (copy-list new-value) #'>
+ :key #'(lambda (x)
+ (etypecase (car x)
+ ((eql t) -1)
+ (pathname
+ (let ((directory (pathname-directory (car x))))
+ (if (listp directory) (length directory) 0))))))))
+ new-value)
+
+(defun* output-translations-initialized-p ()
+ (and *output-translations* t))
+
+(defun* clear-output-translations ()
+ "Undoes any initialization of the output translations.
+You might want to call that before you dump an image that would be resumed
+with a different configuration, so the configuration would be re-read then."
+ (setf *output-translations* '())
+ (values))
+
+(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
+ (values (or null pathname) &optional))
+ resolve-location))
+
+(defun* resolve-relative-location-component (x &key directory wilden)
+ (let ((r (etypecase x
+ (pathname x)
+ (string (coerce-pathname x :type (when directory :directory)))
+ (cons
+ (if (null (cdr x))
+ (resolve-relative-location-component
+ (car x) :directory directory :wilden wilden)
+ (let* ((car (resolve-relative-location-component
+ (car x) :directory t :wilden nil)))
+ (merge-pathnames*
+ (resolve-relative-location-component
+ (cdr x) :directory directory :wilden wilden)
+ car))))
+ ((eql :default-directory)
+ (relativize-pathname-directory (default-directory)))
+ ((eql :*/) *wild-directory*)
+ ((eql :**/) *wild-inferiors*)
+ ((eql :*.*.*) *wild-file*)
+ ((eql :implementation)
+ (coerce-pathname (implementation-identifier) :type :directory))
+ ((eql :implementation-type)
+ (coerce-pathname (string-downcase (implementation-type)) :type :directory))
+ ((eql :hostname)
+ (coerce-pathname (hostname) :type :directory)))))
+ (when (absolute-pathname-p r)
+ (error (compatfmt "~@<pathname ~S is not relative~@:>") x))
+ (if (or (pathnamep x) (not wilden)) r (wilden r))))
+
+(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
+ (pathname x)
+ (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x)))
+ #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
+ (if directory (ensure-directory-pathname p) p)))
+ (cons
+ (return-from resolve-absolute-location-component
+ (if (null (cdr x))
+ (resolve-absolute-location-component
+ (car x) :directory directory :wilden wilden)
+ (merge-pathnames*
+ (resolve-relative-location-component
+ (cdr x) :directory directory :wilden wilden)
+ (resolve-absolute-location-component
+ (car x) :directory t :wilden nil)))))
+ ((eql :root)
+ ;; special magic! we encode such paths as relative pathnames,
+ ;; but it means "relative to the root of the source pathname's host and device".
+ (return-from resolve-absolute-location-component
+ (let ((p (make-pathname :directory '(:relative))))
+ (if wilden (wilden p) p))))
+ ((eql :home) (user-homedir))
+ ((eql :here)
+ (resolve-location (or *here-directory*
+ ;; give semantics in the case of use interactively
+ :default-directory)
+ :directory t :wilden nil))
+ ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
+ ((eql :system-cache)
+ (error "Using the :system-cache is deprecated. ~%~
+Please remove it from your ASDF configuration"))
+ ((eql :default-directory) (default-directory))))
+ (s (if (and wilden (not (pathnamep x)))
+ (wilden r)
+ r)))
+ (unless (absolute-pathname-p s)
+ (error (compatfmt "~@<Invalid designator for an absolute pathname: ~3i~_~S~@:>") x))
+ s))
+
+(defun* resolve-location (x &key directory wilden)
+ (if (atom x)
+ (resolve-absolute-location-component x :directory directory :wilden wilden)
+ (loop :with path = (resolve-absolute-location-component
+ (car x) :directory (and (or directory (cdr x)) t)
+ :wilden (and wilden (null (cdr x))))
+ :for (component . morep) :on (cdr x)
+ :for dir = (and (or morep directory) t)
+ :for wild = (and wilden (not morep))
+ :do (setf path (merge-pathnames*
+ (resolve-relative-location-component
+ component :directory dir :wilden wild)
+ path))
+ :finally (return path))))
+
+(defun* location-designator-p (x)
+ (flet ((absolute-component-p (c)
+ (typep c '(or string pathname
+ (member :root :home :here :user-cache :system-cache :default-directory))))
+ (relative-component-p (c)
+ (typep c '(or string pathname
+ (member :default-directory :*/ :**/ :*.*.*
+ :implementation :implementation-type)))))
+ (or (typep x 'boolean)
+ (absolute-component-p x)
+ (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
+
+(defun* location-function-p (x)
+ (and
+ (length=n-p x 2)
+ (eq (car x) :function)
+ (or (symbolp (cadr x))
+ (and (consp (cadr x))
+ (eq (caadr x) 'lambda)
+ (length=n-p (cadadr x) 2)))))
+
+(defun* validate-output-translations-directive (directive)
+ (or (member directive '(:enable-user-cache :disable-cache nil))
+ (and (consp directive)
+ (or (and (length=n-p directive 2)
+ (or (and (eq (first directive) :include)
+ (typep (second directive) '(or string pathname null)))
+ (and (location-designator-p (first directive))
+ (or (location-designator-p (second directive))
+ (location-function-p (second directive))))))
+ (and (length=n-p directive 1)
+ (location-designator-p (first directive)))))))
+
+(defun* validate-output-translations-form (form &key location)
+ (validate-configuration-form
+ form
+ :output-translations
+ 'validate-output-translations-directive
+ :location location :invalid-form-reporter 'invalid-output-translation))
+
+(defun* validate-output-translations-file (file)
+ (validate-configuration-file
+ file 'validate-output-translations-form :description "output translations"))
+
+(defun* validate-output-translations-directory (directory)
+ (validate-configuration-directory
+ directory :output-translations 'validate-output-translations-directive
+ :invalid-form-reporter 'invalid-output-translation))
+
+(defun* parse-output-translations-string (string &key location)
+ (cond
+ ((or (null string) (equal string ""))
+ '(:output-translations :inherit-configuration))
+ ((not (stringp string))
+ (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
+ ((eql (char string 0) #\")
+ (parse-output-translations-string (read-from-string string) :location location))
+ ((eql (char string 0) #\()
+ (validate-output-translations-form (read-from-string string) :location location))
+ (t
+ (loop
+ :with inherit = nil
+ :with directives = ()
+ :with start = 0
+ :with end = (length string)
+ :with source = nil
+ :with separator = (inter-directory-separator)
+ :for i = (or (position separator string :start start) end) :do
+ (let ((s (subseq string start i)))
+ (cond
+ (source
+ (push (list source (if (equal "" s) nil s)) directives)
+ (setf source nil))
+ ((equal "" s)
+ (when inherit
+ (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+ string))
+ (setf inherit t)
+ (push :inherit-configuration directives))
+ (t
+ (setf source s)))
+ (setf start (1+ i))
+ (when (> start end)
+ (when source
+ (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
+ string))
+ (unless inherit
+ (push :ignore-inherited-configuration directives))
+ (return `(:output-translations ,@(nreverse directives)))))))))
+
+(defparameter *default-output-translations*
+ '(environment-output-translations
+ user-output-translations-pathname
+ user-output-translations-directory-pathname
+ system-output-translations-pathname
+ system-output-translations-directory-pathname))
+
+(defun* wrapping-output-translations ()
+ `(:output-translations
+ ;; Some implementations have precompiled ASDF systems,
+ ;; so we must disable translations for implementation paths.
+ #+sbcl ,(let ((h (getenv-pathname "SBCL_HOME" :want-directory t)))
+ (when h `((,(truenamize h) ,*wild-inferiors*) ())))
+ ;; The below two are not needed: no precompiled ASDF system there
+ #+(or ecl mkcl) (,(translate-logical-pathname "SYS:**;*.*") ())
+ #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
+ ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ()))
+ ;; All-import, here is where we want user stuff to be:
+ :inherit-configuration
+ ;; These are for convenience, and can be overridden by the user:
+ #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
+ #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
+ ;; We enable the user cache by default, and here is the place we do:
+ :enable-user-cache))
+
+(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))
+(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
+
+(defun* user-output-translations-pathname (&key (direction :input))
+ (in-user-configuration-directory *output-translations-file* :direction direction))
+(defun* system-output-translations-pathname (&key (direction :input))
+ (in-system-configuration-directory *output-translations-file* :direction direction))
+(defun* user-output-translations-directory-pathname (&key (direction :input))
+ (in-user-configuration-directory *output-translations-directory* :direction direction))
+(defun* system-output-translations-directory-pathname (&key (direction :input))
+ (in-system-configuration-directory *output-translations-directory* :direction direction))
+(defun* environment-output-translations ()
+ (getenv "ASDF_OUTPUT_TRANSLATIONS"))
+
+(defgeneric* process-output-translations (spec &key inherit collect))
+(declaim (ftype (function (t &key (:collect (or symbol function))) t)
+ inherit-output-translations))
+(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)
+ process-output-translations-directive))
+
+(defmethod process-output-translations ((x symbol) &key
+ (inherit *default-output-translations*)
+ collect)
+ (process-output-translations (funcall x) :inherit inherit :collect collect))
+(defmethod process-output-translations ((pathname pathname) &key inherit collect)
+ (cond
+ ((directory-pathname-p pathname)
+ (process-output-translations (validate-output-translations-directory pathname)
+ :inherit inherit :collect collect))
+ ((probe-file* pathname)
+ (process-output-translations (validate-output-translations-file pathname)
+ :inherit inherit :collect collect))
+ (t
+ (inherit-output-translations inherit :collect collect))))
+(defmethod process-output-translations ((string string) &key inherit collect)
+ (process-output-translations (parse-output-translations-string string)
+ :inherit inherit :collect collect))
+(defmethod process-output-translations ((x null) &key inherit collect)
+ (declare (ignorable x))
+ (inherit-output-translations inherit :collect collect))
+(defmethod process-output-translations ((form cons) &key inherit collect)
+ (dolist (directive (cdr (validate-output-translations-form form)))
+ (process-output-translations-directive directive :inherit inherit :collect collect)))
+
+(defun* inherit-output-translations (inherit &key collect)
+ (when inherit
+ (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
+
+(defun* process-output-translations-directive (directive &key inherit collect)
+ (if (atom directive)
+ (ecase directive
+ ((:enable-user-cache)
+ (process-output-translations-directive '(t :user-cache) :collect collect))
+ ((:disable-cache)
+ (process-output-translations-directive '(t t) :collect collect))
+ ((:inherit-configuration)
+ (inherit-output-translations inherit :collect collect))
+ ((:ignore-inherited-configuration :ignore-invalid-entries nil)
+ nil))
+ (let ((src (first directive))
+ (dst (second directive)))
+ (if (eq src :include)
+ (when dst
+ (process-output-translations (pathname dst) :inherit nil :collect collect))
+ (when src
+ (let ((trusrc (or (eql src t)
+ (let ((loc (resolve-location src :directory t :wilden t)))
+ (if (absolute-pathname-p loc) (truenamize loc) loc)))))
+ (cond
+ ((location-function-p dst)
+ (funcall collect
+ (list trusrc
+ (if (symbolp (second dst))
+ (fdefinition (second dst))
+ (eval (second dst))))))
+ ((eq dst t)
+ (funcall collect (list trusrc t)))
+ (t
+ (let* ((trudst (if dst
+ (resolve-location dst :directory t :wilden t)
+ trusrc))
+ (wilddst (merge-pathnames* *wild-file* trudst)))
+ (funcall collect (list wilddst t))
+ (funcall collect (list trusrc trudst)))))))))))
+
+(defun* compute-output-translations (&optional parameter)
+ "read the configuration, return it"
+ (remove-duplicates
+ (while-collecting (c)
+ (inherit-output-translations
+ `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
+ :test 'equal :from-end t))
+
+(defvar *output-translations-parameter* nil)
+
+(defun* initialize-output-translations (&optional (parameter *output-translations-parameter*))
+ "read the configuration, initialize the internal configuration variable,
+return the configuration"
+ (setf *output-translations-parameter* parameter
+ (output-translations) (compute-output-translations parameter)))
+
+(defun* disable-output-translations ()
+ "Initialize output translations in a way that maps every file to itself,
+effectively disabling the output translation facility."
+ (initialize-output-translations
+ '(:output-translations :disable-cache :ignore-inherited-configuration)))
+
+;; checks an initial variable to see whether the state is initialized
+;; or cleared. In the former case, return current configuration; in
+;; the latter, initialize. ASDF will call this function at the start
+;; of (asdf:find-system).
+(defun* ensure-output-translations ()
+ (if (output-translations-initialized-p)
+ (output-translations)
+ (initialize-output-translations)))
+
+(defun* translate-pathname* (path absolute-source destination &optional root source)
+ (declare (ignore source))
+ (cond
+ ((functionp destination)
+ (funcall destination path absolute-source))
+ ((eq destination t)
+ path)
+ ((not (pathnamep destination))
+ (error "Invalid destination"))
+ ((not (absolute-pathname-p destination))
+ (translate-pathname path absolute-source (merge-pathnames* destination root)))
+ (root
+ (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
+ (t
+ (translate-pathname path absolute-source destination))))
+
+(defun* apply-output-translations (path)
+ #+cormanlisp (truenamize path) #-cormanlisp
+ (etypecase path
+ (logical-pathname
+ path)
+ ((or pathname string)
+ (ensure-output-translations)
+ (loop :with p = (truenamize path)
+ :for (source destination) :in (car *output-translations*)
+ :for root = (when (or (eq source t)
+ (and (pathnamep source)
+ (not (absolute-pathname-p source))))
+ (pathname-root p))
+ :for absolute-source = (cond
+ ((eq source t) (wilden root))
+ (root (merge-pathnames* source root))
+ (t source))
+ :when (or (eq source t) (pathname-match-p p absolute-source))
+ :return (translate-pathname* p absolute-source destination root source)
+ :finally (return p)))))
+
+(defmethod output-files :around (operation component)
+ "Translate output files, unless asked not to"
+ operation component ;; hush genera, not convinced by declare ignorable(!)
+ (values
+ (multiple-value-bind (files fixedp) (call-next-method)
+ (if fixedp
+ files
+ (mapcar #'apply-output-translations files)))
+ t))
+
+(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
+ (if (absolute-pathname-p output-file)
+ ;; what cfp should be doing, w/ mp* instead of mp
+ (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys)))
+ (defaults (make-pathname
+ :type type :defaults (merge-pathnames* input-file))))
+ (merge-pathnames* output-file defaults))
+ (apply-output-translations
+ (apply 'compile-file-pathname input-file
+ (if output-file keys (remove-keyword :output-file keys))))))
+
+(defun* tmpize-pathname (x)
+ (make-pathname
+ :name (strcat "ASDF-TMP-" (pathname-name x))
+ :defaults x))
+
+(defun* delete-file-if-exists (x)
+ (when (and x (probe-file* x))
+ (delete-file x)))
+
+(defun* compile-file* (input-file &rest keys &key compile-check output-file &allow-other-keys)
+ (let* ((keywords (remove-keyword :compile-check keys))
+ (output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))
+ (tmp-file (tmpize-pathname output-file))
+ (status :error))
+ (multiple-value-bind (output-truename warnings-p failure-p)
+ (apply 'compile-file input-file :output-file tmp-file keywords)
+ (cond
+ (failure-p
+ (setf status *compile-file-failure-behaviour*))
+ (warnings-p
+ (setf status *compile-file-warnings-behaviour*))
+ (t
+ (setf status :success)))
+ (cond
+ ((and (ecase status
+ ((:success :warn :ignore) t)
+ ((:error nil)))
+ (or (not compile-check)
+ (apply compile-check input-file :output-file tmp-file keywords)))
+ (delete-file-if-exists output-file)
+ (when output-truename
+ (rename-file output-truename output-file)
+ (setf output-truename output-file)))
+ (t ;; error or failed check
+ (delete-file-if-exists output-truename)
+ (setf output-truename nil failure-p t)))
+ (values output-truename warnings-p failure-p))))
+
+#+abcl
+(defun* translate-jar-pathname (source wildcard)
+ (declare (ignore wildcard))
+ (let* ((p (pathname (first (pathname-device source))))
+ (root (format nil "/___jar___file___root___/~@[~A/~]"
+ (and (find :windows *features*)
+ (pathname-device p)))))
+ (apply-output-translations
+ (merge-pathnames*
+ (relativize-pathname-directory source)
+ (merge-pathnames*
+ (relativize-pathname-directory (ensure-directory-pathname p))
+ root)))))
+
+;;;; -----------------------------------------------------------------
+;;;; Compatibility mode for ASDF-Binary-Locations
+
+(defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
+ (declare (ignorable operation-class system args))
+ (when (find-symbol* '#:output-files-for-system-and-operation :asdf)
+ (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
+ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
+which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
+and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
+In case you insist on preserving your previous A-B-L configuration, but
+do not know how to achieve the same effect with A-O-T, you may use function
+ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
+call that function where you would otherwise have loaded and configured A-B-L.")))
+
+(defun* enable-asdf-binary-locations-compatibility
+ (&key
+ (centralize-lisp-binaries nil)
+ (default-toplevel-directory
+ (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
+ (include-per-user-information nil)
+ (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
+ (source-to-target-mappings nil))
+ #+(or clisp ecl mkcl)
+ (when (null map-all-source-files)
+ (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
+ (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
+ (mapped-files (if map-all-source-files *wild-file*
+ (make-pathname :type fasl-type :defaults *wild-file*)))
+ (destination-directory
+ (if centralize-lisp-binaries
+ `(,default-toplevel-directory
+ ,@(when include-per-user-information
+ (cdr (pathname-directory (user-homedir))))
+ :implementation ,*wild-inferiors*)
+ `(:root ,*wild-inferiors* :implementation))))
+ (initialize-output-translations
+ `(:output-translations
+ ,@source-to-target-mappings
+ ((:root ,*wild-inferiors* ,mapped-files)
+ (,@destination-directory ,mapped-files))
+ (t t)
+ :ignore-inherited-configuration))))
+
+;;;; -----------------------------------------------------------------
+;;;; Source Registry Configuration, by Francois-Rene Rideau
+;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
+
+;; Using ack 1.2 exclusions
+(defvar *default-source-registry-exclusions*
+ '(".bzr" ".cdv"
+ ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
+ ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
+ "_sgbak" "autom4te.cache" "cover_db" "_build"
+ "debian")) ;; debian often builds stuff under the debian directory... BAD.
+
+(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
+
+(defvar *source-registry* nil
+ "Either NIL (for uninitialized), or an equal hash-table, mapping
+system names to pathnames of .asd files")
+
+(defun* source-registry-initialized-p ()
+ (typep *source-registry* 'hash-table))
+
+(defun* clear-source-registry ()
+ "Undoes any initialization of the source registry.
+You might want to call that before you dump an image that would be resumed
+with a different configuration, so the configuration would be re-read then."
+ (setf *source-registry* nil)
+ (values))
+
+(defparameter *wild-asd*
+ (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
+
+(defun* filter-logical-directory-results (directory entries merger)
+ (if (typep directory 'logical-pathname)
+ ;; Try hard to not resolve logical-pathname into physical pathnames;
+ ;; otherwise logical-pathname users/lovers will be disappointed.
+ ;; If directory* could use some implementation-dependent magic,
+ ;; we will have logical pathnames already; otherwise,
+ ;; we only keep pathnames for which specifying the name and
+ ;; translating the LPN commute.
+ (loop :for f :in entries
+ :for p = (or (and (typep f 'logical-pathname) f)
+ (let* ((u (ignore-errors (funcall merger f))))
+ ;; The first u avoids a cumbersome (truename u) error.
+ ;; At this point f should already be a truename,
+ ;; but isn't quite in CLISP, for doesn't have :version :newest
+ (and u (equal (ignore-errors (truename u)) (truename f)) u)))
+ :when p :collect p)
+ entries))
+
+(defun* directory-files (directory &optional (pattern *wild-file*))
+ (let ((dir (pathname directory)))
+ (when (typep dir 'logical-pathname)
+ ;; Because of the filtering we do below,
+ ;; logical pathnames have restrictions on wild patterns.
+ ;; Not that the results are very portable when you use these patterns on physical pathnames.
+ (when (wild-pathname-p dir)
+ (error "Invalid wild pattern in logical directory ~S" directory))
+ (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
+ (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
+ (setf pattern (make-pathname-logical pattern (pathname-host dir))))
+ (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir)))))
+ (filter-logical-directory-results
+ directory entries
+ #'(lambda (f)
+ (make-pathname :defaults dir
+ :name (make-pathname-component-logical (pathname-name f))
+ :type (make-pathname-component-logical (pathname-type f))
+ :version (make-pathname-component-logical (pathname-version f))))))))
+
+(defun* directory-asd-files (directory)
+ (directory-files directory *wild-asd*))
+
+(defun* subdirectories (directory)
+ (let* ((directory (ensure-directory-pathname directory))
+ #-(or abcl cormanlisp genera xcl)
+ (wild (merge-pathnames*
+ #-(or abcl allegro cmu lispworks sbcl scl xcl)
+ *wild-directory*
+ #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
+ directory))
+ (dirs
+ #-(or abcl cormanlisp genera xcl)
+ (ignore-errors
+ (directory* wild . #.(or #+clozure '(:directories t :files nil)
+ #+mcl '(:directories t))))
+ #+(or abcl xcl) (system:list-directory directory)
+ #+cormanlisp (cl::directory-subdirs directory)
+ #+genera (fs:directory-list directory))
+ #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
+ (dirs (loop :for x :in dirs
+ :for d = #+(or abcl xcl) (extensions:probe-directory x)
+ #+allegro (excl:probe-directory x)
+ #+(or cmu sbcl scl) (directory-pathname-p x)
+ #+genera (getf (cdr x) :directory)
+ #+lispworks (lw:file-directory-p x)
+ :when d :collect #+(or abcl allegro xcl) d
+ #+genera (ensure-directory-pathname (first x))
+ #+(or cmu lispworks sbcl scl) x)))
+ (filter-logical-directory-results
+ directory dirs
+ (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
+ '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
+ #'(lambda (d)
+ (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
+ (and (consp dir) (consp (cdr dir))
+ (make-pathname
+ :defaults directory :name nil :type nil :version nil
+ :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
+
+(defun* collect-asds-in-directory (directory collect)
+ (map () collect (directory-asd-files directory)))
+
+(defun* collect-sub*directories (directory collectp recursep collector)
+ (when (funcall collectp directory)
+ (funcall collector directory))
+ (dolist (subdir (subdirectories directory))
+ (when (funcall recursep subdir)
+ (collect-sub*directories subdir collectp recursep collector))))
+
+(defun* collect-sub*directories-asd-files
+ (directory &key
+ (exclude *default-source-registry-exclusions*)
+ collect)
+ (collect-sub*directories
+ directory
+ (constantly t)
+ #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
+ #'(lambda (dir) (collect-asds-in-directory dir collect))))
+
+(defun* validate-source-registry-directive (directive)
+ (or (member directive '(:default-registry))
+ (and (consp directive)
+ (let ((rest (rest directive)))
+ (case (first directive)
+ ((:include :directory :tree)
+ (and (length=n-p rest 1)
+ (location-designator-p (first rest))))
+ ((:exclude :also-exclude)
+ (every #'stringp rest))
+ ((:default-registry)
+ (null rest)))))))
+
+(defun* validate-source-registry-form (form &key location)
+ (validate-configuration-form
+ form :source-registry 'validate-source-registry-directive
+ :location location :invalid-form-reporter 'invalid-source-registry))
+
+(defun* validate-source-registry-file (file)
+ (validate-configuration-file
+ file 'validate-source-registry-form :description "a source registry"))
+
+(defun* validate-source-registry-directory (directory)
+ (validate-configuration-directory
+ directory :source-registry 'validate-source-registry-directive
+ :invalid-form-reporter 'invalid-source-registry))
+
+(defun* parse-source-registry-string (string &key location)
+ (cond
+ ((or (null string) (equal string ""))
+ '(:source-registry :inherit-configuration))
+ ((not (stringp string))
+ (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
+ ((find (char string 0) "\"(")
+ (validate-source-registry-form (read-from-string string) :location location))
+ (t
+ (loop
+ :with inherit = nil
+ :with directives = ()
+ :with start = 0
+ :with end = (length string)
+ :with separator = (inter-directory-separator)
+ :for pos = (position separator string :start start) :do
+ (let ((s (subseq string start (or pos end))))
+ (flet ((check (dir)
+ (unless (absolute-pathname-p dir)
+ (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
+ dir))
+ (cond
+ ((equal "" s) ; empty element: inherit
+ (when inherit
+ (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+ string))
+ (setf inherit t)
+ (push ':inherit-configuration directives))
+ ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
+ (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
+ (t
+ (push `(:directory ,(check s)) directives))))
+ (cond
+ (pos
+ (setf start (1+ pos)))
+ (t
+ (unless inherit
+ (push '(:ignore-inherited-configuration) directives))
+ (return `(:source-registry ,@(nreverse directives))))))))))
+
+(defun* register-asd-directory (directory &key recurse exclude collect)
+ (if (not recurse)
+ (collect-asds-in-directory directory collect)
+ (collect-sub*directories-asd-files
+ directory :exclude exclude :collect collect)))
+
+(defparameter *default-source-registries*
+ '(environment-source-registry
+ user-source-registry
+ user-source-registry-directory
+ system-source-registry
+ system-source-registry-directory
+ default-source-registry))
+
+(defparameter *source-registry-file* (coerce-pathname "source-registry.conf"))
+(defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/"))
+
+(defun* wrapping-source-registry ()
+ `(:source-registry
+ #+ecl (:tree ,(translate-logical-pathname "SYS:"))
+ #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
+ #+sbcl (:tree ,(truenamize (getenv-pathname "SBCL_HOME" :want-directory t)))
+ :inherit-configuration
+ #+cmu (:tree #p"modules:")
+ #+scl (:tree #p"file://modules/")))
+(defun* default-source-registry ()
+ `(:source-registry
+ #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
+ (:directory ,(default-directory))
+ ,@(loop :for dir :in
+ `(,@(when (os-unix-p)
+ `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
+ (subpathname (user-homedir) ".local/share/"))
+ ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
+ '("/usr/local/share" "/usr/share"))))
+ ,@(when (os-windows-p)
+ (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
+ :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
+ :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
+ :inherit-configuration))
+(defun* user-source-registry (&key (direction :input))
+ (in-user-configuration-directory *source-registry-file* :direction direction))
+(defun* system-source-registry (&key (direction :input))
+ (in-system-configuration-directory *source-registry-file* :direction direction))
+(defun* user-source-registry-directory (&key (direction :input))
+ (in-user-configuration-directory *source-registry-directory* :direction direction))
+(defun* system-source-registry-directory (&key (direction :input))
+ (in-system-configuration-directory *source-registry-directory* :direction direction))
+(defun* environment-source-registry ()
+ (getenv "CL_SOURCE_REGISTRY"))
+
+(defgeneric* process-source-registry (spec &key inherit register))
+(declaim (ftype (function (t &key (:register (or symbol function))) t)
+ inherit-source-registry))
+(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
+ process-source-registry-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)
+ (cond
+ ((directory-pathname-p pathname)
+ (let ((*here-directory* (truenamize pathname)))
+ (process-source-registry (validate-source-registry-directory pathname)
+ :inherit inherit :register register)))
+ ((probe-file* pathname)
+ (let ((*here-directory* (pathname-directory-pathname pathname)))
+ (process-source-registry (validate-source-registry-file pathname)
+ :inherit inherit :register register)))
+ (t
+ (inherit-source-registry inherit :register register))))
+(defmethod process-source-registry ((string string) &key inherit register)
+ (process-source-registry (parse-source-registry-string string)
+ :inherit inherit :register register))
+(defmethod process-source-registry ((x null) &key inherit register)
+ (declare (ignorable x))
+ (inherit-source-registry inherit :register register))
+(defmethod process-source-registry ((form cons) &key inherit register)
+ (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
+ (dolist (directive (cdr (validate-source-registry-form form)))
+ (process-source-registry-directive directive :inherit inherit :register register))))
+
+(defun* inherit-source-registry (inherit &key register)
+ (when inherit
+ (process-source-registry (first inherit) :register register :inherit (rest inherit))))
+
+(defun* process-source-registry-directive (directive &key inherit register)
+ (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
+ (ecase kw
+ ((:include)
+ (destructuring-bind (pathname) rest
+ (process-source-registry (resolve-location pathname) :inherit nil :register register)))
+ ((:directory)
+ (destructuring-bind (pathname) rest
+ (when pathname
+ (funcall register (resolve-location pathname :directory t)))))
+ ((:tree)
+ (destructuring-bind (pathname) rest
+ (when pathname
+ (funcall register (resolve-location pathname :directory t)
+ :recurse t :exclude *source-registry-exclusions*))))
+ ((:exclude)
+ (setf *source-registry-exclusions* rest))
+ ((:also-exclude)
+ (appendf *source-registry-exclusions* rest))
+ ((:default-registry)
+ (inherit-source-registry '(default-source-registry) :register register))
+ ((:inherit-configuration)
+ (inherit-source-registry inherit :register register))
+ ((:ignore-inherited-configuration)
+ nil)))
+ nil)