#+xcvb (module (:build-depends-on () :depends-on ("/asdf")))
#| ;;; cl-launch 4.1.3 lisp header

|# ;;;; Silence our lisp implementation for quiet batch use...

#| We'd like to evaluate as little as possible of the code without compilation.
 This poses a typical bootstrapping problem: the more sophistication we want
 to distinguish what to put where in what dynamic environment, the more code
 we have to evaluate before we may actually load compiled files. And, then,
 it is a waste of time to try to compile said code into a file. Moving things
 to the shell can only help so much, and reduces flexibility. Our best bet is
 to tell sbcl or cmucl to not try to optimize too hard.
|#
(eval-when (:compile-toplevel :load-toplevel :execute)
  ;; Configure the printer
  (setf *print-readably* nil ; allegro 5.0 may bork without this
        *print-level* nil)
  ;; Hush the compiler and loader.
  (setf *load-verbose* nil *compile-verbose* nil *compile-print* nil *load-print* nil)
  ;; The code below exemplifies how to try super-hard to load ASDF 3 from standard locations,
  ;; by trying nice methods first, then increasingly desperate ones.
  ;; Stage 1 is to load ASDF at all.
  ;; Stage 2 is to upgrade to whichever ASDF installation the user has configured (if any).
  ;; Versions older than ASDF 3.1 need to be told about ~/common-lisp/
  ;; ASDF 1 has no output translation layer, so can be configured to load ASDF 3
  ;; only if ASDF 3 is in a predictable place under the user's homedir, thus
  ;; ~/common-lisp/asdf/ or ~/.local/share/common-lisp/source/asdf/ only.
  (block nil
    (let ((required-asdf-version  "3.1.2")
          (verbose *load-verbose*))
      (labels ((asdf-symbol (name)
                 (and (find-package :asdf) (find-symbol (string name) :asdf)))
               (asdf-call (name &rest args)
                 (apply (asdf-symbol name) args))
               (asdf-version ()
                 (when (find-package :asdf)
                   (or (symbol-value (or (asdf-symbol '*asdf-version*)
                                         (asdf-symbol '*asdf-revision*)))
                       "1.0")))
               (maybe-display (message)
                 (when (and verbose message) (format t "~&~A~%" message)))
               (call-maybe-verbosely (message function &rest args)
                 (cond
                   (verbose
                    (maybe-display message)
                    (apply function args))
                   (t
                    #+abcl ;; Bug in ABCL 1.3.0: without this, loading asdf.fasl shows warnings
                    (let* ((uc (asdf-symbol '*uninteresting-conditions*))
                           (vars (when uc (list uc)))
                           (vals (when uc (list (cons 'warning (symbol-value uc))))))
                      (progv vars vals
                        (handler-bind ((warning #'muffle-warning))
                          (apply function args))))
                    #-abcl
                    (handler-bind ((warning #'muffle-warning))
                      (apply function args)))))
               (try-stage-1 (message function)
                 (ignore-errors
                  (call-maybe-verbosely (format nil "Trying to ~A" message) function))
                 (maybe-done-stage-1))
               (subpath (parent &key directory name type)
                 (merge-pathnames (make-pathname :defaults parent :name name :type type :version nil
                                                 :directory (cons :relative directory))
                                  parent))
               (build/asdf.lisp (x) (subpath x :directory '("build") :name "asdf" :type "lisp"))
               (visible-default-user-asdf-directory ()
                 (subpath (user-homedir-pathname) :directory '("common-lisp" "asdf")))
               (visible-default-user-asdf-lisp ()
                 (build/asdf.lisp (visible-default-user-asdf-directory)))
               (hidden-default-user-asdf-directory ()
                 (subpath (user-homedir-pathname) :directory '(".local" "share" "common-lisp" "asdf")))
               (hidden-default-user-asdf-lisp ()
                 (build/asdf.lisp (hidden-default-user-asdf-directory)))
               (try-file-stage-1 (name explanation base root sub)
                 (try-stage-1
                  (format nil "load ASDF from ~A/ under the ~A CL source directory ~A~{~A/~}"
                          name explanation root sub)
                  #'(lambda () (load (build/asdf.lisp
                                      (subpath base :directory (append sub (list name))))))))
               (stage-1 () ;; Try to load ASDF at all, any ASDF.
                 (try-stage-1
                  ;; Do nothing if ASDF is already loaded
                  "use an already loaded ASDF"
                  (constantly nil))
                 (try-stage-1
                  "require ASDF from the implementation"
                  ;; Most implementations provide ASDF, but while most of them are case-insensitive,
                  ;; CLISP is case-sensitive, so we need to specify a lowercase string,
                  ;; and not the keyword :asdf or symbol 'asdf.
                  ;; Most recent implementations provide ASDF 3, but some of them only ASDF 2
                  ;; and antique versions only of ASDF 1.
                  #'(lambda () (funcall 'require "asdf")))
                 (try-file-stage-1 "asdf" "default (visible)" (user-homedir-pathname)
                                   "~/" '("common-lisp"))
                 (try-file-stage-1 "asdf" "default (hidden)" (user-homedir-pathname)
                                   "~/" '(".local" "share" "common-lisp"))
                 #+(or unix linux bsd darwin)
                 (progn
                   (loop :for (name path) :in '(("local system" ("local")) ("managed system" ()))
                         :do (loop :for sub :in '(() ("source"))
                                   :do (try-file-stage-1
                                        "asdf" name #p"/" "/"
                                        (append '("usr") path '("share" "common-lisp") sub))))
                   (try-file-stage-1 "cl-asdf" "managed system" #p"/" "/"
                                     '("usr" "share" "common-lisp" "source")))
                 (error "Could not load ASDF."))
               (maybe-done-stage-1 ()
                 ;; If we have ASDF, then go to stage 2: have it upgrade itself.
                 (when (member :asdf *features*)
                   (maybe-display (format nil "Found ASDF ~A" (asdf-version)))
                   (stage-2))) ;; doesn't return.
               (centrally-register (path)
                 (let ((r (asdf-symbol '*central-registry*)))
                   (pushnew path (symbol-value r))
                   (pushnew (subpath path :directory '("uiop")) (symbol-value r))))
               (configure-asdf ()
                 ;; configure older versions of ASDF, as needed
                 (cond
                   ((probe-file (visible-default-user-asdf-lisp))
                    (unless (member :asdf3.1 *features*)
                      (maybe-display "Telling this old ASDF about your ~/common-lisp/asdf/")
                      (centrally-register (visible-default-user-asdf-directory))))
                   ((probe-file (hidden-default-user-asdf-lisp))
                    (unless (member :asdf2 *features*)
                      (maybe-display "Telling this antique ASDF about your ~/.local/share/common-lisp/asdf/")
                      (centrally-register (hidden-default-user-asdf-directory))))))
               (maybe-done-stage-2 ()
                 (when (ignore-errors (asdf-call 'version-satisfies
                                                 (asdf-version) required-asdf-version))
                   (when verbose
                     (format t "~&Victory! We now have ASDF ~A~%" (asdf-version)))
                   (return)))
               (stage-2 ()
                 ;; We have ASDF, now have it upgrade itself.
                 (configure-asdf)
                 (when (asdf-call 'find-system :asdf nil)
                   (call-maybe-verbosely
                    "Trying to upgrade ASDF"
                    (asdf-symbol 'operate) (asdf-symbol 'load-op) :asdf) :verbose nil)
                 (maybe-done-stage-2)
                 (error "We could only load ASDF ~A but we need ASDF ~A"
                        (asdf-version) required-asdf-version)))
        ;; :asdf3.1 is both more recent than required and self-upgrading, so doesn't need this dance
        ;; :asdf3 is self-upgrading but might not be recent enough (it could be a pre-release).
        (unless (member :asdf3.1 *features*)
          (call-maybe-verbosely nil #'stage-1)))))

  (in-package :asdf))
;; Because of ASDF upgrade punting, this ASDF package may be a new one.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (unless (or #+asdf2 (asdf:version-satisfies (asdf:asdf-version) "3.1.2"))
    (error "cl-launch requires ASDF 3.1.2 or later")))
;;;; Create cl-launch with UIOP.
(progn
(uiop:define-package :cl-launch
  (:use :common-lisp :uiop :asdf)
  (:export #:compile-and-load-file))

(in-package :cl-launch))
;;;; cl-launch initialization code
(progn
(defvar *cl-launch-header* nil) ;; name of the file with this Lisp header (if any)
(defvar *cl-launch-file* nil) ;; name of the file with the user code (if any)
(defvar *verbose* nil)
(defun dump-stream-to-file (i n)
  (with-output-file (o n :if-exists :rename-and-delete) (copy-stream-to-stream i o)))
(defun dump-sexp-to-file (x n)
  (with-output-file (o n :if-exists :rename-and-delete) (write x :stream o :pretty t :readably t)))
(defvar *temporary-filenames* nil)
(defvar *temporary-file-prefix*
  (native-namestring (subpathname *temporary-directory*
                                  (strcat "cl-launch-" (getenvp "CL_LAUNCH_PID")))))
(defun make-temporary-filename (x)
  (parse-native-namestring (strcat *temporary-file-prefix* x)))
(defun register-temporary-filename (n)
  (push n *temporary-filenames*)
  n)
(defun temporary-filename (x)
  (register-temporary-filename (make-temporary-filename x)))
(defun temporary-file-from-foo (dumper arg x)
  (let ((n (temporary-filename x)))
    (funcall dumper arg n)
    n))
(defun temporary-file-from-stream (i x)
  (temporary-file-from-foo #'dump-stream-to-file i x))
(defun temporary-file-from-string (i x)
  (temporary-file-from-foo
   #'(lambda (i n) (with-output-file (o n :if-exists :rename-and-delete) (princ i o))) i x))
(defun temporary-file-from-sexp (i x)
  (temporary-file-from-foo #'dump-sexp-to-file i x))
(defun temporary-file-from-code (i x)
  (if (stringp i)
      (temporary-file-from-string i x)
      (temporary-file-from-sexp i x)))
(defun temporary-file-from-file (f x)
  (with-open-file (i f :direction :input :if-does-not-exist :error)
    (temporary-file-from-stream i x)))
(defun ensure-lisp-file-name (x &optional (name "load.lisp"))
  (if (equal (pathname-type x) "lisp") x (temporary-file-from-file x name)))
(defun ensure-lisp-loadable (x)
  (cond
    ((eq x t) (ensure-lisp-loadable (or *cl-launch-file* (error "Missing CL_LAUNCH_FILE"))))
    ((equal x "-") *standard-input*)
    ((or (streamp x) (pathnamep x)) x)
    ((stringp x) (ensure-absolute-pathname (parse-native-namestring x) #'getcwd))))
(defun ensure-lisp-file (x &optional (name "load.lisp"))
  (let ((x (ensure-lisp-loadable x)))
    (etypecase x
      (stream (temporary-file-from-stream x name))
      (pathname (ensure-lisp-file-name x name)))))
(defun cleanup-temporary-files ()
  (loop :for n = (pop *temporary-filenames*)
        :while n :do
          (delete-file-if-exists n)))
(defun file-newer-p (new-file old-file)
  "Returns true if NEW-FILE is strictly newer than OLD-FILE."
  (> (file-write-date new-file) (file-write-date old-file)))
(defun compile-and-load-file (source &key force-recompile
                              (verbose *verbose*) (load t)
                              output-file)
  "compiles and load specified SOURCE file, if either required by keyword
argument FORCE-RECOMPILE, or not yet existing, or not up-to-date.
Keyword argument VERBOSE specifies whether to be verbose.
Returns two values: the fasl path, and T if the file was (re)compiled"

  ;; When in doubt, don't trust - recompile. Indeed, there are
  ;; edge cases cases when on the first time of compiling a simple
  ;; auto-generated file (e.g. from the automated test suite), the
  ;; fasl ends up being written to disk within the same second as the
  ;; source was produced, which cannot be distinguished from the
  ;; reverse case where the source code was produced in the same split
  ;; second as the previous version was done compiling. Could be
  ;; tricky if a big system needs be recompiled as a dependency on an
  ;; automatically generated file, but for cl-launch those
  ;; dependencies are not detected anyway (BAD). If/when they are, and
  ;; lacking better timestamps than the filesystem provides, you
  ;; should sleep after you generate your source code.
  (let* (#+gcl
         (maybe-delete
           (unless (equal (pathname-type source) "lisp")
             (let ((temp (make-temporary-filename (strcat (pathname-name source) ".lisp"))))
               (copy-file source temp)
               (setf source temp))))
         (truesource (truename source))
         (fasl (or output-file (compile-file-pathname* truesource)))
         (compiled-p
          (when (or force-recompile
                    (not (probe-file fasl))
                    (not (file-newer-p fasl source)))
            (ensure-directories-exist fasl)
            (multiple-value-bind (path warnings failures)
                (compile-file* truesource :output-file fasl)
              (declare (ignorable warnings failures))
              (unless (equal (truename fasl) (truename path))
                (error "cl-launch: file compiled to ~A, expected ~A" path fasl))
              (when failures
                (error "cl-launch: failures while compiling ~A" source)))
            t)))
    (when load
      (load* fasl :verbose verbose))
    #+gcl (delete-file-if-exists maybe-delete)
    (values fasl compiled-p)))
(defun load-file (source &key output-file)
  (declare (ignorable output-file))
  #-(or gcl (and ecl (not dlopen)))
  (compile-and-load-file source :verbose *verbose* :output-file output-file)
  #+gcl
  (let* ((pn (parse-namestring source))) ; when compiling, gcl 2.6 will always
    (if (pathname-type pn) ; add a type .lsp if type is missing, to avoid compilation
      (compile-and-load-file source :verbose *verbose* :output-file output-file)
      (load source :verbose *verbose*)))
  #+(and ecl (not dlopen))
  (load source :verbose *verbose*))
(defun compute-arguments ()
  (setf *cl-launch-file* (getenvp "CL_LAUNCH_FILE")
        *cl-launch-header* (getenvp "CL_LAUNCH_HEADER")
        *verbose* (when (getenvp "CL_LAUNCH_VERBOSE") t)))

(asdf::register-preloaded-system "cl-launch")

(defun load-sys (system)
  (if (find-package :quicklisp)
      (let ((*standard-output* (make-broadcast-stream)))
        (symbol-call :quicklisp :quickload system))
      (asdf:load-system system)))

;;; We need this on all implementations when dumping an image,
;;; so that --eval and --file statements may properly depend
;;; on previously loaded systems, etc.
;;; To do it right, though, we want to only create a file
;;; for the --eval statement if needed by ECL...
(defvar *dependency-counter* 0)
(defun cl-launch-files ()
  (when (pathnamep *cl-launch-file*)
    (list *cl-launch-file*)))
(defun make-temporary-system (stem rdeps options)
  ;; Make a temporary system with given name stem and options
  ;; return the new list of dependencies, i.e. a singleton of the actual system name.
  (let ((sys (strcat "cl-launch-" stem)))
    (eval `(handler-bind ((warning #'muffle-warning))
             (defsystem ,sys :pathname ,*temporary-directory* :depends-on ,(reverse rdeps) ,@options)
             (defmethod input-files ((o operation) (s (eql (find-system ,sys))))
               ',(cl-launch-files))))
    (list sys)))
(defclass asdf::cl-source-file-in-package (cl-source-file)
  ((package :initarg :package :reader component-package)))
(defclass asdf::cl-source-code (source-file)
  ((code :initarg :code :initform nil :reader component-code)
   (package :initarg :package :reader component-package)))
(handler-bind ((warning #'muffle-warning))
  (defmethod perform :around ((o compile-op) (c asdf::cl-source-file-in-package))
    (let ((*package* (find-package (component-package c))))
      (call-next-method)))
  (defmethod component-pathname ((c asdf::cl-source-code)) nil)
  (defmethod perform ((o compile-op) (c asdf::cl-source-code)))
  (defmethod perform ((o load-op) (c asdf::cl-source-code))
    (let ((*package* (find-package (component-package c))))
      (eval-thunk (or (component-code c) (component-name c))))))
(defun make-dependency-system (rdeps options)
  ;; Make a system for given dependencies,
  ;; return the new list of dependencies, i.e. a singleton of the system name.
  (let ((name (format nil "build-~D" *dependency-counter*)))
    (incf *dependency-counter*)
    (make-temporary-system name rdeps options)))
(defun make-dependency (dump fun arg pkg previous)
  ;; Make a dependency, return the new list of dependencies
  (ecase fun
    ((:load)
       (let ((x (ensure-lisp-loadable arg)))
         (if (or (pathnamep x) #+(or ecl mkcl) dump)
           (let ((load-file (ensure-lisp-file x (format nil "load-~D.lisp" *dependency-counter*))))
             (make-dependency-system previous
              `(:components ((:cl-source-file-in-package ,(pathname-name load-file)
                              :package ,pkg :pathname ,(truename load-file))))))
           (make-dependency dump :eval `(load* ,x) pkg previous))))
    ((:eval)
     (if (and #+(or ecl mkcl) (not dump))
       (make-dependency-system previous
        `(:components ((:cl-source-code ,(format nil "eval-~D" *dependency-counter*)
                        :code ,arg :package :cl-user))))
       #+(or ecl mkcl)
       (with-input (i (temporary-file-from-code arg (format nil "eval-~D.lisp" *dependency-counter*)))
         (make-dependency dump :load i :cl-user previous))))
    ((:require)
     (cons `(:require ,arg) previous))
    ((:load-system)
     (cons arg previous))))

(defun build-program (dump build restart final init quit)
  (unwind-protect
       (let* ((*compile-verbose* *verbose*)
              #+ecl (c::*suppress-compiler-warnings* (not *verbose*))
              #+ecl (c::*suppress-compiler-notes* (not *verbose*))
              (standalone (and (getenvp "CL_LAUNCH_STANDALONE") t))
              (op (if standalone 'program-op 'image-op))
              (dependencies
                (loop :with r = ()
                      :for (fun arg pkg) :in
                      `((:load-system "asdf")
                        ,@(when dump ;; do we still want to include cl-launch in the dumped code,
                            #+(or ecl mkcl) ;; now that all the relevant runtime support is in UIOP?
                            (let ((header *cl-launch-header*)) ;; maybe for dependency timestamp?
                              (setf *features* (remove :cl-launch *features*))
                              `((:load ,(ensure-lisp-file header "header.lisp") :cl-user))))
                        ,@build
                        ,(let ((footer
                                 `(setf
                                   *package* (find-package :cl-user)
                                   *image-dumped-p* ,(when dump (if standalone :executable t))
                                   *image-entry-point*
                                   ,(when restart `(ensure-function ,(car restart) :package ,(cdr restart)))
                                   *image-prelude* ,init
                                   *image-postlude* ,final
                                   *lisp-interaction* ,(not quit))))
                           `(:eval ,footer :cl-user)))
                      :do (setf r (make-dependency dump fun arg pkg r))
                      :finally (return r)))
              (program-sys
                (make-temporary-system
                 "program" dependencies
                 `(:serial t
                   :build-operation ,op
                   :build-pathname ,(when dump (ensure-absolute-pathname dump #'getcwd))
                   :entry-point ,(when restart
                                   `(lambda ()
                                      (funcall (ensure-function ,(car restart) :package ,(cdr restart)))))
                   ;; Provide a sensible timestamp
                   ;; For SBCL and other platforms that die on dump-image, clean before the end:
                   ,@(if (version<= "3.1.1" (asdf-version))
                         `(:perform (image-op :before (o c)
                             (setf *features* (remove :cl-launched *features*))
                             (cleanup-temporary-files)))
                         (when dump
                           (error "Dumping an image with cl-launch 4 requires ASDF 3.1.1 or later")))))))
         (load-sys program-sys) ;; Give quicklisp a chance to download things
         (when dump
           (operate op program-sys)))
    (cleanup-temporary-files))
  (unless dump
    (restore-image))
  (quit 0))

(defun load-quicklisp ()
  (block nil
    (flet ((try (x) (when (probe-file* x) (return (load* x)))))
      (try (subpathname (user-homedir-pathname) "quicklisp/setup.lisp"))
      (try (subpathname (user-homedir-pathname) ".quicklisp/setup.lisp"))
      (error "Couldn't find quicklisp in your home directory. ~
              Go get it at http://www.quicklisp.org/beta/index.html"))))

(defun run (&key quicklisp source-registry build dump restart final init (quit t))
  (setf *lisp-interaction* (not quit))
  (with-fatal-condition-handler ()
    (pushnew :cl-launched *features*)
    (compute-arguments)
    (when source-registry (initialize-source-registry source-registry))
    (when quicklisp (load-quicklisp))
    (build-program dump build restart final init quit)))

(pushnew :cl-launch *features*))

(cl-launch::compute-arguments)

;;; END OF CL-LAUNCH LISP HEADER
