4fb5e6701c8e82082ecab31e6bb1f946d09ede55
[projects/xcvb/xcvb.git] / driver.lisp
1 ;;;;; XCVB driver. Load it in your Lisp image and build with XCVB.
2
3 ;;;; ----- Prelude -----
4 #+xcvb
5 (module
6  (:description "XCVB Driver"
7   :author ("Francois-Rene Rideau")
8   :maintainer "Francois-Rene Rideau"
9   :licence "MIT" ;; MIT-style license. See LICENSE
10   :build-depends-on nil))
11
12 ;; #.(setf *load-verbose* () *load-print* () *compile-verbose* () *compile-print* ()) ;; Hush!
13
14 (cl:in-package :cl-user)
15
16 (declaim (optimize (speed 2) (space 2) (safety 3) (debug 3) (compilation-speed 0))
17          #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
18
19 (defpackage :xcvb-driver
20   (:nicknames :xcvbd :xd)
21   (:use :cl)
22   (:export
23
24    ;;; special variables shared with XCVB itself
25    #:*lisp-implementation-type*
26    #:*lisp-executable-pathname* #:*lisp-image-pathname*
27    #:*lisp-implementation-directory*
28    #:*lisp-flags*  #:*lisp-allow-debugger*
29    #:*use-base-image* #:*disable-cfasls*
30    #:*features-defined* #:*features-undefined*
31    #:*xcvb-verbosity*
32    #:*cache* #:*object-cache* #:*workspace*
33    #:*install-prefix* #:*install-program* #:*install-configuration*
34    #:*install-data* #:*install-library* #:*install-image* #:*install-lisp*
35    #:*temporary-directory*
36    #:*source-registry*
37
38    ;;; special variables for XCVB master itself
39    #:*xcvb-program* #:*manifest*
40    #:*required-xcvb-version*
41
42    ;;; special variables for portability issues
43    #:*default-element-type*
44
45    ;;; String utilities - copied from fare-utils
46    ;;#:string-prefix-p #:string-suffix-p #:string-enclosed-p
47
48    ;;; I/O utilities
49    #:with-output #:with-input-file #:with-safe-io-syntax #:with-temporary-file
50    #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-forms
51    #:slurp-file-string #:slurp-file-lines #:slurp-file-forms
52    #:copy-stream-to-stream #:copy-stream-to-stream-line-by-line
53    #:read-first-file-form #:read-function
54    #:slurp-input-stream
55
56    ;;; Escaping the command invocation madness
57    #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
58    #:escape-windows-token #:escape-windows-command
59    #:escape-token #:escape-command
60
61    ;;; run-program/foo
62    #:run-program/
63    #:subprocess-error
64    #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
65    ;; Obsolete:
66    #:run-program/process-output-stream
67    #:run-program/read-output-lines #:run-program/read-output-string
68    #:run-program/read-output-form #:run-program/read-output-forms
69    #:run-program/for-side-effects #:run-program/echo-output
70
71    ;; pathname utilities
72    #:native-namestring #:parse-native-namestring
73
74    ;; current directory
75    #:getcwd #:chdir #:with-current-directory
76
77    ;; Magic strings
78    #:+xcvb-slave-greeting+ #:+xcvb-slave-farewell+
79
80    ;;; Using an inferior XCVB
81    #:build-and-load #:bnl #:build-in-slave
82
83    ;;; Build-time variables
84    #:*optimization-settings*
85    #:*uninteresting-conditions* #:*uninteresting-load-conditions*
86    #:*fatal-conditions* #:*deferred-warnings*
87    #:*goal* #:*stderr* #:*debugging* #:*profiling*
88    #:*post-image-restart* #:*entry-point*
89
90    ;;; Environment support
91    #:getenv #:emptyp #:getenvp #:setup-environment
92    #:debugging #:with-profiling
93    #:format! #:finish-outputs #:quit #:shell-boolean
94    #:print-backtrace #:die #:bork #:with-coded-exit
95    #:uninteresting-condition-p #:fatal-condition-p
96    #:with-controlled-compiler-conditions #:with-controlled-loader-conditions
97    #:with-xcvb-compilation-unit
98    #:find-symbol* #:call #:eval-string #:load-string #:load-stream
99    ;; #:run #:do-run #:run-commands #:run-command ; used by XCVB, not end-users.
100    #:resume #-ecl #:dump-image #+ecl #:create-bundle
101    #:register-fullname #:register-fullnames #:load-fullname-mappings
102    #:registered-fullname-pathname))
103
104 (in-package :xcvb-driver)
105
106 ;;; Initial implementation-dependent setup
107 (eval-when (:compile-toplevel :load-toplevel :execute)
108   (defvar *implementation-settings*
109     `(;; These should ensure all tail calls are optimized, says jsnell:
110       #+sbcl (sb-c::insert-debug-catch 0) ;; (sb-c::merge-tail-calls 3) is redundant and deprecated
111       #+(or cmu scl) (ext:inhibit-warnings 3)))
112   (defvar *optimization-settings*
113     `((speed 2) (space 2) (safety 3) (debug 2) (compilation-speed 0)
114       ,@*implementation-settings*))
115   (proclaim `(optimize ,@*optimization-settings*))
116   ;; otherwise ACL 5.0 may crap out on ASDF dependencies,
117   ;; but even other implementations may have "fun" debugging.
118   (setf *print-readably* nil)
119   (defun featurep (x &optional (*features* *features*))
120     (cond
121       ((atom x) (and (member x *features*) t))
122       ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
123       ((eq :or (car x)) (some #'featurep (cdr x)))
124       ((eq :and (car x)) (every #'featurep (cdr x)))
125       (t (error "Malformed feature specification ~S" x))))
126   (defun os-unix-p ()
127     (featurep '(:or :unix :cygwin :darwin)))
128   (defun os-windows-p ()
129     (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32))))
130   (defun detect-os ()
131     (flet ((yes (yes) (pushnew yes *features*))
132            (no (no) (setf *features* (remove no *features*))))
133       (cond
134         ((os-unix-p) (yes :os-unix) (no :os-windows))
135         ((os-windows-p) (yes :os-windows) (no :os-unix))
136         (t (error "Congratulations for trying XCVB on an operating system~%~
137 that is neither Unix, nor Windows.~%Now you port it.")))))
138   (detect-os)
139   #+gcl ;;; If using GCL, do some safety checks
140   (flet ((bork (&rest args)
141            (apply #'format *error-output* args)
142            (lisp:quit 42)))
143     (when (or (< system::*gcl-major-version* 2)
144               (and (= system::*gcl-major-version* 2)
145                    (< system::*gcl-minor-version* 7)))
146       (bork "GCL version ~D.~D < 2.7 not supported"
147              system::*gcl-major-version* system::*gcl-minor-version*))
148     (unless (member :ansi-cl *features*)
149       (bork "XCVB only supports GCL in ANSI mode. Aborting.~%"))
150     (setf compiler::*compiler-default-type* (pathname "")
151           compiler::*lsp-ext* ""))
152   #+cmu (setf ext:*gc-verbose* nil)
153   #+(and ecl (not ecl-bytecmp))
154   (progn
155     (let ((*load-verbose* nil)) (require :cmp))
156     (setf c::*compile-in-constants* t))
157   #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
158      (read-from-string
159       "(eval-when (:compile-toplevel :load-toplevel :execute)
160          (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
161          (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
162          ;; See http://code.google.com/p/mcl/wiki/Portability
163          (defun current-user-homedir-pathname ()
164            (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
165          (defun probe-posix (posix-namestring)
166            \"If a file exists for the posix namestring, return the pathname\"
167            (ccl::with-cstrs ((cpath posix-namestring))
168              (ccl::rlet ((is-dir :boolean)
169                          (fsref :fsref))
170                (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
171                  (ccl::%path-from-fsref fsref is-dir))))))"))
172   #+sbcl (progn
173            (require :sb-posix)
174            (proclaim '(sb-ext:muffle-conditions sb-ext:compiler-note)))
175   (pushnew :xcvb-driver *features*))
176
177 ;;;; ----- User-visible variables, 1: Control build in current process -----
178
179 ;;; Variables used to control building in the current image
180
181 (defvar *post-image-restart* nil
182   "a string containing forms to read and evaluate when the image is restarted,
183 but before the entry point is called.")
184
185 (defvar *entry-point* nil
186   "a function with which to restart the dumped image when execution is resumed from it.")
187
188 (defvar *debugging* nil
189   "boolean: should we enter the debugger on failure?")
190
191 (defvar *profiling* nil
192   "boolean: should we compute and display the time spend in each command?")
193
194 (defvar *goal* nil
195   "what is the name of the goal toward which we execute commands?")
196
197 (defvar *stderr* *error-output*
198   "the original error output stream at startup")
199
200 (defvar *uninteresting-conditions*
201   (append
202    #+sbcl
203    '(sb-c::simple-compiler-note
204      "&OPTIONAL and &KEY found in the same lambda list: ~S"
205      sb-int:package-at-variance
206      sb-kernel:uninteresting-redefinition
207      ;; the below four are controversial to include here;
208      ;; however there are issues with the asdf upgrade if they are not present
209      sb-kernel:redefinition-with-defun
210      sb-kernel:redefinition-with-defgeneric
211      sb-kernel:redefinition-with-defmethod
212      sb-kernel::redefinition-with-defmacro ; not exported by old SBCLs
213      sb-kernel:undefined-alien-style-warning
214      sb-ext:implicit-generic-function-warning
215      sb-kernel:lexical-environment-too-complex
216      "Couldn't grovel for ~A (unknown to the C compiler).")
217    ;;#+clozure '(ccl:compiler-warning)
218    '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.") ;; from closer2mop
219    )
220   "Conditions that may be skipped. type symbols, predicates or strings")
221
222 (defvar *uninteresting-load-conditions*
223   (append
224    #+clisp '(clos::simple-gf-replacing-method-warning))
225   "Additional conditions that may be skipped while loading. type symbols, predicates or strings")
226
227 (defvar *fatal-conditions*
228   '(serious-condition)
229   "Conditions to be considered fatal during compilation.")
230
231 (defvar *deferred-warnings* ()
232   "Warnings the handling of which is deferred until the end of the compilation unit")
233
234 (defvar *initial-random-state* (make-random-state nil)
235   "initial random state to preserve determinism")
236
237
238 ;;;; ----- Basic Utilities, used to bootstrap further -----
239
240 ;;; Dealing with future packages
241
242 (eval-when (:compile-toplevel :load-toplevel :execute)
243   (defun find-symbol* (name package-name &optional (error t))
244     "Find a symbol in a package of given string'ified NAME;
245 unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
246 by letting you supply a symbol or keyword for the name;
247 also works well when the package is not present.
248 If optional ERROR argument is NIL, return NIL instead of an error
249 when the symbol is not found."
250     (let ((package (find-package (string package-name))))
251       (if package
252           (let ((symbol (find-symbol (string name) package)))
253             (or symbol
254                 (when error
255                   (error "There is no symbol ~A in package ~A" name package-name))))
256           (when error
257             (error "There is no package ~A" package-name))))))
258
259 (defun call (package name &rest args)
260   "Call a function associated with symbol of given name in given package,
261 with given ARGS. Useful when the call is read before the package is loaded,
262 or when loading the package is optional."
263   (apply (find-symbol* name package) args))
264
265 ;;; Setting up the environment from shell variables
266
267 (defun getenv (x)
268   "Query the libc runtime environment. See getenv(3)."
269   (declare (ignorable x))
270   #+(or abcl clisp xcl) (ext:getenv x)
271   #+allegro (sys:getenv x)
272   #+clozure (ccl:getenv x)
273   #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
274   #+cormanlisp
275   (let* ((buffer (ct:malloc 1))
276          (cname (ct:lisp-string-to-c-string x))
277          (needed-size (win:getenvironmentvariable cname buffer 0))
278          (buffer1 (ct:malloc (1+ needed-size))))
279     (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
280                nil
281                (ct:c-string-to-lisp-string buffer1))
282       (ct:free buffer)
283       (ct:free buffer1)))
284   #+ecl (si:getenv x)
285   #+gcl (system:getenv x)
286   #+genera nil
287   #+lispworks (lispworks:environment-variable x)
288   #+mcl (ccl:with-cstrs ((name x))
289           (let ((value (_getenv name)))
290             (unless (ccl:%null-ptr-p value)
291               (ccl:%get-cstring value))))
292   #+sbcl (sb-ext:posix-getenv x)
293   #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
294   (error "~S is not supported on your implementation" 'getenv))
295
296 (defun emptyp (x)
297   "Predicate that is true for an empty sequence"
298   (or (null x) (and (vectorp x) (zerop (length x)))))
299 (defun getenvp (x)
300   "Predicate that is true if the named variable is present in the libc environment,
301 then returning the non-empty string value of the variable"
302   (let ((g (getenv x))) (and (not (emptyp g)) g)))
303
304
305 ;;; On ABCL at least, the Operating System is no compile-time constant.
306
307 (defun default-temporary-directory ()
308   (flet ((f (s v d) (format nil "~A~A" (or (getenv v) d (error "No temporary directory!")) s)))
309     (let ((dir (cond
310                  ((os-unix-p) (f #\/ "TMP" "/tmp"))
311                  ((os-windows-p) (f #\\ "TEMP" nil))))
312           #+mcl (dir (probe-posix dir)))
313       (pathname dir))))
314
315
316 ;;;; ----- User-visible variables, 2: Control XCVB -----
317
318 ;;; These variables are shared with XCVB itself.
319
320 (defvar *lisp-implementation-type*
321   ;; TODO: test on all OS and implementation platform combinations!
322   #+abcl :abcl #+allegro :allegro
323   #+clisp :clisp #+clozure :ccl #+cmu :cmucl #+cormanlisp :corman
324   #+ecl :ecl #+gcl :gcl #+genera :genera
325   #+lispworks-personal-edition :lispworks-personal
326   #+(and lispworks (not lispworks-personal-edition)) :lispworks
327   #+mcl :mcl #+sbcl :sbcl #+scl :scl #+xcl :xcl
328   #-(or abcl allegro clisp clozure cmu cormanlisp
329         ecl gcl genera lispworks mcl sbcl scl xcl)
330   (error "Your Lisp implementation is not supported by the XCVB driver (yet). Please help.")
331   "Type of Lisp implementation for the target system. A keyword.
332   Default: same as XCVB itself.")
333
334 (defvar *lisp-executable-pathname* nil
335   "Path to the Lisp implementation to use for the target system.
336   NIL, or a string.
337   Default: what's in your PATH.")
338
339 (defvar *lisp-image-pathname* nil
340   "What path to a Lisp image do we need invoke the target Lisp with?
341   Default: whatever's the default for your implementation.")
342
343 (defvar *lisp-implementation-directory*
344   (or #+clozure (namestring (ccl::ccl-directory))
345       #+gcl (namestring system::*system-directory*)
346       #+sbcl (namestring (sb-int:sbcl-homedir-pathname)))
347   "Where is the home directory for the Lisp implementation,
348   in case we need it to (require ...) special features?
349   Default: whatever's the default for your implementation.")
350
351 (defvar *lisp-flags* :default
352   ;;; TODO: add support for overriding this feature at the command-line?
353   "What options do we need invoke the target Lisp with?
354 A list of strings, or the keyword :DEFAULT.")
355
356 (defvar *features-defined* nil
357   "What additional features to define in the target image")
358
359 (defvar *features-undefined* nil
360   "What additional features to undefine in the target image")
361
362 (defvar *disable-cfasls* nil
363   "Should we disable CFASL support when the target Lisp has it?")
364
365 (defvar *xcvb-verbosity* 5
366   "Level of verbosity of XCVB:
367   0 - silent except for emergency
368   5 - usual warnings
369   9 - plenty of debug info")
370
371 (defvar *lisp-allow-debugger* nil
372   "Should we allow interactive debugging of failed build attempts?")
373
374 (defvar *cache* nil
375   "where to store object files, etc.
376 NIL: default to $XDG_CACHE_HOME/xcvb/ or $HOME/.cache/xcvb/, see docs")
377
378 (defvar *object-cache* nil
379   "Path to the object cache.
380 NIL: default to *cache*/*implementation-identifier*/, see docs")
381
382 (defvar *workspace* nil
383   "where to store test and intermediate files private to current run
384 NIL: default to <current-directory>/workspace/, see docs")
385
386 (defvar *install-prefix* nil
387   "where to install files.
388 NIL: default to /usr/local/, see docs
389 \"/\": default to /, with special defaults for other paths.
390 T: use home directory with special defaults for other paths below.")
391
392 (defvar *install-program* nil
393   "where to install program 'binary' (executable) files.
394 NIL: default to *install-prefix*/bin, see docs")
395
396 (defvar *install-configuration* nil
397   "where to install configuration files.
398 NIL: default to *install-prefix*/etc, see docs")
399
400 (defvar *install-data* nil
401   "where to install shared (architecture-independent) data files.
402 NIL: default to *install-prefix*/share, see docs")
403
404 (defvar *install-library* nil
405   "where to install library (architecture-dependent) files.
406 NIL: default to *install-prefix*/lib, see docs")
407
408 (defvar *install-image* nil
409   "where to install common-lisp image (architecture- and implementation- dependent) files.
410 NIL: default to *install-library*/common-lisp/images/, see docs")
411
412 (defvar *install-lisp* nil
413   "where to install common-lisp source code and systems, etc.
414 NIL: default to *install-data*/common-lisp/, see docs")
415
416 (defvar *temporary-directory* (default-temporary-directory)
417   "pathname of directory where to store temporary files")
418
419 (defvar *use-base-image* t
420   "Should we be using a base image for all builds?")
421
422
423 ;;; These variables are specific to a master controlling XCVB as a slave.
424
425 (defvar *xcvb-program* "xcvb"
426   "Path to the XCVB binary (a string), OR t if you want to use an in-image XCVB")
427
428 (defvar *required-xcvb-version* "0.577"
429   "Minimal version of XCVB required for use with this version of the xcvb-driver")
430
431 (defvar *source-registry* nil
432   "CL source registry specification. A sexp or string.
433 Will override the shell variable CL_SOURCE_REGISTRY when calling slaves.")
434
435 (defvar *xcvb-setup* nil
436   "Lisp file to load to setup the target build system, if any")
437
438 (defvar *manifest* nil
439   ;; Note that older versions are kept in the tail, documenting the command history,
440   ;; without affecting the behavior of ASSOC on the alist.
441   "an alist of the XCVB load commands executed in this image,
442 with associated pathnames and tthsums.")
443
444
445 ;;;; ---- More utilities -----
446
447 ;;; To be portable to CCL and more, we need to explicitly flush stream buffers.
448
449 (defun finish-outputs ()
450   "Finish output on the main output streams.
451 Useful for portably flushing I/O before user input or program exit."
452   (dolist (s (list *stderr* *error-output* *standard-output* *trace-output*))
453     (ignore-errors (finish-output s)))
454   (values))
455
456 (defun format! (stream format &rest args)
457   "Just like format, but call finish-outputs before and after the output."
458   (finish-outputs)
459   (apply 'format stream format args)
460   (finish-output stream))
461
462
463 ;;; Pathname helpers
464
465 (defun pathname-directory-pathname (pathname)
466   "Pathname for the directory containing given PATHNAME"
467   (make-pathname :name nil :type nil :version nil :defaults pathname))
468
469 (defun native-namestring (x)
470   "From a CL pathname, a namestring suitable for use by the OS shell"
471   (let ((p (pathname x)))
472     #+clozure (ccl:native-translated-namestring p)
473     #+(or cmu scl) (ext:unix-namestring p nil)
474     #+sbcl (sb-ext:native-namestring p)
475     #-(or clozure cmu sbcl scl) (namestring p)))
476
477 (defun parse-native-namestring (x)
478   "From a native namestring suitable for use by the OS shell, a CL pathname"
479   (check-type x string)
480   #+clozure (ccl:native-to-pathname x)
481   #+sbcl (sb-ext:parse-native-namestring x)
482   #-(or clozure sbcl) (parse-namestring x))
483
484
485 ;;; Output helpers
486
487 (defgeneric call-with-output (x thunk)
488   (:documentation
489    ;; code from fare-utils base/streams where it's now named
490    ;; call-with-output-stream to avoid the package clash in a lot of my code.
491    "Calls FUN with an actual stream argument, behaving like FORMAT with respect to stream'ing:
492 If OBJ is a stream, use it as the stream.
493 If OBJ is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
494 If OBJ is T, use *STANDARD-OUTPUT* as the stream.
495 If OBJ is a string with a fill-pointer, use it as a string-output-stream.
496 Otherwise, signal an error.")
497   (:method ((x null) thunk)
498     (declare (ignorable x))
499     (with-output-to-string (s) (funcall thunk s)))
500   (:method ((x (eql t)) thunk)
501     (declare (ignorable x))
502     (funcall thunk *standard-output*) nil)
503   #-genera
504   (:method ((x stream) thunk)
505     (funcall thunk x) nil)
506   (:method ((x string) thunk)
507     (assert (fill-pointer x))
508     (with-output-to-string (s x) (funcall thunk s)))
509   (:method (x thunk)
510     (declare (ignorable thunk))
511     (cond
512       #+genera
513       ((typep x 'stream) (funcall thunk x) nil)
514       (t (error "not a valid stream designator ~S" x)))))
515
516 (defmacro with-output ((x &optional (value x)) &body body)
517   "Bind X to an output stream, coercing VALUE (default: previous binding of X)
518 as per FORMAT, and evaluate BODY within the scope of this binding."
519   `(call-with-output ,value #'(lambda (,x) ,@body)))
520
521
522 ;;; Input helpers
523
524 (defvar *default-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default)
525   "default element-type for open (depends on the current CL implementation)")
526
527 (defun call-with-input-file (pathname thunk
528                              &key (element-type *default-element-type*)
529                              (external-format :default))
530   "Open FILE for input with given options, call THUNK with the resulting stream."
531   (with-open-file (s pathname :direction :input
532                      :element-type element-type :external-format external-format
533                      :if-does-not-exist :error)
534     (funcall thunk s)))
535
536 (defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body)
537   (declare (ignore element-type external-format))
538   `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))
539
540
541 ;;; Using temporary files
542
543 (defun call-with-temporary-file
544     (thunk &key
545      prefix keep (direction :io)
546      (element-type *default-element-type*)
547      (external-format :default))
548   (check-type direction (member :output :io))
549   (loop
550     :with prefix = (or prefix (format nil "~Axm" (native-namestring *temporary-directory*)))
551     :for counter :from (random (ash 1 32))
552     :for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
553      ;; TODO: on Unix, do something about umask
554      ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
555      ;; TODO: on Unix, use CFFI and mkstemp -- but the master is precisely meant to not depend on CFFI or on anything! Grrrr.
556     (with-open-file (stream pathname
557                             :direction direction
558                             :element-type element-type :external-format external-format
559                             :if-exists nil :if-does-not-exist :create)
560       #+cormanlisp (format t "~&Using pathname ~S~%" pathname)
561       (when stream
562         (return
563           (if keep
564               (funcall thunk stream pathname)
565               (unwind-protect
566                    (funcall thunk stream pathname)
567                 (ignore-errors (delete-file pathname)))))))))
568
569 (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
570                                 (pathname (gensym "PATHNAME") pathnamep)
571                                 prefix keep direction element-type external-format)
572                                &body body)
573   "Evaluate BODY where the symbols specified by keyword arguments
574 STREAM and PATHNAME are bound corresponding to a newly created temporary file
575 ready for I/O. Unless KEEP is specified, delete the file afterwards."
576   (check-type stream symbol)
577   (check-type pathname symbol)
578   `(flet ((think (,stream ,pathname)
579             ,@(unless pathnamep `((declare (ignore ,pathname))))
580             ,@(unless streamp `((when ,stream (close ,stream))))
581             ,@body))
582      #-gcl (declare (dynamic-extent #'think))
583      (call-with-temporary-file
584       #'think
585       ,@(when direction `(:direction ,direction))
586       ,@(when prefix `(:prefix ,prefix))
587       ,@(when keep `(:keep ,keep))
588       ,@(when element-type `(:element-type ,element-type))
589       ,@(when external-format `(:external-format external-format)))))
590
591
592 ;;; Reading helpers
593
594 (defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
595   "Establish safe CL reader options around the evaluation of BODY"
596   `(call-with-safe-io-syntax (lambda () ,@body) :package ,package))
597
598 (defun call-with-safe-io-syntax (thunk &key (package :cl))
599   (with-standard-io-syntax ()
600     (let ((*package* (find-package package))
601           (*print-readably* nil)
602           (*print-escape* t)
603           (*read-eval* nil))
604       (funcall thunk))))
605
606 (defun read-function (string)
607   "Read a form from a string in function context, return a function"
608   (eval `(function ,(read-from-string string))))
609
610 (defun read-first-file-form (pathname &key (package :cl) eof-error-p eof-value)
611   "Reads the first form from the top of a file"
612   (with-safe-io-syntax (:package package)
613     (with-input-file (in pathname)
614       (read in eof-error-p eof-value))))
615
616
617 ;;; String utilities
618
619 (defun string-prefix-p (prefix string)
620   "Does STRING begin with PREFIX?"
621   (let* ((x (string prefix))
622          (y (string string))
623          (lx (length x))
624          (ly (length y)))
625     (and (<= lx ly) (string= x y :end2 lx))))
626
627 (defun string-suffix-p (string suffix)
628   "Does STRING end with SUFFIX?"
629   (let* ((x (string string))
630          (y (string suffix))
631          (lx (length x))
632          (ly (length y)))
633     (and (<= ly lx) (string= x y :start1 (- lx ly)))))
634
635 (defun string-enclosed-p (prefix string suffix)
636   "Does STRING begin with PREFIX and end with SUFFIX?"
637   (and (string-prefix-p prefix string)
638        (string-suffix-p string suffix)))
639
640
641 ;;;; Slurping streams
642
643 (defun copy-stream-to-stream (input output &key (element-type 'character))
644   "Copy the contents of the INPUT stream into the OUTPUT stream,
645 using WRITE-SEQUENCE and a sensibly sized buffer."
646   (with-open-stream (input input)
647     (loop :with length = 8192
648       :for buffer = (make-array length :element-type element-type)
649       :for end = (read-sequence buffer input)
650       :until (zerop end)
651       :do (write-sequence buffer output :end end)
652       :do (when (< end length) (return)))))
653
654 (defun copy-stream-to-stream-line-by-line (input output &key prefix)
655   "Copy the contents of the INPUT stream into the OUTPUT stream,
656 reading contents line by line."
657   (with-open-stream (input input)
658     (loop :for (line eof) = (multiple-value-list (read-line input nil nil))
659       :while line :do
660       (when prefix (princ prefix output))
661       (princ line output)
662       (unless eof (terpri output))
663       (finish-output output)
664       (when eof (return)))))
665
666 (defun slurp-stream-string (input &key (element-type 'character))
667   "Read the contents of the INPUT stream as a string"
668   (with-open-stream (input input)
669     (with-output-to-string (output)
670       (copy-stream-to-stream input output :element-type element-type))))
671
672 (defun slurp-stream-lines (input)
673   "Read the contents of the INPUT stream as a list of lines"
674   (with-open-stream (input input)
675     (loop :for l = (read-line input nil nil) :while l :collect l)))
676
677 (defun slurp-stream-forms (input)
678   "Read the contents of the INPUT stream as a list of forms"
679   (with-open-stream (input input)
680     (loop :with eof = '#:eof
681       :for form = (read input nil eof)
682       :until (eq form eof) :collect form)))
683
684 (defun slurp-file-string (file &rest keys)
685   "Open FILE with option KEYS, read its contents as a string"
686   (apply 'call-with-input-file file 'slurp-stream-string keys))
687
688 (defun slurp-file-lines (file &rest keys)
689   "Open FILE with option KEYS, read its contents as a list of lines"
690   (apply 'call-with-input-file file 'slurp-stream-lines keys))
691
692 (defun slurp-file-forms (file &rest keys)
693   "Open FILE with option KEYS, read its contents as a list of forms"
694   (apply 'call-with-input-file file 'slurp-stream-forms keys))
695
696
697 ;;;; ----- Current directory -----
698 ;; TODO: make it work on all supported implementations
699
700 (defun getcwd ()
701   "Get the current working directory as per POSIX getcwd(3)"
702   (or #+clisp (ext:default-directory)
703       #+clozure (ccl:current-directory)
704       #+sbcl (sb-posix:getcwd)
705       (error "getcwd not supported on your implementation")))
706
707 (defun chdir (x)
708   "Change current directory, as per POSIX chdir(2)"
709   (when (pathnamep x) (setf x (native-namestring x)))
710   (or #+clisp (ext:cd x)
711       #+clozure (setf (ccl:current-directory) x)
712       #+sbcl (sb-posix:chdir x)
713       (error "chdir not supported on your implementation")))
714
715 (defun call-with-current-directory (dir thunk)
716   (if dir
717       (let* ((dir (truename (merge-pathnames (pathname-directory-pathname dir))))
718              (*default-pathname-defaults* dir)
719              (cwd (getcwd)))
720         (chdir dir)
721         (unwind-protect
722              (funcall thunk)
723           (chdir cwd)))
724       (funcall thunk)))
725
726 (defmacro with-current-directory ((dir) &body body)
727   "Call BODY while the POSIX current working directory is set to DIR"
728   `(call-with-current-directory ,dir #'(lambda () ,@body)))
729
730
731 ;;;; ---- Build and Execution control ----
732
733 ;;; Optimization settings
734
735 (defvar *previous-optimization-settings* nil)
736 (defun get-optimization-settings ()
737   "Get current compiler optimization settings, ready to PROCLAIM again"
738   (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
739     #-(or clisp clozure cmu sbcl scl)
740     (warn "xcvb-driver::get-optimization-settings does not support your implementation. Please help me fix that.")
741     #.`(loop :for x :in settings
742          ,@(or #+clozure '(:for v :in '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*))
743                #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
744          :for y = (or #+clisp (gethash x system::*optimize*)
745                       #+clozure (symbol-value v)
746                       #+(or cmu scl) (funcall f c::*default-cookie*)
747                       #+sbcl (cdr (assoc x sb-c::*policy*)))
748          :when y :collect (list x y))))
749 (defun proclaim-optimization-settings ()
750   "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
751   (proclaim `(optimize ,@*optimization-settings*))
752   (when *debugging*
753     (let ((settings (get-optimization-settings)))
754       (unless (equal *previous-optimization-settings* settings)
755         (setf *previous-optimization-settings* settings)
756         (format! *error-output* "~&Optimization settings: ~S~%" settings)))))
757
758 ;;; Performance tweaks
759
760 (defun tweak-implementation ()
761   "Common performance tweaks for various CL implementations."
762   #+sbcl
763   (progn
764     ;; add ample margin between GC's: 400 MiB
765     (setf (sb-ext:bytes-consed-between-gcs) (* 400 1024 1024))
766     ;; add ample margin for *next* GC: 200 MiB
767     (incf (sb-alien:extern-alien "auto_gc_trigger" sb-alien:long) (* 200 1024 1024))
768     #|(sb-ext:gc :full t)|#)
769   #+clozure
770   (progn
771     (ccl::configure-egc 32768 65536 98304)
772     (ccl::set-lisp-heap-gc-threshold (* 384 1024 1024))
773     (ccl::use-lisp-heap-gc-threshold)
774     #|(ccl:gc)|#)
775   nil)
776
777 ;;; Debugging
778
779 (defun debugging (&optional (debug t))
780   "Enable (or with NIL argument, disable) verbose debugging output from XCVB"
781   (setf *debugging* debug
782         *load-verbose* debug
783         *load-print* debug
784         #+clisp custom:*compile-warnings* #+clisp debug
785         *compile-verbose* debug
786         *compile-print* debug
787         *optimization-settings* '((speed 2) (safety 3) (compilation-speed 0) (debug 3)))
788   (proclaim-optimization-settings)
789   (cond
790     (debug
791      #+sbcl (sb-ext:enable-debugger)
792      #+clisp (ext:set-global-handler nil nil))
793     (t
794      #+sbcl (sb-ext:disable-debugger)
795      #+clisp (ext:set-global-handler 'error #'bork)))
796   (values))
797
798 (defun print-backtrace (out)
799   "Print a backtrace (implementation-defined)"
800   (declare (ignorable out))
801   #+clozure (let ((*debug-io* out))
802               (ccl:print-call-history :count 100 :start-frame-number 1)
803               (finish-output out))
804   #+sbcl
805   (sb-debug:backtrace
806    #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream 'most-positive-fixnum)
807    out))
808
809 ;;; Profiling
810 (defun call-with-maybe-profiling (thunk what goal)
811   (when *debugging*
812     (format! *trace-output* "~&Now ~S~&" what))
813   (if *profiling*
814     (let* ((start-time (get-internal-real-time))
815            (values (multiple-value-list (funcall thunk)))
816            (end-time (get-internal-real-time))
817            (duration (coerce (/ (- end-time start-time) internal-time-units-per-second) 'double-float)))
818       (format! *trace-output* "~&~S~&" `(:profiling ,what :from ,goal :duration ,duration))
819       (apply #'values values))
820     (funcall thunk)))
821 (defmacro with-profiling (what &body body)
822   "Macro to run a BODY of code, and
823 profile it under some profiling name when *PROFILING* is enabled."
824   `(call-with-maybe-profiling #'(lambda () ,@body) ,what *goal*))
825
826 ;;; Build initialization
827
828 (defun setup-environment ()
829   "Setup the XCVB environment with respect to debugging, profiling, performance"
830   (debugging (getenvp "XCVB_DEBUGGING"))
831   (setf *profiling* (getenvp "XCVB_PROFILING"))
832   (tweak-implementation))
833
834 ;;; Exiting properly or im-
835 (defun quit (&optional (code 0) (finish-output t))
836   "Quits from the Lisp world, with the given exit status if provided.
837 This is designed to abstract away the implementation specific quit forms."
838   (when *debugging*
839     (format! *stderr* "~&Quitting with code ~A~%" code))
840   (when finish-output ;; essential, for ClozureCL, and for standard compliance.
841     (finish-outputs))
842   #+(or abcl xcl) (ext:quit :status code)
843   #+allegro (excl:exit code :quiet t)
844   #+clisp (ext:quit code)
845   #+clozure (ccl:quit code)
846   #+cormanlisp (win32:exitprocess code)
847   #+(or cmu scl) (unix:unix-exit code)
848   #+ecl (si:quit code)
849   #+gcl (lisp:quit code)
850   #+genera (error "You probably don't want to Halt the Machine.")
851   #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
852   #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
853   #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
854                  (quit (find-symbol* :quit :sb-ext nil)))
855              (cond
856                (exit `(,exit :code code :abort (not finish-output)))
857                (quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
858   #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl xcl)
859   (error "xcvb driver: Quitting not implemented"))
860
861 (defun shell-boolean (x)
862   "Quit with a return code that is 0 iff argument X is true"
863   (quit (if x 0 1)))
864
865 (defun die (format &rest arguments)
866   "Die in error with some error message"
867   (format! *stderr* "~&")
868   (apply #'format! *stderr* format arguments)
869   (format! *stderr* "~&")
870   (quit 99))
871
872 (defun bork (condition)
873   "Depending on whether *DEBUGGING* is set, enter debugger or die"
874   (format! *stderr* "~&BORK:~%~A~%" condition)
875   (cond
876     (*debugging*
877      (invoke-debugger condition))
878     (t
879      (print-backtrace *stderr*)
880      (die "~A" condition))))
881
882 (defun call-with-coded-exit (thunk)
883   (handler-bind ((error #'bork))
884     (funcall thunk)
885     (quit 0)))
886
887 (defmacro with-coded-exit ((&optional) &body body)
888   "Run BODY, BORKing on error and otherwise exiting with a success status"
889   `(call-with-coded-exit #'(lambda () ,@body)))
890
891
892 ;;;; ----- Pathname mappings -----
893 ;; TODO: make it work, test it.
894
895 (defvar *pathname-mappings* (make-hash-table :test 'equal)
896   "Mappings from xcvb fullname to plist of
897  (physical) :pathname, :logical-pathname, :tthsum digest, etc.")
898
899 (defun register-fullname (&key fullname pathname tthsum logical-pathname)
900   (setf (gethash fullname *pathname-mappings*)
901         (list :truename (truename (merge-pathnames pathname))
902               :pathname pathname :logical-pathname logical-pathname
903               :tthsum tthsum))
904   (values))
905 (defun register-fullnames (mappings &key (defaults *load-truename*))
906   (let ((*default-pathname-defaults*
907          (or (and defaults (truename (pathname-directory-pathname defaults)))
908              *default-pathname-defaults*)))
909     (dolist (m mappings)
910       (apply 'register-fullname m))))
911 (defun registered-fullname-pathname (fullname)
912   (let ((plist (gethash fullname *pathname-mappings*)))
913     (or (getf plist :logical-pathname) (getf plist :truename))))
914 (defun load-fullname-mappings (file)
915   (let ((tn (truename file)))
916     (register-fullnames (read-first-file-form tn) :defaults tn)))
917
918
919 ;;;; ----- Filtering conditions while building -----
920
921 (defun match-condition-p (x condition)
922   "Compare received CONDITION to some pattern X"
923   (etypecase x
924     (symbol (typep condition x))
925     (function (funcall x condition))
926     (string (and (typep condition 'simple-condition)
927                  #+(or clozure cmu scl) ; Note: on SBCL, always bound, and testing triggers warning
928                  (slot-boundp condition
929                               #+clozure 'ccl::format-control
930                               #+(or cmu scl) 'conditions::format-control)
931                  (ignore-errors (equal (simple-condition-format-control condition) x))))))
932
933 (defun match-any-condition-p (condition conditions)
934   "match CONDITION against any of the patterns of CONDITIONS supplied"
935   (loop :for x :in conditions :thereis (match-condition-p x condition)))
936
937 (defun uninteresting-condition-p (condition)
938   "match CONDITION against any of the patterns of *UNINTERESTING-CONDITIONS*"
939   (match-any-condition-p condition *uninteresting-conditions*))
940
941 (defun fatal-condition-p (condition)
942   "match CONDITION against any of the patterns of *FATAL-CONDITIONS*"
943   (match-any-condition-p condition *fatal-conditions*))
944
945 (defun call-with-controlled-compiler-conditions (thunk)
946   (handler-bind
947       ((t
948         #'(lambda (condition)
949             ;; TODO: do something magic for undefined-function,
950             ;; save all of aside, and reconcile in the end of the virtual compilation-unit.
951             (cond
952               ((uninteresting-condition-p condition)
953                (muffle-warning condition))
954               ((fatal-condition-p condition)
955                (bork condition))))))
956     (funcall thunk)))
957
958 (defmacro with-controlled-compiler-conditions ((&optional) &body body)
959   "Run BODY while suppressing conditions patterned after *UNINTERESTING-CONDITIONS*"
960   `(call-with-controlled-compiler-conditions #'(lambda () ,@body)))
961
962 (defun call-with-controlled-loader-conditions (thunk)
963   (let ((*uninteresting-conditions*
964          (append
965           *uninteresting-load-conditions*
966           *uninteresting-conditions*)))
967     (call-with-controlled-compiler-conditions thunk)))
968
969 (defmacro with-controlled-loader-conditions ((&optional) &body body)
970   "Run BODY while suppressing conditions patterned after *UNINTERESTING-CONDITIONS* plus a few others that don't matter at load-time."
971   `(call-with-controlled-loader-conditions #'(lambda () ,@body)))
972
973 (defun save-forward-references (forward-references)
974   "Save forward reference conditions so they may be issued at a latter time,
975 possibly in a different process."
976   #+sbcl
977   (loop :for w :in sb-c::*undefined-warnings*
978     :for kind = (sb-c::undefined-warning-kind w) ; :function :variable :type
979     :for name = (sb-c::undefined-warning-name w)
980     :for symbol = (cond
981                     ((consp name)
982                      (unless (eq kind :function)
983                        (error "unrecognized warning ~S not a function?" w))
984                      (ecase (car name)
985                        ((setf)
986                         (assert (and (consp (cdr name)) (null (cddr name))) ())
987                                   (setf kind :setf-function)
988                         (second name))
989                        ((sb-pcl::slot-accessor)
990                         (assert (eq :global (second name)))
991                         (assert (eq 'boundp (fourth name)))
992                         (assert (null (nthcdr 4 name)))
993                         (setf kind :sb-pcl-global-boundp-slot-accessor)
994                         (third name))))
995                     (t
996                      (assert (member kind '(:function :variable :type)) ())
997                      name))
998     :for symbol-name = (symbol-name symbol)
999     :for package-name = (package-name (symbol-package symbol))
1000     :collect `(:undefined ,symbol-name ,package-name ,kind) :into undefined-warnings
1001     :finally (setf *deferred-warnings* undefined-warnings
1002                    sb-c::*undefined-warnings* nil))
1003   (when forward-references
1004     (with-open-file (s forward-references :direction :output :if-exists :supersede)
1005       (write *deferred-warnings* :stream s :pretty t :readably t)
1006       (terpri s))))
1007
1008 (defun call-with-xcvb-compilation-unit (thunk &key forward-references)
1009   (with-compilation-unit (:override t)
1010     (let ((*deferred-warnings* ())
1011           #+sbcl (sb-c::*undefined-warnings* nil))
1012       (multiple-value-prog1
1013           (with-controlled-compiler-conditions ()
1014             (funcall thunk))
1015         (save-forward-references forward-references)))))
1016
1017 (defmacro with-xcvb-compilation-unit ((&key forward-references) &body body)
1018   "Like WITH-COMPILATION-UNIT, but saving forward-reference issues
1019 for processing later (possibly in a different process)."
1020   `(call-with-xcvb-compilation-unit #'(lambda () ,@body) :forward-references ,forward-references))
1021
1022
1023 ;;;; ----- The xcvb-driver-command DSL for building Lisp code -----
1024
1025 (defun function-for-command (designator)
1026   (fdefinition (find-symbol* designator :xcvb-driver)))
1027
1028 (defun run-command (command)
1029   "Run a single command.
1030 Entry point for XCVB-DRIVER when used by XCVB's farmer"
1031   (proclaim-optimization-settings)
1032   (multiple-value-bind (head args)
1033       (etypecase command
1034         (symbol (values command nil))
1035         (cons (values (car command) (cdr command))))
1036     (apply (function-for-command head) args)))
1037
1038 (defun run-commands (commands)
1039   (map () #'run-command commands))
1040
1041 (defun do-run (commands)
1042   (let ((*stderr* *error-output*))
1043     (setup-environment)
1044     (run-commands commands)))
1045
1046 (defmacro run (&rest commands)
1047   "Run a series of XCVB-DRIVER commands, then exit.
1048 Entry point for XCVB-DRIVER when used by XCVB"
1049   `(with-coded-exit ()
1050     (do-run ',commands)))
1051
1052
1053 ;;;; ----- Simple build commands -----
1054
1055 ;;; Loading and evaluating code
1056
1057 (defun do-load (x)
1058   (with-controlled-loader-conditions ()
1059     (load x :verbose (>= *xcvb-verbosity* 8) :print (>= *xcvb-verbosity* 9))))
1060
1061 (defun load-file (x)
1062   (with-profiling `(:load-file ,x)
1063     (unless (do-load x)
1064       (error "Failed to load ~A" (list x)))))
1065
1066 (defun eval-string (string)
1067   "Evaluate a form read from a string"
1068   (with-controlled-loader-conditions ()
1069     (eval (read-from-string string))))
1070
1071 (defun cl-require (x)
1072   (with-profiling `(:require ,x)
1073     (require x)))
1074
1075 (defun load-stream (&optional (stream *standard-input*))
1076   "Portably read and evaluate forms from a STREAM."
1077   ;; GCL 2.6 can't load from a string-input-stream
1078   ;; ClozureCL 1.6 can only load from file input
1079   ;; Allegro 5, I don't remember but it must have been broken when I tested.
1080   #+(or gcl-pre2.7 clozure allegro)
1081   (with-controlled-loader-conditions ()
1082     (do ((eof '#:eof) (x t (read stream nil eof))) ((eq x eof)) (eval x)))
1083   #-(or gcl-pre2.7 clozure allegro)
1084   (do-load stream))
1085
1086 (defun load-string (string)
1087   "Portably read and evaluate forms from a STRING."
1088   (with-input-from-string (s string) (load-stream s)))
1089
1090
1091 ;;; ASDF support
1092
1093 (defun asdf-symbol (x)
1094   (find-symbol* x :asdf))
1095
1096 (defun load-asdf (x &key parallel (verbose *compile-verbose*)) ;; parallel loading requires POIU
1097   (with-profiling `(:asdf ,x)
1098     (with-controlled-loader-conditions ()
1099       (call :asdf :operate
1100             (asdf-symbol (if parallel :parallel-load-op :load-op))
1101             x :verbose verbose))))
1102
1103 (defparameter *asdf-version-required-for-xcvb* "2.019")
1104
1105 (defun require-asdf ()
1106   (funcall 'require "asdf") ;; work around CLISP annoyance
1107   (load-asdf :asdf) ;; upgrade early, avoid issues.
1108   (let ((required *asdf-version-required-for-xcvb*))
1109     (unless (call :asdf :version-satisfies (call :asdf :asdf-version) required)
1110       (error "XCVB requires ASDF ~A or later" required))))
1111
1112 (defun register-asdf-directory (x)
1113   (pushnew x (symbol-value (asdf-symbol :*central-registry*))))
1114
1115 (defun asdf-system-needs-compilation-p (system)
1116   "Takes a name of an asdf system (or the system itself) and a asdf operation
1117   and returns a boolean indicating whether or not anything needs to be done
1118   in order to perform the given operation on the given system.
1119   This returns whether or not the operation has already been performed,
1120   and none of the source files in the system have changed since then"
1121   (progv
1122       (list (asdf-symbol :*verbose-out*))
1123       (list (make-broadcast-stream))
1124     (let* ((op (make-instance (asdf-symbol :load-op)))
1125            (system (call :asdf :find-system system))
1126            (steps (call :asdf :traverse op system)))
1127       (and (member (asdf-symbol :compile-op) steps
1128                    :key (lambda (x) (type-of (car x)))) t))))
1129
1130 (defun asdf-systems-up-to-date-p (systems)
1131   "Takes a list of names of asdf systems, and
1132   exits lisp with a status code indicating
1133   whether or not all of those systems were up-to-date or not."
1134   (notany #'asdf-system-needs-compilation-p systems))
1135
1136 (defun asdf-systems-up-to-date (&rest systems)
1137   "Are all the loaded systems up to date?"
1138   (with-coded-exit ()
1139     (shell-boolean (asdf-systems-up-to-date-p systems))))
1140
1141
1142 ;;; Actually compiling
1143
1144 (defmacro with-determinism (goal &body body)
1145   "Attempt to recreate deterministic conditions for the building a component."
1146   `(call-with-determinism ,goal #'(lambda () ,@body)))
1147
1148 (defun seed-random-state (seed) ; seed is a integer
1149   (declare (ignorable seed))
1150   #+sbcl (sb-ext:seed-random-state seed)
1151   #+clozure
1152   (flet ((get-bits (&aux bits)
1153            (multiple-value-setq (seed bits) (floor seed ccl::mrg31k3p-limit))
1154            bits))
1155     (multiple-value-bind (x0 x1 x2 x3 x4 x5)
1156         (apply 'values (loop :repeat 6 :collect (get-bits)))
1157       (when (zerop (logior x0 x1 x2))
1158         (setf x0 (logior (get-bits) 1)))
1159       (when (zerop (logior x3 x4 x5))
1160         (setf x3 (logior (get-bits) 1)))
1161       (ccl::initialize-mrg31k3p-state x0 x1 x2 x3 x4 x5)))
1162   #-(or sbcl clozure) (make-random-state *initial-random-state*))
1163
1164 (defun call-with-determinism (seed thunk)
1165   ;;; The seed is an arbitrary object from (a hash of) which we initialize
1166   ;;; all sources of randomness and non-determinism in the file being compiled.
1167   ;;;
1168   ;;; We typically use as a seed the goal as opposed to the tthsum of some contents
1169   ;;; to give a greater chance to trivial modifications of the source text (e.g.
1170   ;;; comments and whitespace changes) to be without effect on the compilation output.
1171   ;;; We possibly should be using the tthsum instead of a sxhash,
1172   ;;; as provided by the master process.
1173   ;;;
1174   ;;; In SBCL, we'll also need to somehow disable the start-time slot of the
1175   ;;; (def!struct (source-info ...)) from main/compiler.lisp (package SB-C),
1176   ;;; and override the source location to point to some logical pathname.
1177   (let* ((hash (sxhash seed))
1178          (*gensym-counter* (* hash 10000))
1179          #+sbcl (sb-impl::*gentemp-counter* (* hash 10000))
1180          ;;; SBCL will hopefully export a better mechanism soon. See:
1181          ;;; https://bugs.launchpad.net/sbcl/+bug/310116
1182          (*random-state* (seed-random-state hash)))
1183     (funcall thunk)))
1184
1185 (defun do-compile-lisp (dependencies source fasl
1186                         &key #+sbcl cfasl #+ecl lisp-object around-compile)
1187   (let ((*goal* `(:compile-lisp ,source))
1188         (*default-pathname-defaults* (truename *default-pathname-defaults*)))
1189     (multiple-value-bind (output-truename warnings-p failure-p)
1190         (with-profiling `(:preparing-and-compiling ,source)
1191           (with-xcvb-compilation-unit ()
1192             (with-profiling `(:preparing-compilation-of ,source)
1193               (run-commands dependencies))
1194             (with-profiling `(:compiling ,source)
1195               (with-determinism `(:compiling ,source)
1196                 (multiple-value-prog1
1197                     ((lambda (thunk)
1198                        (if around-compile
1199                            (funcall (read-function around-compile) thunk)
1200                            (funcall thunk)))
1201                      (lambda ()
1202                        (apply #'compile-file source
1203                            :output-file (merge-pathnames (or #+ecl lisp-object fasl))
1204                            (append
1205                             #+sbcl (when cfasl `(:emit-cfasl ,(merge-pathnames cfasl)))
1206                             #+ecl (when lisp-object '(:system-p t))))))
1207                   #+ecl
1208                   (when lisp-object
1209                     (or (call :c :build-fasl
1210                               (merge-pathnames fasl)
1211                               :lisp-files (list (merge-pathnames lisp-object)))
1212                         (die "Failed to build ~S from ~S" fasl lisp-object))))))))
1213       (declare (ignorable warnings-p failure-p))
1214       (unless output-truename
1215         (die "Compilation Failed for ~A, no fasl created" source))
1216       #-clisp
1217       (when failure-p
1218         (die "Compilation Failed for ~A" source))
1219       #-(or clisp cmu ecl)
1220       (when warnings-p
1221         (die "Compilation Warned for ~A" source))))
1222   (values))
1223
1224 (defun compile-lisp (spec &rest dependencies)
1225   (apply 'do-compile-lisp dependencies spec))
1226
1227
1228 ;;;; ----- Dumping an image and running it -----
1229
1230 ;;; Resuming from an image with proper command-line arguments
1231
1232 (defparameter *arguments* nil
1233   "Command-line arguments")
1234
1235 (defparameter *dumped* nil
1236   "Is this a dumped image? As a standalone executable?")
1237
1238 (defun raw-command-line-arguments ()
1239   "Find what the actual command line for this process was."
1240   #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
1241   #+allegro (sys:command-line-arguments) ; default: :application t
1242   #+clisp (coerce (ext:argv) 'list)
1243   #+clozure (ccl::command-line-arguments)
1244   #+(or cmu scl) extensions:*command-line-strings*
1245   #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
1246   #+gcl si:*command-args*
1247   #+lispworks sys:*line-arguments-list*
1248   #+sbcl sb-ext:*posix-argv*
1249   #+xcl system:*argv*
1250   #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl)
1251   (error "raw-command-line-arguments not implemented yet"))
1252
1253 (defun command-line-arguments (&optional (raw (raw-command-line-arguments)))
1254   "Extract user arguments from command-line invocation of current process.
1255 Assume the calling conventions of an XCVB-generated script
1256 if we are not called from a directly executable image dumped by XCVB."
1257   (let* (#-abcl
1258          (cooked
1259           #+(or sbcl allegro) raw
1260           #-(or sbcl allegro)
1261           (if (eq *dumped* :executable)
1262               raw
1263               (member "--" raw :test 'string-equal))))
1264     #+abcl raw
1265     #-abcl (cdr cooked)))
1266
1267 (defun do-resume (&key (post-image-restart *post-image-restart*) (entry-point *entry-point*))
1268   (with-standard-io-syntax
1269     (when post-image-restart (load-string post-image-restart)))
1270   (with-coded-exit ()
1271     (when entry-point
1272       (let ((ret (apply entry-point *arguments*)))
1273         (if (typep ret 'integer)
1274             (quit ret)
1275             (quit 99))))))
1276
1277 (defun resume ()
1278   (setf *arguments* (command-line-arguments))
1279   (do-resume))
1280
1281 ;;; Dumping an image
1282
1283 #-ecl
1284 (defun dump-image (filename &key output-name executable pre-image-dump post-image-restart entry-point package)
1285   (declare (ignorable filename output-name executable pre-image-dump post-image-restart entry-point))
1286   (setf *dumped* (if executable :executable t))
1287   (setf *package* (find-package (or package :cl-user)))
1288   (with-standard-io-syntax
1289     (when pre-image-dump (load-string pre-image-dump))
1290     (setf *entry-point* (when entry-point (read-function entry-point)))
1291     (when post-image-restart (setf *post-image-restart* post-image-restart)))
1292   #-(or clisp clozure cmu lispworks sbcl)
1293   (when executable
1294     (error "Dumping an executable is not supported on this implementation! Aborting."))
1295   #+allegro
1296   (progn
1297     (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
1298     (excl:dumplisp :name filename :suppress-allegro-cl-banner t))
1299   #+clisp
1300   (apply #'ext:saveinitmem filename
1301    :quiet t
1302    :start-package *package*
1303    :keep-global-handlers nil
1304    :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x
1305    (when executable
1306      (list
1307       :norc t
1308       :script nil
1309       :init-function #'resume
1310       ;; :parse-options nil ;--- requires a non-standard patch to clisp.
1311       )))
1312   #+clozure
1313   (ccl:save-application filename :prepend-kernel t
1314                         :toplevel-function (when executable #'resume))
1315   #+(or cmu scl)
1316   (progn
1317    (ext:gc :full t)
1318    (setf ext:*batch-mode* nil)
1319    (setf ext::*gc-run-time* 0)
1320    (apply 'ext:save-lisp filename #+cmu :executable #+cmu t
1321           (when executable '(:init-function resume :process-command-line nil))))
1322   #+gcl
1323   (progn
1324    (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
1325    (si::save-system filename))
1326   #+lispworks
1327   (if executable
1328       (lispworks:deliver 'resume filename 0 :interface nil)
1329       (hcl:save-image filename :environment nil))
1330   #+sbcl
1331   (progn
1332     ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself
1333    (setf sb-ext::*gc-run-time* 0)
1334    (apply 'sb-ext:save-lisp-and-die filename
1335     :executable t ;--- always include the runtime that goes with the core
1336     (when executable (list :toplevel #'resume :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
1337   #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
1338   (die "Can't dump ~S: xcvb-driver doesn't support image dumping with this Lisp implementation.~%" filename))
1339
1340 ;;; DSL entry point to create images
1341 #-ecl
1342 (defun do-create-image (image dependencies &rest flags)
1343   (let ((*goal* `(create-image ,image))
1344         #+sbcl (*uninteresting-conditions*
1345                 (cons "undefined ~(~A~): ~S" *uninteresting-conditions*)))
1346     (with-controlled-compiler-conditions ()
1347       (run-commands dependencies))
1348     (apply #'dump-image image flags)))
1349
1350 #+ecl ;; wholly untested and probably buggy.
1351 (defun do-create-image (image dependencies &key
1352                         executable output-name pre-image-dump post-image-restart entry-point)
1353   (do-create-bundle image dependencies
1354                     :kind (if executable :program :shared-library)
1355                     :output-name output-name
1356                     :pre-image-dump pre-image-dump
1357                     :post-image-restart post-image-restart
1358                     :entry-point entry-point))
1359
1360 #+ecl
1361 (defun do-create-bundle (bundle dependencies
1362                          &rest keys
1363                          &key kind output-name pre-image-dump post-image-restart entry-point)
1364   (let ((*goal* `(create-bundle ,bundle ,dependencies ,@keys))
1365         (first-dep (car dependencies)))
1366     (multiple-value-bind (object-files manifest)
1367         (case (first first-dep)
1368           ((:load-manifest)
1369            (assert (null (rest dependencies)))
1370            (let ((manifest (read-first-file-form (second first-dep))))
1371              (values
1372               (loop :for l :in manifest :collect
1373                 (destructuring-bind (&key command parent pathname
1374                                      tthsum source-pathname source-tthsum) l
1375                   (declare (ignore tthsum source-pathname source-tthsum))
1376                   (assert (eq (car command) :load-file))
1377                   pathname))
1378               manifest)))
1379           (:load-file
1380            (loop :for l :in dependencies :collect
1381            (destructuring-bind (link-file pathname) l
1382              (assert (eq link-file :load-file))
1383              pathname)))
1384           (t
1385            (assert (null dependencies))))
1386       (c::builder
1387        kind (parse-namestring bundle)
1388        :lisp-files object-files
1389        :init-name (c::compute-init-name (or output-name bundle) :kind kind)
1390        :epilogue-code
1391        (when (eq kind :program)
1392          `(progn
1393             (setf xcvb-driver:*manifest*
1394                   ',(reverse manifest))
1395             ,(when pre-image-dump
1396                    `(load-string ,pre-image-dump))
1397             (setf *entry-point* ,(when entry-point `(read-function ,entry-point)))
1398             (setf *post-image-restart* ,post-image-restart)
1399             (resume))))))) ;; default behavior would be (si::top-level)
1400
1401 #+ecl
1402 (defun create-bundle (spec &rest dependencies)
1403   (destructuring-bind (bundle &rest keys) spec
1404     (apply 'do-create-bundle bundle dependencies keys)))
1405
1406 (defun create-image (spec &rest dependencies)
1407   (destructuring-bind (image &rest keys) spec
1408     (apply 'do-create-image image dependencies keys)))
1409
1410
1411 ;;;; ----- CFFI-grovel support -----
1412
1413 (defun process-cffi-grovel-file (input c exe output &key cc-flags)
1414   (destructuring-bind (input c exe output)
1415       (mapcar 'fullname-pathname (list input c exe output))
1416     (with-current-directory (exe)
1417       (progv (list (find-symbol* :*cc-flags* :cffi-grovel)) (list cc-flags)
1418         (call :cffi-grovel :generate-c-file input c)
1419         (call :cffi-grovel :cc-compile-and-link c exe)
1420         (call :cffi-grovel :invoke exe output)))))
1421
1422 (defun process-cffi-wrapper-file (input c so output &key cc-flags)
1423   (declare (ignore output)); see below
1424   (flet ((f (x) (native-namestring (merge-pathnames x))))
1425     (let* ((input (f input))
1426            (c (f c))
1427            (so (f so))
1428            ;;(output (f output))
1429            (*default-pathname-defaults* (pathname-directory-pathname so)))
1430       (progv (list (find-symbol* :*cc-flags* :cffi-grovel)) (list cc-flags)
1431         (with-standard-io-syntax
1432           (multiple-value-bind (c-file lisp-forms)
1433               (call :cffi-grovel :generate-c-lib-file input c)
1434             (declare (ignore c-file))
1435             (call :cffi-grovel :cc-compile-and-link c so :library t)
1436             (values (call :cffi-grovel :generate-bindings-file
1437                           c so lisp-forms c)
1438                     ;; currently use C instead of OUTPUT, due to output locations.
1439                     ;; ugly, but generate-bindings-file already adds .grovel-tmp.lisp
1440                     ;; to the output name, so we reuse the c name here. Sigh.
1441                     so)))))))
1442
1443 ;;; Magic strings. Do not change. Constants, except we can't portably use defconstant here.
1444 (defvar +xcvb-slave-greeting+ #.(format nil "Dear Master, here are your build commands:~%"))
1445 (defvar +xcvb-slave-farewell+ #.(format nil "~%Your desires are my orders, sincerely, XCVB.~%"))
1446
1447
1448 ;;;; ----- Escaping strings for the shell -----
1449
1450 (defun requires-escaping-p (token &key good-chars bad-chars)
1451   "Does this token require escaping, given the specification of
1452 either good chars that don't need escaping or bad chars that do need escaping,
1453 as either a recognizing function or a sequence of characters."
1454   (some
1455    (cond
1456      ((and good-chars bad-chars)
1457       (error "only one of good-chars and bad-chars can be provided"))
1458      ((functionp good-chars)
1459       (complement good-chars))
1460      ((functionp bad-chars)
1461       bad-chars)
1462      ((and good-chars (typep good-chars 'sequence))
1463       (lambda (c) (not (find c good-chars))))
1464      ((and bad-chars (typep bad-chars 'sequence))
1465       (lambda (c) (find c bad-chars)))
1466      (t (error "requires-escaping-p: no good-char criterion")))
1467    token))
1468
1469 (defun output-string (string &optional stream)
1470   (if stream
1471       (with-output (stream) (princ string stream))
1472       string))
1473
1474 (defun escape-token (token &key stream quote good-chars bad-chars escaper)
1475   "Call the ESCAPER function on TOKEN string if it needs escaping as per
1476 REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
1477 using STREAM as output (or returning result as a string if NIL)"
1478   (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars)
1479       (with-output (stream)
1480         (apply escaper token stream (when quote `(:quote ,quote))))
1481       (output-string token stream)))
1482
1483 (defun escape-windows-token-within-double-quotes (x &optional s)
1484   "Escape a string token X within double-quotes
1485 for use within a MS Windows command-line, outputing to S."
1486   (labels ((issue (c) (princ c s))
1487            (issue-backslash (n) (loop :repeat n :do (issue #\\))))
1488     (loop
1489       :initially (issue #\") :finally (issue #\")
1490       :with l = (length x) :with i = 0
1491       :for i+1 = (1+ i) :while (< i l) :do
1492       (case (char x i)
1493         ((#\") (issue-backslash 1) (issue #\") (incf i))
1494         ((#\\)
1495          (let* ((j (and (< i+1 l) (position-if-not
1496                                    (lambda (c) (eql c #\\)) x :start i+1)))
1497                 (n (- (or j l) i)))
1498            (cond
1499              ((null j)
1500               (issue-backslash (* 2 n)) (setf i l))
1501              ((and (< j l) (eql (char x j) #\"))
1502               (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
1503              (t
1504               (issue-backslash n) (setf i j)))))
1505         (otherwise
1506          (issue (char x i)) (incf i))))))
1507
1508 (defun escape-windows-token (token &optional s)
1509   "Escape a string TOKEN within double-quotes if needed
1510 for use within a MS Windows command-line, outputing to S."
1511   (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil
1512                 :escaper 'escape-windows-token-within-double-quotes))
1513
1514 (defun escape-sh-token-within-double-quotes (x s &key (quote t))
1515   "Escape a string TOKEN within double-quotes
1516 for use within a POSIX Bourne shell, outputing to S;
1517 omit the outer double-quotes if key argument :QUOTE is NIL"
1518   (when quote (princ #\" s))
1519   (loop :for c :across x :do
1520     (when (find c "$`\\\"") (princ #\\ s))
1521     (princ c s))
1522   (when quote (princ #\" s)))
1523
1524 (defun easy-sh-character-p (x)
1525   (or (alphanumericp x) (find x "+-_.,%@:/")))
1526
1527 (defun escape-sh-token (token &optional s)
1528   "Escape a string TOKEN within double-quotes if needed
1529 for use within a POSIX Bourne shell, outputing to S."
1530   (escape-token token :stream s :quote #\" :good-chars
1531                 #'easy-sh-character-p
1532                 :escaper 'escape-sh-token-within-double-quotes))
1533
1534 (defun escape-shell-token (token &optional s)
1535   (cond
1536     ((os-unix-p) (escape-sh-token token s))
1537     ((os-windows-p) (escape-windows-token token s))))
1538
1539 (defun escape-command (command &optional s
1540                        (escaper 'escape-shell-token))
1541   "Given a COMMAND as a list of tokens, return a string of the
1542 spaced, escaped tokens, using ESCAPER to escape."
1543   (etypecase command
1544     (string (output-string command s))
1545     (list (with-output (s)
1546             (loop :for first = t :then nil :for token :in command :do
1547               (unless first (princ #\space s))
1548               (funcall escaper token s))))))
1549
1550 (defun escape-windows-command (command &optional s)
1551   "Escape a list of command-line arguments into a string suitable for parsing
1552 by CommandLineToArgv in MS Windows"
1553     ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
1554     ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
1555   (escape-command command s 'escape-windows-token))
1556
1557 (defun escape-sh-command (command &optional s)
1558   "Escape a list of command-line arguments into a string suitable for parsing
1559 by /bin/sh in POSIX"
1560   (escape-command command s 'escape-sh-token))
1561
1562 (defun escape-shell-command (command &optional stream)
1563   "Escape a command for the current operating system's shell"
1564   (escape-command command stream 'escape-shell-token))
1565
1566 ;;;; ----- Running an external program -----
1567 ;;; Simple variant of run-program with no input, and capturing output
1568 ;;; On some implementations, may output to a temporary file...
1569
1570 (defgeneric slurp-input-stream (processor input-stream &key &allow-other-keys))
1571
1572 (defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys)
1573   (funcall function input-stream))
1574
1575 (defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys)
1576   (apply (first list) (cons input-stream (rest list))))
1577
1578 (defmethod slurp-input-stream ((output-stream stream) input-stream
1579                                &key element-type &allow-other-keys)
1580   (copy-stream-to-stream
1581    input-stream output-stream :element-type element-type))
1582
1583 (defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-keys)
1584   (declare (ignorable x))
1585   (slurp-stream-string stream))
1586
1587 (defmethod slurp-input-stream ((x (eql :string)) stream &key &allow-other-keys)
1588   (declare (ignorable x))
1589   (slurp-stream-string stream))
1590
1591 (defmethod slurp-input-stream ((x (eql :lines)) stream &key &allow-other-keys)
1592   (declare (ignorable x))
1593   (slurp-stream-lines stream))
1594
1595 (defmethod slurp-input-stream ((x (eql :form)) stream &key &allow-other-keys)
1596   (declare (ignorable x))
1597   (read stream))
1598
1599 (defmethod slurp-input-stream ((x (eql :forms)) stream &key &allow-other-keys)
1600   (declare (ignorable x))
1601   (slurp-stream-forms stream))
1602
1603 (define-condition subprocess-error (error)
1604   ((code :initform nil :initarg :code :reader subprocess-error-code)
1605    (command :initform nil :initarg :command :reader subprocess-error-command)
1606    (process :initform nil :initarg :process :reader subprocess-error-process))
1607   (:report (lambda (condition stream)
1608              (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]"
1609                      (subprocess-error-process condition)
1610                      (subprocess-error-command condition)
1611                      (subprocess-error-code condition)))))
1612
1613 (defun run-program/ (command
1614                      &rest keys
1615                      &key output ignore-error-status force-shell
1616                      (element-type *default-element-type*)
1617                      (external-format :default)
1618                      &allow-other-keys)
1619   "Run program specified by COMMAND,
1620 either a list of strings specifying a program and list of arguments,
1621 or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
1622 have its output processed by the OUTPUT processor function
1623 as per PROCESS-INPUT-STREAM,
1624 or merely output to the inherited standard output if it's NIL.
1625 Always call a shell (rather than directly execute the command)
1626 if FORCE-SHELL is specified.
1627 Issue an error if the process wasn't successful unless IGNORE-ERROR-STATUS
1628 is specified.
1629 Return the exit status code of the process that was called.
1630 Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
1631   (declare (ignorable ignore-error-status element-type external-format))
1632   (let ((s (find-symbol* 'run-program/ :quux-iolib nil)))
1633     (when s (return-from run-program/ (apply s command keys))))
1634   #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
1635   (error "RUN-PROGRAM/PROCESS-OUTPUT-STREAM not implemented for this Lisp")
1636   (labels (#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
1637            (run-program (command &key pipe)
1638              "runs the specified command (a list of program and arguments).
1639               If using a pipe, returns two values: process and stream
1640               If not using a pipe, returns one values: the process result;
1641               also, inherits the output stream."
1642              ;; NB: these implementations have unix vs windows set at compile-time.
1643              (let* ((wait (not pipe))
1644                     #-(and clisp os-windows)
1645                     (command
1646                      (etypecase command
1647                        #+os-unix (string `("/bin/sh" "-c" ,command))
1648                        #+os-unix (list command)
1649                        #+os-windows
1650                        (string
1651                         ;; NB: We do NOT add cmd /c here. You might want to.
1652                         #+(or allegro clozure) command
1653                         ;; NB: On other implementations, this is utterly bogus
1654                         ;; except in the most trivial cases where no quoting is needed.
1655                         ;; Use at your own risk.
1656                         #-(or allegro clozure) (list "cmd" "/c" command))
1657                        #+os-windows
1658                        (list
1659                         #+(or allegro clozure) (escape-windows-command command)
1660                         #-(or allegro clozure) command)))
1661                     ;; ClozureCL on Windows requires some magic until they fix
1662                     ;; http://trac.clozure.com/ccl/ticket/858
1663                     #+(and clozure os-windows) (command (list command))
1664                     (process*
1665                      (multiple-value-list
1666                       #+allegro
1667                       (excl:run-shell-command
1668                        #+os-unix (coerce (cons (first command) command) 'vector)
1669                        #+os-windows command
1670                        :input nil :output (and pipe :stream) :wait wait
1671                        #+os-windows :show-window #+os-windows (and pipe :hide))
1672                       #+clisp
1673                       (flet ((run (f &rest args)
1674                                (apply f `(,@args :input nil :wait ,wait :output
1675                                           ,(if pipe :stream :terminal)))))
1676                         (etypecase command
1677                           #+os-windows (run 'ext:run-shell-command command)
1678                           (list (run 'ext:run-program (car command)
1679                                      :arguments (cdr command)))))
1680                       #+lispworks
1681                       (system:run-shell-command
1682                        (cons "/usr/bin/env" command) ; lispworks wants a full path.
1683                        :input nil :output (and pipe :stream)
1684                        :wait wait :save-exit-status (and pipe t))
1685                       #+(or clozure cmu ecl sbcl scl)
1686                       (#+(or cmu ecl scl) ext:run-program
1687                        #+clozure ccl:run-program
1688                        #+sbcl sb-ext:run-program
1689                        (car command) (cdr command)
1690                        :input nil :wait wait
1691                        :output (if pipe :stream t)
1692                        . #.(append
1693                             #+(or clozure cmu ecl sbcl scl) '(:error t)
1694                             #+sbcl '(:search t
1695                                      #|:external-format external-format ; not in old SBCLs|#)))))
1696                     (process
1697                      #+(or allegro lispworks) (if pipe (third process*) (first process*))
1698                      #+ecl (third process*)
1699                      #-(or allegro lispworks ecl) (first process*))
1700                     (stream
1701                      (when pipe
1702                        #+(or allegro lispworks ecl) (first process*)
1703                        #+clisp (first process*)
1704                        #+clozure (ccl::external-process-output process)
1705                        #+(or cmu scl) (ext:process-output process)
1706                        #+sbcl (sb-ext:process-output process))))
1707                (values process stream)))
1708            #+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
1709            (process-result (process)
1710              ;; 1- wait
1711              #+(and clozure os-unix) (ccl::external-process-wait process)
1712              #+(or cmu scl) (ext:process-wait process)
1713              #+(and ecl os-unix) (ext:external-process-wait process)
1714              #+sbcl (sb-ext:process-wait process)
1715              ;; 2- extract result
1716              #+allegro (sys:reap-os-subprocess :pid process :wait t)
1717              #+clisp process
1718              #+clozure (nth-value 1 (ccl:external-process-status process))
1719              #+(or cmu scl) (ext:process-exit-code process)
1720              #+ecl (nth-value 1 (ext:external-process-status process))
1721              #+lispworks (system:pid-exit-status process :wait t)
1722              #+sbcl (sb-ext:process-exit-code process))
1723            (check-result (exit-code process)
1724              #+clisp
1725              (setf exit-code
1726                    (typecase exit-code (integer exit-code) (null 0) (t -1)))
1727              (unless (or ignore-error-status
1728                          (equal exit-code 0))
1729                (error 'subprocess-error :command command :code exit-code :process process))
1730              exit-code)
1731            (use-run-program ()
1732              #-(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl)
1733              (let ((pipe (and output t)))
1734                (multiple-value-bind (process stream)
1735                    (run-program command :pipe pipe)
1736                  (if output
1737                      (unwind-protect
1738                           (slurp-input-stream output stream)
1739                        (when stream (close stream))
1740                        (check-result (process-result process) process))
1741                      (unwind-protect
1742                           (check-result
1743                            #+(or allegro lispworks) ; when not capturing, returns the exit code!
1744                            process
1745                            #-(or allegro lispworks) (process-result process)
1746                            process))))))
1747            (system-command (command)
1748              (etypecase command
1749                (string (if (os-windows-p) (format nil "cmd /c ~A" command) command))
1750                (list (escape-shell-command
1751                       (if (os-unix-p) (cons "exec" command) command)))))
1752            (redirected-system-command (command out)
1753              (format nil (if (os-unix-p) "exec > ~*~A ; ~2:*~A" "~A > ~A")
1754                      (system-command command) (native-namestring out)))
1755            (system (command)
1756              #+(or abcl xcl) (ext:run-shell-command command)
1757              #+allegro
1758              (excl:run-shell-command command :input nil :output nil :wait t)
1759              #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl)
1760              (run-program command :pipe nil)
1761              #+ecl (ext:system command)
1762              #+cormanlisp (win32:system command)
1763              #+gcl (lisp:system command)
1764              #+(and lispworks os-windows)
1765              (system:call-system-showing-output
1766               command :show-cmd nil :prefix "" :output-stream nil)
1767              #+mcl (ccl::with-cstrs ((%command command)) (_system %command)))
1768            (call-system (command-string)
1769              (check-result (system command-string) nil))
1770            (use-system ()
1771              (if output
1772                  (with-temporary-file (:pathname tmp :direction :output)
1773                    (call-system (redirected-system-command command tmp))
1774                    (with-open-file (stream tmp
1775                                            :direction :input
1776                                            :if-does-not-exist :error
1777                                            :element-type element-type
1778                                            :external-format external-format)
1779                      (slurp-input-stream output stream)))
1780                  (call-system (system-command command)))))
1781     (if (and (not force-shell)
1782              #+(or clisp ecl) ignore-error-status
1783              #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) nil)
1784         (use-run-program)
1785         (use-system))))
1786
1787
1788 ;;;; ----- Common things to do with an external program -----
1789
1790 (defmacro run-program/process-output-stream (command output-processor &rest keys)
1791   (warn "run-program/process-output-stream has been superseded by run-program/")
1792   `(run-program/ ,command :output ,output-processor ,@keys))
1793
1794 (defmacro run-program/read-output-lines (command &rest keys)
1795   (warn "run-program/read-output-lines has been superseded by run-program/ ... :output :lines")
1796   `(run-program/ ,command :output :lines ,@keys))
1797
1798 (defmacro run-program/read-output-string (command &rest keys)
1799   (warn "run-program/read-output-string has been superseded by run-program/ ... :output :string")
1800   `(run-program/ ,command :output :string ,@keys))
1801
1802 (defmacro run-program/read-output-form (command &rest keys)
1803   (warn "run-program/read-output-form has been superseded by run-program/ ... :output :form")
1804   `(run-program/ ,command :output :form ,@keys))
1805
1806 (defmacro run-program/read-output-forms (command &rest keys)
1807   (warn "run-program/read-output-forms has been superseded by run-program/ ... :output :forms")
1808   `(run-program/ ,command :output :forms ,@keys))
1809
1810 (defmacro run-program/for-side-effects (command &rest keys)
1811   (warn "run-program/for-side-effects has been superseded by run-program/ ... :output nil")
1812   `(run-program/ ,command :output :forms ,@keys))
1813
1814 (defun run-program/echo-output (command &rest keys &key prefix (stream t) &allow-other-keys)
1815   (apply
1816    'run-program/ command
1817    :output `(copy-stream-to-stream-line-by-line ,stream :prefix ,prefix)
1818    keys))
1819
1820 ;;;; ----- Manifest: representing how an image was built or is to be built -----
1821
1822 ;;; Maintaining memory of which grains have been loaded in the current image.
1823 ;; TODO: fix brokenness. We need to distinguish
1824 ;; 1- either a grain or a virtual command that we issue, e.g. (:load-file (:fasl "/foo/bar"))
1825 ;; 2- the actual thing that the driver runs, e.g. (:load-file "/path/to/foo/bar.fasl")
1826 ;; The mapping can be done at one place or the other, but currently there's a big confusion!
1827 (defun process-manifest-entry (&rest entry &key command pathname tthsum &allow-other-keys)
1828   ;; also source source-tthsum source-pathname
1829   (unless (and tthsum
1830                (equal tthsum
1831                       (getf (find command *manifest* :test #'equal
1832                                   :key (lambda (x) (getf x :command)))
1833                             :tthsum))
1834                (progn
1835                  (when (>= *xcvb-verbosity* 8)
1836                    (format! *error-output* "~&Skipping XCVB command ~S ~@[from already loaded file ~S (tthsum: ~A)~]~%"
1837                             command pathname tthsum))
1838                  t))
1839     (when (>= *xcvb-verbosity* 7)
1840       (format! *error-output* "~&Loading XCVB grain ~S~@[ pathname: ~S~]~@[ (tthsum: ~A)~]~%"
1841                command pathname tthsum))
1842     (cond
1843       (pathname
1844        (assert (and (consp command) (eq :load-file (car command))
1845                     (consp (cdr command)) (null (cddr command))))
1846        (load pathname :verbose (>= *xcvb-verbosity* 8) :print (>= *xcvb-verbosity* 9)))
1847       (t
1848        (run-command command)))
1849     (push entry *manifest*)))
1850
1851 (defun process-manifest (manifest)
1852   (dolist (entry manifest)
1853     (apply 'process-manifest-entry entry)))
1854
1855 (defun initialize-manifest (pathname)
1856   (assert (not *manifest*))
1857   (setf *manifest* (reverse (read-first-file-form pathname))))
1858 (defun load-manifest (pathname)
1859   (process-manifest (read-first-file-form pathname)))
1860
1861 ;;;; ----- XCVB automagic bootstrap: creating XCVB if not there yet -----
1862 (defvar *xcvb-present* nil)
1863
1864 (defun default-xcvb-program ()
1865   (require-asdf)
1866   (native-namestring
1867    (call :asdf :subpathname (call :asdf :user-homedir)
1868          (format nil ".cache/common-lisp/bin/~(~A~@[-~A~]~)/xcvb"
1869                  (call :asdf :operating-system) (call :asdf :architecture)))))
1870
1871 (defun xcvb-present-p (&optional (program *xcvb-program*))
1872   ;; returns the resolved path to xcvb if present
1873   (or (and (equal program *xcvb-present*) program)
1874       (etypecase program
1875         ((eql t) (and (find-package :xcvb) (setf *xcvb-present* t)))
1876         (string
1877          (and
1878           (string-prefix-p "XCVB version "
1879                            (run-program/
1880                             (list program "version")
1881                             :ignore-error-status t :output :string))
1882           (setf *xcvb-present* program)))
1883         (pathname
1884          (xcvb-present-p (native-namestring program))))
1885       (when (equal program "xcvb")
1886         (let ((default (default-xcvb-program)))
1887           (assert (not (equal default "xcvb")))
1888           (xcvb-present-p default)))
1889       (setf *xcvb-present* nil)))
1890
1891 (declaim (ftype (function (t) string) build-xcvb)) ; avoid warning on forward reference.
1892
1893 (defun create-xcvb-program (&optional (program *xcvb-program*))
1894   ;; Ugly: May side-effect *xcvb-program* to point to the resolved location of xcvb.
1895   (when (equal program "xcvb")
1896     (setf program (default-xcvb-program))
1897     (when (equal *xcvb-program* "xcvb")
1898       (setf *xcvb-program* program)))
1899   (require-asdf)
1900   (load-asdf :xcvb-bootstrap)
1901   (funcall 'build-xcvb program))
1902
1903 (defun require-xcvb ()
1904   (require-asdf)
1905   (call :asdf :load-system :xcvb)
1906   t)
1907
1908 (defun ensure-xcvb-present (&optional (program *xcvb-program*))
1909   ;; returns the resolved path to the xcvb binary
1910   (or (xcvb-present-p program)
1911       (etypecase program
1912         ((eql t) (require-xcvb))
1913         ((or string pathname) (create-xcvb-program program)))))
1914
1915
1916 ;;;; ----- XCVB master: calling XCVB -----
1917 ;;; Run a slave, obey its orders. (who's the master?)
1918 ;;; TODO: detect whether XCVB is installed or reachable, have fall back plan
1919 ;;;  1- fall back to executing a lisp that invokes asdf to bootstrap xcvb
1920 ;;;   (requires a merge of lisp-invocation into driver) (use SBCL? clisp? ccl?)
1921 ;;;  2- fall back to loading xcvb in the current image
1922
1923 (eval-when (:compile-toplevel :load-toplevel :execute)
1924   (defparameter *bnl-keys-with-defaults*
1925     '((xcvb-program *xcvb-program*)
1926       (required-xcvb-version *required-xcvb-version*)
1927       (setup *xcvb-setup*)
1928       (source-registry *source-registry*)
1929       (output-path nil)
1930       (lisp-implementation *lisp-implementation-type*)
1931       (lisp-binary-path *lisp-executable-pathname*)
1932       (lisp-image-path *lisp-image-pathname*)
1933       (features-defined *features-defined*)
1934       (features-undefined *features-undefined*)
1935       (disable-cfasl *disable-cfasls*)
1936       (use-base-image *use-base-image*)
1937       (cache *cache*)
1938       (object-cache *object-cache*)
1939       (workspace *workspace*)
1940       (install-prefix *install-prefix*)
1941       (install-program *install-program*)
1942       (install-configuration *install-configuration*)
1943       (install-data *install-data*)
1944       (install-library *install-library*)
1945       (install-image *install-image*)
1946       (install-lisp *install-lisp*)
1947       (verbosity *xcvb-verbosity*)
1948       (debugging *lisp-allow-debugger*)
1949       (profiling nil)))
1950   (defparameter *bnl-keys* (mapcar #'car *bnl-keys-with-defaults*)))
1951
1952 (defun build-slave-command-line (build &key . #.*bnl-keys-with-defaults*)
1953   (flet ((list-option-arguments (string values)
1954            (loop
1955              :for value :in values
1956              :nconc (list string value))))
1957     (macrolet
1958         ((to-option-name (name)
1959                  (format nil "--~(~a~)" name))
1960          (pathname-option (var)
1961            `(when ,var
1962               (list (to-option-name ,var) (native-namestring ,var))))
1963          (string-option (var)
1964            `(when ,var
1965               (list (to-option-name ,var) (let ((*print-case* :downcase))
1966                                             (princ-to-string ,var)))))
1967          (boolean-option (var)
1968            `(when ,var
1969               (list (to-option-name ,var))))
1970          (pluralize (wrapper &rest vars)
1971            `(append ,@(loop :for var :in vars :collect `(,wrapper ,var))))
1972          (string-options (&rest vars)
1973            `(pluralize string-option ,@vars))
1974          (pathname-options (&rest vars)
1975            `(pluralize pathname-option ,@vars))
1976          (boolean-options (&rest vars)
1977            `(pluralize boolean-option ,@vars)))
1978       (append
1979        (list "slave-builder")
1980        (string-options build setup lisp-implementation source-registry
1981                        verbosity required-xcvb-version)
1982        (pathname-options output-path lisp-binary-path lisp-image-path
1983                          xcvb-program cache object-cache workspace
1984                          install-prefix install-program install-configuration
1985                          install-data install-library install-image install-lisp)
1986        (list-option-arguments "define-feature" features-defined)
1987        (list-option-arguments "undefine-feature" features-undefined)
1988        (boolean-options disable-cfasl use-base-image debugging profiling)))))
1989
1990 (defun run-xcvb-command (program command)
1991   (etypecase program
1992     (string
1993      ;; Ugly: rely on the above having side-effected *xcvb-program*
1994      (with-safe-io-syntax ()
1995        (run-program/
1996         (cons program command) :output :string :ignore-error-status t)))
1997     (pathname
1998      (run-xcvb-command (namestring program) command))
1999     ((eql t)
2000      (unless (find-symbol* :cmd :xvcb nil)
2001        (require-xcvb))
2002      (with-safe-io-syntax ()
2003        (with-output-to-string (*standard-output*)
2004          (apply 'call :xcvb :cmd command))))))
2005
2006 (defun build-in-slave (build &rest args &key . #.*bnl-keys-with-defaults*)
2007   "Entry point to call XCVB to build (but not necessarily load) a system."
2008   (declare (ignore . #.(set-difference *bnl-keys* '(xcvb-program verbosity))))
2009   (let* ((xcvb-program (ensure-xcvb-present xcvb-program))
2010          (slave-command (apply 'build-slave-command-line build :xcvb-program xcvb-program args))
2011          (slave-output (run-xcvb-command xcvb-program slave-command))
2012          (slave-greeting-pos (search +xcvb-slave-greeting+ slave-output :from-end t))
2013          (manifest
2014           (progn
2015             (unless (and slave-output
2016                          slave-greeting-pos
2017                          (string-suffix-p slave-output +xcvb-slave-farewell+))
2018               (format! *error-output*
2019                        "Failed to execute a build slave.~%~
2020                         Slave command:~%  ~S~%~
2021                         Slave output:~%~A~%~
2022                         (If using SLIME, you might have useful error output in your *inferior-lisp* buffer~%in which case next time you may M-x slime-redirect-inferior-output.)"
2023                        slave-command slave-output)
2024               (error "XCVB slave failed"))
2025             (read-from-string
2026              slave-output t nil
2027              :start (+ (length +xcvb-slave-greeting+) slave-greeting-pos)
2028              :end (- (length slave-output) (length +xcvb-slave-farewell+)))))
2029          (*xcvb-verbosity* (+ (or verbosity *xcvb-verbosity*) 2)))
2030     (when (>= *xcvb-verbosity* 9)
2031       (format! *error-output* "~&Slave XCVB returned following manifest:~%~S~%" manifest))
2032     manifest))
2033
2034 (defun build-and-load (build &rest args &key . #.*bnl-keys*)
2035   "Entry point for users to call XCVB to build and load a system."
2036   (declare (ignore . #.*bnl-keys*))
2037   (process-manifest (apply 'build-in-slave build args)))
2038
2039 (defun bnl (build &rest keys &key . #.*bnl-keys*)
2040   "Short hand for BUILD-AND-LOAD"
2041   (declare (ignore . #.*bnl-keys*))
2042   (apply 'build-and-load build keys))
2043
2044 ;;;; ----- The End -----