;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;FILE:               driver.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;    A lisp driver similar to gcc.
;;;;    Right, that's silly.  But some non-lispers may be lured into
;;;;    lisp by it.
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;    2013-07-01 <PJB> Created.
;;;;    AGPL3
;;;;    Copyright Pascal J. Bourguignon 2013 - 2016
;;;;    This program is free software: you can redistribute it and/or modify
;;;;    it under the terms of the GNU Affero General Public License as published by
;;;;    the Free Software Foundation, either version 3 of the License, or
;;;;    (at your option) any later version.
;;;;    This program is distributed in the hope that it will be useful,
;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;;    GNU Affero General Public License for more details.
;;;;    You should have received a copy of the GNU Affero General Public License
;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf *readtable* (copy-readtable nil)))
  (:use "COMMON-LISP")
  (:export "COMPILE-FILES"



       plc -c -Iincludes_dir -o file.o file.lisp…

            Compiles the possibly multiple source files file.lisp into
            an object file.o.

            The directories specified with -I are searched by LOAD,
            REQUIRE, and ASDF.

            The object files generated by plc are not necessarily
            compatible with gcc or ld.

       plc -o libfile.a -static file.lisp|file.o …

       plc -o executable file.lisp|file.o …

            Loads the files specified (sources or object), link-edit
            them, and generate an executable.  In all those files,
            there should be a function named CL-USER::MAIN, which will
            be called when the executable is run, with as arguments
            all the command line arguments (as strings).

            The environment variables are accessible thru the accessor

            CL-USER::EXIT is a function taking 0 or 1 argument, a
            status code to be returned by the command.

        Compile or assemble the source files, but do not link.  The
           linking stage simply is not done.  The ultimate output is
           in the form of an object file for each source file.

    -o file

        Place output in file file.  This applies regardless to
        whatever sort of output is being produced, whether it be an
        executable file, an object file, an assembler file or
        preprocessed C code.

        If -o is not specified, the default is to put an executable
        file in a.out, the object file for source.suffix in source.o.


        Print (on standard error output) the commands executed to run
        the stages of compilation.  Also print the version number of
        the compiler driver program and of the preprocessor and the
        compiler proper.

    -version, --version

        Display the version number and copyrights of the invoked plc.


        Ensures that strict Ansi Common Lisp is used.  This is the default.


        Do not enfore strict Ansi Common Lisp.


        Produce debugging information.
        You can use -g with -O, but this may give strange results.

speed space debug safety

    -O, -O0, -O1, -O2, -O3

        Optimize. -O is equivalent to -O1

no -Os    ==> (space 0)
   -Os    ==> (space 3) (speed 2)
   -O#    ==> (speed #)
no -Ofast ==> (safety 3)
   -Ofast ==> (safety 0)
   -g     ==> (debug 3)
no -g     ==> (debug 0)

   -fsingle-precision-constant ==> (setf *read-default-float-format* 'single-float)
no -fsingle-precision-constant ==> (setf *read-default-float-format* 'double-float)

-Dname             ==> (push :name *features*)
-Dname=definition  ==> (define-symbol-macro cl-user::name definition) (-D-register 'cl-user::name 'definition)
-Uname             ==> (setf *features* (remove :name *features*)) (-D-unregister 'cl-user::name) (unintern 'cl-user::name)

-Idir, -I dir

    Add the directory dir to the list of directories to be searched for
    lisp files.  Directories named by -I are searched before the
    standard system include directories.

-dM Dumps *features*
-dD Prints the -Dname=definition definitions. (-D-definitions)

-Ldir, -L dir

    Add directory dir to the list of directories to be searched for -l.

-llibrary, -l library

   library names a lisp library, created with lpc -static, which will
   be loaded before compiling or linking the program.


    produces a library containing the compiled code of all the input
    source files.

    library is the name of an asdf or quicklisp system, which is
    loaded before compiling.


    Specifies what implementation to use. It is the name of a Common
    Lisp implementation executable, or its full path. Examples:
     -Bclisp -B/opt/local/bin/sbcl


    Specifies the quicklisp directory.


    Print the name of the configured installation directory and a list
    of program and library directories plc will search---and don't do
    anything else.


    Print the target sysroot directory that will be used during
    compilation.  This is the target sysroot specified either at
    configure time or using the --sysroot option.  If no target
    sysroot is specified, the default is ~/quicklisp/.


    Print the compiler's target machine (for example,
    i686-pc-linux-gnu)---and don't do anything else.


    Print the compiler version (for example, 3.0)---and don't do
    anything else.

-A predicate=answer

    Evaluates: (assert (equal predicate answer))


(in-package "COMMON-LISP-USER")

(setf #+clisp ext:*load-echo* #+clisp *verbose*
      *load-verbose*          *verbose*
      *compile-verbose*       *verbose*)

(when *ansi*
  (dolist (used-package (package-use-list "COMMON-LISP-USER"))
    (unless (eq (package-name used-package  (find-package "COMMON-LISP")))
      (unuse-package package "COMMON-LISP-USER"))))

(in-package "COMMON-LISP-USER")

  (:use "COMMON-LISP")
  (:export "*VERBOSE*" "*DEBUG*"


           ;; I/O

           ;; Options
           "PARSE-OPTIONS" "MAIN"

           ;; Utilities:
           "CONCAT" "MAPCONCAT"


           ;; Exit codes:



(defvar *default-program-name* "untitled")

(defun program-path ()
  (let* ((argv  (ext:argv))
         (largv (length argv))
         (args  ext:*args*)
         (largs (length args))
         (index (- largv largs 1))
         (path  (and (<= 0 index largv) (elt argv index))))
      ((and *load-truename*
            (string/= (file-namestring *load-truename*) "script.lisp"))
       (namestring *load-truename*))

(defvar *program-path* (program-path)
  "A namestring of the path to the program.
This may be a relative pathname, when it's obtained from argv[0].
If available we use the actual program name (from (EXT:ARGV) or
*LOAD-TRUENAME*), otherwise we fallback to *DEFAULT-PROGRAM-NAME*.")

(defvar *program-name* (file-namestring *program-path*)
  "Name of the program.")

(defvar *arguments* ext:*args*
  "A list of command line arguments (strings).")

(defvar *verbose* nil
  "Adds some trace output.")

(defvar *debug* nil
  "Errors break into the debugger.")

#-(or use-ppcre use-regexp) (push #-(and) :use-ppcre
                                  #+(and) :use-regexp



(defun relauch-with-kfull-linkset-if-needed (thunk)
  ;; If the version of clisp requires -Kfull to have linux, then let's call it with -Kfull…
  (multiple-value-bind (res err) (ignore-errors (funcall thunk))
    (when err
      (if (find "-Kfull" (ext:argv) :test (function string=))
        (error err)
         (or  (ext:run-program "/usr/bin/clisp"
                :arguments (append '("-ansi" "-q" "-E" "utf-8" "-Kfull")
                                   (cons *program-path* *arguments*))
                :wait t
                #+linux :may-exec  #+linux t
                #+win32 :indirectp #+win32 nil)

#-linux (when (find "linux" *modules* :test (function string=))
          (push :linux *features*))

#-(or linux macos win32 #|what else is not linux?|#)
(relauch-with-kfull-linkset-if-needed (lambda () (require "linux")))

(defmacro redirecting-stdout-to-stderr (&body body)
  (let ((verror  (gensym))
        (voutput (gensym)))
   `(let* ((,verror  nil)
           (,voutput (with-output-to-string (stream)
                       (let ((*standard-output* stream)
                             (*error-output*    stream)
                             (*trace-output*    stream))
                         (handler-case (progn ,@body)
                           (error (err) (setf ,verror err)))))))
      (when ,verror
        (terpri *error-output*)
        (princ ,voutput *error-output*)
        (terpri *error-output*)
        (princ ,verror *error-output*)
        (terpri *error-output*)
        (terpri *error-output*)
        #-testing-script (exit ex-software)))))

(defun getpid ()
  (or (ignore-errors (find-symbol "getpid"     "LINUX"))
      (ignore-errors (find-symbol "PROCESS-ID" "OS"))
      (ignore-errors (find-symbol "PROCESS-ID" "SYSTEM"))))

(defun report-the-error (err string-stream)
  (let ((log-path (format nil "/tmp/~A.~D.errors" *program-name*
                          (let ((getpid (getpid)))
                            (if getpid
                                (funcall getpid)
    (with-open-file (log-stream log-path
                                :direction :output
                                :if-exists :supersede
                                :if-does-not-exist :create)
      (format log-stream "~A GOT AN ERROR: ~A~%~80,,,'-<~>~%~A~%"
              *program-name* err (get-output-stream-string string-stream)))
    (format *error-output* "~A: ~A~%  See ~A~%" *program-name* err log-path)
    (finish-output *error-output*)
    (exit ex-software)))

(defmacro without-output (&body body)
  `(prog1 (values)
     (with-output-to-string (net)
           (let ((*standard-output* net)
                 (*error-output*    net)
                 (*trace-output*    net))
         (error (err) (report-the-error err net))))))

(defmacro with-pager ((&key lines) &body body)
Executes the BODY, redirecting *STANDARD-OUTPUT* to a pager.

If no option is given, use the system pager obtained from the
environment variable PAGER.  If none is defined, then no pager is

The following is NOT IMPLEMENTED YET:

If an option is given, then it defines a local pager.

LINES     Number of line to output in a single chunk.
          After this number of line has been written,
          some user input is required to further display lines.
  (when lines
    (error "~S: Sorry :LINES is not implemented yet." 'with-pager))
  ;; (print (list (version:clisp-version)
  ;;              (version:rt-version<= "2.48" (version:clisp-version))))
  #+#.(version:rt-version<= "2.44" (version:clisp-version))
  `(progn ,@body)
  #-#.(version:rt-version<= "2.44" (version:clisp-version))
  (let ((pager (ext:getenv "PAGER")))
    (if pager
        (let ((pager-stream (gensym)))
          `(let ((,pager-stream (ext:make-pipe-output-stream
                                 :external-format charset:utf-8
                                 :buffered nil)
                   ;; (ext:run-program ,pager
                   ;;                  :input :stream
                   ;;                  :output :terminal
                   ;;                  :wait nil)
                  (let ((*standard-output* ,pager-stream))
               (close ,pager-stream))))
        `(progn ,@body))))


(defun shell-quote-argument (argument)
  "Quote ARGUMENT for passing as argument to an inferior shell."
  #+(or MSWINDOWS WIN32)
  ;; Quote using double quotes, but escape any existing quotes in
  ;; the argument with backslashes.
  (let ((result "")
        (start 0)
    (when (or (null (setf match-end (position #\" argument)))
              (< match-end (length argument)))
         :while (setf match-beginning (position #\" argument :start start))
         :do (setf end (1+ match-beginning)
                   result (concatenate 'string result (subseq argument start end)
                                       "\\" (subseq argument end (1+ end)))
                   start (1+ end))))
    (concatenate 'string "\"" result (subseq argument start) "\""))
  #-(or MSWINDOWS WIN32)
  (if (equal argument "")
      ;; Quote everything except POSIX filename characters.
      ;; This should be safe enough even for really weird shells.
      (let ((result "")
            (start 0)
           :while (setf match-end (position-if-not (lambda (ch) (or (alphanumericp ch) (position ch "-_./")))  argument :start start))
           :do (setf end match-end
                     result (concatenate 'string result (subseq argument start end)
                                         "\\" (subseq argument end (1+ end)))
                     start (1+ end)))
        (concatenate 'string result (subseq argument start)))))

(defun shell   (command)
  (ext:shell command))

(defun execute (&rest command)
RETURN:     The status returned by the command.
  (ext:run-program (car command)
    :arguments (cdr command)
    :input :terminal :output :terminal))

(defun copy-file (file newname &optional ok-if-already-exists keep-time)
IMPLEMENTATION: The optional argument is not implemented.

Copy FILE to NEWNAME.  Both args must be strings.
If NEWNAME names a directory, copy FILE there.
Signals a `file-already-exists' error if file NEWNAME already exists,
unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
A number as third arg means request confirmation if NEWNAME already exists.
This is what happens in interactive use with M-x.
Fourth arg KEEP-TIME non-nil means give the new file the same
last-modified time as the old one.  (This works on only some systems.)
A prefix arg makes KEEP-TIME non-nil.
  (declare (ignore ok-if-already-exists keep-time))
  (execute "cp" (shell-quote-argument file)  (shell-quote-argument newname)))

#+linux ;; Should probably move away.
(defun make-symbolic-link (filename linkname &optional ok-if-already-exists)
IMPLEMENTATION: The optional argument is not implemented.

Make a symbolic link to FILENAME, named LINKNAME.  Both args strings.
Signals a `file-already-exists' error if a file LINKNAME already exists
unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
A number as third arg means request confirmation if LINKNAME already exists.
  (declare (ignore ok-if-already-exists))
  (/= 0 (linux:|symlink| filename linkname)))

#+linux ;; Should probably move away.
(defun make-directory (*path* &optional (parents nil))
Create the directory *PATH* and any optionally nonexistent parents dirs.
The second (optional) argument PARENTS says whether
to create parents directories if they don't exist.
  (if parents
      (ensure-directories-exist (concatenate 'string *path* "/.") :verbose nil)
      (linux:|mkdir| *path*  511 #| #o777 |# ))
  (ext:probe-directory (if (char= (char *path* (1- (length *path*)))
                                  (character "/"))
                           *path* (concatenate 'string *path* "/"))))


(defun perror (format-string &rest args)
DO:     Writes a message on the error output in the name of the script.
  (format *error-output* "~&~A: ~?" *program-name*  format-string args)
  (finish-output *error-output*))

(defun pmessage (format-string &rest args)
DO:     Writes a message on the standard output in the name of the script.
  (format *standard-output* "~&~A: ~?" *program-name* format-string args)
  (finish-output *standard-output*))

(defun pquery (format-string &rest args)
DO:     Writes a message on the query I/O in the name of the script, and
        read a response line.
RETURN: A string containing the response line.
  (format *query-io* "~&~A: ~?" *program-name* format-string args)
  (finish-output *query-io*)
  (read-line *query-io*))

;;; From /usr/include/sysexits.h (Linux)

(defconstant ex-ok            0   "successful termination")

(defconstant ex--base         64  "base value for error messages")

(defconstant ex-usage         64  "command line usage error
    The command was used incorrectly, e.g., with
    the wrong number of arguments, a bad flag, a bad
    syntax in a parameter, or whatever.") ;;EX-USAGE

(defconstant ex-dataerr       65  "data format error
    The input data was incorrect in some way.
    This should only be used for user's data & not
    system files.") ;;EX-DATAERR

(defconstant ex-noinput       66  "cannot open input
    An input file (not a system file) did not
    exist or was not readable.  This could also include
    errors like \"No message\" to a mailer (if it cared
    to catch it).") ;;EX-NOINPUT

(defconstant ex-nouser        67  "addressee unknown
    The user specified did not exist.  This might
    be used for mail addresses or remote logins.
    ") ;;EX-NOUSER

(defconstant ex-nohost        68  "host name unknown
    The host specified did not exist.  This is used
    in mail addresses or network requests.") ;;EX-NOHOST

(defconstant ex-unavailable   69  "service unavailable
    A service is unavailable.  This can occur
    if a support program or file does not exist.  This
    can also be used as a catchall message when something
    you wanted to do doesn't work, but you don't know
    why.") ;;EX-UNAVAILABLE

(defconstant ex-software      70  "internal software error
    An internal software error has been detected.
    This should be limited to non-operating system related
    errors as possible.") ;;EX-SOFTWARE

(defconstant ex-oserr         71  "system error (e.g., can't fork)
    An operating system error has been detected.
    This is intended to be used for such things as \"cannot
    fork\", \"cannot create pipe\", or the like.  It includes
    things like getuid returning a user that does not
    exist in the passwd file.") ;;EX-OSERR

(defconstant ex-osfile        72  "critical OS file missing
    Some system file (e.g., /etc/passwd, /etc/utmp,
    etc.) does not exist, cannot be opened, or has some
    sort of error (e.g., syntax error).") ;;EX-OSFILE

(defconstant ex-cantcreat     73  "can't create (user) output file
    A (user specified) output file cannot be created.") ;;EX-CANTCREAT

(defconstant ex-ioerr         74  "input/output error
     An error occurred while doing I/O on some file.") ;;EX-IOERR

(defconstant ex-tempfail      75  "temp failure; user is invited to retry
    temporary failure, indicating something that
    is not really an error.  In sendmail, this means
    that a mailer (e.g.) could not create a connection,
    and the request should be reattempted later.") ;;EX-TEMPFAIL

(defconstant ex-protocol      76  "remote error in protocol
    the remote system returned something that
    was \"not possible\" during a protocol exchange.") ;;EX-PROTOCOL

(defconstant ex-noperm        77  "permission denied
    You did not have sufficient permission to
    perform the operation.  This is not intended for
    file system problems, which should use NOINPUT or
    CANTCREAT, but rather for higher level permissions.") ;;EX-NOPERM

(defconstant ex-config        78  "configuration error")

(defconstant ex--max          78  "maximum listed value")

(defun exit (&optional (code ex-ok))
  (ext:exit code))


(defparameter *options*
  (make-hash-table :test (function equal))
  "The dictionary of options.")

(defstruct option
  keys arguments documentation function)

(defun split-string (string &optional (separators " "))
NOTE:   current implementation only accepts as separators
        a string containing literal characters.
  (unless (simple-string-p string)     (setq string     (copy-seq string)))
  (unless (simple-string-p separators) (setq separators (copy-seq separators)))
  (let ((chunks  '())
        (position 0)
        (nextpos  0)
        (strlen   (length string)) )
    (declare (type simple-string string separators))
    (loop :while (< position strlen) :do
      (loop :while (and (< nextpos strlen) (not (position (char string nextpos) separators))) :do
        (setq nextpos (1+ nextpos)))
      (push (subseq string position nextpos) chunks)
      (setf position (1+ nextpos)
            nextpos  position))
    (nreverse chunks)))

(defun q&d-parse-parameters (parameters)
  "Parses (mandatory &optional optionals... &rest rest &key key...)"
     :with mandatories = '()
     :with optionals   = '()
     :with rest        = nil
     :with keys        = '()
     :with state       = :mandatory
     :with params      = parameters
     :for param = (first params)
     :while params
     :do (ecase state
            (case param
              ((&optional) (setf state :optional))
              ((&rest)     (setf state :rest))
              ((&key)      (setf state :key))
              (otherwise (push param mandatories)))
            (pop params))
            (case param
              ((&optional) (error "&OPTIONAL given more than once in ~S" parameters))
              ((&rest)     (setf state :rest))
              ((&key)      (setf state :key))
              (otherwise (push param optionals)))
            (pop params))
            (case param
              ((&optional) (error "&OPTIONAL given after &REST in ~S" parameters))
              ((&rest)     (error "&REST given twice in ~S" parameters))
              ((&key)      (setf state :key))
              (otherwise   (setf state :after-rest
                                 rest param)))
            (pop params))
            (case param
              ((&optional) (error "&OPTIONAL given after &REST in ~S" parameters))
              ((&rest)     (error "&REST given after &REST in ~S" parameters))
              ((&key)      (setf state :key))
              (otherwise   (error "Several &REST parameters given in ~S" parameters)))
            (pop params))
            (case param
              ((&optional) (error "&OPTIONAL given after &KEY in ~S" parameters))
              ((&rest)     (error "&REST given after &KEY in ~S" parameters))
              ((&key)      (setf state :key))
              (otherwise   (push param keys)))
            (pop params)))
     :finally (return (values (nreverse mandatories)
                              (nreverse optionals)
                              (nreverse keys)))))

(defun keywordize (string-designator)
  (intern (string string-designator) (load-time-value (find-package "KEYWORD"))))

(defun q&d-arguments (mandatories optionals rest keys)
BUG: when the optionals or keys have a present indicator,
     we just ignore it and build a list that will pass
     the default value anyways...
  (assert (every (function symbolp) mandatories))
  (append mandatories
          (mapcar (lambda (opt)
                    (etypecase opt
                      (cons   (first opt))
                      (symbol opt)))
          (when rest (list rest))
          (mapcan (lambda (key)
                    (etypecase key
                      (cons  (etypecase (first key)
                               (symbol (list (keywordize (first key)) (first key)))
                               (cons   (list (second (first key)) (first (first key))))))
                      (symbol (list (keywordize key) key))))

(defun wrap-option-function (keys option-arguments docstring option-function)
  (let ((vargs (gensym)))
    (multiple-value-bind (mandatories optionals rest keys-args) (q&d-parse-parameters option-arguments)
      (setf *print-circle* nil)
       :keys keys
       :arguments option-arguments
       :function (compile (make-symbol (format nil "~:@(~A-WRAPPER~)" (first keys)))
                          `(lambda (option-key ,vargs)
                             (let ((nargs (length ,vargs)))
                               (if (<= ,(length mandatories) nargs)
                                      `(destructuring-bind ,option-arguments ,vargs
                                         (funcall ',option-function ,@(q&d-arguments mandatories
                                      (error "An option cannot have &key parameters without a &rest parameter. ~@
                                              Invalid option parameters: ~S" option-arguments))
                                      (let ((vremaining (gensym)))
                                        `(destructuring-bind (,@option-arguments &rest ,vremaining) ,vargs
                                           (funcall ',option-function ,@(q&d-arguments mandatories
                                   (let ((missing-count (- ,(length mandatories) nargs))
                                         (missing-args  (subseq ',mandatories nargs)))
                                     (error "option ~A is missing ~:[an ~*~;~A ~]argument~:*~p: ~{~A ~}"
                                            (< 1 missing-count) missing-count
       :documentation (split-string docstring (string #\newline))))))

(defun call-option-function (option-key arguments &optional undefined-argument)
  (let* ((option (gethash option-key *options*)))
      (option             (funcall (option-function option) option-key arguments))
      (undefined-argument (funcall undefined-argument option-key arguments))
      (t                  (error "Unknown option ~A ; try: ~A help" option-key *program-name*)))))

(defmacro define-option (names parameters &body body)
DO:         Define a new option for the scirpt.
NAMES:      A list designator of option names (strings
            such as \"-a\" \"--always\").
PARAMETERS: A list of option parameters.  The names of
            these parameters must be descriptive as they
            are used to build the usage help text.
BODY:       The code implementing this option.
RETURN:     The lisp-name of the option (this is a symbol
            named for the first option name).
  (let* ((main-name   (if (listp names)
                          (first names)
         (other-names (if (listp names)
                          (rest names)
         (lisp-name   (intern (string-upcase main-name)))
         (docstring   (if (and (stringp (first body)) (rest body))
                          (first body)
         (body        (if (and (stringp (first body)) (rest body))
                          (rest body)
       (setf (gethash ',main-name *options*)
             (wrap-option-function ',(cons main-name other-names)
                                   (lambda ,(remove '&rest parameters)
                                     (block ,lisp-name
       ,@(mapcar (lambda (other-name)
                   `(setf (gethash ',other-name *options*) (gethash ',main-name *options*)))

(defvar *documentation-text* "")

(defun set-documentation-text (text)
  (setf *documentation-text* text))

(defun option-list ()
  (let ((options '()))
    (maphash (lambda (key option)
               (declare (ignore key))
               (pushnew option options))

(define-option ("help" "-h" "--help") ()
  "Give this help."
  (with-pager ()
      (let ((options (option-list)))
        (format t "~2%~A options:~2%" *program-name*)
        (dolist (option (sort options (function string<)
                              :key (lambda (option) (first (option-keys option)))))
          (format t "    ~{~A~^ | ~}  ~:@(~{~A ~}~)~%~@[~{~%        ~A~}~]~2%"
                  (option-keys option)
                  (option-arguments option)
                  (option-documentation option)))
        (format t "~A~%" *documentation-text*))))

;; TODO: See if we couldn't simplify it, perhaps with complete -C.

(defun list-all-option-keys ()
  (let ((keys '()))
    (dolist (option (option-list))
      (dolist (key (option-keys option))
        (push key keys)))

(defun completion-option-prefix (prefix)
  (dolist (key (remove-if-not (lambda (key)
                                (and (<= (length prefix) (length key))
                                     (string= prefix key :end2 (length prefix))))
    (format t "~A~%" key))

(defun completion-all-options ()
  (dolist (key (list-all-option-keys))
    (format t "~A~%" key))

(defvar *bash-completion-hook* nil
  "A function (lambda (index words) ...)
that will print the completion and return true, or do nothing and return nil.")

(define-option ("--bash-completions") (index &rest words)
  "Implement the auto-completion of arguments.
This option is designed to be invoked from the function generated by
the '--bash-completion-function' option.  There should be no need to
use directly.
  (let ((index (parse-integer index :junk-allowed t)))
    (unless (and *bash-completion-hook*
                 (funcall *bash-completion-hook* index words))
      (if index
          (completion-option-prefix (elt words index))
  (exit 0))

(define-option ("--bash-completion-function") ()
  "Write two bash commands (separated by a semi-colon) to create a
bash function used to do auto-completion of command arguments.
Use it with:

       eval $($COMMAND  --bash-completion-function)

and then typing TAB on the command line after the command name will
autocomplete argument prefixes.
  (format t "function completion_~A(){ ~
COMPREPLY=( $(~:*~A --bash-completions \"$COMP_CWORD\" \"${COMP_WORDS[@]}\") ) ; } ;~
complete -F completion_~:*~A ~:*~A~%"
  (exit 0))

(defun parse-options (arguments &optional default undefined-argument)
  (flet ((process-arguments ()
                 :while arguments
                 :do (setf arguments (call-option-function (pop arguments) arguments undefined-argument))))
              (funcall default)))))
    (if *debug*
        (handler-case (process-arguments)
          (error (err)
            (format *error-output* "~%ERROR: ~A~%" err)
            ;; TODO: select different sysexits codes depending on the error class.
            (return-from parse-options ex-software)))))


(defun not-implemented-here (function-name)
  (error "How to implement ~S in ~S"

(defun prepare-options (options)
  (mapcar (lambda (option)
            (typecase option
              (keyword (format nil "-~(~A~)" option))
              (symbol  (string-downcase option))
              (string  option)
              (t       (prin1-to-string option))))

(defun shell  (command &rest arguments)
  #+clisp (ext:shell (format nil command arguments))
  #-clisp (not-implemented-here 'shell))

(defun run-program (program arguments &key (input :terminal) (output :terminal)
                    (if-output-exists :error) (wait t))
RETURN:     The status returned by the command.
  #+clisp (ext:run-program program
                           :arguments arguments
                           :input input :output output
                           :if-output-exists if-output-exists
                           :wait wait)
  #-clisp (not-implemented-here 'run-program))

(defun uname (&rest options)
  "Without OPTIONS, return a keyword naming the system (:LINUX, :DARWIN, etc).
With options, returns the first line output by uname(1)."
  (with-open-stream (uname (run-program "uname" (prepare-options options)
                                        :input nil
                                        :output :stream
                                        :wait t))
    (values (if options
                (read-line uname)
                (intern (string-upcase (read-line uname))

;;;  Some emacs style functions.

(defun find-directories (rootpath)
  "Return a list of recursive subdirectories starting from ROOTPATH
that are accessible by the user."
  (directory (merge-pathnames (make-pathname :directory '(:relative :wild-inferiors)
                                             :name nil :type nil :version nil)
                              rootpath nil)))

(defun concat (&rest items)
  (with-output-to-string (*standard-output*)
    (dolist (item items)
      (typecase item
        (string   (write-string   item *standard-output*))
        (sequence (write-sequence item *standard-output*))
        (t        (with-standard-io-syntax (format *standard-output* "~A" item)))))))

(defun mapconcat (function sequence separator)
  (etypecase sequence
     (if sequence
         (let* ((items (mapcar (lambda (item)
                                 (let ((sitem (funcall function item)))
                                   (if (stringp sitem)
                                       (princ-to-string sitem))))
                (ssepa (if (stringp separator)
                           (princ-to-string separator)))
                (size (+ (reduce (function +) items :key (function length))
                         (* (length ssepa) (1- (length items)))))
                (result (make-array size :element-type 'character))
                (start  0))
           (replace result  (first items) :start1 start)
           (incf start (length (first items)))
           (dolist (item (rest items))
             (replace result ssepa :start1 start) (incf start (length ssepa))
             (replace result item  :start1 start) (incf start (length item)))
     (if (plusp (length sequence))
         (let* ((items (map 'vector (lambda (item)
                                      (let ((sitem (funcall function item)))
                                        (if (stringp sitem)
                                            (princ-to-string sitem))))
                (ssepa (if (stringp separator)
                           (princ-to-string separator)))
                (size (+ (reduce (function +) items :key (function length))
                         (* (length ssepa) (1- (length items)))))
                (result (make-array size :element-type 'character))
                (start  0))
           (replace result (aref items 0) :start1 start) (incf start (length (aref items 0)))
              :for i :from 1 :below (length items)
              :do (replace result ssepa :start1 start) (incf start (length ssepa))
              (replace result (aref items i) :start1 start) (incf start (length (aref items i))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;;
;; ;;; The main program, definition of the options
;; ;;;
;; (in-package "COMMON-LISP-USER")
;; (load (make-pathname :name "SCRIPT" :type "LISP" :version NIL :case :common
;;                      :defaults *load-pathname*))
;; (use-package "SCRIPT")
;; ;; (redirecting-stdout-to-stderr (load #p"/etc/gentoo-init.lisp"))
;; (redirecting-stdout-to-stderr
;;  (let ((*load-verbose* nil)
;;        (*compile-verbose* nil))
;;    (load (make-pathname :name ".clisprc" :type "lisp" :case :local
;;                         :defaults (user-homedir-pathname)))
;;    ;; (setf *features* (delete :testing-script *features*))
;;    ))
;; (redirecting-stdout-to-stderr (asdf:oos 'asdf:load-op :split-sequence)
;;                               (asdf:oos 'asdf:load-op :cl-ppcre))
;; ;; #-testing-script
;; (exit (main ext:*args*))

;;;; THE END ;;;;