;;; -*- indent-tabs-mode: nil -*-

;;; Copyright (c) 2006 David Lichteblau
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation files
;;; (the "Software"), to deal in the Software without restriction,
;;; including without limitation the rights to use, copy, modify, merge,
;;; publish, distribute, sublicense, and/or sell copies of the Software,
;;; and to permit persons to whom the Software is furnished to do so,
;;; subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;; SOFTWARE.

(in-package :sb-heapdump)

(defvar *central-registry*
    (list *default-pathname-defaults*
          (truename (sb-ext:posix-getenv "SBCL_HOME"))))

(defun dump-systems (pathname systems package-names &key (if-exists :error))
  (let* ((names (mapcar #'asdf::coerce-name systems))
         (specs
          (mapcar (lambda (name)
                    (or (gethash name asdf::*defined-systems*)
                        (error "system not found: ~A" name)))
                  names))
         (depends-on
          (loop
              for (nil . system) in specs
              for do-first = (slot-value system 'asdf::do-first)
              for in-order-to-compile = (cdr (assoc 'asdf:compile-op do-first))
              append (cdr (assoc 'asdf:load-op in-order-to-compile)))))
    (setf depends-on (mapcar #'asdf::coerce-name depends-on))
    (setf depends-on (remove-duplicates depends-on :test #'string=))
    (setf depends-on (set-difference depends-on names :test #'string=))
    (dump-packages
     package-names
     pathname
     :initializer (lambda (packages)
                    (dolist (spec specs)
                      (let ((name (asdf:component-name (cdr spec))))
                        (setf (gethash name asdf::*defined-systems*) spec)))
                    (dolist (dep depends-on)
                      (unless (find (string-upcase dep) *modules* :test 'equal)
                        (when *dumpload-verbose*
                          (format t "~&; loading dependency ~A~%" dep))
                        (require dep)))
                    packages)
     :if-exists if-exists)))

(defmethod dump-system ((system symbol))
  (dump-system (asdf:find-system system)))

(defmethod dump-system ((system string))
  (dump-system (asdf:find-system system)))

(defmethod dump-system ((c asdf:component))
  (error "Component ~A does not implement SB-HEAPDUMP:DUMP-SYSTEM." c))

(defun coerce-name (name)
  (etypecase name
    (symbol (string-downcase (symbol-name name)))
    (string name)))

(defun find-heap-file (name)
  (some (lambda (dir)
          (let* ((defaults (eval dir))
                 (file (and defaults
                            (make-pathname
                             :defaults defaults :version :newest
                             :name name :type "heap" :case :local))))
            (and file (probe-file file))))
        *central-registry*))

(defun module-provide-heapfile (name)
  (setf name (coerce-name name))
  (if (gethash name asdf::*defined-systems*)
      nil
      (let ((heap-file (find-heap-file name)))
        (when heap-file
          (load-dumpfile heap-file)
          (provide (string-upcase name))
          t))))

(pushnew 'module-provide-heapfile sb-ext:*module-provider-functions*)