;;;;; XCVB driver. Load it in your Lisp image and build with XCVB.

;;;; ----- Prelude -----

#+xcvb
(module

 (:description "XCVB Driver"

  :author ("Francois-Rene Rideau")

  :maintainer "Francois-Rene Rideau"
  :licence "MIT" ;; MIT-style license. See LICENSE

  :build-depends-on nil))

;; #.(setf *load-verbose* () *load-print* () *compile-verbose* () *compile-print* ()) ;; Hush!

(cl:in-package :cl-user)

(declaim (optimize (speed 2) (space 2) (safety 3) (debug 3) (compilation-speed 0))
         #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))

(defpackage :xcvb-driver

  (:nicknames :xcvbd :xd)

  (:use :cl)

  (:export

   ;;; special variables shared with XCVB itself
   #:*lisp-implementation-type*

   #:*lisp-executable-pathname* #:*lisp-image-pathname*

   #:*lisp-implementation-directory*

   #:*lisp-flags*  #:*lisp-allow-debugger*
   #:*use-base-image* #:*disable-cfasls*

   #:*features-defined* #:*features-undefined*
   #:*xcvb-verbosity*

   #:*cache* #:*object-cache* #:*workspace*

   #:*install-prefix* #:*install-program* #:*install-configuration*
   #:*install-data* #:*install-library* #:*install-image* #:*install-lisp*

   #:*temporary-directory*

   #:*source-registry*

   ;;; special variables for XCVB master itself

   #:*xcvb-program* #:*manifest*

   #:*required-xcvb-version*

   ;;; special variables for portability issues
   #:*default-element-type*

   ;;; String utilities - copied from fare-utils

   ;;#:string-prefix-p #:string-suffix-p #:string-enclosed-p

   ;; command-line arguments
   #:raw-command-line-arguments #:command-line-arguments #:*arguments* #:*dumped*
   

   ;;; I/O utilities

   #:with-output #:with-input-file #:with-safe-io-syntax #:with-temporary-file
   #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-forms
   #:slurp-file-string #:slurp-file-lines #:slurp-file-forms
   #:copy-stream-to-stream #:copy-stream-to-stream-line-by-line
   #:read-first-file-form #:read-function

   #:slurp-input-stream

   ;;; Escaping the command invocation madness

   #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
   #:escape-windows-token #:escape-windows-command
   #:escape-token #:escape-command

   ;;; run-program/foo

   #:run-program/

   #:subprocess-error
   #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process

   ;; Obsolete:

   #:run-program/process-output-stream

   #:run-program/read-output-lines #:run-program/read-output-string
   #:run-program/read-output-form #:run-program/read-output-forms
   #:run-program/for-side-effects #:run-program/echo-output

   ;; pathname utilities

   #:native-namestring #:parse-native-namestring

   ;; current directory

   #:getcwd #:chdir #:with-current-directory

   ;; Magic strings

   #:+xcvb-slave-greeting+ #:+xcvb-slave-farewell+

   ;;; Using an inferior XCVB

   #:build-and-load #:bnl #:build-in-slave

   ;;; Build-time variables

   #:*optimization-settings*

   #:*uninteresting-conditions* #:*uninteresting-load-conditions*
   #:*fatal-conditions* #:*deferred-warnings*

   #:*goal* #:*stderr* #:*debugging* #:*profiling*

   #:*post-image-restart* #:*entry-point*

   ;;; Environment support

   #:getenv #:emptyp #:getenvp #:setup-environment

   #:debugging #:with-profiling

   #:format! #:finish-outputs #:quit #:shell-boolean

   #:print-backtrace #:die #:bork #:with-coded-exit
   #:uninteresting-condition-p #:fatal-condition-p

   #:proclaim-optimization-settings

   #:with-controlled-compiler-conditions #:with-controlled-loader-conditions
   #:with-xcvb-compilation-unit

   #:find-symbol* #:call #:eval-string #:load-string #:load-stream

   ;; #:run #:do-run #:run-commands #:run-command ; used by XCVB, not end-users.

   #:resume #-ecl #:dump-image #+ecl #:create-bundle

   #:register-fullname #:register-fullnames #:load-fullname-mappings

   #:registered-fullname-pathname))

(in-package :xcvb-driver)

;;; Initial implementation-dependent setup

(eval-when (:compile-toplevel :load-toplevel :execute)

  (defvar *implementation-settings*
    `(;; These should ensure all tail calls are optimized, says jsnell:

      #+sbcl (sb-c::insert-debug-catch 0) ;; (sb-c::merge-tail-calls 3) is redundant and deprecated

      #+(or cmu scl) (ext:inhibit-warnings 3)))

  (defvar *optimization-settings*

    `((speed 2) (space 2) (safety 3) (debug 2) (compilation-speed 0)

      ,@*implementation-settings*))

  (proclaim `(optimize ,@*optimization-settings*))

  ;; otherwise ACL 5.0 may crap out on ASDF dependencies,
  ;; but even other implementations may have "fun" debugging.
  (setf *print-readably* nil)

  (defun featurep (x &optional (*features* *features*))
    (cond
      ((atom x) (and (member x *features*) t))
      ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
      ((eq :or (car x)) (some #'featurep (cdr x)))
      ((eq :and (car x)) (every #'featurep (cdr x)))
      (t (error "Malformed feature specification ~S" x))))
  (defun os-unix-p ()
    (featurep '(:or :unix :cygwin :darwin)))
  (defun os-windows-p ()
    (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32))))
  (defun detect-os ()
    (flet ((yes (yes) (pushnew yes *features*))
           (no (no) (setf *features* (remove no *features*))))
      (cond
        ((os-unix-p) (yes :os-unix) (no :os-windows))
        ((os-windows-p) (yes :os-windows) (no :os-unix))
        (t (error "Congratulations for trying XCVB on an operating system~%~
that is neither Unix, nor Windows.~%Now you port it.")))))
  (detect-os)

  #+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode) clozure
        lispworks (and sbcl sb-unicode) scl)

  (pushnew :xcvb-unicode *features*)

  #+gcl ;;; If using GCL, do some safety checks
  (flet ((bork (&rest args)

           (apply #'format *error-output* args)

           (lisp:quit 42)))
    (when (or (< system::*gcl-major-version* 2)
              (and (= system::*gcl-major-version* 2)
                   (< system::*gcl-minor-version* 7)))
      (bork "GCL version ~D.~D < 2.7 not supported"
             system::*gcl-major-version* system::*gcl-minor-version*))
    (unless (member :ansi-cl *features*)
      (bork "XCVB only supports GCL in ANSI mode. Aborting.~%"))
    (setf compiler::*compiler-default-type* (pathname "")
          compiler::*lsp-ext* ""))
  #+cmu (setf ext:*gc-verbose* nil)

  #+(and ecl (not ecl-bytecmp))
  (progn
    (let ((*load-verbose* nil)) (require :cmp))
    (setf c::*compile-in-constants* t))

  #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
     (read-from-string
      "(eval-when (:compile-toplevel :load-toplevel :execute)
         (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
         (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
         ;; See http://code.google.com/p/mcl/wiki/Portability
         (defun current-user-homedir-pathname ()
           (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
         (defun probe-posix (posix-namestring)
           \"If a file exists for the posix namestring, return the pathname\"
           (ccl::with-cstrs ((cpath posix-namestring))
             (ccl::rlet ((is-dir :boolean)
                         (fsref :fsref))
               (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
                 (ccl::%path-from-fsref fsref is-dir))))))"))

  #+sbcl (progn
           (require :sb-posix)
           (proclaim '(sb-ext:muffle-conditions sb-ext:compiler-note)))

  (pushnew :xcvb-driver *features*))

;;;; ----- User-visible variables, 1: Control build in current process -----

;;; Variables used to control building in the current image

(defvar *post-image-restart* nil
  "a string containing forms to read and evaluate when the image is restarted,
but before the entry point is called.")

(defvar *entry-point* nil

  "a function with which to restart the dumped image when execution is resumed from it.")

(defvar *debugging* nil
  "boolean: should we enter the debugger on failure?")

(defvar *profiling* nil
  "boolean: should we compute and display the time spend in each command?")

(defvar *goal* nil
  "what is the name of the goal toward which we execute commands?")

(defvar *stderr* #-clozure *error-output* #+clozure ccl::*stderr*

  "the original error output stream at startup")

(defvar *uninteresting-conditions*
  (append
   #+sbcl
   '(sb-c::simple-compiler-note
     "&OPTIONAL and &KEY found in the same lambda list: ~S"
     sb-int:package-at-variance
     sb-kernel:uninteresting-redefinition

     ;; the below four are controversial to include here;
     ;; however there are issues with the asdf upgrade if they are not present
     sb-kernel:redefinition-with-defun
     sb-kernel:redefinition-with-defgeneric
     sb-kernel:redefinition-with-defmethod

     sb-kernel::redefinition-with-defmacro ; not exported by old SBCLs

     sb-kernel:undefined-alien-style-warning
     sb-ext:implicit-generic-function-warning
     sb-kernel:lexical-environment-too-complex
     "Couldn't grovel for ~A (unknown to the C compiler).")

   ;;#+clozure '(ccl:compiler-warning)

   '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.") ;; from closer2mop

   )
  "Conditions that may be skipped. type symbols, predicates or strings")

(defvar *uninteresting-load-conditions*
  (append

   '("Overwriting already existing readtable ~S." ;; from named-readtables
     #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers

   #+clisp '(clos::simple-gf-replacing-method-warning))
  "Additional conditions that may be skipped while loading. type symbols, predicates or strings")

(defvar *fatal-conditions*
  '(serious-condition)

  "Conditions to be considered fatal during compilation.")

(defvar *deferred-warnings* ()
  "Warnings the handling of which is deferred until the end of the compilation unit")

(defvar *initial-random-state* (make-random-state nil)
  "initial random state to preserve determinism")

;;;; ----- Basic Utilities, used to bootstrap further -----

;;; Dealing with future packages

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun find-symbol* (name package-name &optional (error t))

    "Find a symbol in a package of given string'ified NAME;
unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
by letting you supply a symbol or keyword for the name;
also works well when the package is not present.
If optional ERROR argument is NIL, return NIL instead of an error
when the symbol is not found."

    (let ((package (find-package (string package-name))))
      (if package
          (let ((symbol (find-symbol (string name) package)))
            (or symbol
                (when error
                  (error "There is no symbol ~A in package ~A" name package-name))))
          (when error
            (error "There is no package ~A" package-name))))))

(defun call (package name &rest args)
  "Call a function associated with symbol of given name in given package,
with given ARGS. Useful when the call is read before the package is loaded,
or when loading the package is optional."
  (apply (find-symbol* name package) args))

;;; Setting up the environment from shell variables

(defun getenv (x)

  "Query the libc runtime environment. See getenv(3)."

  (declare (ignorable x))
  #+(or abcl clisp xcl) (ext:getenv x)
  #+allegro (sys:getenv x)
  #+clozure (ccl:getenv x)
  #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
  #+cormanlisp
  (let* ((buffer (ct:malloc 1))
         (cname (ct:lisp-string-to-c-string x))
         (needed-size (win:getenvironmentvariable cname buffer 0))
         (buffer1 (ct:malloc (1+ needed-size))))
    (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
               nil
               (ct:c-string-to-lisp-string buffer1))
      (ct:free buffer)
      (ct:free buffer1)))
  #+ecl (si:getenv x)
  #+gcl (system:getenv x)
  #+genera nil
  #+lispworks (lispworks:environment-variable x)
  #+mcl (ccl:with-cstrs ((name x))
          (let ((value (_getenv name)))
            (unless (ccl:%null-ptr-p value)
              (ccl:%get-cstring value))))

  #+mkcl (#.(or (find-symbol* 'getenv :si) (find-symbol* 'getenv :mk-ext)) x)

  #+sbcl (sb-ext:posix-getenv x)

  #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)

  (error "~S is not supported on your implementation" 'getenv))

(defun emptyp (x)
  "Predicate that is true for an empty sequence"
  (or (null x) (and (vectorp x) (zerop (length x)))))
(defun getenvp (x)

  "Predicate that is true if the named variable is present in the libc environment,
then returning the non-empty string value of the variable"
  (let ((g (getenv x))) (and (not (emptyp g)) g)))

;;; On ABCL at least, the Operating System is no compile-time constant.

(defun default-temporary-directory ()
  (flet ((f (s v d) (format nil "~A~A" (or (getenv v) d (error "No temporary directory!")) s)))
    (let ((dir (cond

                 ((os-unix-p) (f #\/ "TMPDIR" "/tmp"))

                 ((os-windows-p) (f #\\ "TEMP" nil))))
          #+mcl (dir (probe-posix dir)))
      (pathname dir))))

;;;; ----- User-visible variables, 2: Control XCVB -----

;;; These variables are shared with XCVB itself.

(defvar *lisp-implementation-type*
  ;; TODO: test on all OS and implementation platform combinations!

  #+abcl :abcl #+allegro :allegro
  #+clisp :clisp #+clozure :ccl #+cmu :cmucl #+cormanlisp :corman
  #+ecl :ecl #+gcl :gcl #+genera :genera

  #+lispworks-personal-edition :lispworks-personal
  #+(and lispworks (not lispworks-personal-edition)) :lispworks

  #+mcl :mcl #+mkcl :mkcl #+sbcl :sbcl #+scl :scl #+xcl :xcl

  #-(or abcl allegro clisp clozure cmu cormanlisp

        ecl gcl genera lispworks mcl mkcl sbcl scl xcl)

  (error "Your Lisp implementation is not supported by the XCVB driver (yet). Please help.")
  "Type of Lisp implementation for the target system. A keyword.

  Default: same as XCVB itself.")

(defvar *lisp-executable-pathname* nil
  "Path to the Lisp implementation to use for the target system.
  NIL, or a string.
  Default: what's in your PATH.")

(defvar *lisp-image-pathname* nil
  "What path to a Lisp image do we need invoke the target Lisp with?
  Default: whatever's the default for your implementation.")

(defvar *lisp-implementation-directory*

  (or #+clozure (namestring (ccl::ccl-directory))

      #+gcl (namestring system::*system-directory*)
      #+sbcl (namestring (sb-int:sbcl-homedir-pathname)))
  "Where is the home directory for the Lisp implementation,
  in case we need it to (require ...) special features?
  Default: whatever's the default for your implementation.")

(defvar *lisp-flags* :default
  ;;; TODO: add support for overriding this feature at the command-line?
  "What options do we need invoke the target Lisp with?
A list of strings, or the keyword :DEFAULT.")

(defvar *features-defined* nil
  "What additional features to define in the target image")

(defvar *features-undefined* nil
  "What additional features to undefine in the target image")

(defvar *disable-cfasls* nil
  "Should we disable CFASL support when the target Lisp has it?")

(defvar *xcvb-verbosity* 5
  "Level of verbosity of XCVB:
  0 - silent except for emergency
  5 - usual warnings
  9 - plenty of debug info")

(defvar *lisp-allow-debugger* nil
  "Should we allow interactive debugging of failed build attempts?")

(defvar *cache* nil
  "where to store object files, etc.
NIL: default to $XDG_CACHE_HOME/xcvb/ or $HOME/.cache/xcvb/, see docs")

(defvar *object-cache* nil
  "Path to the object cache.
NIL: default to *cache*/*implementation-identifier*/, see docs")

(defvar *workspace* nil
  "where to store test and intermediate files private to current run
NIL: default to <current-directory>/workspace/, see docs")

(defvar *install-prefix* nil
  "where to install files.
NIL: default to /usr/local/, see docs
\"/\": default to /, with special defaults for other paths.
T: use home directory with special defaults for other paths below.")

(defvar *install-program* nil
  "where to install program 'binary' (executable) files.
NIL: default to *install-prefix*/bin, see docs")

(defvar *install-configuration* nil
  "where to install configuration files.
NIL: default to *install-prefix*/etc, see docs")

(defvar *install-data* nil
  "where to install shared (architecture-independent) data files.
NIL: default to *install-prefix*/share, see docs")

(defvar *install-library* nil
  "where to install library (architecture-dependent) files.
NIL: default to *install-prefix*/lib, see docs")

(defvar *install-image* nil
  "where to install common-lisp image (architecture- and implementation- dependent) files.
NIL: default to *install-library*/common-lisp/images/, see docs")

(defvar *install-lisp* nil
  "where to install common-lisp source code and systems, etc.
NIL: default to *install-data*/common-lisp/, see docs")

(defvar *temporary-directory* (default-temporary-directory)

  "pathname of directory where to store temporary files")

(defvar *use-base-image* t
  "Should we be using a base image for all builds?")

;;; These variables are specific to a master controlling XCVB as a slave.

(defvar *xcvb-program* "xcvb"
  "Path to the XCVB binary (a string), OR t if you want to use an in-image XCVB")

(defvar *required-xcvb-version* "0.591"

  "Minimal version of XCVB required for use with this version of the xcvb-driver")

(defvar *source-registry* nil
  "CL source registry specification. A sexp or string.
Will override the shell variable CL_SOURCE_REGISTRY when calling slaves.")

(defvar *xcvb-setup* nil
  "Lisp file to load to setup the target build system, if any")

(defvar *manifest* nil
  ;; Note that older versions are kept in the tail, documenting the command history,
  ;; without affecting the behavior of ASSOC on the alist.
  "an alist of the XCVB load commands executed in this image,
with associated pathnames and tthsums.")

;;;; ---- More utilities -----

;;; To be portable to CCL and more, we need to explicitly flush stream buffers.

(defun finish-outputs ()
  "Finish output on the main output streams.
Useful for portably flushing I/O before user input or program exit."
  (dolist (s (list *stderr* *error-output* *standard-output* *trace-output*))
    (ignore-errors (finish-output s)))

  (values))

(defun format! (stream format &rest args)
  "Just like format, but call finish-outputs before and after the output."
  (finish-outputs)
  (apply 'format stream format args)
  (finish-output stream))


;;; Pathname helpers

(defun pathname-directory-pathname (pathname)
  "Pathname for the directory containing given PATHNAME"
  (make-pathname :name nil :type nil :version nil :defaults pathname))

(defun native-namestring (x)
  "From a CL pathname, a namestring suitable for use by the OS shell"
  (let ((p (pathname x)))

    #+clozure (let ((*default-pathname-defaults* #p"")) (ccl:native-translated-namestring p)) ; see ccl bug 978

    #+(or cmu scl) (ext:unix-namestring p nil)
    #+sbcl (sb-ext:native-namestring p)
    #-(or clozure cmu sbcl scl) (namestring p)))

(defun parse-native-namestring (x)
  "From a native namestring suitable for use by the OS shell, a CL pathname"
  (check-type x string)
  #+clozure (ccl:native-to-pathname x)
  #+sbcl (sb-ext:parse-native-namestring x)
  #-(or clozure sbcl) (parse-namestring x))


;;; Output helpers

(defgeneric call-with-output (x thunk)

  (:documentation
   ;; code from fare-utils base/streams where it's now named
   ;; call-with-output-stream to avoid the package clash in a lot of my code.

   "Calls FUN with an actual stream argument, behaving like FORMAT with respect to stream'ing:
If OBJ is a stream, use it as the stream.
If OBJ is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
If OBJ is T, use *STANDARD-OUTPUT* as the stream.
If OBJ is a string with a fill-pointer, use it as a string-output-stream.
Otherwise, signal an error.")
  (:method ((x null) thunk)
    (declare (ignorable x))
    (with-output-to-string (s) (funcall thunk s)))
  (:method ((x (eql t)) thunk)
    (declare (ignorable x))
    (funcall thunk *standard-output*) nil)
  #-genera
  (:method ((x stream) thunk)
    (funcall thunk x) nil)
  (:method ((x string) thunk)
    (assert (fill-pointer x))
    (with-output-to-string (s x) (funcall thunk s)))
  (:method (x thunk)
    (declare (ignorable thunk))
    (cond
      #+genera
      ((typep x 'stream) (funcall thunk x) nil)
      (t (error "not a valid stream designator ~S" x)))))

(defmacro with-output ((x &optional (value x)) &body body)
  "Bind X to an output stream, coercing VALUE (default: previous binding of X)
as per FORMAT, and evaluate BODY within the scope of this binding."
  `(call-with-output ,value #'(lambda (,x) ,@body)))


;;; Input helpers

(defvar *default-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default)

  "default element-type for open (depends on the current CL implementation)")

(defun call-with-input-file (pathname thunk
                             &key (element-type *default-element-type*)
                             (external-format :default))
  "Open FILE for input with given options, call THUNK with the resulting stream."
  (with-open-file (s pathname :direction :input
                     :element-type element-type :external-format external-format
                     :if-does-not-exist :error)
    (funcall thunk s)))

(defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body)
  (declare (ignore element-type external-format))
  `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))


;;; Using temporary files

(defun call-with-temporary-file
    (thunk &key
     prefix keep (direction :io)
     (element-type *default-element-type*)
     (external-format :default))
  (check-type direction (member :output :io))
  (loop

    :with prefix = (or prefix (format nil "~Axm" (native-namestring *temporary-directory*)))

    :for counter :from (random (ash 1 32))
    :for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
     ;; TODO: on Unix, do something about umask
     ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
     ;; TODO: on Unix, use CFFI and mkstemp -- but the master is precisely meant to not depend on CFFI or on anything! Grrrr.
    (with-open-file (stream pathname
                            :direction direction
                            :element-type element-type :external-format external-format
                            :if-exists nil :if-does-not-exist :create)
      (when stream
        (return
          (if keep
              (funcall thunk stream pathname)
              (unwind-protect
                   (funcall thunk stream pathname)
                (ignore-errors (delete-file pathname)))))))))

(defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
                                (pathname (gensym "PATHNAME") pathnamep)

                                prefix keep direction element-type external-format)

                               &body body)
  "Evaluate BODY where the symbols specified by keyword arguments
STREAM and PATHNAME are bound corresponding to a newly created temporary file
ready for I/O. Unless KEEP is specified, delete the file afterwards."
  (check-type stream symbol)
  (check-type pathname symbol)
  `(flet ((think (,stream ,pathname)
            ,@(unless pathnamep `((declare (ignore ,pathname))))
            ,@(unless streamp `((when ,stream (close ,stream))))
            ,@body))
     #-gcl (declare (dynamic-extent #'think))
     (call-with-temporary-file
      #'think

      ,@(when direction `(:direction ,direction))

      ,@(when prefix `(:prefix ,prefix))
      ,@(when keep `(:keep ,keep))
      ,@(when element-type `(:element-type ,element-type))
      ,@(when external-format `(:external-format external-format)))))


;;; Reading helpers

(defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
  "Establish safe CL reader options around the evaluation of BODY"
  `(call-with-safe-io-syntax (lambda () ,@body) :package ,package))

(defun call-with-safe-io-syntax (thunk &key (package :cl))
  (with-standard-io-syntax ()
    (let ((*package* (find-package package))

          (*print-readably* nil)

	  (*read-eval* nil))
      (funcall thunk))))

(defun read-function (string)
  "Read a form from a string in function context, return a function"
  (eval `(function ,(read-from-string string))))

(defun read-first-file-form (pathname &key (package :cl) eof-error-p eof-value)
  "Reads the first form from the top of a file"
  (with-safe-io-syntax (:package package)
    (with-input-file (in pathname)
      (read in eof-error-p eof-value))))


;;; String utilities

(defun string-prefix-p (prefix string)
  "Does STRING begin with PREFIX?"
  (let* ((x (string prefix))
         (y (string string))
         (lx (length x))
         (ly (length y)))
    (and (<= lx ly) (string= x y :end2 lx))))

(defun string-suffix-p (string suffix)
  "Does STRING end with SUFFIX?"
  (let* ((x (string string))
         (y (string suffix))
         (lx (length x))
         (ly (length y)))
    (and (<= ly lx) (string= x y :start1 (- lx ly)))))

(defun string-enclosed-p (prefix string suffix)
  "Does STRING begin with PREFIX and end with SUFFIX?"
  (and (string-prefix-p prefix string)
       (string-suffix-p string suffix)))


;;;; Slurping streams

(defun copy-stream-to-stream (input output &key (element-type 'character))
  "Copy the contents of the INPUT stream into the OUTPUT stream,
using WRITE-SEQUENCE and a sensibly sized buffer."
  (with-open-stream (input input)
    (loop :with length = 8192
      :for buffer = (make-array length :element-type element-type)
      :for end = (read-sequence buffer input)
      :until (zerop end)
      :do (write-sequence buffer output :end end)
      :do (when (< end length) (return)))))

(defun copy-stream-to-stream-line-by-line (input output &key prefix)

  "Copy the contents of the INPUT stream into the OUTPUT stream,
reading contents line by line."
  (with-open-stream (input input)
    (loop :for (line eof) = (multiple-value-list (read-line input nil nil))

      :while line :do

      (when prefix (princ prefix output))

      (princ line output)
      (unless eof (terpri output))
      (finish-output output)
      (when eof (return)))))

(defun slurp-stream-string (input &key (element-type 'character))
  "Read the contents of the INPUT stream as a string"
  (with-open-stream (input input)
    (with-output-to-string (output)
      (copy-stream-to-stream input output :element-type element-type))))

(defun slurp-stream-lines (input)
  "Read the contents of the INPUT stream as a list of lines"
  (with-open-stream (input input)

    (loop :for l = (read-line input nil nil) :while l :collect l)))

(defun slurp-stream-forms (input)
  "Read the contents of the INPUT stream as a list of forms"
  (with-open-stream (input input)
    (loop :with eof = '#:eof
      :for form = (read input nil eof)

      :until (eq form eof) :collect form)))

(defun slurp-file-string (file &rest keys)
  "Open FILE with option KEYS, read its contents as a string"
  (apply 'call-with-input-file file 'slurp-stream-string keys))

(defun slurp-file-lines (file &rest keys)
  "Open FILE with option KEYS, read its contents as a list of lines"
  (apply 'call-with-input-file file 'slurp-stream-lines keys))

(defun slurp-file-forms (file &rest keys)
  "Open FILE with option KEYS, read its contents as a list of forms"
  (apply 'call-with-input-file file 'slurp-stream-forms keys))


;;;; ----- Current directory -----
;; TODO: make it work on all supported implementations

(defun getcwd ()
  "Get the current working directory as per POSIX getcwd(3)"
  (or #+clisp (ext:default-directory)
      #+clozure (ccl:current-directory)

      #+cormanlisp (pl::get-current-directory)

      #+mkcl (mk-ext:getcwd)
      #+sbcl (sb-unix:posix-getcwd/)

      (error "getcwd not supported on your implementation")))

(defun chdir (x)
  "Change current directory, as per POSIX chdir(2)"

  #-(or clisp clozure) (when (pathnamep x) (setf x (native-namestring x)))

  (or #+clisp (ext:cd x)
      #+clozure (setf (ccl:current-directory) x)

      #+cormanlisp (unless (zerop (win32::_chdir x))
                     (error "Could not set current directory to ~A" x))

      #+sbcl (sb-posix:chdir x)
      (error "chdir not supported on your implementation")))

(defun call-with-current-directory (dir thunk)

  (if dir
      (let* ((dir (truename (merge-pathnames (pathname-directory-pathname dir))))
             (*default-pathname-defaults* dir)
             (cwd (getcwd)))
        (chdir dir)
        (unwind-protect
             (funcall thunk)
          (chdir cwd)))
      (funcall thunk)))

(defmacro with-current-directory ((dir) &body body)
  "Call BODY while the POSIX current working directory is set to DIR"
  `(call-with-current-directory ,dir #'(lambda () ,@body)))


;;;; ---- Build and Execution control ----

;;; Optimization settings

(defvar *previous-optimization-settings* nil)
(defun get-optimization-settings ()
  "Get current compiler optimization settings, ready to PROCLAIM again"

  (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
    #-(or clisp clozure cmu sbcl scl)
    (warn "xcvb-driver::get-optimization-settings does not support your implementation. Please help me fix that.")

    #.`(loop :for x :in settings

         ,@(or #+clozure '(:for v :in '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*))
               #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))

         :for y = (or #+clisp (gethash x system::*optimize*)
                      #+clozure (symbol-value v)

                      #+(or cmu scl) (funcall f c::*default-cookie*)

                      #+sbcl (cdr (assoc x sb-c::*policy*)))
         :when y :collect (list x y))))
(defun proclaim-optimization-settings ()
  "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
  (proclaim `(optimize ,@*optimization-settings*))

  (let ((settings (get-optimization-settings)))
    (unless (equal *previous-optimization-settings* settings)
      (setf *previous-optimization-settings* settings)

      (when (>= *xcvb-verbosity* 8)

	(format! *error-output* "~&Optimization settings: ~S~%" settings)))))

;;; Performance tweaks

(defun tweak-implementation ()

  "Common performance tweaks for various CL implementations."