+ #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
+ (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
+
+;;;; ---------------------------------------------------------------------------
+;;;; system-relative-pathname
+
+(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."
+ (make-pathname :name nil
+ :type nil
+ :defaults (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)
+ (merge-pathnames*
+ (merge-component-name-type name :type type)
+ (system-source-directory system)))
+
+
+;;; ---------------------------------------------------------------------------
+;;; implementation-identifier
+;;;
+;;; produce a string to identify current implementation.
+;;; Initially stolen from SLIME's SWANK, hacked since.
+
+(defparameter *implementation-features*
+ '((:acl :allegro)
+ (:lw :lispworks)
+ (:digitool) ; before clozure, so it won't get preempted by ccl
+ (:ccl :clozure)
+ (:corman :cormanlisp)
+ (:abcl :armedbear)
+ :sbcl :cmu :clisp :gcl :ecl :scl))
+
+(defparameter *os-features*
+ '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
+ (:solaris :sunos)
+ (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
+ (:macosx :darwin :darwin-target :apple)
+ :freebsd :netbsd :openbsd :bsd
+ :unix))
+
+(defparameter *architecture-features*
+ '((:amd64 :x86-64 :x86_64 :x8664-target)
+ (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
+ :hppa64
+ :hppa
+ (:ppc64 :ppc64-target)
+ (:ppc32 :ppc32-target :ppc :powerpc)
+ :sparc64
+ (:sparc32 :sparc)
+ (:arm :arm-target)
+ (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
+
+(defun* lisp-version-string ()
+ (let ((s (lisp-implementation-version)))
+ (declare (ignorable s))
+ #+allegro (format nil
+ "~A~A~A~A"
+ excl::*common-lisp-version-number*
+ ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
+ (if (eq excl:*current-case-mode*
+ :case-sensitive-lower) "M" "A")
+ ;; 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")
+ (:+ics ""))
+ (if (member :64bit *features*) "-64bit" ""))
+ #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
+ #+clisp (subseq s 0 (position #\space s))
+ #+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)
+ #+digitool (subseq s 8)
+ #+ecl (format nil "~A~@[-~A~]" s
+ (let ((vcs-id (ext:lisp-implementation-vcs-id)))
+ (when (>= (length vcs-id) 8)
+ (subseq vcs-id 0 8))))
+ #+gcl (subseq s (1+ (position #\space s)))
+ #+lispworks (format nil "~A~@[~A~]" s
+ (when (member :lispworks-64bit *features*) "-64bit"))
+ ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
+ #+(or cormanlisp mcl sbcl scl) s
+ #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
+ ecl gcl lispworks mcl sbcl scl) s))
+
+(defun* first-feature (features)
+ (labels
+ ((fp (thing)
+ (etypecase thing
+ (symbol
+ (let ((feature (find thing *features*)))
+ (when feature (return-from fp feature))))
+ ;; allows features to be lists of which the first
+ ;; member is the "main name", the rest being aliases
+ (cons
+ (dolist (subf thing)
+ (when (find subf *features*) (return-from fp (first thing))))))
+ nil))
+ (loop :for f :in features
+ :when (fp f) :return :it)))
+
+(defun* implementation-type ()
+ (first-feature *implementation-features*))
+
+(defun* implementation-identifier ()
+ (labels
+ ((maybe-warn (value fstring &rest args)
+ (cond (value)
+ (t (apply #'warn fstring args)
+ "unknown"))))
+ (let ((lisp (maybe-warn (implementation-type)
+ "No implementation feature found in ~a."
+ *implementation-features*))
+ (os (maybe-warn (first-feature *os-features*)
+ "No os feature found in ~a." *os-features*))
+ (arch (maybe-warn (first-feature *architecture-features*)
+ "No architecture feature found in ~a."
+ *architecture-features*))
+ (version (maybe-warn (lisp-version-string)
+ "Don't know how to get Lisp implementation version.")))
+ (substitute-if
+ #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
+ (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
+
+
+
+;;; ---------------------------------------------------------------------------
+;;; Generic support for configuration files
+
+(defparameter *inter-directory-separator*
+ #+(or unix cygwin) #\:
+ #-(or unix cygwin) #\;)
+
+(defun* user-homedir ()
+ (truename (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* (merge-component-name-type sub :type type) p)))
+ (ts (and sp (probe-file* sp))))
+ (and ts (values sp ts))))
+(defun* user-configuration-directories ()
+ (remove-if
+ #'null
+ (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
+ `(,(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/"))
+ #+(and (or win32 windows mswindows mingw32) (not cygwin))
+ ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
+ ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
+ ,(try (getenv "APPDATA") "common-lisp/config/"))
+ ,(try (user-homedir) ".config/common-lisp/")))))
+(defun* system-configuration-directories ()
+ (remove-if
+ #'null
+ (append
+ #+(and (or win32 windows mswindows mingw32) (not cygwin))
+ (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
+ `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
+ ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
+ ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
+ (list #p"/etc/common-lisp/"))))
+(defun* in-first-directory (dirs x)
+ (loop :for dir :in dirs
+ :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))
+(defun* in-user-configuration-directory (x)
+ (in-first-directory (user-configuration-directories) x))
+(defun* in-system-configuration-directory (x)
+ (in-first-directory (system-configuration-directories) x))
+
+(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* validate-configuration-form (form tag directive-validator
+ &optional (description tag))
+ (unless (and (consp form) (eq (car form) tag))
+ (error "Error: Form doesn't specify ~A ~S~%" description form))
+ (loop :with inherit = 0
+ :for directive :in (cdr form) :do
+ (if (configuration-inheritance-directive-p directive)
+ (incf inherit)
+ (funcall directive-validator directive))
+ :finally
+ (unless (= inherit 1)
+ (error "One and only one of ~S or ~S is required"
+ :inherit-configuration :ignore-inherited-configuration)))
+ form)
+
+(defun* validate-configuration-file (file validator description)
+ (let ((forms (read-file-forms file)))
+ (unless (length=n-p forms 1)
+ (error "One and only one form allowed for ~A. Got: ~S~%" description forms))
+ (funcall validator (car forms))))
+
+(defun* hidden-file-p (pathname)
+ (equal (first-char (pathname-name pathname)) #\.))
+
+(defun* validate-configuration-directory (directory tag validator)
+ (let ((files (sort (ignore-errors
+ (remove-if
+ 'hidden-file-p
+ (directory (make-pathname :name :wild :type "conf" :defaults directory)
+ #+sbcl :resolve-symlinks #+sbcl nil)))
+ #'string< :key #'namestring)))
+ `(,tag
+ ,@(loop :for file :in files :append
+ (mapcar validator (read-file-forms 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 "XDG_CACHE_HOME") "common-lisp" :implementation)
+ #+(and (or win32 windows mswindows mingw32) (not cygwin))
+ (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
+ '(:home ".cache" "common-lisp" :implementation))))
+(defvar *system-cache*
+ ;; No good default, plus there's a security problem
+ ;; with other users messing with such directories.
+ *user-cache*)
+
+(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
+ (length (pathname-directory (car x)))))))))
+ 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 (super x &key directory wilden)
+ (let* ((r (etypecase x
+ (pathname x)
+ (string x)
+ (cons
+ (return-from resolve-relative-location-component
+ (if (null (cdr x))
+ (resolve-relative-location-component
+ super (car x) :directory directory :wilden wilden)
+ (let* ((car (resolve-relative-location-component
+ super (car x) :directory t :wilden nil))
+ (cdr (resolve-relative-location-component
+ (merge-pathnames* car super) (cdr x)
+ :directory directory :wilden wilden)))
+ (merge-pathnames* cdr car)))))
+ ((eql :default-directory)
+ (relativize-pathname-directory (default-directory)))
+ ((eql :implementation) (implementation-identifier))
+ ((eql :implementation-type) (string-downcase (implementation-type)))
+ #-(and (or win32 windows mswindows mingw32) (not cygwin))
+ ((eql :uid) (princ-to-string (get-uid)))))
+ (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
+ (s (if (or (pathnamep x) (not wilden)) d (wilden d))))
+ (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
+ (error "pathname ~S is not relative to ~S" s super))
+ (merge-pathnames* s super)))
+
+(defun* resolve-absolute-location-component (x &key directory wilden)
+ (let* ((r
+ (etypecase x
+ (pathname x)
+ (string (if directory (ensure-directory-pathname x) (parse-namestring x)))
+ (cons
+ (return-from resolve-absolute-location-component
+ (if (null (cdr x))
+ (resolve-absolute-location-component
+ (car x) :directory directory :wilden wilden)
+ (let* ((car (resolve-absolute-location-component
+ (car x) :directory t :wilden nil))
+ (cdr (resolve-relative-location-component
+ car (cdr x) :directory directory :wilden wilden)))
+ (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?
+ ((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 :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))))
+ (s (if (and wilden (not (pathnamep x)))
+ (wilden r)
+ r)))
+ (unless (absolute-pathname-p s)
+ (error "Not an absolute pathname ~S" s))
+ 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 (resolve-relative-location-component
+ path component :directory dir :wilden wild))
+ :finally (return path))))
+
+(defun* location-designator-p (x)
+ (flet ((componentp (c) (typep c '(or string pathname keyword))))
+ (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
+
+(defun* location-function-p (x)
+ (and
+ (consp x)
+ (length=n-p x 2)
+ (or (and (equal (first x) :function)
+ (typep (second x) 'symbol))
+ (and (equal (first x) 'lambda)
+ (cddr x)
+ (length=n-p (second x) 2)))))
+
+(defun* validate-output-translations-directive (directive)
+ (unless
+ (or (member directive '(:inherit-configuration
+ :ignore-inherited-configuration
+ :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))))))
+ (error "Invalid directive ~S~%" directive))
+ directive)
+
+(defun* validate-output-translations-form (form)
+ (validate-configuration-form
+ form
+ :output-translations
+ 'validate-output-translations-directive
+ "output translations"))
+
+(defun* validate-output-translations-file (file)
+ (validate-configuration-file
+ file 'validate-output-translations-form "output translations"))
+
+(defun* validate-output-translations-directory (directory)
+ (validate-configuration-directory
+ directory :output-translations 'validate-output-translations-directive))
+
+(defun* parse-output-translations-string (string)
+ (cond
+ ((or (null string) (equal string ""))
+ '(:output-translations :inherit-configuration))
+ ((not (stringp string))
+ (error "environment string isn't: ~S" string))
+ ((eql (char string 0) #\")
+ (parse-output-translations-string (read-from-string string)))
+ ((eql (char string 0) #\()
+ (validate-output-translations-form (read-from-string string)))
+ (t
+ (loop
+ :with inherit = nil
+ :with directives = ()
+ :with start = 0
+ :with end = (length string)
+ :with source = nil
+ :for i = (or (position *inter-directory-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 "only one inherited configuration allowed: ~S" string))
+ (setf inherit t)
+ (push :inherit-configuration directives))
+ (t
+ (setf source s)))
+ (setf start (1+ i))
+ (when (> start end)
+ (when source
+ (error "Uneven number of components in source to destination mapping ~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 "SBCL_HOME"))) (when (plusp (length h)) `(,h ())))
+ #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
+ #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
+ ;; 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* #p"asdf-output-translations.conf")
+(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
+
+(defun* user-output-translations-pathname ()
+ (in-user-configuration-directory *output-translations-file* ))
+(defun* system-output-translations-pathname ()
+ (in-system-configuration-directory *output-translations-file*))
+(defun* user-output-translations-directory-pathname ()
+ (in-user-configuration-directory *output-translations-directory*))
+(defun* system-output-translations-directory-pathname ()
+ (in-system-configuration-directory *output-translations-directory*))
+(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 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 (make-pathname
+ :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
+ (wilddst (make-pathname
+ :name :wild :type :wild :version :wild
+ :defaults 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))
+
+(defun* initialize-output-translations (&optional parameter)
+ "read the configuration, initialize the internal configuration variable,
+return the configuration"
+ (setf (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)
+ (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"
+ (declare (ignorable operation component))
+ (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)
+ (or output-file
+ (apply-output-translations
+ (apply 'compile-file-pathname
+ (truenamize (lispize-pathname input-file))
+ keys))))
+
+(defun* tmpize-pathname (x)
+ (make-pathname
+ :name (format nil "ASDF-TMP-~A" (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 output-file &allow-other-keys)
+ (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
+ (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 keys)
+ (cond
+ (failure-p
+ (setf status *compile-file-failure-behaviour*))
+ (warnings-p
+ (setf status *compile-file-warnings-behaviour*))
+ (t
+ (setf status :success)))
+ (ecase status
+ ((:success :warn :ignore)
+ (delete-file-if-exists output-file)
+ (when output-truename
+ (rename-file output-truename output-file)
+ (setf output-truename output-file)))
+ (:error
+ (delete-file-if-exists output-truename)
+ (setf output-truename nil)))
+ (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
+
+(defun* enable-asdf-binary-locations-compatibility
+ (&key
+ (centralize-lisp-binaries nil)
+ (default-toplevel-directory
+ ;; Use ".cache/common-lisp" instead ???
+ (merge-pathnames* (make-pathname :directory '(:relative ".fasls"))
+ (user-homedir)))
+ (include-per-user-information nil)
+ (map-all-source-files (or #+(or ecl clisp) t nil))
+ (source-to-target-mappings nil))
+ #+(or ecl clisp)
+ (when (null map-all-source-files)
+ (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
+ (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
+ (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
+ (mapped-files (make-pathname
+ :name :wild :version :wild
+ :type (if map-all-source-files :wild fasl-type)))
+ (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))))
+
+;;;; -----------------------------------------------------------------
+;;;; Windows shortcut support. Based on:
+;;;;
+;;;; Jesse Hager: The Windows Shortcut File Format.
+;;;; http://www.wotsit.org/list.asp?fc=13
+
+#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
+(progn
+(defparameter *link-initial-dword* 76)
+(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
+
+(defun* read-null-terminated-string (s)
+ (with-output-to-string (out)
+ (loop :for code = (read-byte s)
+ :until (zerop code)
+ :do (write-char (code-char code) out))))
+
+(defun* read-little-endian (s &optional (bytes 4))
+ (loop
+ :for i :from 0 :below bytes
+ :sum (ash (read-byte s) (* 8 i))))
+
+(defun* parse-file-location-info (s)
+ (let ((start (file-position s))
+ (total-length (read-little-endian s))
+ (end-of-header (read-little-endian s))
+ (fli-flags (read-little-endian s))
+ (local-volume-offset (read-little-endian s))
+ (local-offset (read-little-endian s))
+ (network-volume-offset (read-little-endian s))
+ (remaining-offset (read-little-endian s)))
+ (declare (ignore total-length end-of-header local-volume-offset))
+ (unless (zerop fli-flags)
+ (cond
+ ((logbitp 0 fli-flags)
+ (file-position s (+ start local-offset)))
+ ((logbitp 1 fli-flags)
+ (file-position s (+ start
+ network-volume-offset
+ #x14))))
+ (concatenate 'string
+ (read-null-terminated-string s)
+ (progn
+ (file-position s (+ start remaining-offset))
+ (read-null-terminated-string s))))))
+
+(defun* parse-windows-shortcut (pathname)
+ (with-open-file (s pathname :element-type '(unsigned-byte 8))
+ (handler-case
+ (when (and (= (read-little-endian s) *link-initial-dword*)
+ (let ((header (make-array (length *link-guid*))))
+ (read-sequence header s)
+ (equalp header *link-guid*)))
+ (let ((flags (read-little-endian s)))
+ (file-position s 76) ;skip rest of header
+ (when (logbitp 0 flags)
+ ;; skip shell item id list
+ (let ((length (read-little-endian s 2)))
+ (file-position s (+ length (file-position s)))))
+ (cond
+ ((logbitp 1 flags)
+ (parse-file-location-info s))
+ (t
+ (when (logbitp 2 flags)
+ ;; skip description string
+ (let ((length (read-little-endian s 2)))
+ (file-position s (+ length (file-position s)))))
+ (when (logbitp 3 flags)
+ ;; finally, our pathname
+ (let* ((length (read-little-endian s 2))
+ (buffer (make-array length)))
+ (read-sequence buffer s)
+ (map 'string #'code-char buffer)))))))
+ (end-of-file ()
+ nil)))))
+
+;;;; -----------------------------------------------------------------
+;;;; 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 build stuff under the debian directory... BAD.
+
+(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
+
+(defvar *source-registry* ()
+ "Either NIL (for uninitialized), or a list of one element,
+said element itself being a list of directory pathnames where to look for .asd files")
+
+(defun* source-registry ()
+ (car *source-registry*))
+
+(defun* (setf source-registry) (new-value)
+ (setf *source-registry* (list new-value))
+ new-value)
+
+(defun* source-registry-initialized-p ()
+ (and *source-registry* t))
+
+(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* '())
+ (values))
+
+(defparameter *wild-asd*
+ (make-pathname :directory nil :name :wild :type "asd" :version :newest))
+
+(defun directory-has-asd-files-p (directory)
+ (and (ignore-errors
+ (directory (merge-pathnames* *wild-asd* directory)
+ #+sbcl #+sbcl :resolve-symlinks nil
+ #+ccl #+ccl :follow-links nil
+ #+clisp #+clisp :circle t))
+ t))
+
+(defun subdirectories (directory)
+ (let* ((directory (ensure-directory-pathname directory))
+ #-cormanlisp
+ (wild (merge-pathnames*
+ #-(or abcl allegro lispworks scl)
+ (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
+ #+(or abcl allegro lispworks scl) "*.*"
+ directory))
+ (dirs
+ #-cormanlisp
+ (ignore-errors
+ (directory wild .
+ #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
+ #+ccl '(:follow-links nil :directories t :files nil)
+ #+clisp '(:circle t :if-does-not-exist :ignore)
+ #+(or cmu scl) '(:follow-links nil :truenamep nil)
+ #+digitool '(:directories t)
+ #+sbcl '(:resolve-symlinks nil))))
+ #+cormanlisp (cl::directory-subdirs directory))
+ #+(or abcl allegro lispworks scl)
+ (dirs (remove-if-not #+abcl #'extensions:probe-directory
+ #+allegro #'excl:probe-directory
+ #+lispworks #'lw:file-directory-p
+ #-(or abcl allegro lispworks) #'directory-pathname-p
+ dirs)))
+ dirs))
+
+(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-with-asd
+ (directory &key
+ (exclude *default-source-registry-exclusions*)
+ collect)
+ (collect-sub*directories
+ directory
+ #'directory-has-asd-files-p
+ #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
+ collect))
+
+(defun* validate-source-registry-directive (directive)
+ (unless
+ (or (member directive '(:default-registry (:default-registry)) :test 'equal)
+ (destructuring-bind (kw &rest rest) directive
+ (case kw
+ ((:include :directory :tree)
+ (and (length=n-p rest 1)
+ (location-designator-p (first rest))))
+ ((:exclude :also-exclude)
+ (every #'stringp rest))
+ (null rest))))
+ (error "Invalid directive ~S~%" directive))
+ directive)
+
+(defun* validate-source-registry-form (form)
+ (validate-configuration-form
+ form :source-registry 'validate-source-registry-directive "a source registry"))
+
+(defun* validate-source-registry-file (file)
+ (validate-configuration-file
+ file 'validate-source-registry-form "a source registry"))
+
+(defun* validate-source-registry-directory (directory)
+ (validate-configuration-directory
+ directory :source-registry 'validate-source-registry-directive))
+
+(defun* parse-source-registry-string (string)
+ (cond
+ ((or (null string) (equal string ""))
+ '(:source-registry :inherit-configuration))
+ ((not (stringp string))
+ (error "environment string isn't: ~S" string))
+ ((find (char string 0) "\"(")
+ (validate-source-registry-form (read-from-string string)))
+ (t
+ (loop
+ :with inherit = nil
+ :with directives = ()
+ :with start = 0
+ :with end = (length string)
+ :for pos = (position *inter-directory-separator* string :start start) :do
+ (let ((s (subseq string start (or pos end))))
+ (cond
+ ((equal "" s) ; empty element: inherit
+ (when inherit
+ (error "only one inherited configuration allowed: ~S" string))
+ (setf inherit t)
+ (push ':inherit-configuration directives))
+ ((ends-with s "//")
+ (push `(:tree ,(subseq s 0 (1- (length s)))) directives))
+ (t
+ (push `(:directory ,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)
+ (funcall collect directory)
+ (collect-sub*directories-with-asd
+ 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* #p"source-registry.conf")
+(defparameter *source-registry-directory* #p"source-registry.conf.d/")
+
+(defun* wrapping-source-registry ()
+ `(:source-registry
+ #+sbcl (:tree ,(getenv "SBCL_HOME"))
+ :inherit-configuration
+ #+cmu (:tree #p"modules:")))
+(defun* default-source-registry ()
+ (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
+ `(:source-registry
+ #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
+ (:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
+ ,@(let*
+ #+(or unix cygwin)
+ ((datahome
+ (or (getenv "XDG_DATA_HOME")
+ (try (user-homedir) ".local/share/")))
+ (datadirs
+ (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
+ (dirs (cons datahome (split-string datadirs :separator ":"))))
+ #+(and (or win32 windows mswindows mingw32) (not cygwin))
+ ((datahome (getenv "APPDATA"))
+ (datadir
+ #+lispworks (sys:get-folder-path :local-appdata)
+ #-lispworks (try (getenv "ALLUSERSPROFILE")
+ "Application Data"))
+ (dirs (list datahome datadir)))
+ #-(or unix win32 windows mswindows mingw32 cygwin)
+ ((dirs ()))
+ (loop :for dir :in dirs
+ :collect `(:directory ,(try dir "common-lisp/systems/"))
+ :collect `(:tree ,(try dir "common-lisp/source/"))))
+ :inherit-configuration)))
+(defun* user-source-registry ()
+ (in-user-configuration-directory *source-registry-file*))
+(defun* system-source-registry ()
+ (in-system-configuration-directory *source-registry-file*))
+(defun* user-source-registry-directory ()
+ (in-user-configuration-directory *source-registry-directory*))
+(defun* system-source-registry-directory ()
+ (in-system-configuration-directory *source-registry-directory*))
+(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)
+ (process-source-registry (validate-source-registry-directory pathname)
+ :inherit inherit :register register))
+ ((probe-file 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)