Newer
Older
Francois-Rene Rideau
committed
;;;;; XCVB driver. Load it in your Lisp image and build with XCVB.
Francois-Rene Rideau
committed
;;;; ----- Prelude -----
:author ("Francois-Rene Rideau")
:maintainer "Francois-Rene Rideau"
:licence "MIT" ;; MIT-style license. See LICENSE
Francois-Rene Rideau
committed
: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
;;; 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*
;;; special variables for XCVB master itself
Francois-Rene Rideau
committed
;;; special variables for portability issues
#:*default-element-type*
;;; String utilities - copied from fare-utils
;;#:string-prefix-p #:string-suffix-p #:string-enclosed-p
Francois-Rene Rideau
committed
;; command-line arguments
#:raw-command-line-arguments #:command-line-arguments #:*arguments* #:*dumped*
#: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
;;; 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
#:subprocess-error
#:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
#: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
#:getcwd #:chdir #:with-current-directory
#:+xcvb-slave-greeting+ #:+xcvb-slave-farewell+
;;; Using an inferior XCVB
Francois-Rene Rideau
committed
#:build-and-load #:bnl #:build-in-slave
;;; Build-time variables
Francois-Rene Rideau
committed
#:*optimization-settings*
Francois-Rene Rideau
committed
#:*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
#: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
Francois-Rene Rideau
committed
(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)))
`((speed 2) (space 2) (safety 3) (debug 2) (compilation-speed 0)
(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)
Francois-Rene Rideau
committed
#+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode) clozure
lispworks (and sbcl sb-unicode) scl)
(pushnew :xcvb-unicode *features*)
Francois-Rene Rideau
committed
#+gcl ;;; If using GCL, do some safety checks
(flet ((bork (&rest args)
(apply #'format *error-output* args)
Francois-Rene Rideau
committed
(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)
Francois-Rene Rideau
committed
#+(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*))
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
;;;; ----- 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.")
Francois-Rene Rideau
committed
"a function with which to restart the dumped image when execution is resumed from it.")
Francois-Rene Rideau
committed
(defvar *debugging* nil
"boolean: should we enter the debugger on failure?")
Francois-Rene Rideau
committed
(defvar *profiling* nil
"boolean: should we compute and display the time spend in each command?")
Francois-Rene Rideau
committed
(defvar *goal* nil
"what is the name of the goal toward which we execute commands?")
Francois-Rene Rideau
committed
(defvar *stderr* #-clozure *error-output* #+clozure ccl::*stderr*
"the original error output stream at startup")
Francois-Rene Rideau
committed
(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)
Francois-Rene Rideau
committed
'("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")
Francois-Rene Rideau
committed
(defvar *uninteresting-load-conditions*
(append
'("Overwriting already existing readtable ~S." ;; from named-readtables
#(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
Francois-Rene Rideau
committed
#+clisp '(clos::simple-gf-replacing-method-warning))
"Additional conditions that may be skipped while loading. type symbols, predicates or strings")
Francois-Rene Rideau
committed
(defvar *fatal-conditions*
'(serious-condition)
"Conditions to be considered fatal during compilation.")
Francois-Rene Rideau
committed
(defvar *deferred-warnings* ()
"Warnings the handling of which is deferred until the end of the compilation unit")
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
(defvar *initial-random-state* (make-random-state nil)
"initial random state to preserve determinism")
Francois-Rene Rideau
committed
;;;; ----- 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
Francois-Rene Rideau
committed
(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))))
Francois-Rene Rideau
committed
#+mkcl (#.(or (find-symbol* 'getenv :si) (find-symbol* 'getenv :mk-ext)) x)
#+sbcl (sb-ext:posix-getenv x)
Francois-Rene Rideau
committed
#-(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))
Francois-Rene Rideau
committed
(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)))
Francois-Rene Rideau
committed
;;; 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))))
Francois-Rene Rideau
committed
;;;; ----- User-visible variables, 2: Control XCVB -----
;;; These variables are shared with XCVB itself.
Francois-Rene Rideau
committed
(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
Francois-Rene Rideau
committed
#+mcl :mcl #+mkcl :mkcl #+sbcl :sbcl #+scl :scl #+xcl :xcl
#-(or abcl allegro clisp clozure cmu cormanlisp
Francois-Rene Rideau
committed
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))
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
#+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?")
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
(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?")
Francois-Rene Rideau
committed
;;; These variables are specific to a master controlling XCVB as a slave.
Francois-Rene Rideau
committed
(defvar *xcvb-program* "xcvb"
"Path to the XCVB binary (a string), OR t if you want to use an in-image XCVB")
"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.")
Francois-Rene Rideau
committed
;;;; ---- 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)))
Francois-Rene Rideau
committed
(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
Francois-Rene Rideau
committed
#+(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.
Francois-Rene Rideau
committed
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
"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)
Francois-Rene Rideau
committed
"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*)))
Francois-Rene Rideau
committed
: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)
Francois-Rene Rideau
committed
&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))
Francois-Rene Rideau
committed
,@(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))
Francois-Rene Rideau
committed
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
(*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)
Francois-Rene Rideau
committed
"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))
(princ line output)
(unless eof (terpri output))
(finish-output output)
(when eof (return)))))
Francois-Rene Rideau
committed
(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)))
Francois-Rene Rideau
committed
(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)))
Francois-Rene Rideau
committed
(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)
Francois-Rene Rideau
committed
#+cormanlisp (pl::get-current-directory)
#+mkcl (mk-ext:getcwd)
#+sbcl (sb-unix:posix-getcwd/)
Francois-Rene Rideau
committed
(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)))
Francois-Rene Rideau
committed
(or #+clisp (ext:cd x)
#+clozure (setf (ccl:current-directory) x)
Francois-Rene Rideau
committed
#+cormanlisp (unless (zerop (win32::_chdir x))
(error "Could not set current directory to ~A" x))
Francois-Rene Rideau
committed
#+sbcl (sb-posix:chdir x)
(error "chdir not supported on your implementation")))
(defun call-with-current-directory (dir thunk)
Francois-Rene Rideau
committed
(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)))
Francois-Rene Rideau
committed
(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.")
Francois-Rene Rideau
committed
#.`(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)))
Francois-Rene Rideau
committed
:for y = (or #+clisp (gethash x system::*optimize*)
#+clozure (symbol-value v)
#+(or cmu scl) (funcall f c::*default-cookie*)
Francois-Rene Rideau
committed
#+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 *debugging*
(format! *error-output* "~&Optimization settings: ~S~%" settings)))))
Francois-Rene Rideau
committed
;;; Performance tweaks
(defun tweak-implementation ()
"Common performance tweaks for various CL implementations."
#+sbcl
(progn
;; add ample margin between GC's: 400 MiB
(setf (sb-ext:bytes-consed-between-gcs) (* 400 1024 1024))
;; add ample margin for *next* GC: 200 MiB
(incf (sb-alien:extern-alien "auto_gc_trigger" sb-alien:long) (* 200 1024 1024))
#|(sb-ext:gc :full t)|#)
(progn
(ccl::configure-egc 32768 65536 98304)
(ccl::set-lisp-heap-gc-threshold (* 384 1024 1024))
(ccl::use-lisp-heap-gc-threshold)
#|(ccl:gc)|#)
nil)
Francois-Rene Rideau
committed
;;; Debugging
Francois-Rene Rideau
committed
(defun debugging (&optional (debug t))
"Enable (or with NIL argument, disable) verbose debugging output from XCVB"
(setf *debugging* debug
*load-verbose* debug
*load-print* debug
#+clisp custom:*compile-warnings* #+clisp debug
*compile-verbose* debug
*compile-print* debug
*optimization-settings* '((speed 2) (safety 3) (compilation-speed 0) (debug 3)))
(proclaim-optimization-settings)
(cond
(debug
#+sbcl (sb-ext:enable-debugger)
#+clisp (ext:set-global-handler nil nil))
(t
#+sbcl (sb-ext:disable-debugger)
#+clisp (ext:set-global-handler 'error #'bork)))
(values))
Francois-Rene Rideau
committed
(defun print-backtrace (out)
"Print a backtrace (implementation-defined)"
(declare (ignorable out))
#+clozure (let ((*debug-io* out))
(ccl:print-call-history :count 100 :start-frame-number 1)
(finish-output out))
#+sbcl
(sb-debug:backtrace
#.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream 'most-positive-fixnum)
out))
;;; Profiling
(defun call-with-maybe-profiling (thunk what goal)
(when *debugging*
(format! *trace-output* "~&Now ~S~&" what))
(if *profiling*
(let* ((start-time (get-internal-real-time))
(values (multiple-value-list (funcall thunk)))
(end-time (get-internal-real-time))
(duration (coerce (/ (- end-time start-time) internal-time-units-per-second) 'double-float)))
(format! *trace-output* "~&~S~&" `(:profiling ,what :from ,goal :duration ,duration))
(apply #'values values))
(funcall thunk)))
(defmacro with-profiling (what &body body)
"Macro to run a BODY of code, and
profile it under some profiling name when *PROFILING* is enabled."
`(call-with-maybe-profiling #'(lambda () ,@body) ,what *goal*))
Francois-Rene Rideau
committed
;;; Build initialization
(defun setup-environment ()
"Setup the XCVB environment with respect to debugging, profiling, performance"
(debugging (getenvp "XCVB_DEBUGGING"))
(setf *profiling* (getenvp "XCVB_PROFILING"))
(tweak-implementation))
;;; Exiting properly or im-
(defun quit (&optional (code 0) (finish-output t))
"Quits from the Lisp world, with the given exit status if provided.
This is designed to abstract away the implementation specific quit forms."
(when *debugging*
(format! *stderr* "~&Quitting with code ~A~%" code))
Francois-Rene Rideau
committed
(when finish-output ;; essential, for ClozureCL, and for standard compliance.
(finish-outputs))
#+(or abcl xcl) (ext:quit :status code)
#+allegro (excl:exit code :quiet t)
#+clisp (ext:quit code)
#+clozure (ccl:quit code)
Francois-Rene Rideau
committed
#+cormanlisp (win32:exitprocess code)
#+(or cmu scl) (unix:unix-exit code)
#+ecl (si:quit code)
Francois-Rene Rideau
committed
#+gcl (lisp:quit code)
#+genera (error "You probably don't want to Halt the Machine.")
#+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
#+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
Francois-Rene Rideau
committed
#+mkcl (mk-ext:quit :exit-code code)
#+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
(quit (find-symbol* :quit :sb-ext nil)))
(cond
(exit `(,exit :code code :abort (not finish-output)))
(quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
Francois-Rene Rideau
committed
#-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
(error "xcvb driver: Quitting not implemented"))
Francois-Rene Rideau
committed
(defun shell-boolean (x)
"Quit with a return code that is 0 iff argument X is true"
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
(defun die (format &rest arguments)
"Die in error with some error message"
(format! *stderr* "~&")
(apply #'format! *stderr* format arguments)
(format! *stderr* "~&")
Francois-Rene Rideau
committed
(quit 99))
Francois-Rene Rideau
committed
(defun bork (condition)
"Depending on whether *DEBUGGING* is set, enter debugger or die"
(format! *stderr* "~&BORK:~%~A~%" condition)
(cond
(*debugging*
(invoke-debugger condition))
(t
(print-backtrace *stderr*)
(die "~A" condition))))
Francois-Rene Rideau
committed
(defun call-with-coded-exit (thunk)
(handler-bind ((error #'bork))
(funcall thunk)
(quit 0)))
Francois-Rene Rideau
committed
(defmacro with-coded-exit ((&optional) &body body)
"Run BODY, BORKing on error and otherwise exiting with a success status"
`(call-with-coded-exit #'(lambda () ,@body)))
Francois-Rene Rideau
committed
;;;; ----- Pathname mappings -----
;; TODO: make it work, test it.
(defvar *pathname-mappings* (make-hash-table :test 'equal)
"Mappings from xcvb fullname to plist of
(physical) :pathname, :logical-pathname, :tthsum digest, etc.")
(defun register-fullname (&key fullname pathname tthsum logical-pathname)
(setf (gethash fullname *pathname-mappings*)
(list :truename (truename (merge-pathnames pathname))
:pathname pathname :logical-pathname logical-pathname
:tthsum tthsum))
(values))
(defun register-fullnames (mappings &key (defaults *load-truename*))
(let ((*default-pathname-defaults*
(or (and defaults (truename (pathname-directory-pathname defaults)))
*default-pathname-defaults*)))
(dolist (m mappings)
(apply 'register-fullname m))))
(defun registered-fullname-pathname (fullname)
Francois-Rene Rideau
committed
(let ((plist (gethash fullname *pathname-mappings*)))
(or (getf plist :logical-pathname) (getf plist :truename))))
(defun load-fullname-mappings (file)
(let ((tn (truename file)))
(register-fullnames (read-first-file-form tn) :defaults tn)))
;;;; ----- Filtering conditions while building -----
(defun match-condition-p (x condition)
"Compare received CONDITION to some pattern X:
a symbol naming a condition class,
a simple vector of length 2, arguments to find-symbol* with result as above,
or a string describing the format-control of a simple-condition."
(etypecase x
(symbol (typep condition x))
((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))
(function (funcall x condition))
(string (and (typep condition 'simple-condition)
#+(or clozure cmu scl) ; Note: on SBCL, always bound, and testing triggers warning
(slot-boundp condition
(ignore-errors (equal (simple-condition-format-control condition) x))))))
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
(defun match-any-condition-p (condition conditions)
"match CONDITION against any of the patterns of CONDITIONS supplied"
Francois-Rene Rideau
committed
(loop :for x :in conditions :thereis (match-condition-p x condition)))
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
(defun uninteresting-condition-p (condition)
"match CONDITION against any of the patterns of *UNINTERESTING-CONDITIONS*"
Francois-Rene Rideau
committed
(match-any-condition-p condition *uninteresting-conditions*))
Francois-Rene Rideau
committed
(defun fatal-condition-p (condition)
"match CONDITION against any of the patterns of *FATAL-CONDITIONS*"
Francois-Rene Rideau
committed
(match-any-condition-p condition *fatal-conditions*))
Francois-Rene Rideau
committed
(defun call-with-controlled-compiler-conditions (thunk)
(handler-bind
((t
#'(lambda (condition)
;; TODO: do something magic for undefined-function,
;; save all of aside, and reconcile in the end of the virtual compilation-unit.
(cond
((uninteresting-condition-p condition)
(muffle-warning condition))
((fatal-condition-p condition)
(bork condition))))))
(funcall thunk)))
Francois-Rene Rideau
committed
(defmacro with-controlled-compiler-conditions ((&optional) &body body)
"Run BODY while suppressing conditions patterned after *UNINTERESTING-CONDITIONS*"
`(call-with-controlled-compiler-conditions #'(lambda () ,@body)))
Francois-Rene Rideau
committed
(defun call-with-controlled-loader-conditions (thunk)
(let ((*uninteresting-conditions*
(append
Francois-Rene Rideau
committed
*uninteresting-load-conditions*
*uninteresting-conditions*)))
(call-with-controlled-compiler-conditions thunk)))
Francois-Rene Rideau
committed
(defmacro with-controlled-loader-conditions ((&optional) &body body)
"Run BODY while suppressing conditions patterned after *UNINTERESTING-CONDITIONS* plus a few others that don't matter at load-time."
`(call-with-controlled-loader-conditions #'(lambda () ,@body)))
Francois-Rene Rideau
committed
(defun save-forward-references (forward-references)
"Save forward reference conditions so they may be issued at a latter time,
possibly in a different process."
#+sbcl
(loop :for w :in sb-c::*undefined-warnings*
:for kind = (sb-c::undefined-warning-kind w) ; :function :variable :type
:for name = (sb-c::undefined-warning-name w)
:for symbol = (cond
((consp name)
(unless (eq kind :function)
(error "unrecognized warning ~S not a function?" w))