texinfo-docstrings

   1 #!/bin/sh
   2 #| CL-LAUNCH 2.07 CONFIGURATION
   3 SOFTWARE_FILE=.
   4 SOFTWARE_SYSTEM=
   5 SOFTWARE_INIT_FORMS=
   6 SYSTEMS_PATHS=
   7 INCLUDE_PATH=
   8 LISPS="cmucl sbcl clisp ecl openmcl gclcvs allegro lisp gcl"
   9 WRAPPER_CODE=
  10 DUMP=
  11 RESTART=
  12 IMAGE_BASE=
  13 IMAGE_DIR=
  14 IMAGE=
  15 # END OF CL-LAUNCH CONFIGURATION
  16
  17 # This file was generated by CL-Launch 2.07
  18 # This file was automatically generated and contains parts of CL-Launch
  19 #
  20 # Please send your improvements to the author:
  21 # fare at tunes dot org < http://www.cliki.net/Fare%20Rideau >.
  22 #
  23 # CL-Launch is available under the terms of the bugroff license.
  24 #       http://www.geocities.com/SoHo/Cafe/5947/bugroff.html
  25 # You may at your leisure use the LLGPL instead < http://www.cliki.net/LLGPL >
  26 #
  27 # This software can be used in conjunction with any other software:
  28 # the result may consist in pieces of the two software glued together in
  29 # a same file, but even then these pieces remain well distinguished, and are
  30 # each available under its own copyright and licensing terms, as applicable.
  31 # The parts that come from the other software are subject to the terms of use
  32 # and distribution relative to said software, which may well be
  33 # more restrictive than the terms of this software (according to lawyers
  34 # and the armed henchmen they got the taxpayers to pay to enforce their laws).
  35 # The bits of code generated by cl-launch, however, remain available
  36 # under the terms of their own license, and you may service them as you wish:
  37 # manually, using cl-launch --update or whichever means you prefer.
  38 # That said, if you believe in any of that intellectual property scam,
  39 # you may be subject to the terms of my End-Seller License:
  40 #       http://www.livejournal.com/users/fare/21806.html
  41 #
  42 PROG="$0"
  43 # cl-launch 2.07 shell wrapper
  44 #   Find and execute the most appropriate supported Lisp implementation
  45 #   to evaluate software prepared with CL-Launch.
  46 #
  47 ECHOn () { printf '%s' "$*" ;}
  48 simple_term_p () {
  49   case "$1" in *[!a-zA-Z0-9-+_,.:=%/]*) return 1 ;; *) return 0 ;; esac
  50 }
  51 kwote0 () { ECHOn "$1" | sed -e "s/\([\\\\\"\$\`]\)/\\\\\\1/g" ;}
  52 kwote () { if simple_term_p "$1" ; then ECHOn "$1" ; else kwote0 "$1" ; fi ;}
  53 load_form_0 () { echo "(load $1 :verbose nil :print nil)" ;}
  54 load_form () { load_form_0 "\"$(kwote "$1")\"" ;}
  55 ECHO () { printf '%s\n' "$*" ;}
  56 DBG () { ECHO "$*" >& 2 ;}
  57 abort () { ERR="$1" ; shift ; DBG "$*" ; exit "$ERR" ;}
  58 ABORT () { abort 42 "$*" ;}
  59 DO_LISP=do_exec_lisp
  60 HASH_BANG_FORM='(set-dispatch-macro-character #\# #\! #'\''(lambda(stream char arg)(declare(ignore char arg))(values (read-line stream))))'
  61 PACKAGE_FORM=" #.(progn(defpackage :cl-launch (:use :cl))())"
  62 MAYBE_PACKAGE_FORM=
  63
  64 implementation_cmucl () {
  65   implementation "${CMUCL:-cmucl}" || return 1
  66   OPTIONS="${CMUCL_OPTIONS:- -quiet -batch -noinit}"
  67   EVAL=-eval
  68   ENDARGS=--
  69   IMAGE_ARG=-core
  70   EXEC_LISP=exec_lisp_noarg
  71   # exec_lisp works fine, except in the corner case when the program's user
  72   # would use arguments that cmucl would process as its own arguments, even
  73   # though they are meant for the Lisp program. cmucl provides no way to
  74   # specify that arguments after "--" don't really matter.
  75   # And so we use exec_lisp_noarg.
  76   BIN_ARG=CMUCL
  77   OPTIONS_ARG=CMUCL_OPTIONS
  78 }
  79 implementation_lisp () {
  80   implementation ${CMULISP:=lisp} || return 1
  81   CMUCL=$CMULISP
  82   implementation_cmucl "$@"
  83 }
  84 implementation_sbcl () {
  85   implementation "${SBCL:-sbcl}" || return 1
  86   OPTIONS="${SBCL_OPTIONS:- --noinform --userinit /dev/null --disable-debugger}"
  87   # We purposefully specify --userinit /dev/null but NOT --sysinit /dev/null
  88   EVAL=--eval # SBCL's eval can only handle one form per argument.
  89   ENDARGS=--end-toplevel-options
  90   IMAGE_ARG=--core
  91   #! IMAGE_ARG=EXECUTABLE_IMAGE # not appropriate: only executable if specified as such
  92   #! DIRECT_EXECUTABLE=t # won't work as of sbcl 0.9.17: we need to modify sbcl
  93   #! so it leaves all argument parsing to the software.
  94   EXEC_LISP=exec_lisp
  95   BIN_ARG=SBCL
  96   OPTIONS_ARG=SBCL_OPTIONS
  97 }
  98 implementation_clisp () {
  99   implementation "${CLISP:-clisp}" || return 1
 100   OPTIONS="${CLISP_OPTIONS:- -norc --quiet --quiet}"
 101   EVAL=-x
 102   LOAD=-i
 103   ENDARGS="-- foo"
 104   # if the first argument begins with - there might be problems,
 105   # so we avoid that and take the cdr or ext:*args*
 106   IMAGE_ARG=-M # for use without :executable t
 107   #! IMAGE_ARG="EXECUTABLE_IMAGE" # we don't use this by default
 108   #! DIRECT_EXECUTABLE=t # won't work as of unpatched 2.41: we need to modify clisp
 109   #! so it leaves all argument parsing to the software. See for instance
 110   #! http://article.gmane.org/gmane.lisp.clisp.devel/15476
 111   EXEC_LISP=exec_lisp
 112   BIN_ARG=CLISP
 113   OPTIONS_ARG=CLISP_OPTIONS
 114 }
 115 implementation_lispworks () { ### NEVER TESTED
 116   implementation "${LISPWORKS:-lispworks}" || return 1
 117   OPTIONS="${LISPWORKS_OPTIONS:- -siteinit -}" # -init -
 118   LOAD=-init #### No such thing found in the online documentation.
 119   #! EVAL=-eval # No such thing found in the online documentation.
 120   #! ENDARGS="--"
 121   IMAGE_ARG="EXECUTABLE_IMAGE" # we don't use this by default
 122   EXEC_LISP=exec_lisp_file
 123   BIN_ARG=LISPWORKS
 124   OPTIONS_ARG=LISPWORKS_OPTIONS
 125 }
 126 prepare_arg_form () {
 127   ENDARGS= F=
 128   for arg ; do
 129     F="$F\"$(kwote "$arg")\""
 130   done
 131   MAYBE_PACKAGE_FORM="$PACKAGE_FORM"
 132   LAUNCH_FORMS="(defparameter cl-launch::*arguments*'($F))${LAUNCH_FORMS}"
 133 }
 134 exec_lisp_noarg () {
 135   prepare_arg_form "$@"
 136   exec_lisp
 137 }
 138 exec_lisp_file () {
 139   prepare_arg_form "$@"
 140   LOADFILE=${TMP:-/tmp}/cl-load-file-$(date +%s)-$$
 141   cat > $LOADFILE <<END
 142 ${MAYBE_PACKAGE_FORM}
 143 ${HASH_BANG_FORM}
 144 ${LAUNCH_FORMS}
 145 END
 146   $LISP_BIN $IMAGE_OPT $IMAGE $OPTIONS $LOAD "$LOADFILE"
 147   RET=$?
 148   rm -f $LOADFILE
 149   exit $RET
 150 }
 151 implementation_clisp_noarg () {
 152   implementation_clisp
 153   EXEC_LISP=exec_lisp_noarg
 154   # For testing purposes
 155 }
 156 implementation_clisp_file () {
 157   implementation_clisp
 158   EXEC_LISP=exec_lisp_file
 159   # For testing purposes
 160 }
 161 implementation_openmcl () {
 162   implementation "${OPENMCL:-openmcl}" || return 1
 163   OPTIONS="${OPENMCL_OPTIONS:- --no-init --batch}"
 164   EVAL=--eval # -e
 165   IMAGE_ARG=--image-name # -I
 166   ENDARGS=--
 167   # (finish-output) is essential for openmcl, that won't do it by default,
 168   # unlike the other lisp implementations tested.
 169   EXEC_LISP=exec_lisp_noarg
 170   # exec_lisp will work great for 1.1, but 1.1 isn't there yet,
 171   # 1.0 doesn't support --, and the latest 1.1-pre060826 snapshot has a bug
 172   # whereby it doesn't stop at -- when looking for a -I or --image-file argument.
 173   BIN_ARG=OPENMCL
 174   OPTIONS_ARG=OPENMCL_OPTIONS
 175 }
 176 implementation_gcl () {
 177   implementation "${GCL:-gcl}" || return 1
 178   OPTIONS="${GCL_OPTIONS:- -batch}"
 179   EVAL=-eval
 180   ENDARGS=--
 181   IMAGE_ARG=EXECUTABLE_IMAGE
 182   BIN_ARG=GCL
 183   OPTIONS_ARG=GCL_OPTIONS
 184   export GCL_ANSI=t
 185   EXEC_LISP=exec_lisp
 186 }
 187 implementation_ecl () {
 188   implementation "${ECL:-ecl}" || return 1
 189   OPTIONS="${ECL_OPTIONS:- -q -norc}"
 190   EVAL=-eval
 191   ENDARGS=--
 192   #IMAGE_ARG="-q -load" # for :fasl
 193   IMAGE_ARG="EXECUTABLE_IMAGE" # for :program
 194   DIRECT_EXECUTABLE=t
 195   BIN_ARG=ECL
 196   OPTIONS_ARG=ECL_OPTIONS
 197   EXEC_LISP=exec_lisp
 198
 199   # work around brokenness in c-l-c packaging of ECL,
 200   # at least as of ecl 0.9i-2 and c-l-c 6.2
 201   if [ -z "$ECL" ] &&
 202      [ "/usr/bin/ecl" = "$LISP_BIN" ] &&
 203      [ -x "/usr/lib/ecl/ecl-original" ] ; then
 204     LISP_BIN=/usr/lib/ecl/ecl-original
 205   fi
 206 }
 207 implementation_gclcvs () {
 208   implementation "${GCLCVS:=gclcvs}" || return 1
 209   GCL="$GCLCVS"
 210   implementation_gcl "$@" && BIN_ARG=GCLCVS
 211 }
 212 implementation_allegro () {
 213   implementation "${ALLEGRO:-acl}" || return 1
 214   OPTIONS="${ALLEGRO_OPTIONS:- -QQ -qq -batch}"
 215   EVAL=-e
 216   ENDARGS=--
 217   IMAGE_ARG=-I
 218   EXEC_LISP=exec_lisp
 219   BIN_ARG=ALLEGRO
 220   OPTIONS_ARG=ALLEGRO_OPTIONS
 221 }
 222 implementation () {
 223   if [ -x "$1" ] ; then
 224     LISP_BIN="$1"
 225     return 0
 226   elif LISP_BIN=`which "$1" 2> /dev/null` ; then
 227     return 0
 228   else
 229     return 1
 230   fi
 231 }
 232 trylisp () {
 233   IMPL="$1" ; shift
 234   implementation_${IMPL} "$@"
 235 }
 236 do_exec_lisp () {
 237   $EXEC_LISP "$@"
 238 }
 239 no_implementation_found () {
 240   ABORT "$PROG: Cannot find a supported lisp implementation.
 241 Tried the following: $*"
 242 }
 243 ensure_implementation () {
 244   trylisp "$1" || no_implementation_found "$1"
 245 }
 246 try_all_lisps () {
 247   for l in $LISP $LISPS ; do
 248     if trylisp $l ; then
 249       $DO_LISP "$@"
 250       return 0
 251     fi
 252   done
 253   no_implementation_found "$LISP $LISPS"
 254 }
 255 exec_lisp () {
 256   # SBCL wants only one form per --eval so we need put everything in one progn.
 257   # However we also want any in-package form to be evaluated before any of the
 258   # remaining forms is read, so we get it to be evaluated at read-time as the
 259   # first thing in the main progn.
 260   # GNU clisp allows multiple forms per -x but prints the result of every form
 261   # evaluated and so we also need put everything in a single progn, and that progn
 262   # must quit before it may return to the clisp frame that would print its value.
 263   # CMUCL allows multiple forms per -eval and won't print values, so is ok anyway.
 264   # I don't know about other Lisps, but they will all work this way.
 265   LAUNCH_FORM="(progn${MAYBE_PACKAGE_FORM}${HASH_BANG_FORM}${LAUNCH_FORMS})"
 266   if [ -n "$CL_LAUNCH_VERBOSE" ] ; then set -x ; fi
 267   exec $LISP_BIN $IMAGE_OPT $IMAGE $OPTIONS $EVAL "$LAUNCH_FORM" $ENDARGS "$@"
 268 }
 269 launch_self () {
 270   LAUNCH_FORMS="$(load_form "$PROG")"
 271   try_all_lisps "$@"
 272 }
 273 invoke_image () {
 274   if [ "x$IMAGE_ARG" = xEXECUTABLE_IMAGE ] ; then
 275     LISP_BIN= IMAGE_OPT=
 276   else
 277     IMAGE_OPT="$IMAGE_ARG"
 278   fi
 279   PACKAGE_FORM=
 280   HASH_BANG_FORM=
 281   LAUNCH_FORMS="(cl-launch::resume)"
 282   "$EXEC_LISP" "$@"
 283 }
 284
 285 export CL_LAUNCH_PID=$$
 286 export CL_LAUNCH_FILE="$PROG"
 287
 288 ## execute configuration-provided code
 289 eval "$WRAPPER_CODE"
 290
 291 ### END OF CL-LAUNCH SHELL WRAPPER
 292
 293
 294 launch_self "$@"
 295 ABORT
 296 # |#
 297 #| ;;; cl-launch 2.07 lisp header
 298 |# ;;;; Silence our lisp implementation for quiet batch use...
 299
 300 #| We'd like to evaluate as little as possible of the code without compilation.
 301  This poses a typical bootstrapping problem: the more sophistication we want
 302  to distinguish what to put where in what dynamic environment, the more code
 303  we have to evaluate before we may actually load compiled files. And, then,
 304  it is a waste of time to try to compile said code into a file. Moving things
 305  to the shell can only help so much, and reduces flexibility. Our best bet is
 306  to tell sbcl or cmucl to not try to optimize too hard.
 307 |#
 308 #-cl-launch (eval-when (:load-toplevel :execute :compile-toplevel)
 309   (declaim (optimize (speed 1) (safety 2) (compilation-speed 3) #-gcl (debug 1)
 310            #+sbcl (sb-ext:inhibit-warnings 3)
 311            #+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
 312            #+cmu (ext:inhibit-warnings 3)))
 313   #+gcl ;;; If using GCL, do some safety checks
 314   (when (or #-ansi-cl t)
 315     (format *error-output*
 316      "CL-Launch only supports GCL in ANSI mode. Aborting.~%")
 317     (lisp:quit))
 318   #+gcl
 319   (when (or (< system::*gcl-major-version* 2)
 320             (and (= system::*gcl-major-version* 2)
 321                  (< system::*gcl-minor-version* 7)))
 322     (pushnew :gcl-pre2.7 *features*))
 323   (setf *print-readably* nil ; allegro 5.0 notably will bork without this
 324         *load-verbose* nil *compile-verbose* nil *compile-print* nil)
 325   #+cmu (setf ext:*gc-verbose* nil)
 326   #+clisp (setf custom:*source-file-types* nil custom:*compiled-file-types* nil)
 327   #+gcl (setf compiler::*compiler-default-type* (pathname "")
 328               compiler::*lsp-ext* "")
 329   #+ecl (require 'cmp)
 330
 331   ;;;; Ensure package hygiene
 332   (unless (find-package :cl-launch)
 333     (if (find-package :common-lisp)
 334        (defpackage :cl-launch (:use :common-lisp))
 335        (make-package :cl-launch :use '(:lisp))))
 336   (in-package :cl-launch))
 337 #-cl-launch (defmacro dbg (tag &rest exprs)
 338   "simple debug statement macro:
 339 outputs a tag plus a list of source expressions and their resulting values, returns the last values"
 340   (let ((res (gensym))(f (gensym)))
 341   `(let ((,res))
 342     (flet ((,f (fmt &rest args) (apply #'format *error-output* fmt args)))
 343       (,f "~&~A~%" ,tag)
 344       ,@(mapcan
 345          #'(lambda (x)
 346             `((,f "~&  ~S => " ',x)
 347               (,f "~{~S~^ ~}~%" (setf ,res (multiple-value-list ,x)))))
 348          exprs)
 349       (apply 'values ,res)))))
 350 #-cl-launch (eval-when (:load-toplevel :execute :compile-toplevel)
 351   ;; Import a few symbols if needed
 352   #+common-lisp-controller
 353   (map () #'import
 354        '(clc::*source-root*
 355          clc::*fasl-root*
 356          clc::calculate-fasl-root
 357          clc::source-root-path-to-fasl-path
 358          clc::alternative-root-path-to-fasl-path
 359          clc::*redirect-fasl-files-to-cache*))
 360   #+ecl
 361   (map () #'import
 362        '(c::system-ld-flag
 363          c::library-type-p
 364          c::built-type-p
 365          c::builder
 366          c::build-fasl
 367          c::wt-filtered-data
 368          c::init-function-name
 369          c::data-init
 370          c::compiler-cc
 371          c::linker-cc
 372          c::shared-cc
 373          c::bundle-cc
 374          c::safe-system
 375          c::cmp-delete-file
 376          c::+lisp-program-header+
 377          c::+lisp-program-init+
 378          c::+lisp-program-main+
 379          c::+static-library-prefix+
 380          c::+lisp-program-init+
 381          ))
 382   ;;; define getenv and quit in ways that minimize package conflicts
 383   ;;; (use-package :cl-launch) while in cl-user.
 384   #+(or openmcl allegro gcl clisp ecl)
 385     (import '#+openmcl ccl::getenv
 386              #+allegro sys:getenv
 387              #+gcl system:getenv
 388              #+clisp ext:getenv
 389              #+ecl si:getenv
 390       :cl-launch)
 391   #+(or cmu sbcl lispworks)
 392     (defun getenv (x)
 393       #+sbcl (sb-ext:posix-getenv x)
 394       #+lispworks (lispworks:environment-variable x)
 395       #+cmu (cdr (assoc (intern x :keyword) ext:*environment-list*)))
 396   (defun quit (&optional (code 0) (finish-output t))
 397     (when finish-output ;; essential, for openmcl, and for standard compliance.
 398       (finish-outputs))
 399     #+cmu (unix:unix-exit code)
 400     #+clisp (ext:quit code)
 401     #+sbcl (sb-unix:unix-exit code)
 402     #+openmcl (ccl:quit code)
 403     #+gcl (lisp:quit code)
 404     #+allegro (excl:exit code :quiet t)
 405     #+ecl (si:quit code)
 406     #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
 407     #-(or cmu clisp sbcl openmcl gcl allegro ecl lispworks)
 408     (error "Quitting not implemented")))
 409 #-cl-launch (eval-when (:load-toplevel :execute :compile-toplevel)
 410   ;;;; Load ASDF
 411   (ignore-errors (require :asdf))
 412   ;;; Here is a fallback plan in case the lisp implementation isn't asdf-aware.
 413   (unless (and (find-package :asdf) (find-symbol "OUTPUT-FILES" :asdf))
 414     (defvar *asdf-path*
 415       (or (and (getenv "ASDF_PATH") (probe-file (getenv "ASDF_PATH")))
 416           (probe-file (merge-pathnames "src/asdf/asdf.lisp"
 417                                        (user-homedir-pathname)))
 418           (probe-file "/usr/share/common-lisp/source/asdf/asdf.lisp")))
 419     (when *asdf-path*
 420       (ignore-errors (load *asdf-path* :verbose nil :print nil)))))
 421 #-cl-launch (eval-when (:load-toplevel :execute :compile-toplevel)
 422   ;;; Even in absence of asdf, at least create a package asdf.
 423   (unless (find-package :asdf)
 424     (make-package :asdf)))
 425 #-cl-launch (eval-when (:load-toplevel :execute :compile-toplevel)
 426   ;;; Try to share this with asdf, in case we get asdf to support it one day.
 427   (map () #'import
 428        '(asdf::*output-pathname-translations*
 429          asdf::resolve-symlinks
 430          asdf::oos asdf::load-op asdf::find-system)))
 431
 432 ;;;; CL-Launch Initialization code
 433 #-cl-launch (progn
 434
 435 (pushnew :cl-launch *features*)
 436
 437 ;;#+ecl (require 'cmp) ; ensure we use the compiler (we use e.g. *ecl-library-directory*)
 438
 439 (dolist (s '(*arguments* getenv quit compile-and-load-file
 440              compile-file-pathname* apply-pathname-translations
 441              *output-pathname-translations*
 442              apply-output-pathname-translations))
 443   (export s))
 444
 445 ;; To dynamically recompute from the environment at each invocation
 446 (defvar *cl-launch-file* nil)
 447 (defvar *verbose* nil)
 448 (defvar *lisp-fasl-cache* nil "lisp fasl cache hierarchy")
 449 (defvar *lisp-fasl-root* nil "top path for the fasl cache for current implementation")
 450 ;; To dynamically recompute from the command-line at each invocation
 451 (defvar *arguments* nil "command-line parameters")
 452
 453 ;; Variables that define the current system
 454 (defvar *dumped* nil)
 455 (defvar *restart* nil)
 456 (defvar *init-forms* nil)
 457 (defvar *quit* t)
 458
 459 ;; Provide compatibility with clc 6.2
 460 (defvar *redirect-fasl-files-to-cache* t)
 461
 462 #+ecl
 463 (defun command-line-arguments ()
 464   (loop for i from 1 below (si:argc) collect (si:argv i)))
 465
 466 (defun compute-arguments ()
 467   #+gcl (setf system::*tmp-dir* (ensure-directory-name (or (getenv "TMP") "/tmp"))) ; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1
 468   (setf *cl-launch-file* (getenv "CL_LAUNCH_FILE")
 469         *verbose* (when (getenv "CL_LAUNCH_VERBOSE") t)
 470         *lisp-fasl-cache* (let* ((cache-env (getenv "LISP_FASL_CACHE"))
 471                             (cache-spec
 472                              (cond
 473                                ((null cache-env)
 474                                 (merge-pathnames
 475                                  #p".cache/lisp-fasl/"
 476                                  ;;(make-pathname :directory (list :relative ".cache" "lisp-fasl"))
 477                                  (user-homedir-pathname)))
 478                                ((equal cache-env "NIL") nil)
 479                                (t (dirname->pathname cache-env)))))
 480                        #+gcl-pre2.7 cache-spec #-gcl-pre2.7
 481                        (when cache-spec
 482                          (ensure-directories-exist cache-spec)
 483                          (resolve-symlinks cache-spec)))
 484         *lisp-fasl-root* (let* ((root-env
 485                                  (when (getenv "LISP")
 486                                    (let ((r (getenv "LISP_FASL_ROOT")))
 487                                      (when r (if (equal r "NIL") :disabled
 488                                                  (dirname->pathname r))))))
 489                                 (root-spec
 490                                  (or root-env
 491                                      (when *lisp-fasl-cache*
 492                                        (merge-pathnames
 493                                         (make-pathname
 494                                          :directory (list :relative *implementation-name*))
 495                                         *lisp-fasl-cache*)))))
 496                            #+gcl-pre2.7 root-spec #-gcl-pre2.7
 497                            (when root-spec
 498                              (ensure-directories-exist root-spec)
 499                              (resolve-symlinks root-spec))))
 500   (calculate-output-pathname-translations)
 501   (setf *arguments*
 502    (or *arguments*
 503        #+(or cmu gcl ecl lispworks)
 504          (cdr (member "--"
 505                       #+gcl si:*command-args*
 506                       #+ecl (command-line-arguments)
 507                       #+cmu extensions:*command-line-strings*
 508                       #+lispworks system:*line-arguments-list*
 509                       :test 'equal))
 510        #+openmcl ccl:*unprocessed-command-line-arguments*
 511        #+sbcl (cdr sb-ext:*posix-argv*)
 512        #+allegro (cdr (sys:command-line-arguments))
 513        #+clisp (cdr ext:*args*))))
 514
 515 (defun register-paths (paths)
 516   #-asdf (declare (ignore paths))
 517   #+asdf
 518   (dolist (p (reverse paths))
 519     (pushnew p asdf::*central-registry* :test 'equal)))
 520
 521 (defun load-stream (&optional (s #-clisp *standard-input*
 522                                  #+clisp *terminal-io*))
 523   ;; GCL 2.6 can't load from a string-input-stream
 524   ;; OpenMCL 1.1-pre cannot load from either *standard-input* or *terminal-io*
 525   ;; Allegro 5, I don't remember but it must have been broken when I tested.
 526   #+(or gcl-pre2.7 allegro)
 527   (do ((eof '#:eof) (x t (read s nil eof))) ((eq x eof)) (eval x))
 528   #-(or gcl-pre2.7 allegro)
 529   (load s :verbose nil :print nil))
 530
 531 (defun load-string (string)
 532   (with-input-from-string (s string) (load-stream s)))
 533
 534 (defun finish-outputs ()
 535   (finish-output *error-output*)
 536   (finish-output))
 537
 538 (defun %abort (code fmt &rest args)
 539   (apply #'format *error-output* fmt args)
 540   (quit code))
 541
 542 (defun resume ()
 543   (compute-arguments)
 544   (do-resume))
 545
 546 (defun do-resume ()
 547   (when *restart* (funcall *restart*))
 548   (when *init-forms* (load-string *init-forms*))
 549   (finish-outputs)
 550   (when *quit* (quit 0)))
 551
 552 (defun dump-image (filename &key executable (package :cl-user))
 553   (declare (ignorable filename executable package))
 554   (setf *dumped* (if executable :executable t)
 555         *arguments* nil)
 556   #+clisp
 557   (ext:saveinitmem filename
 558    :executable executable
 559    :init-function (when executable #'resume)
 560    ;; :parse-options (not executable) ;--- requires a patch to clisp
 561    :script t
 562    :quiet t
 563    :norc t
 564    :start-package package
 565    :keep-global-handlers nil)
 566   #+sbcl
 567   (progn
 568     ;;(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
 569    (setf sb-ext::*gc-run-time* 0)
 570    (apply 'sb-ext:save-lisp-and-die filename
 571     :executable executable
 572     (when executable (list :toplevel #'resume))))
 573   #+cmu
 574   (progn
 575    (ext:gc :full t)
 576    (setf ext:*batch-mode* nil)
 577    (setf ext::*gc-run-time* 0)
 578    (extensions:save-lisp filename))
 579   #+openmcl
 580   (ccl:save-application filename)
 581   #+allegro
 582   (progn
 583    (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
 584    (excl:dumplisp :name filename :suppress-allegro-cl-banner t))
 585   #+lispworks
 586   (save-image filename :environment nil) ; XXXXX
 587   #+gcl
 588   (progn
 589    (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
 590    (si::save-system filename))
 591   #-(or clisp sbcl cmu openmcl allegro gcl lispworks)
 592   (%abort 11 "CL-Launch doesn't supports image dumping with this Lisp implementation.~%"))
 593
 594 (defun run (&key paths load system dump restart init (quit 0))
 595   (pushnew :cl-launched *features*)
 596   (compute-arguments)
 597   (when paths (register-paths paths))
 598   (if dump
 599       (build-and-dump dump load system restart init quit)
 600       (build-and-run load system restart init quit)))
 601
 602 (defun read-function (string)
 603   `(function ,(read-from-string string)))
 604
 605 (defun build-and-load (load system restart init quit)
 606   (when load
 607     (cond
 608      ((eq load t) (load-stream))
 609      ((streamp load) (load-stream load))
 610      ((eq load :self) (load-file *cl-launch-file*))
 611      (t (load-file load))))
 612   (when system
 613     #+asdf
 614     (load-system system :verbose *verbose*)
 615     #-asdf
 616     (%abort 10 "ERROR: asdf requested, but not found~%"))
 617   (setf *restart* (when restart (eval (read-function restart)))
 618         *init-forms* init
 619         *quit* quit))
 620
 621 (defun build-and-run (load system restart init quit)
 622   (build-and-load load system restart init quit)
 623   (do-resume))
 624
 625 #-ecl
 626 (defun build-and-dump (dump load system restart init quit)
 627   (build-and-load load system restart init quit)
 628   (dump-image dump :executable (getenv "CL_LAUNCH_EXECUTABLE"))
 629   (quit))
 630
 631 #+ecl (progn ;;; ECL PATCH: modifies and adds functions into ecl*/src/cmp/cmpmain.lsp
 632 ;;; necessary for ecl 0.9i. The patch since made it to the development branch and so
 633 ;;; will have to be removed from here when new ecl releases make it to our target
 634 ;;; linux distributions.
 635
 636 (defun system-ld-flag (library)
 637   (let ((asdf (find-package "ASDF"))
 638         system)
 639     (labels ((asdfsym (x) (find-symbol (string x) asdf))
 640              (asdfcall (fun &rest rest) (apply (asdfsym fun) rest))
 641              (system-output (system type)
 642                (let ((build (make-instance (asdfsym :build-op) :type type)))
 643                  (first (asdfcall :output-files build system))))
 644              (existing-system-output (system type)
 645                (let ((o (system-output system type)))
 646                  (and o (probe-file o))))
 647              (find-archive (system)
 648                  (or (existing-system-output system :library)
 649                      (existing-system-output system :shared-library)))
 650              (fallback () (format nil #-msvc "-l~A" #+msvc "~A.lib" (string-downcase library))))
 651       (or (and asdf
 652                (setf system (asdfcall :find-system library nil))
 653                (find-archive system))
 654         (fallback)))))
 655
 656 (defun library-type-p (type)
 657   (member type
 658           #-msvc '("a" "so")
 659           #+msvc '("lib" "dll")
 660           :test #'equal))
 661
 662 (defun built-type-p (type)
 663   (or (equal type #-msvc "o" #+msvc "obj")
 664       (library-type-p type)))
 665
 666 (defun builder (target output-name &key lisp-files ld-flags shared-data-file
 667                 (init-name nil)
 668                 (prologue-code "")
 669                 (epilogue-code (when (eq target :program) '(SI::TOP-LEVEL)))
 670                 #+:win32 (system :console))
 671   ;;
 672   ;; The epilogue-code can be either a string made of C code, or a
 673   ;; lisp form.  In the latter case we add some additional C code to
 674   ;; clean up, and the lisp form is stored in a text representation,
 675   ;; to avoid using the compiler.
 676   ;;
 677   (cond ((null epilogue-code)
 678          (setf epilogue-code ""))
 679         ((stringp epilogue-code)
 680          )
 681         (t
 682          (with-standard-io-syntax
 683            (setq epilogue-code
 684                  (with-output-to-string (stream)
 685                    (princ "{ const char *lisp_code = " stream)
 686                    (wt-filtered-data (write-to-string epilogue-code) stream)
 687                    (princ ";
 688 cl_object output;
 689 si_select_package(make_simple_base_string(\"CL-USER\"));
 690 output = cl_safe_eval(c_string_to_object(lisp_code), Cnil, OBJNULL);
 691 " stream)
 692                    (when (eq target :program)
 693                      (princ "cl_shutdown(); return (output != OBJNULL);" stream))
 694                    (princ #\} stream)
 695                    )))))
 696   ;;
 697   ;; When a module is built out of several object files, we have to
 698   ;; create an additional object file that initializes those ones.
 699   ;; This routine is responsible for creating this file.
 700   ;;
 701   ;; To avoid name clashes, this object file will have a temporary
 702   ;; file name (tmp-name).
 703   ;;
 704   (let* ((tmp-name (si::mkstemp #P"TMP:ECLINIT"))
 705          (c-name (si::coerce-to-filename
 706                   (compile-file-pathname tmp-name :type :c)))
 707          (o-name (si::coerce-to-filename
 708                   (compile-file-pathname tmp-name :type :object)))
 709          submodules
 710          c-file)
 711     (dolist (item (reverse lisp-files))
 712       (etypecase item
 713         (symbol
 714          (push (system-ld-flag item) ld-flags)
 715          ;;---*** NOTE: reduce clashes by having a system prefix in the init-name
 716          (push (init-function-name item "system") submodules))
 717         ((or string pathname)
 718          (let* ((pn (parse-namestring item))
 719                 (type (pathname-type pn))
 720                 (module (pathname-name pn))
 721                 (init-fn
 722                  ;;---*** NOTE: it would reduce clashes to keep/add a
 723                  ;;---*** system/library prefix in/to the init-name
 724                  (if (library-type-p type)
 725                    (let ((name
 726                           (if (equal (subseq module 0 (length +static-library-prefix+))
 727                                      +static-library-prefix+)
 728                            (subseq module (length +static-library-prefix+))
 729                            module)))
 730                      (init-function-name name "system"))
 731                    (init-function-name module)))
 732                 (built-pn
 733                  (if (built-type-p type) pn
 734                    (compile-file-pathname pn :type :object)))
 735                 (filename (si::coerce-to-filename built-pn)))
 736            (push filename ld-flags)
 737            (push init-fn submodules)))))
 738     (setq c-file (open c-name :direction :output))
 739     (format c-file +lisp-program-header+
 740             #-(or :win32 :mingw32 :darwin) (if (eq :fasl target) nil submodules)
 741             #+(or :win32 :mingw32 :darwin) submodules)
 742     (cond (shared-data-file
 743            (data-init shared-data-file)
 744            (format c-file "
 745 #define VM ~A
 746 #ifdef ECL_DYNAMIC_VV
 747 static cl_object *VV;
 748 #else
 749 static cl_object VV[VM];
 750 #endif
 751 #define ECL_SHARED_DATA_FILE 1
 752 " (data-permanent-storage-size))
 753            (data-dump c-file))
 754           (t
 755            (format c-file "
 756 #define compiler_data_text NULL
 757 #define compiler_data_text_size 0
 758 #define VV NULL
 759 #define VM 0" c-file)))
 760     (ecase target
 761       (:program
 762        (when (or (symbolp output-name) (stringp output-name))
 763          (setf output-name (compile-file-pathname output-name :type :program)))
 764        (unless init-name
 765          (setf init-name (init-function-name (pathname-name output-name) nil)))
 766        (format c-file +lisp-program-init+ init-name "" shared-data-file
 767                submodules "")
 768        (format c-file #+:win32 (ecase system (:console +lisp-program-main+)
 769                                              (:windows +lisp-program-winmain+))
 770                       #-:win32 +lisp-program-main+
 771                       prologue-code init-name epilogue-code)
 772        (close c-file)
 773        (compiler-cc c-name o-name)
 774        (apply #'linker-cc output-name (namestring o-name) ld-flags))
 775       ((:library :static-library :lib)
 776        (when (or (symbolp output-name) (stringp output-name))
 777          (setf output-name (compile-file-pathname output-name :type :lib)))
 778        (unless init-name
 779          ;; Remove the leading "lib"
 780          (setf init-name (subseq (pathname-name output-name) (length +static-library-prefix+)))
 781          (setf init-name (init-function-name init-name "system")))
 782        (format c-file +lisp-program-init+ init-name prologue-code
 783                shared-data-file submodules epilogue-code)
 784        (close c-file)
 785        (compiler-cc c-name o-name)
 786        #-msvc
 787        (progn
 788        (safe-system (format nil "ar cr ~A ~A ~{~A ~}"
 789                             output-name o-name ld-flags))
 790        (safe-system (format nil "ranlib ~A" output-name)))
 791        #+msvc
 792        (unwind-protect
 793          (progn
 794            (with-open-file (f "static_lib.tmp" :direction :output :if-does-not-exist :create :if-exists :supersede)
 795              (format f "/DEBUGTYPE:CV /OUT:~A ~A ~{~&\"~A\"~}"
 796                      output-name o-name ld-flags))
 797            (safe-system "link -lib @static_lib.tmp"))
 798          (when (probe-file "static_lib.tmp")
 799            (cmp-delete-file "static_lib.tmp")))
 800        )
 801       #+dlopen
 802       ((:shared-library :dll)
 803        (when (or (symbolp output-name) (stringp output-name))
 804          (setf output-name (compile-file-pathname output-name :type :dll)))
 805        (unless init-name
 806          ;; Remove the leading "lib"
 807          (setf init-name (subseq (pathname-name output-name)
 808                                  (length +static-library-prefix+)))
 809          (setf init-name (init-function-name init-name nil)))
 810        (format c-file +lisp-program-init+ init-name prologue-code
 811                shared-data-file submodules epilogue-code)
 812        (close c-file)
 813        (compiler-cc c-name o-name)
 814        (apply #'shared-cc output-name o-name ld-flags))
 815       #+dlopen
 816       (:fasl
 817        (when (or (symbolp output-name) (stringp output-name))
 818          (setf output-name (compile-file-pathname output-name :type :fasl)))
 819        (unless init-name
 820          (setf init-name (init-function-name "CODE" nil)))
 821        #-(or :win32 :mingw32 :darwin)
 822        (setf submodules
 823              (mapcar #'(lambda (sm)
 824                          (format nil "((ecl_init_function_t) ecl_library_symbol(Cblock, \"~A\", 0))" sm))
 825                      submodules))
 826        (format c-file +lisp-program-init+ init-name prologue-code shared-data-file
 827                submodules epilogue-code)
 828        (close c-file)
 829        (compiler-cc c-name o-name)
 830        (apply #'bundle-cc output-name o-name ld-flags)))
 831     (cmp-delete-file tmp-name)
 832     (cmp-delete-file c-name)
 833     (cmp-delete-file o-name)
 834     output-name))
 835 );END OF ECL PATCH
 836
 837 #+ecl
 838 (defun build-and-dump (dump load system restart init quit)
 839   (setf *compile-verbose* *verbose*
 840         c::*suppress-compiler-warnings* (not *verbose*)
 841         c::*suppress-compiler-notes* (not *verbose*))
 842   (let* ((library-type :library) ; :library :shared-library
 843          (program-type :program) ; :program :fasl
 844          (cl-launch-objects
 845           (let ((*features* (remove :cl-launch *features*))
 846                 (header (or *compile-file-pathname* *load-pathname* (getenv "CL_LAUNCH_HEADER"))))
 847             (list
 848              (compile-and-load-file header :verbose *verbose* :load nil :system-p t))))
 849          (file-objects
 850           (when load
 851             (list
 852              (labels ((x (file)
 853                         (compile-and-load-file file :verbose *verbose* :system-p t :load t))
 854                       (xwt (s)
 855                         (error "dumping image from a stream is unsupported")
 856                         ;; should be dumping the stream to a temporary file then compiling
 857                         ))
 858                (cond
 859                  ((eq load t) (xwt *standard-input*))
 860                  ((streamp load) (xwt load))
 861                  ((eq load :self) (x *cl-launch-file*))
 862                  (t (x load)))))))
 863          (system-objects
 864           (when system
 865             (let* ((target (find-system system))
 866                    (build (make-instance 'asdf:build-op :type library-type))
 867                    (sysdep ()))
 868               (loop for (op . component) in (asdf::traverse build target)
 869                     when (typep component 'asdf:system)
 870                     do (pushnew component sysdep)
 871                     finally (setf sysdep (nreverse sysdep)))
 872               (loop for system in sysdep
 873                     nconc (asdf:output-files build system)
 874                     do (asdf:oos 'asdf:compile-op system)
 875                     do (asdf:oos 'asdf:build-op system :type library-type)))))
 876          (executable (getenv "CL_LAUNCH_EXECUTABLE"))
 877          (init-code
 878           `(setf
 879             *load-verbose* nil
 880             *dumped* ,(if executable :executable t)
 881             ,@(when executable
 882                 '(*arguments* (command-line-arguments)))
 883             ,@(when restart
 884                     `(*restart* ,(read-function restart)))
 885             ,@(when init
 886                     `(*init-forms* ,init))
 887             ,@(unless quit
 888                       `(*quit* nil))))
 889          (epilogue-code
 890           (ecase program-type
 891             (:fasl init-code)
 892             (:program `(progn ,init-code (resume)))))
 893          (fasl
 894           (builder program-type (parse-namestring dump)
 895                    :lisp-files
 896                    (append cl-launch-objects file-objects system-objects)
 897                    :epilogue-code epilogue-code)))
 898   (quit)))
 899
 900 ;;;; Find a unique directory name for current implementation for the fasl cache
 901 ;;; (modified from SLIME's swank-loader.lisp)
 902
 903 (defparameter *implementation-features*
 904   '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp
 905     :armedbear :gcl :ecl :scl))
 906
 907 (defparameter *os-features*
 908   '(:macosx :linux :windows :mswindows :win32
 909     :solaris :darwin :sunos :hpux :unix))
 910
 911 (defparameter *architecture-features*
 912   '(:powerpc :ppc
 913     :x86-64 :amd64 :x86 :i686 :i586 :i486 :pc386 :iapx386
 914     :sparc64 :sparc :hppa64 :hppa))
 915
 916 (defun lisp-version-string ()
 917   #+cmu       (substitute-if #\_ (lambda (x) (find x " /"))
 918                              (lisp-implementation-version))
 919   #+scl       (lisp-implementation-version)
 920   #+sbcl      (lisp-implementation-version)
 921   #+ecl       (lisp-implementation-version)
 922   #+openmcl   (format nil "~d.~d.fasl~d"
 923                       ccl::*openmcl-major-version*
 924                       ccl::*openmcl-minor-version*
 925                       (logand ccl::fasl-version #xFF))
 926   #+lispworks (lisp-implementation-version)
 927   #+allegro   (format nil
 928                       "~A~A~A"
 929                       excl::*common-lisp-version-number*
 930                       (if (eq 'h 'H) "A" "M")     ; ANSI vs MoDeRn
 931                       (if (member :64bit *features*) "-64bit" ""))
 932   #+clisp     (let ((s (lisp-implementation-version)))
 933                 (subseq s 0 (position #\space s)))
 934   #+armedbear (lisp-implementation-version)
 935   #+cormanlisp (lisp-implementation-version)
 936   #+gcl       (let ((s (lisp-implementation-version))) (subseq s 4)))
 937
 938 (defun ensure-directory-name (dn)
 939    (if (eql #\/ (char dn (1- (length dn)))) dn
 940       (concatenate 'string dn "/")))
 941
 942 (defun dirname->pathname (dn)
 943   (parse-namestring (ensure-directory-name dn)))
 944
 945 (defun unique-directory-name (&optional warn)
 946   "Return a name that can be used as a directory name that is
 947 unique to a Lisp implementation, Lisp implementation version,
 948 operating system, and hardware architecture."
 949   (flet ((first-of (features)
 950            (find-if #'(lambda (f) (find f *features*)) features))
 951          (maybe-warn (value fstring &rest args)
 952            (cond (value)
 953                  (t (when warn (apply #'warn fstring args))
 954                     "unknown"))))
 955     (let ((lisp (maybe-warn (first-of *implementation-features*)
 956                             "No implementation feature found in ~a."
 957                             *implementation-features*))
 958           (os   (maybe-warn (first-of *os-features*)
 959                             "No os feature found in ~a." *os-features*))
 960           (arch (maybe-warn (first-of *architecture-features*)
 961                             "No architecture feature found in ~a."
 962                             *architecture-features*))
 963           (version (maybe-warn (lisp-version-string)
 964                                "Don't know how to get Lisp ~
 965                                 implementation version.")))
 966       (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
 967
 968 (defvar *implementation-name* (unique-directory-name *verbose*)
 969   "The name of the implementation, used to make a directory hierarchy for fasl files")
 970
 971 ;;;; Redefine the ASDF output-files method to put fasl's under the fasl cache.
 972 ;;; (taken from common-lisp-controller's post-sysdef-install.lisp)
 973
 974 ;;#-common-lisp-controller (progn ; BEGIN of progn to disable caching when clc is detected
 975
 976 (defparameter *wild-path*
 977    (make-pathname :directory '(:relative :wild-inferiors)
 978                   :name :wild :type :wild :version nil))
 979
 980 (defun wilden (path)
 981    (merge-pathnames *wild-path* path))
 982
 983 #-asdf
 984 (defun resolve-symlinks (x)
 985   #+allegro (excl:pathname-resolve-symbolic-links x)
 986   #+gcl-pre2.7 (truename (merge-pathnames x *default-pathname-defaults*))
 987   #-(or allegro gcl-pre2.7)
 988   (truename x))
 989
 990 (defvar *output-pathname-translations* nil
 991   "a list of pathname translations, where every translation is a list
 992 of a source pathname and destination pathname.")
 993
 994 (defun exclude-from-cache (&rest dirs)
 995   (dolist (dir dirs)
 996     (when dir
 997       (let* ((p (if (pathnamep dir) dir (dirname->pathname dir)))
 998              (n #+asdf (resolve-symlinks p) #-asdf p)
 999              (w (wilden n)))
1000         (pushnew (list w w)
1001                  cl-launch::*output-pathname-translations*
1002                  :test #'equal)))))
1003
1004 (defun calculate-output-pathname-translations ()
1005   (setf *output-pathname-translations*
1006         `(#+(and common-lisp-controller (not gcl))
1007           ,@(progn
1008               #-gcl-pre2.7 (ensure-directories-exist (calculate-fasl-root))
1009               (let* ((sr (resolve-symlinks *source-root*))
1010                      (fr (resolve-symlinks *fasl-root*))
1011                      (sp (wilden sr))
1012                      (fp (wilden fr)))
1013                 `((,sp ,fp)
1014                   (,fp ,fp)
1015                   ,@(when *redirect-fasl-files-to-cache*
1016                       `((,(wilden "/")
1017                           ,(wilden (merge-pathnames
1018                                     (make-pathname :directory '(:relative "local")) fr))))))))
1019           #-(and common-lisp-controller (not gcl))
1020           ,@(when (and *lisp-fasl-root* (not (eq *lisp-fasl-root* :disabled)))
1021               `((,(wilden "/") ,(wilden *lisp-fasl-root*))))))
1022
1023   ;; Do not recompile in private cache system-installed sources
1024   ;; that already have their accompanying precompiled fasls.
1025   #+(or clisp sbcl cmucl gcl) ; no need for ECL: no source/fasl couples there.
1026   (exclude-from-cache
1027    #p"/usr/lib/"
1028    #+clisp ext:*lib-directory*
1029    #+gcl system::*lib-directory*
1030    #+ecl c::*ecl-library-directory*
1031    #+sbcl (getenv "SBCL_HOME")
1032    #+cmu (truename #p"library:")))
1033
1034
1035 (defun apply-pathname-translations
1036   (path &optional (translations *output-pathname-translations*))
1037 #+gcl-pre2.7 path ;;; gcl 2.6 lacks pathname-match-p, anyway
1038 #-gcl-pre2.7
1039   (loop
1040     for (source destination) in translations
1041     when (pathname-match-p path source)
1042     do (return (translate-pathname path source destination))
1043     finally (return path)))
1044
1045 #+asdf
1046 (handler-bind ((warning #'muffle-warning))
1047   (defmethod asdf:output-files :around ((op asdf:operation) (c asdf:component))
1048     "Method to rewrite output files to fasl-path"
1049     (let ((orig (call-next-method)))
1050        (mapcar #'apply-pathname-translations orig))))
1051
1052 ;; We provide cl-launch, no need to go looking for it further!
1053 #+asdf
1054 (unless (find-system :cl-launch nil)
1055   (asdf:defsystem :cl-launch
1056       #+gcl :pathname #+gcl "/dev/null"
1057       :depends-on () :serial t :components ()))
1058
1059 ;);;END of progn to disable caching when clc is detected
1060
1061 #|
1062 #+common-lisp-controller
1063 (defun beneath-clc-source-root? (pn)
1064   "Returns T if pn's directory below *source-root*"
1065   (when pn
1066     (let ((root-dir (pathname-directory (resolve-symlinks *source-root*)))
1067           (comp-dir (pathname-directory pn)))
1068       (and (>= (length comp-dir)
1069                (length root-dir))
1070            (equalp root-dir (subseq comp-dir 0 (length root-dir)))))))
1071 |#
1072
1073 (defun apply-output-pathname-translations (path)
1074 #|  #+common-lisp-controller
1075   (progn
1076     (if (beneath-clc-source-root? path)
1077       (source-root-path-to-fasl-path path)
1078       (alternative-root-path-to-fasl-path path)))
1079   #-common-lisp-controller |#
1080   (apply-pathname-translations path))
1081
1082 #+asdf
1083 (defun load-system (system &key verbose)
1084   (asdf:oos 'asdf:load-op system :verbose verbose))
1085
1086 #+asdf
1087 (defun load-systems (&rest systems)
1088   (dolist (s systems) (load-system s :verbose *verbose*)))
1089
1090 (defun file-newer-p (new-file old-file)
1091   "Returns true if NEW-FILE is strictly newer than OLD-FILE."
1092   (> (file-write-date new-file) (file-write-date old-file)))
1093
1094 (defun compile-file-pathname* (source &rest args)
1095   #-(or gcl ecl)
1096   (apply-output-pathname-translations
1097    (apply #'compile-file-pathname source args))
1098   #+(or gcl ecl) ;; ECL BUG: compile-file-pathname doesn't accept system-p
1099   (let* ((system-p (getf args :system-p))
1100          (args (loop for (x y . z) on args by #'cddr nconc
1101                      (unless (eq x :system-p)
1102                        (list x y))))
1103          (path (apply-output-pathname-translations
1104                 (apply #'compile-file-pathname source args))))
1105     (if system-p
1106         (make-pathname :type "o" :defaults path)
1107         path)))
1108
1109 #-(or cormanlisp)
1110 (defun compile-and-load-file (source &key force-recompile verbose (load t)
1111                                      #+(or ecl gcl) system-p)
1112   "compiles and load specified SOURCE file, if either required by keyword
1113 argument FORCE-RECOMPILE, or not yet existing, or not up-to-date.
1114 Keyword argument VERBOSE specifies whether to be verbose.
1115 Returns two values: the fasl path, and T if the file was (re)compiled"
1116   (let* ((truesource (truename source))
1117          (fasl
1118           (compile-file-pathname* truesource
1119                                   #+(or ecl gcl) :system-p #+(or ecl gcl) system-p))
1120          (compiled-p
1121           (when (or force-recompile
1122                     (not (probe-file fasl))
1123                     (not (file-newer-p fasl source)))
1124             ;; When in doubt, don't trust and recompile, even though there are cases
1125             ;; when on the first time of compiling a simple auto-generated file
1126             ;; (e.g. from the automated test suite), the fasl ends up being written
1127             ;; to disk within the same second as the source was produced, which cannot
1128             ;; be distinguished from the reverse case where the source code was produced
1129             ;; in the same split second as the previous version was done compiling.
1130             ;; Could be tricky if a big system needs be recompiled as a dependency on
1131             ;; an automatically generated file, but for cl-launch those dependencies are
1132             ;; not detected anyway (BAD). If/when they are, and lacking better timestamps
1133             ;; than the filesystem provides, you should sleep after you generate your source code.
1134             #-gcl-pre2.7 (ensure-directories-exist fasl)
1135             (multiple-value-bind (path warnings failures)
1136                 (compile-file truesource
1137                               :output-file fasl
1138                               #+ecl :system-p #+ecl system-p
1139                               #-gcl-pre2.7 :print #-gcl-pre2.7 verbose
1140                               #-gcl-pre2.7 :verbose #-gcl-pre2.7 verbose)
1141               (declare (ignore warnings))
1142               (unless (equal (truename fasl) (truename path))
1143                 (error "CL-Launch: file compiled to ~A, expected ~A" path fasl))
1144               (when failures
1145                 (error "CL-Launch: failures while compiling ~A" source)))
1146             t)))
1147     (when load
1148       (load #-(and ecl (not dlopen)) fasl
1149             #+(and ecl (not dlopen)) (if system-p source fasl)
1150             :verbose verbose))
1151     (values fasl compiled-p)))
1152
1153 #+(or cormanlisp)
1154 (defun compile-and-load-file (source &key force-recompile verbose load)
1155   "Corman Lisp has trouble with compiled files (says SLIME)."
1156   (declare (ignore force-recompile))
1157   (when load
1158     (load source :verbose verbose))
1159   (force-output)
1160   (values nil t))
1161
1162 (defun load-file (source)
1163   #-(or gcl-pre2.7 (and ecl (not dlopen)))
1164   (compile-and-load-file source :verbose *verbose*)
1165   #+gcl-pre2.7
1166   (let* ((pn (parse-namestring source))) ; when compiling, gcl 2.6 will always
1167     (if (pathname-type pn) ; add a type .lsp if type is missing, so avoid compilation
1168       (compile-and-load-file source :verbose *verbose*)
1169       (load source :verbose *verbose*)))
1170   #+(and ecl (not dlopen))
1171   (load source :verbose *verbose*)))
1172 ;;;;; Return to the default package.
1173 (in-package :cl-user)
1174
1175 ;;; END OF CL-LAUNCH LISP HEADER
1176
1177
1178 ;;;; CL-LAUNCH LISP INITIALIZATION CODE
1179
1180 #-cl-launched
1181 (cl-launch::run :load :self)
1182
1183 ;;;; END OF CL-LAUNCH LISP INITIALIZATION CODE
1184
1185
1186 ;;; 65bcc57c2179aad145614ec328ce5ba8 SOFTWARE WRAPPED BY CL-LAUNCH BEGINS HERE:
1187 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
1188 ;;;
1189 ;;; texinfo-docstrings.lisp --- Front-end script.
1190 ;;;
1191 ;;; Copyright (C) 2007, Luis Oliveira  <loliveira@common-lisp.net>
1192 ;;;
1193 ;;; Permission is hereby granted, free of charge, to any person
1194 ;;; obtaining a copy of this software and associated documentation
1195 ;;; files (the "Software"), to deal in the Software without
1196 ;;; restriction, including without limitation the rights to use, copy,
1197 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
1198 ;;; of the Software, and to permit persons to whom the Software is
1199 ;;; furnished to do so, subject to the following conditions:
1200 ;;;
1201 ;;; The above copyright notice and this permission notice shall be
1202 ;;; included in all copies or substantial portions of the Software.
1203 ;;;
1204 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
1205 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
1206 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
1207 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
1208 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
1209 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
1210 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
1211 ;;; DEALINGS IN THE SOFTWARE.
1212
1213 (in-package #:cl-launch)
1214
1215 (defun print-help-and-quit ()
1216   (write-line "Usage: texinfo-docstrings [html|pdf|all] <system> <filename> <title> <css style> packages...")
1217   (quit 1))
1218
1219 (when (< (length *arguments*) 6)
1220   (write-line "Not enough arguments.")
1221   (print-help-and-quit))
1222
1223 (defparameter *output*
1224   (let ((arg1 (first *arguments*)))
1225     (cond
1226       ((string-equal arg1 "html") 'html)
1227       ((string-equal arg1 "pdf") 'pdf)
1228       ((string-equal arg1 "all") 'all)
1229       (t (print-help-and-quit)))))
1230
1231 (defparameter *system* (second *arguments*))
1232 (defparameter *filename* (third *arguments*))
1233 (defparameter *title* (fourth *arguments*))
1234 (defparameter *css-style* (fifth *arguments*))
1235 (defparameter *packages* (mapcar #'string-upcase (nthcdr 5 *arguments*)))
1236
1237 (load-system *system*)
1238
1239 (eval-when (:compile-toplevel :load-toplevel :execute)
1240   (asdf:oos 'asdf:load-op :texinfo-docstrings))
1241
1242 (apply #'texinfo-docstrings:generate-includes "include/" *packages*)
1243
1244 (defparameter *sysdir*
1245   (namestring
1246    (make-pathname :directory
1247                   (pathname-directory
1248                    (asdf:system-definition-pathname
1249                     (asdf:find-system :texinfo-docstrings))))))
1250
1251 (defparameter *gendocs-template-dir*
1252   (or (getenv "GENDOCS_TEMPLATE_DIR") *sysdir*))
1253
1254 (when (string-equal *css-style* "default")
1255   (setq *css-style*
1256         (format nil "~Astyles/~A"
1257                 *sysdir*
1258                 (case *output*
1259                   (html "edi-style.css")
1260                   (t "style.css")))))
1261
1262 (let ((asdf::*verbose-out* *terminal-io*))
1263   (ecase *output*
1264     (html
1265      (asdf:run-shell-command "echo not yet"))
1266     (pdf
1267      (asdf:run-shell-command "echo not yet"))
1268     (all
1269      (asdf:run-shell-command
1270       "GENDOCS_TEMPLATE_DIR=~A sh ~Agendocs.sh --html \"--css-include=~A\" ~A \"~A\""
1271       *gendocs-template-dir* *sysdir* *css-style* *filename* *title*))))