Skip to content
Snippets Groups Projects
asdf.lisp 112 KiB
Newer Older
    #+cmu (substitute #\- #\/ s)
    #+clozure (format nil "~d.~d~@[-~d~]"
                      ccl::*openmcl-major-version*
                      ccl::*openmcl-minor-version*
                      #-ppc64-target nil)
    #+lispworks (format nil "~A~@[~A~]" s
                        (when (member :lispworks-64bit *features*) "-64bit"))
    #+allegro (format nil
                      "~A~A~A~A"
                      excl::*common-lisp-version-number*
                      ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                      (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
                      (if (member :64bit *features*) "-64bit" ""))
    #+(or clisp gcl) (subseq s 0 (position #\space s))
    #+digitool (subseq s 8)))

(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
(defun user-configuration-directory ()
  (merge-pathnames #p".config/" (user-homedir-pathname)))
(defun system-configuration-directory ()
  #p"/etc/")

(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 validate-configuration-directory (directory tag validator)
  (let ((files (sort (ignore-errors
                       (directory (merge-pathnames
                                   (make-pathname :name :wild :type :wild)
                                   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* '(:home ".cache" "common-lisp" :implementation))
(defvar *system-cache* '(:root "var" "cache" "common-lisp" :uid :implementation))

(defun output-translations ()
  (car *output-translations*))

(defun (setf output-translations) (x)
  (setf *output-translations*
        (list
         (stable-sort (copy-list x) #'>
                      :key (lambda (x) (length (pathname-directory (car x))))))))

(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))

(defparameter *wild-path*
  (make-pathname :directory '(:relative :wild-inferiors)
                 :name :wild :type :wild :version nil))

(defun wilden (path)
  (merge-pathnames *wild-path* path))
(defun resolve-absolute-location-component (x wildenp)
  (let* ((r
          (etypecase x
            (pathname x)
            (string (ensure-directory-pathname x))
            ((eql :home) (user-homedir-pathname))
            ((eql :user-cache) (resolve-location *user-cache* nil))
            ((eql :system-cache) (resolve-location *system-cache* nil))
            ((eql :current-directory) (truenamize *default-pathname-defaults*))
            ((eql :root) (make-pathname :directory '(:absolute)))))
         (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-relative-location-component (super x &optional wildenp)
  (let* ((r (etypecase x
              (pathname x)
              (string x)
              ((eql :current-directory)
               (relativize-pathname-directory
                (truenamize *default-pathname-defaults*)))
              ((eql :implementation) (implementation-identifier))
              ((eql :implementation-type) (implementation-type))
              ((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-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 (componentp x) (and (consp x) (every #'componentp x)))))

(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)))
                            (and (location-designator-p (first directive))
                                 (or (location-designator-p (second directive))
                                     (null (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))
    ((find (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 #\: 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*
  '(implementation-output-translations
    user-output-translations-pathname
    user-output-translations-directory-pathname
    system-output-translations-pathname
    system-output-translations-directory-pathname))

(defparameter *implementation-output-translations*
  `(:output-translations
   ;; If clozure had any precompiled ASDF system, we'd use that:
   ; #+clozure (,(ccl::ccl-directory) ())
   ;; SBCL *does* have precompiled ASDF system, so we use this:
   #+sbcl (,(getenv "SBCL_HOME") ())
   ;; All-import, here is where we want user stuff to be:
   :inherit-configuration
   ;; If we want to enable the user cache by default, here would be the place:
   :enable-user-cache
   ))

(defun implementation-output-translations ()
  *implementation-output-translations*)

(defparameter *output-translations-file* #p"common-lisp/asdf-output-translations.conf")
(defparameter *output-translations-directory* #p"common-lisp/asdf-output-translations.conf.d/")

(defun user-output-translations-pathname ()
  (merge-pathnames *output-translations-file* (user-configuration-directory)))
(defun system-output-translations-pathname ()
  (merge-pathnames *output-translations-file* (system-configuration-directory)))
(defun user-output-translations-directory-pathname ()
  (merge-pathnames *output-translations-directory* (user-configuration-directory)))
(defun system-output-translations-directory-pathname ()
  (merge-pathnames *output-translations-directory* (system-configuration-directory)))
(defun environment-output-translations ()
  (getenv "ASDF_OUTPUT_TRANSLATIONS"))

(defgeneric process-output-translations (spec &key inherit collect))
(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 *default-output-translations*)
                                        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 *default-output-translations*)
                                        collect)
  (process-output-translations (parse-output-translations-string string)
                               :inherit inherit :collect collect))
(defmethod process-output-translations ((x null) &key
                                    (inherit *default-output-translations*)
                                    collect)
  (declare (ignorable x))
  (inherit-output-translations inherit :collect collect))
(defmethod process-output-translations ((form cons) &key
                                        (inherit *default-output-translations*)
                                        collect)
  (multiple-value-bind (collect result)
      (if collect
          (values collect (constantly nil))
          (make-collector))
    (dolist (directive (cdr (validate-output-translations-form form)))
      (process-output-translations-directive directive :inherit inherit :collect collect))
    (funcall result)))

(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 '(:root :user-cache) :collect collect))
        ((:disable-cache)
         (process-output-translations-directive '(:root :root) :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)
            (process-output-translations (pathname dst) :inherit nil :collect collect)
            (let* ((trusrc (truenamize (resolve-location src t)))
                   (trudst (if dst (resolve-location dst t) trusrc)))
              (funcall collect (list trusrc trudst)))))))

;; Will read the configuration and initialize all internal variables,
;; and return the new configuration.
(defun initialize-output-translations
    (&optional (translations *default-output-translations*))
  (setf (output-translations)
        (inherit-output-translations translations)))

;; 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)))

  (ensure-output-translations)
  (setf path (truenamize path))
  (loop :for (source destination) :in (car *output-translations*)
    :when (pathname-match-p path source)
    :return (translate-pathname path source destination)
    :finally (return path)))

(defmethod output-files :around ((op operation) (c component))
  "Method to rewrite output files to fasl-root"
  (mapcar #'apply-output-translations (call-next-method)))

(defun compile-file-pathname* (input-file &rest keys)
  (apply-output-translations
   (apply #'compile-file-pathname
          (truenamize (merge-pathnames (make-pathname :type "lisp") input-file))
          keys)))

;;;; -----------------------------------------------------------------
;;;; Windows shortcut support.  Based on:
;;;;
;;;; Jesse Hager: The Windows Shortcut File Format.
;;;; http://www.wotsit.org/list.asp?fc=13
D Herring's avatar
D Herring committed

(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))))
D Herring's avatar
D Herring committed

(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))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
        (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
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
        ((logbitp 0 fli-flags)
          (file-position s (+ start local-offset)))
        ((logbitp 1 fli-flags)
          (file-position s (+ start
                              network-volume-offset
                              #x14))))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
        (read-null-terminated-string s)
        (progn
          (file-position s (+ start remaining-offset))
          (read-null-terminated-string s))))))
D Herring's avatar
D Herring committed
(defun parse-windows-shortcut (pathname)
  (with-open-file (s pathname :element-type '(unsigned-byte 8))
    (handler-case
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
        (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)))))))
D Herring's avatar
D Herring committed
      (end-of-file ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
        nil))))
;;;; -----------------------------------------------------------------
;;;; Source Registry Configuration, by Francois-Rene Rideau
;;;; See README.source-registry and https://bugs.launchpad.net/asdf/+bug/485918
(pushnew 'sysdef-source-registry-search *system-definition-search-functions*)

;; Using ack 1.2 exclusions
(defvar *default-exclusions*
  '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    "_sgbak" "autom4te.cache" "cover_db" "_build"))

(defun default-registry ()
(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 (setf source-registry) (x)

(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))
(defun sysdef-source-registry-search (system)
  (ensure-source-registry)
  (let ((name (coerce-name system)))
    (block nil
      (dolist (dir (source-registry))
        (let ((defaults (eval dir)))
          (when defaults
            (cond ((directory-pathname-p defaults)
                   (let ((file (and defaults
                                    (make-pathname
                                     :defaults defaults :version :newest
                                     :name name :type "asd" :case :local)))
                         #+(and (or win32 windows) (not :clisp))
                         (shortcut (make-pathname
                                    :defaults defaults :version :newest
                                    :name name :type "asd.lnk" :case :local)))
                     (when (and file (probe-file file))
                       (return file))
                     #+(and (or win32 windows) (not :clisp))
                     (when (probe-file shortcut)
                       (let ((target (parse-windows-shortcut shortcut)))
                         (when target
                           (return (pathname target))))))))))))))

(defun validate-source-registry-directive (directive)
      (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)
                    (typep (car rest) '(or pathname string))))
              ((:exclude)
               (every #'stringp rest))
              (null rest))))
    (error "Invalid directive ~S~%" directive))
  (validate-configuration-form
   form :source-registry 'validate-source-registry-directive "a source registry"))
  (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))
  (cond
    ((or (null string) (equal string ""))
     '(:source-registry :inherit-configuration))
    ((not (stringp string))
     (error "environment string isn't: ~S" string))
    ((eql (char string 0) "\"(")
     (validate-source-registry-form (read-from-string string)))
    (t
      :with inherit = nil
      :with directives = ()
      :with start = 0
      :with end = (length string)
      :for i = (or (position #\: string :start start) end) :do
      (let ((s (subseq string start i)))
        (cond
          (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)))
         (setf start (1+ i))
         (when (>= start end)
           (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 (ensure-directory-pathname directory))
      (let* ((files (ignore-errors
                      (directory (merge-pathnames #P"**/*.asd" directory)
                                 #+sbcl #+sbcl :resolve-symlinks nil
                                 #+clisp #+clisp :circle t)))
             (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files)
                                      :test #'equal)))
        (loop
          :for dir :in dirs
          :unless (loop :for x :in exclude
                    :thereis (find x (pathname-directory dir) :test #'equal))
          :do (funcall collect dir)))))
  '(environment-source-registry
    user-source-registry
    user-source-registry-directory
    system-source-registry
    system-source-registry-directory))

(defparameter *source-registry-file* #p"common-lisp/source-registry.conf")
(defparameter *source-registry-directory* #p"common-lisp/source-registry.conf.d/")

  (merge-pathnames *source-registry-file* (user-configuration-directory)))
  (merge-pathnames *source-registry-file* (system-configuration-directory)))
  (merge-pathnames *source-registry-directory* (user-configuration-directory)))
  (merge-pathnames *source-registry-directory* (system-configuration-directory)))
(defun environment-source-registry ()
  (getenv "CL_SOURCE_REGISTRY"))
(defgeneric process-source-registry (spec &key inherit register))
(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))
     (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 ((*default-exclusions* *default-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)
    (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 (pathname pathname) :inherit nil :register register)))
         (funcall register pathname)))
         (funcall register pathname :recurse t :exclude *default-exclusions*)))
      ((:exclude)
       (setf *default-exclusions* rest))
      ((:default-registry)
       (default-registry))
      ((:inherit-configuration)
       (inherit-source-registry inherit :register register))
;; Will read the configuration and initialize all internal variables,
;; and return the new configuration.
(defun compute-source-registry (&optional parameter)
  (multiple-value-bind (collect result) (make-collector)
    (inherit-source-registry
     (list*
      parameter
      *default-source-registries*)
     :register
     (lambda (directory &key recurse exclude)
       (register-asd-directory
        directory
        :recurse recurse :exclude exclude :collect collect)))
    (funcall result)))

(defun initialize-source-registry (&optional parameter)
  (setf (source-registry) (compute-source-registry parameter)))
;; 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-source-registry ()
  (if (source-registry-initialized-p)
      (source-registry)
      (initialize-source-registry)))
;;;; -----------------------------------------------------------------
;;;; SBCL hook into REQUIRE
;;;;
#+sbcl
(progn
  (defun module-provide-asdf (name)
    (handler-bind ((style-warning #'muffle-warning))
      (let* ((*verbose-out* (make-broadcast-stream))
             (system (asdf:find-system name nil)))
        (when system
          (asdf:operate 'asdf:load-op name)
          t))))
  (defun contrib-sysdef-search (system)
    (let ((home (getenv "SBCL_HOME")))
      (when (and home (not (string= home "")))
        (let* ((name (coerce-name system))
               (home (truename home))
               (contrib (merge-pathnames
                         (make-pathname :directory `(:relative ,name)
                                        :name name
                                        :type "asd"
                                        :case :local
                                        :version :newest)
                         home)))
          (probe-file contrib)))))
   '(let ((home (getenv "SBCL_HOME")))
      (when (and home (not (string= home "")))
        (merge-pathnames "site-systems/" (truename home))))
   *central-registry*)
   '(merge-pathnames ".sbcl/systems/"
     (user-homedir-pathname))
   *central-registry*)
  (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
  (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
;;;; -------------------------------------------------------------------------
;;;; Cleanups after hot-upgrade.
;;;; Things to do in case we're upgrading from a previous version of ASDF.
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
;;;;
;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1
(eval-when (:compile-toplevel :load-toplevel :execute)
  #+ecl ;; Support upgrade from before ECL went to 1.369
  (when (fboundp 'compile-op-system-p)
    (defmethod compile-op-system-p ((op compile-op))
      (getf :system-p (compile-op-flags op)))
    (defmethod initialize-instance :after ((op compile-op)
                                           &rest initargs
                                           &key system-p &allow-other-keys)
      (declare (ignorable initargs))
      (when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))
;;;; -----------------------------------------------------------------
;;;; Done!
(when *load-verbose*
  (asdf-message ";; ASDF, version ~a" (asdf-version)))
(eval-when (:compile-toplevel :execute)
  (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
    (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))

;;(pushnew :asdf2 *features*) ;; do that when we reach version 2