+(defparameter *wild-asd*
+ (make-pathname :directory '(:relative :wild-inferiors)
+ :name :wild :type "asd" :version :newest))
+
+
+(declaim (ftype (function (t &optional boolean) (or null pathname))
+ resolve-location))
+
+(defun resolve-relative-location-component (super x &optional wildenp)
+ (let* ((r (etypecase x
+ (pathname x)
+ (string x)
+ (cons
+ (let ((car (resolve-relative-location-component super (car x) nil)))
+ (if (null (cdr x))
+ car
+ (let ((cdr (resolve-relative-location-component
+ (merge-pathnames* car super) (cdr x) wildenp)))
+ (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 (pathnamep x) r (ensure-directory-pathname r)))
+ (s (if (and wildenp (not (pathnamep x)))
+ (wilden d)
+ 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 wildenp)
+ (let* ((r
+ (etypecase x
+ (pathname x)
+ (string (ensure-directory-pathname x))
+ (cons
+ (let ((car (resolve-absolute-location-component (car x) nil)))
+ (if (null (cdr x))
+ car
+ (let ((cdr (resolve-relative-location-component
+ car (cdr x) wildenp)))
+ (merge-pathnames* cdr car)))))
+ ((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
+ (make-pathname :directory '(:relative))))
+ ((eql :home) (user-homedir))
+ ((eql :user-cache) (resolve-location *user-cache* nil))
+ ((eql :system-cache) (resolve-location *system-cache* nil))
+ ((eql :default-directory) (default-directory))))
+ (s (if (and wildenp (not (pathnamep x)))
+ (wilden r)
+ r)))
+ (unless (absolute-pathname-p s)
+ (error "Not an absolute pathname ~S" s))
+ s))
+
+(defun resolve-location (x &optional wildenp)
+ (if (atom x)
+ (resolve-absolute-location-component x wildenp)
+ (loop :with path = (resolve-absolute-location-component (car x) nil)
+ :for (component . morep) :on (cdr x)
+ :do (setf path (resolve-relative-location-component
+ path component (and wildenp (not morep))))
+ :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))
+ (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 (,(getenv "SBCL_HOME") ())
+ #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
+ #+clozure (,(wilden (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))
+ ;; If we want to enable the user cache by default, here would be the place:
+ :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))
+ (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 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 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 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
+ (cond
+ ((functionp destination)
+ (funcall destination p absolute-source))
+ ((eq destination t)
+ p)
+ ((not (pathnamep destination))
+ (error "invalid destination"))
+ ((not (absolute-pathname-p destination))
+ (translate-pathname p absolute-source (merge-pathnames* destination root)))
+ (root
+ (translate-pathname (directorize-pathname-host-device p) absolute-source destination))
+ (t
+ (translate-pathname p absolute-source destination)))
+ :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 (probe-file x)
+ (delete-file x)))
+
+(defun compile-file* (input-file &rest keys &key &allow-other-keys)
+ (let* ((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 nil)
+ (source-to-target-mappings nil))
+ (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
+
+(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"
+ ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
+ "_sgbak" "autom4te.cache" "cover_db" "_build"))
+
+(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))