#!/bin/sh

#| CL-LAUNCH 2.16 CONFIGURATION

SOFTWARE_FILE=.
SOFTWARE_SYSTEM=
SOFTWARE_INIT_FORMS=
SYSTEMS_PATHS=
INCLUDE_PATH=

LISPS="sbcl clisp ccl cmucl ecl gclcvs allegro lispworks lisp gcl"

WRAPPER_CODE=
DUMP=
RESTART=
IMAGE_BASE=
IMAGE_DIR=
IMAGE=
# END OF CL-LAUNCH CONFIGURATION

# This file was generated by CL-Launch 2.16

# This file was automatically generated and contains parts of CL-Launch
#
# Please send your improvements to the author:
# fare at tunes dot org < http://www.cliki.net/Fare%20Rideau >.
#
# CL-Launch is available under the terms of the bugroff license.
#	http://www.geocities.com/SoHo/Cafe/5947/bugroff.html
# You may at your leisure use the LLGPL instead < http://www.cliki.net/LLGPL >
#
# This software can be used in conjunction with any other software:
# the result may consist in pieces of the two software glued together in
# a same file, but even then these pieces remain well distinguished, and are
# each available under its own copyright and licensing terms, as applicable.
# The parts that come from the other software are subject to the terms of use
# and distribution relative to said software, which may well be
# more restrictive than the terms of this software (according to lawyers
# and the armed henchmen they got the taxpayers to pay to enforce their laws).
# The bits of code generated by cl-launch, however, remain available
# under the terms of their own license, and you may service them as you wish:
# manually, using cl-launch --update or whichever means you prefer.
# That said, if you believe in any of that intellectual property scam,
# you may be subject to the terms of my End-Seller License:
#	http://www.livejournal.com/users/fare/21806.html
#
PROG="$0"

# cl-launch 2.16 shell wrapper

#   Find and execute the most appropriate supported Lisp implementation
#   to evaluate software prepared with CL-Launch.
#
ECHOn () { printf '%s' "$*" ;}
simple_term_p () {
  case "$1" in *[!a-zA-Z0-9-+_,.:=%/]*) return 1 ;; *) return 0 ;; esac
}
kwote0 () { ECHOn "$1" | sed -e "s/\([\\\\\"\$\`]\)/\\\\\\1/g" ;}
kwote () { if simple_term_p "$1" ; then ECHOn "$1" ; else kwote0 "$1" ; fi ;}
load_form_0 () { echo "(load $1 :verbose nil :print nil)" ;}
load_form () { load_form_0 "\"$(kwote "$1")\"" ;}
ECHO () { printf '%s\n' "$*" ;}
DBG () { ECHO "$*" >& 2 ;}
abort () { ERR="$1" ; shift ; DBG "$*" ; exit "$ERR" ;}
ABORT () { abort 42 "$*" ;}
DO_LISP=do_exec_lisp
HASH_BANG_FORM='(set-dispatch-macro-character #\# #\! #'\''(lambda(stream char arg)(declare(ignore char arg))(values (read-line stream))))'
PACKAGE_FORM=" #.(progn(defpackage :cl-launch (:use :cl))())"
MAYBE_PACKAGE_FORM=

PROGN="(progn"
NGORP=")"

implementation_cmucl () {
  implementation "${CMUCL:-cmucl}" || return 1

  OPTIONS="${CMUCL_OPTIONS:- -quiet -noinit}"

  EVAL=-eval
  ENDARGS=--
  IMAGE_ARG=-core
  EXEC_LISP=exec_lisp_noarg
  # exec_lisp works fine, except in the corner case when the program's user
  # would use arguments that cmucl would process as its own arguments, even
  # though they are meant for the Lisp program. cmucl provides no way to
  # specify that arguments after "--" don't really matter.
  # And so we use exec_lisp_noarg.
  BIN_ARG=CMUCL
  OPTIONS_ARG=CMUCL_OPTIONS

  if [ -z "$CL_LAUNCH_DEBUG" ] ; then
    OPTIONS="${OPTIONS} -batch"
  fi

}
implementation_lisp () {
  implementation ${CMULISP:=lisp} || return 1
  CMUCL=$CMULISP
  implementation_cmucl "$@"
}
implementation_sbcl () {
  implementation "${SBCL:-sbcl}" || return 1

  OPTIONS="${SBCL_OPTIONS:- --noinform --userinit /dev/null}"

  # We purposefully specify --userinit /dev/null but NOT --sysinit /dev/null
  EVAL=--eval # SBCL's eval can only handle one form per argument.
  ENDARGS=--end-toplevel-options

  IMAGE_ARG="EXECUTABLE_IMAGE" # we use executable images
  # if you want to test non-executable images, uncomment the one below,
  # and comment out the :executable t in (defun dump-image ...)
  # -IMAGE_ARG=--core
  STANDALONE_EXECUTABLE=t # requires sbcl 1.0.21.24 or later.

  EXEC_LISP=exec_lisp
  BIN_ARG=SBCL
  OPTIONS_ARG=SBCL_OPTIONS

  if [ -z "$CL_LAUNCH_DEBUG" ] ; then
    OPTIONS="${OPTIONS} --disable-debugger"
  fi

}
implementation_clisp () {
  implementation "${CLISP:-clisp}" || return 1
  OPTIONS="${CLISP_OPTIONS:- -norc --quiet --quiet}"
  EVAL=-x
  LOAD=-i

  ENDARGS="--"

  # if the first argument begins with - there might be problems,
  # so we avoid that and take the cdr or ext:*args*

  # IMAGE_ARG=-M # for use without :executable t
  IMAGE_ARG="EXECUTABLE_IMAGE" # we don't use this by default
  STANDALONE_EXECUTABLE=t # will mostly work as of clisp 2.44, but with a (in)security backdoor.
  # For details, see the thread at http://sourceforge.net/forum/message.php?msg_id=5532730

  EXEC_LISP=exec_lisp
  BIN_ARG=CLISP
  OPTIONS_ARG=CLISP_OPTIONS

  if [ -z "$CL_LAUNCH_DEBUG" ] ; then
    OPTIONS="${OPTIONS} -on-error exit"
  else
    OPTIONS="${OPTIONS} -on-error debug"
  fi

}

implementation_lispworks () { ### NOT EXTENSIVELY TESTED

  implementation "${LISPWORKS:-lispworks}" || return 1

  OPTIONS="${LISPWORKS_OPTIONS:- -siteinit - -init -}" #
  LOAD=-build #### No such thing found in the online documentation.

  #! EVAL=-eval # No such thing found in the online documentation.
  #! ENDARGS="--"
  IMAGE_ARG="EXECUTABLE_IMAGE" # we don't use this by default
  EXEC_LISP=exec_lisp_file

  STANDALONE_EXECUTABLE=t

  BIN_ARG=LISPWORKS
  OPTIONS_ARG=LISPWORKS_OPTIONS

  if [ -z "$CL_LAUNCH_DEBUG" ] ; then
    : # OPTIONS="${OPTIONS} ..."
  else
    : # OPTIONS="${OPTIONS} ..."
  fi

}
prepare_arg_form () {
  ENDARGS= F=
  for arg ; do
    F="$F\"$(kwote "$arg")\""
  done
  MAYBE_PACKAGE_FORM="$PACKAGE_FORM"
  LAUNCH_FORMS="(defparameter cl-launch::*arguments*'($F))${LAUNCH_FORMS}"
}
exec_lisp_noarg () {
  prepare_arg_form "$@"
  exec_lisp
}
exec_lisp_file () {
  prepare_arg_form "$@"
  LOADFILE=${TMP:-/tmp}/cl-load-file-$(date +%s)-$$
  cat > $LOADFILE <<END
${MAYBE_PACKAGE_FORM}
${HASH_BANG_FORM}
${LAUNCH_FORMS}
END
  $LISP_BIN $IMAGE_OPT $IMAGE $OPTIONS $LOAD "$LOADFILE"
  RET=$?
  rm -f $LOADFILE
  exit $RET
}
implementation_clisp_noarg () {
  implementation_clisp
  EXEC_LISP=exec_lisp_noarg
  # For testing purposes
}
implementation_clisp_file () {
  implementation_clisp
  EXEC_LISP=exec_lisp_file
  # For testing purposes
}

implementation_ccl () {
  # ClozureCL, nee OpenMCL, forked from MCL, formerly Macintosh Common Lisp, nee Coral Common Lisp
  implementation "${CCL:-ccl}" || return 1
  OPTIONS="${CCL_OPTIONS:- --no-init}"

  EVAL=--eval # -e

  # IMAGE_ARG=--image-name # -I
  IMAGE_ARG=EXECUTABLE_IMAGE # depends on our using :prepend-kernel t

  ENDARGS=--

  # (finish-output) is essential for ccl, that won't do it by default,

  # unlike the other lisp implementations tested.

  EXEC_LISP=exec_lisp
  # exec_lisp will work great for 1.1 and later.
  # For earlier versions, use exec_lisp_arg instead:

  # 1.0 doesn't support --, and the latest 1.1-pre060826 snapshot has a bug
  # whereby it doesn't stop at -- when looking for a -I or --image-file argument.

  BIN_ARG=CCL
  OPTIONS_ARG=CCL_OPTIONS
  if [ -z "$CL_LAUNCH_DEBUG" ] ; then
    OPTIONS="${OPTIONS} --batch"
  fi
}
implementation_openmcl () {
  implementation "${OPENMCL:=openmcl}" || return 1
  CCL="$OPENMCL"
  CCL_OPTIONS="$OPENMCL_OPTIONS"
  implementation_ccl "$@" && BIN_ARG=OPENMCL

}
implementation_gcl () {
  implementation "${GCL:-gcl}" || return 1

  OPTIONS="${GCL_OPTIONS}"

  EVAL=-eval
  ENDARGS=--
  IMAGE_ARG=EXECUTABLE_IMAGE
  BIN_ARG=GCL
  OPTIONS_ARG=GCL_OPTIONS
  export GCL_ANSI=t
  EXEC_LISP=exec_lisp

  if [ -z "$CL_LAUNCH_DEBUG" ] ; then
    OPTIONS="${OPTIONS} -batch"
  fi

}
implementation_ecl () {
  implementation "${ECL:-ecl}" || return 1
  OPTIONS="${ECL_OPTIONS:- -q -norc}"
  EVAL=-eval
  ENDARGS=--
  #IMAGE_ARG="-q -load" # for :fasl
  IMAGE_ARG="EXECUTABLE_IMAGE" # for :program

  STANDALONE_EXECUTABLE=t

  BIN_ARG=ECL
  OPTIONS_ARG=ECL_OPTIONS
  EXEC_LISP=exec_lisp

  if [ -n "$CL_LAUNCH_DEBUG" ] ; then
    PROGN="(handler-bind((error'invoke-debugger))(progn(set'si::*break-enable*'t)"
    NGORP="))"
  fi

  # work around brokenness in c-l-c packaging of ECL,

  # at least still as of ecl 0.9j-20080306-4 and c-l-c 6.17

  if [ -z "$ECL" ] &&
     [ "/usr/bin/ecl" = "$LISP_BIN" ] &&
     [ -x "/usr/lib/ecl/ecl-original" ] ; then
    LISP_BIN=/usr/lib/ecl/ecl-original
  fi
}
implementation_gclcvs () {
  implementation "${GCLCVS:=gclcvs}" || return 1
  GCL="$GCLCVS"
  implementation_gcl "$@" && BIN_ARG=GCLCVS
}
implementation_allegro () {
  implementation "${ALLEGRO:-acl}" || return 1

  OPTIONS="${ALLEGRO_OPTIONS:- -QQ -qq}"

  EVAL=-e
  ENDARGS=--
  IMAGE_ARG=-I
  EXEC_LISP=exec_lisp
  BIN_ARG=ALLEGRO
  OPTIONS_ARG=ALLEGRO_OPTIONS

  if [ -z "$CL_LAUNCH_DEBUG" ] ; then
    OPTIONS="${OPTIONS} -batch -backtrace-on-error"
  fi

}
implementation () {

  if [ -n "$USE_CLBUILD" ] ; then
    if CLBUILD_BIN="`which clbuild 2> /dev/null`" ; then
      LISP_BIN="$CLBUILD_BIN --implementation $IMPL lisp"
      return 0
    else
      return 1
    fi
  elif [ -x "$1" ] ; then

    LISP_BIN="$1"
    return 0

  elif LISP_BIN="`which "$1" 2> /dev/null`" ; then

    return 0
  else
    return 1
  fi
}
trylisp () {
  IMPL="$1" ; shift
  implementation_${IMPL} "$@"
}
do_exec_lisp () {

  if [ -n "$IMAGE" ] ; then
    if [ "x$IMAGE_ARG" = xEXECUTABLE_IMAGE ] ; then
      LISP_BIN= IMAGE_OPT=
    else
      IMAGE_OPT="$IMAGE_ARG"
    fi
  fi

  $EXEC_LISP "$@"
}
no_implementation_found () {
  ABORT "$PROG: Cannot find a supported lisp implementation.
Tried the following: $*"
}
ensure_implementation () {
  trylisp "$1" || no_implementation_found "$1"
}
try_all_lisps () {
  for l in $LISP $LISPS ; do
    if trylisp $l ; then
      $DO_LISP "$@"
      return 0
    fi
  done
  no_implementation_found "$LISP $LISPS"
}
exec_lisp () {
  # SBCL wants only one form per --eval so we need put everything in one progn.
  # However we also want any in-package form to be evaluated before any of the
  # remaining forms is read, so we get it to be evaluated at read-time as the
  # first thing in the main progn.
  # GNU clisp allows multiple forms per -x but prints the result of every form
  # evaluated and so we also need put everything in a single progn, and that progn
  # must quit before it may return to the clisp frame that would print its value.
  # CMUCL allows multiple forms per -eval and won't print values, so is ok anyway.
  # I don't know about other Lisps, but they will all work this way.

  LAUNCH_FORM="${PROGN}${MAYBE_PACKAGE_FORM}${HASH_BANG_FORM}${LAUNCH_FORMS}${NGORP}"
  ### This is partial support for CLBUILD.
  if [ -n "$USE_CLBUILD" ] ; then
    if [ -z "$IMAGE_OPT" ] ; then
      OPTIONS=
    else
      ABORT "Cannot use clbuild with a non-executable image different from clbuild's"
    fi
  fi

  if [ -n "$CL_LAUNCH_VERBOSE" ] ; then set -x ; fi
  exec $LISP_BIN $IMAGE_OPT $IMAGE $OPTIONS $EVAL "$LAUNCH_FORM" $ENDARGS "$@"
}
launch_self () {
  LAUNCH_FORMS="$(load_form "$PROG")"
  try_all_lisps "$@"
}
invoke_image () {
  if [ "x$IMAGE_ARG" = xEXECUTABLE_IMAGE ] ; then
    LISP_BIN= IMAGE_OPT=
  else
    IMAGE_OPT="$IMAGE_ARG"
  fi
  PACKAGE_FORM=
  HASH_BANG_FORM=
  LAUNCH_FORMS="(cl-launch::resume)"
  "$EXEC_LISP" "$@"
}

export CL_LAUNCH_PID=$$
export CL_LAUNCH_FILE="$PROG"

## execute configuration-provided code
eval "$WRAPPER_CODE"

### END OF CL-LAUNCH SHELL WRAPPER


launch_self "$@"
ABORT
# |#

#+xcvb (module ())
#| ;;; cl-launch 2.16 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.
|#
#-cl-launch (eval-when (:load-toplevel :execute :compile-toplevel)
  (declaim (optimize (speed 1) (safety 2) (compilation-speed 3) #-gcl (debug 1)
       	   #+sbcl (sb-ext:inhibit-warnings 3)
           #+sbcl (sb-c::merge-tail-calls 3) ;-- this plus debug 1 (or sb-c::insert-debug-catch 0 ???) should ensure all tail calls are optimized, says jsnell
	   #+cmu (ext:inhibit-warnings 3)))
  #+gcl ;;; If using GCL, do some safety checks
  (when (or #-ansi-cl t)
    (format *error-output*
     "CL-Launch only supports GCL in ANSI mode. Aborting.~%")
    (lisp:quit))
  #+gcl
  (when (or (< system::*gcl-major-version* 2)
            (and (= system::*gcl-major-version* 2)
                 (< system::*gcl-minor-version* 7)))
    (pushnew :gcl-pre2.7 *features*))
  (setf *print-readably* nil ; allegro 5.0 notably will bork without this
        *load-verbose* nil *compile-verbose* nil *compile-print* nil)
  #+cmu (setf ext:*gc-verbose* nil)
  #+clisp (setf custom:*source-file-types* nil custom:*compiled-file-types* nil)
  #+gcl (setf compiler::*compiler-default-type* (pathname "")
              compiler::*lsp-ext* "")
  #+ecl (require 'cmp)

  ;;;; Ensure package hygiene
  (unless (find-package :cl-launch)
    (if (find-package :common-lisp)
       (defpackage :cl-launch (:use :common-lisp))
       (make-package :cl-launch :use '(:lisp))))
  (in-package :cl-launch))
#-cl-launch (defmacro dbg (tag &rest exprs)
  "simple debug statement macro:
outputs a tag plus a list of source expressions and their resulting values, returns the last values"
  (let ((res (gensym))(f (gensym)))
  `(let ((,res))

    (flet ((,f (fmt &rest args) (apply #'format *trace-output* fmt args)))

      (,f "~&~A~%" ,tag)
      ,@(mapcan
         #'(lambda (x)
            `((,f "~&  ~S => " ',x)
              (,f "~{~S~^ ~}~%" (setf ,res (multiple-value-list ,x)))))
         exprs)
      (apply 'values ,res)))))
#-cl-launch (eval-when (:load-toplevel :execute :compile-toplevel)
  ;; Import a few symbols if needed
  #+common-lisp-controller
  (map () #'import
       '(clc::*source-root*
         clc::*fasl-root*
         clc::calculate-fasl-root
         clc::source-root-path-to-fasl-path
         clc::alternative-root-path-to-fasl-path
         clc::*redirect-fasl-files-to-cache*))
  ;;; define getenv and quit in ways that minimize package conflicts
  ;;; (use-package :cl-launch) while in cl-user.

  #+(or clozure allegro gcl clisp ecl)
    (import '#+clozure ccl::getenv

             #+allegro sys:getenv
             #+gcl system:getenv
             #+clisp ext:getenv
             #+ecl si:getenv
      :cl-launch)
  #+(or cmu sbcl lispworks)
    (defun getenv (x)
      #+sbcl (sb-ext:posix-getenv x)
      #+lispworks (lispworks:environment-variable x)
      #+cmu (cdr (assoc (intern x :keyword) ext:*environment-list*)))
  (defun quit (&optional (code 0) (finish-output t))

    (when finish-output ;; essential, for ClozureCL, and for standard compliance.

      (finish-outputs))
    #+cmu (unix:unix-exit code)
    #+clisp (ext:quit code)
    #+sbcl (sb-unix:unix-exit code)

    #+clozure (ccl:quit code)

    #+gcl (lisp:quit code)
    #+allegro (excl:exit code :quiet t)
    #+ecl (si:quit code)
    #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)

    #-(or cmu clisp sbcl clozure gcl allegro ecl lispworks)

    (error "Quitting not implemented")))
#-cl-launch (eval-when (:load-toplevel :execute :compile-toplevel)
  ;;;; Load ASDF
  (ignore-errors (require :asdf))
  ;;; Here is a fallback plan in case the lisp implementation isn't asdf-aware.
  (unless (and (find-package :asdf) (find-symbol "OUTPUT-FILES" :asdf))
    (defvar *asdf-path*
      (or (and (getenv "ASDF_PATH") (probe-file (getenv "ASDF_PATH")))
          (probe-file (merge-pathnames "src/asdf/asdf.lisp"
                                       (user-homedir-pathname)))

          (probe-file "/usr/share/common-lisp/source/cl-asdf/asdf.lisp")

          (probe-file "/usr/share/common-lisp/source/asdf/asdf.lisp")))
    (when *asdf-path*
      (ignore-errors (load *asdf-path* :verbose nil :print nil)))))
#-cl-launch (eval-when (:load-toplevel :execute :compile-toplevel)
  ;;; Even in absence of asdf, at least create a package asdf.
  (unless (find-package :asdf)
    (make-package :asdf)))
#-cl-launch (eval-when (:load-toplevel :execute :compile-toplevel)
  ;;; Try to share this with asdf, in case we get asdf to support it one day.
  (map () #'import
       '(asdf::*output-pathname-translations*
         asdf::resolve-symlinks
         asdf::oos asdf::load-op asdf::find-system)))

;;;; CL-Launch Initialization code
#-cl-launch (progn

(pushnew :cl-launch *features*)

;;#+ecl (require 'cmp) ; ensure we use the compiler (we use e.g. *ecl-library-directory*)

(dolist (s '(*arguments* getenv quit compile-and-load-file
             compile-file-pathname* apply-pathname-translations
	     *output-pathname-translations*
             apply-output-pathname-translations))
  (export s))

;; To dynamically recompute from the environment at each invocation
(defvar *cl-launch-file* nil)
(defvar *verbose* nil)
(defvar *lisp-fasl-cache* nil "lisp fasl cache hierarchy")
(defvar *lisp-fasl-root* nil "top path for the fasl cache for current implementation")
;; To dynamically recompute from the command-line at each invocation
(defvar *arguments* nil "command-line parameters")

;; Variables that define the current system
(defvar *dumped* nil)
(defvar *restart* nil)
(defvar *init-forms* nil)
(defvar *quit* t)

;; Provide compatibility with clc 6.2
(defvar *redirect-fasl-files-to-cache* t)

(defun raw-command-line-arguments ()
  nil
  #+ecl (loop for i from 0 below (si:argc) collect (si:argv i))
  #+gcl si:*command-args*
  #+cmu extensions:*command-line-strings*
  #+clozure ccl:*unprocessed-command-line-arguments*
  #+sbcl sb-ext:*posix-argv*
  #+allegro sys:command-line-arguments
  #+lispworks sys:*line-arguments-list*
  #+clisp (cons "--" ext:*args*))

(defun command-line-arguments ()

  (let* ((raw (raw-command-line-arguments))
         (cooked #+sbcl raw #-sbcl
           (if (eq *dumped* :standalone)
                    raw
                    (member "--" raw :test 'string-equal))))
    (cdr cooked)))

#+gcl-pre2.7 (defun ensure-directories-exist (x) "hope for the best" nil)

(defvar *implementation-name* nil
  "The name of the implementation, used to make a directory hierarchy for fasl files")

(defvar *temporary-directory* "/tmp/"
  "The name of the implementation, used to make a directory hierarchy for fasl files")

(defun compute-arguments ()
  (setf *cl-launch-file* (getenv "CL_LAUNCH_FILE")

        *temporary-directory* (ensure-directory-name (or (getenv "TMP") "/tmp"))
        #+gcl #+gcl system::*tmp-dir* *temporary-directory* ; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1

        *verbose* (when (getenv "CL_LAUNCH_VERBOSE") t)

        *implementation-name* (unique-directory-name #-ecl *verbose*)
        *lisp-fasl-cache*
        (let* ((cache-env (getenv "LISP_FASL_CACHE"))
               (cache-spec
                (cond
                  ((null cache-env)
                   (merge-pathnames
                    #p".cache/lisp-fasl/"
                    ;;(make-pathname :directory (list :relative ".cache" "lisp-fasl"))
                    (user-homedir-pathname)))
                  ((equal cache-env "NIL") nil)
                  (t (dirname->pathname cache-env)))))
          (when cache-spec
            (ensure-directories-exist cache-spec)
            (resolve-symlinks cache-spec)))
        *lisp-fasl-root*
        (let* ((root-env
                (when (getenv "LISP")
                  (let ((r (getenv "LISP_FASL_ROOT")))
                    (when r (if (equal r "NIL") :disabled
                                (dirname->pathname r))))))
               (root-spec
                (or root-env
                    (when *lisp-fasl-cache*
                      (merge-pathnames
                       (make-pathname
                        :directory (list :relative *implementation-name*))
                       *lisp-fasl-cache*)))))
          (when root-spec
            (ensure-directories-exist root-spec)
            (resolve-symlinks root-spec))))

  (calculate-output-pathname-translations)
  (setf *arguments*

   (or *arguments* (command-line-arguments))))

(defun register-paths (paths)
  #-asdf (declare (ignore paths))
  #+asdf
  (dolist (p (reverse paths))
    (pushnew p asdf::*central-registry* :test 'equal)))

(defun load-stream (&optional (s #-clisp *standard-input*
				 #+clisp *terminal-io*))
  ;; GCL 2.6 can't load from a string-input-stream

  ;; ClozureCL 1.2 cannot load from either *standard-input* or *terminal-io*

  ;; Allegro 5, I don't remember but it must have been broken when I tested.

  #+(or gcl-pre2.7 clozure allegro)

  (do ((eof '#:eof) (x t (read s nil eof))) ((eq x eof)) (eval x))

  #-(or gcl-pre2.7 clozure allegro)

  (load s :verbose nil :print nil))

(defun load-string (string)
  (with-input-from-string (s string) (load-stream s)))

(defun finish-outputs ()
  (finish-output *error-output*)
  (finish-output))

(defun %abort (code fmt &rest args)
  (apply #'format *error-output* fmt args)
  (quit code))

(defun resume ()
  (compute-arguments)
  (do-resume))

(defun do-resume ()
  (when *restart* (funcall *restart*))
  (when *init-forms* (load-string *init-forms*))
  (finish-outputs)
  (when *quit* (quit 0)))

(defun dump-image (filename &key standalone (package :cl-user))
  (setf *dumped* (if standalone :standalone :wrapped)
        *arguments* nil
	*package* (find-package package)
	*features* (remove :cl-launched *features*))

  #+clisp

  (apply #'ext:saveinitmem filename

   :quiet t

   :start-package *package*
   :keep-global-handlers nil
   :executable (if standalone 0 t) ;--- requires clisp 2.48 or later.
   (when standalone
     (list
      :norc t
      :script nil
      :init-function #'resume
      ;; :parse-options nil ;--- requires a non-standard patch to clisp.
      )))

  #+sbcl
  (progn
    ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself
   (setf sb-ext::*gc-run-time* 0)
   (apply 'sb-ext:save-lisp-and-die filename

    :executable t ;--- always include the runtime that goes with the core
    (when standalone (list :toplevel #'resume :save-runtime-options t)))) ;--- only save runtime-options for standalone executables

  #+cmu
  (progn
   (ext:gc :full t)
   (setf ext:*batch-mode* nil)
   (setf ext::*gc-run-time* 0)
   (extensions:save-lisp filename))

  #+clozure
  (ccl:save-application filename :prepend-kernel t)

  #+allegro
  (progn
   (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
   (excl:dumplisp :name filename :suppress-allegro-cl-banner t))
  #+lispworks

  (if standalone
    (lispworks:deliver 'resume filename 0 :interface nil)
    (hcl:save-image filename :environment nil))

  #+gcl
  (progn
   (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
   (si::save-system filename))

  #-(or clisp sbcl cmu clozure allegro gcl lispworks)

  (%abort 11 "CL-Launch doesn't supports image dumping with this Lisp implementation.~%"))

(defun run (&key paths load system dump restart init (quit 0))
  (pushnew :cl-launched *features*)
  (compute-arguments)
  (when paths (register-paths paths))
  (if dump
      (build-and-dump dump load system restart init quit)
      (build-and-run load system restart init quit)))

(defun read-function (string)

  (eval `(function ,(read-from-string string))))

#-(and gcl (not gcl-pre2.7))

(defun build-and-load (load system restart init quit)

  (do-build-and-load load system restart init quit))

#+(and gcl (not gcl-pre2.7))
(defun build-and-load (load system restart init quit)
  (unwind-protect
       (do-build-and-load load system restart init quit)
    (cleanup-temporary-files)))

(defun do-build-and-load (load system restart init quit)

  (when load
    (cond
     ((eq load t) (load-stream))
     ((streamp load) (load-stream load))
     ((eq load :self) (load-file *cl-launch-file*))
     (t (load-file load))))
  (when system
    #+asdf
    (load-system system :verbose *verbose*)
    #-asdf
    (%abort 10 "ERROR: asdf requested, but not found~%"))

  (setf *restart* (when restart (read-function restart))

        *init-forms* init
        *quit* quit))

(defun build-and-run (load system restart init quit)
  (build-and-load load system restart init quit)
  (do-resume))

#-ecl
(defun build-and-dump (dump load system restart init quit)
  (build-and-load load system restart init quit)

  (dump-image dump :standalone (getenv "CL_LAUNCH_STANDALONE"))

  (quit))

#+(or ecl (and gcl (not gcl-pre2.7)))
(progn
  (defvar *temporary-filenames* nil)
  (defun copy-stream (i o &key (element-type 'character))
    (loop with size = 8192
          with buf = (make-array size :element-type element-type)
          for n = (read-sequence buf i)
          while (plusp n)
          do (write-sequence buf o :end n)))
  (defun call-with-new-file (n f)
    (with-open-file (o n :direction :output :if-exists :error :if-does-not-exist :create)
      (funcall f o)))
  (defun dump-stream-to-file (i n)
    (call-with-new-file n (lambda (o) (copy-stream i o))))
  (defun copy-file (src dst)
    (with-open-file (i src :direction :input :if-does-not-exist :error :element-type '(unsigned-byte 8))
      (with-open-file (o dst :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
        (copy-stream i o :element-type '(unsigned-byte 8)))))
  (defun dump-sexp-to-file (x n)
    (call-with-new-file
     n
     (lambda (o) (write x :stream o :pretty t :readably t))))
  (defvar *temporary-file-prefix*
    (format nil "~Acl-launch-~A-" *temporary-directory* (getenv "CL_LAUNCH_PID")))
  (defun make-temporary-filename (x)
    (concatenate 'string *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-sexp (i x)
    (temporary-file-from-foo #'dump-sexp-to-file 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 (x &optional (name "load.lisp"))
    (cond
      ((eq x t) (temporary-file-from-stream *standard-input* "load.lisp"))
      ((streamp x) (temporary-file-from-stream x "load.lisp"))
      ((eq x :self) (ensure-lisp-file-name *cl-launch-file* name))
      (t (ensure-lisp-file-name x name))))
  (defun ensure-lisp-file-name (x &optional (name "load.lisp"))
    (let ((p (pathname x)))
      (if (equal (pathname-type p) "lisp")
          p
          (temporary-file-from-file p name))))
  (defun cleanup-temporary-files ()
    (loop for n = (pop *temporary-filenames*)
          while n do
          (ignore-errors (delete-file n)))))

;;; choose which strategy you try to debug...
#+ecl (defun build-and-dump (&rest r) (apply #'yyy-build-and-dump r))
;;; Attempt at adapting the code from cl-launch 2.07
;;; seems to break earlier than the yyy- method below.

#+ecl

(defun xxx-build-and-dump (dump load system restart init quit)

  (setf *compile-verbose* *verbose*
        c::*suppress-compiler-warnings* (not *verbose*)
        c::*suppress-compiler-notes* (not *verbose*))

  (let* ((cl-launch-objects
	  (let* ((*features* (remove :cl-launch *features*))
                 (header (or *compile-file-pathname* *load-pathname* (getenv "CL_LAUNCH_HEADER")))
                 (header-file (ensure-lisp-file header "header.lisp"))
                 (object (compile-file-pathname* header-file :system-p t)))
            (compile-file header-file :output-file object :system-p t)
            (list object)))

	 (file-objects
	  (when load

            (list
             (compile-and-load-file (ensure-lisp-file load "load.lisp")
                                    :verbose *verbose* :system-p t :load t))))

	 (system-objects
	  (when system
	    (let* ((target (find-system system))

                   (build (make-instance 'asdf::program-op)))
              (asdf:perform build target)
              (asdf:input-files build target))))
         (standalone (getenv "CL_LAUNCH_STANDALONE"))

	 (init-code
	  `(setf

            *load-verbose* nil
            *dumped* ,(if standalone :standalone :wrapped)
            *arguments* nil
            ,@(when restart `(*restart* (read-function ,restart)))
            ,@(when init `(*init-forms* ,init))
            ,@(unless quit `(*quit* nil))))

         (epilogue-code

          `(progn
            ,init-code
            ,(if standalone '(resume) '(si::top-level))))

	 (fasl

	  (c::builder :program (parse-namestring dump)
                      :lisp-files
                      (append cl-launch-objects file-objects system-objects)
                      :epilogue-code epilogue-code)))
    (cleanup-temporary-files)
    (quit)))

;;; Attempt at compiling directly with asdf-ecl's make-build and temporary wrapper asd's
;;; Fails with weird linking errors.
#+ecl (defvar *in-compile* nil)
#+ecl
(defun yyy-build-and-dump (dump load system restart init quit)
  (unwind-protect
       (let* ((*compile-verbose* *verbose*)
              (*in-compile* t)
              (c::*suppress-compiler-warnings* (not *verbose*))
              (c::*suppress-compiler-notes* (not *verbose*))
              (*features* (remove :cl-launch *features*))
              (header (or *compile-file-pathname* *load-pathname* (getenv "CL_LAUNCH_HEADER")))
              (header-file (ensure-lisp-file header "header.lisp"))
              (load-file (when load (ensure-lisp-file load "load.lisp")))
              (standalone (getenv "CL_LAUNCH_STANDALONE"))
              (init-code
               `(unless *in-compile*
                 (setf
                  *load-verbose* nil
                  *dumped* ,(if standalone :standalone :wrapped)
                  *arguments* nil
                  ,@(when restart `(*restart* (read-function ,restart)))
                  ,@(when init `(*init-forms* ,init))
                  ,@(unless quit `(*quit* nil)))
                 ,(if standalone '(resume) '(si::top-level))))
              (init-file (temporary-file-from-sexp init-code "init.lisp"))
              (prefix-sys (temporary-filename "prefix"))
              (program-sys (temporary-filename "program"))
              (prefix-sysdef
               `(asdf:defsystem ,prefix-sys
                 :depends-on () :serial t
                 :components ((:file "header" :pathname ,header-file)
                              ,@(when load-file `((:file "load" :pathname ,load-file))))))
              (program-sysdef
               `(asdf:defsystem ,program-sys
                 :depends-on (,prefix-sys
                              ,@(when system `(,system)))
                 :components ((:file "init" :pathname ,init-file))))
              (prefix-asd (temporary-file-from-sexp prefix-sysdef "prefix.asd"))
              (program-asd (temporary-file-from-sexp program-sysdef "program.asd")))
         (load prefix-asd)
         (load program-asd)
         (asdf::make-build program-sys :type :program)
         (si:system (format nil "cp -p ~S ~S"
                                    (namestring (first (asdf:output-files (make-instance 'asdf::program-op)
                                                                          (find-system program-sys))))
                            dump)))
    (cleanup-temporary-files))
  (quit))

;;;; Find a unique directory name for current implementation for the fasl cache
;;; (modified from SLIME's swank-loader.lisp)

(defparameter *implementation-features*

  '(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp

    :armedbear :gcl :ecl :scl))

(defparameter *os-features*
  '(:macosx :linux :windows :mswindows :win32
    :solaris :darwin :sunos :hpux :unix))

(defparameter *architecture-features*
  '(:powerpc :ppc

    :x86-64 :amd64 :x86 :i686 :i586 :i486 :pc386 :iapx386 :pentium3
    :sparc64 :sparc
    :hppa64 :hppa))

(defun lisp-version-string ()

  #+(or cmu scl sbcl ecl lispworks armedbear cormanlisp)
  (lisp-implementation-version)
  #+clozure   (format nil "~d.~d.fasl~d"

                      ccl::*openmcl-major-version*
                      ccl::*openmcl-minor-version*
                      (logand ccl::fasl-version #xFF))
  #+allegro   (format nil
                      "~A~A~A"
                      excl::*common-lisp-version-number*
                      (if (eq 'h 'H) "A" "M")     ; ANSI vs MoDeRn
                      (if (member :64bit *features*) "-64bit" ""))
  #+clisp     (let ((s (lisp-implementation-version)))
                (subseq s 0 (position #\space s)))
  #+gcl       (let ((s (lisp-implementation-version))) (subseq s 4)))

(defun ensure-directory-name (dn)
   (if (eql #\/ (char dn (1- (length dn)))) dn
      (concatenate 'string dn "/")))

(defun dirname->pathname (dn)
  (parse-namestring (ensure-directory-name dn)))

(defun unique-directory-name (&optional warn)
  "Return a name that can be used as a directory name that is
unique to a Lisp implementation, Lisp implementation version,
operating system, and hardware architecture."
  (flet ((first-of (features)
           (find-if #'(lambda (f) (find f *features*)) features))
         (maybe-warn (value fstring &rest args)
           (cond (value)
                 (t (when warn (apply #'warn fstring args))
                    "unknown"))))
    (let ((lisp (maybe-warn (first-of *implementation-features*)
                            "No implementation feature found in ~a."
                            *implementation-features*))
          (os   (maybe-warn (first-of *os-features*)
                            "No os feature found in ~a." *os-features*))
          (arch	(maybe-warn (first-of *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)))))

;;;; Redefine the ASDF output-files method to put fasl's under the fasl cache.
;;; (taken from common-lisp-controller's post-sysdef-install.lisp)

;;#-common-lisp-controller (progn ; BEGIN of progn to disable caching when clc is detected

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

(defun wilden (path)
   (merge-pathnames *wild-path* path))

#-asdf
(defun resolve-symlinks (x)
  #+allegro (excl:pathname-resolve-symbolic-links x)

  #+gcl-pre2.7 x

  #-(or allegro gcl-pre2.7)
  (truename x))

(defvar *output-pathname-translations* nil
  "a list of pathname translations, where every translation is a list
of a source pathname and destination pathname.")

(defun exclude-from-cache (&rest dirs)
  (dolist (dir dirs)
    (when dir
      (let* ((p (if (pathnamep dir) dir (dirname->pathname dir)))
             (n #+asdf (resolve-symlinks p) #-asdf p)
             (w (wilden n)))
        (pushnew (list w w)
                 cl-launch::*output-pathname-translations*
                 :test #'equal)))))

(defun calculate-output-pathname-translations ()
  (setf *output-pathname-translations*
        `(#+(and common-lisp-controller (not gcl))
          ,@(progn

              (ensure-directories-exist (calculate-fasl-root))