tlisp-build.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) LICENSE
---
tlisp-build.lisp (41459B)
---
1 ;;;; -------------------------------------------------------------------------
2 ;;;; Support to build (compile and load) Lisp files
3
4 (uiop/package:define-package :uiop/lisp-build
5 (:nicknames :asdf/lisp-build) ;; OBSOLETE, used by slime/contrib/swank-asdf.lisp
6 (:use :uiop/common-lisp :uiop/package :uiop/utility
7 :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image)
8 (:export
9 ;; Variables
10 #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
11 #:*output-translation-function*
12 #:*optimization-settings* #:*previous-optimization-settings*
13 #:*base-build-directory*
14 #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
15 #:compile-warned-warning #:compile-failed-warning
16 #:check-lisp-compile-results #:check-lisp-compile-warnings
17 #:*uninteresting-conditions* #:*usual-uninteresting-conditions*
18 #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
19 ;; Types
20 #+sbcl #:sb-grovel-unknown-constant-condition
21 ;; Functions & Macros
22 #:get-optimization-settings #:proclaim-optimization-settings #:with-optimization-settings
23 #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
24 #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
25 #:reify-simple-sexp #:unreify-simple-sexp
26 #:reify-deferred-warnings #:unreify-deferred-warnings
27 #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings
28 #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type*
29 #:enable-deferred-warnings-check #:disable-deferred-warnings-check
30 #:current-lisp-file-pathname #:load-pathname
31 #:lispize-pathname #:compile-file-type #:call-around-hook
32 #:compile-file* #:compile-file-pathname* #:*compile-check*
33 #:load* #:load-from-string #:combine-fasls)
34 (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
35 (in-package :uiop/lisp-build)
36
37 (with-upgradability ()
38 (defvar *compile-file-warnings-behaviour*
39 (or #+clisp :ignore :warn)
40 "How should ASDF react if it encounters a warning when compiling a file?
41 Valid values are :error, :warn, and :ignore.")
42
43 (defvar *compile-file-failure-behaviour*
44 (or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
45 "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
46 when compiling a file, which includes any non-style-warning warning.
47 Valid values are :error, :warn, and :ignore.
48 Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
49
50 (defvar *base-build-directory* nil
51 "When set to a non-null value, it should be an absolute directory pathname,
52 which will serve as the *DEFAULT-PATHNAME-DEFAULTS* around a COMPILE-FILE,
53 what more while the input-file is shortened if possible to ENOUGH-PATHNAME relative to it.
54 This can help you produce more deterministic output for FASLs."))
55
56 ;;; Optimization settings
57 (with-upgradability ()
58 (defvar *optimization-settings* nil
59 "Optimization settings to be used by PROCLAIM-OPTIMIZATION-SETTINGS")
60 (defvar *previous-optimization-settings* nil
61 "Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS")
62 (defparameter +optimization-variables+
63 ;; TODO: allegro genera corman mcl
64 (or #+(or abcl xcl) '(system::*speed* system::*space* system::*safety* system::*debug*)
65 #+clisp '() ;; system::*optimize* is a constant hash-table! (with non-constant contents)
66 #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety*
67 ccl::*nx-debug* ccl::*nx-cspeed*)
68 #+(or cmucl scl) '(c::*default-cookie*)
69 #+clasp '()
70 #+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*))
71 #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*)
72 #+lispworks '(compiler::*optimization-level*)
73 #+mkcl '(si::*speed* si::*space* si::*safety* si::*debug*)
74 #+sbcl '(sb-c::*policy*)))
75 (defun get-optimization-settings ()
76 "Get current compiler optimization settings, ready to PROCLAIM again"
77 #-(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl)
78 (warn "~S does not support ~S. Please help me fix that."
79 'get-optimization-settings (implementation-type))
80 #+(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl)
81 (let ((settings '(speed space safety debug compilation-speed #+(or cmucl scl) c::brevity)))
82 #.`(loop #+(or allegro clozure)
83 ,@'(:with info = #+allegro (sys:declaration-information 'optimize)
84 #+clozure (ccl:declaration-information 'optimize nil))
85 :for x :in settings
86 ,@(or #+(or abcl clasp ecl gcl mkcl xcl) '(:for v :in +optimization-variables+))
87 :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order
88 #+clisp (gethash x system::*optimize* 1)
89 #+(or abcl clasp ecl mkcl xcl) (symbol-value v)
90 #+(or cmucl scl) (slot-value c::*default-cookie*
91 (case x (compilation-speed 'c::cspeed)
92 (otherwise x)))
93 #+lispworks (slot-value compiler::*optimization-level* x)
94 #+sbcl (sb-c::policy-quality sb-c::*policy* x))
95 :when y :collect (list x y))))
96 (defun proclaim-optimization-settings ()
97 "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
98 (proclaim `(optimize ,@*optimization-settings*))
99 (let ((settings (get-optimization-settings)))
100 (unless (equal *previous-optimization-settings* settings)
101 (setf *previous-optimization-settings* settings))))
102 (defmacro with-optimization-settings ((&optional (settings *optimization-settings*)) &body body)
103 #+(or allegro clisp)
104 (let ((previous-settings (gensym "PREVIOUS-SETTINGS")))
105 `(let ((,previous-settings (get-optimization-settings)))
106 ,@(when settings `((proclaim `(optimize ,@,settings))))
107 (unwind-protect (progn ,@body)
108 (proclaim `(optimize ,@,previous-settings)))))
109 #-(or allegro clisp)
110 `(let ,(loop :for v :in +optimization-variables+ :collect `(,v ,v))
111 ,@(when settings `((proclaim `(optimize ,@,settings))))
112 ,@body)))
113
114
115 ;;; Condition control
116 (with-upgradability ()
117 #+sbcl
118 (progn
119 (defun sb-grovel-unknown-constant-condition-p (c)
120 "Detect SB-GROVEL unknown-constant conditions on older versions of SBCL"
121 (and (typep c 'sb-int:simple-style-warning)
122 (string-enclosed-p
123 "Couldn't grovel for "
124 (simple-condition-format-control c)
125 " (unknown to the C compiler).")))
126 (deftype sb-grovel-unknown-constant-condition ()
127 '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p))))
128
129 (defvar *usual-uninteresting-conditions*
130 (append
131 ;;#+clozure '(ccl:compiler-warning)
132 #+cmucl '("Deleting unreachable code.")
133 #+lispworks '("~S being redefined in ~A (previously in ~A)."
134 "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when.
135 #+sbcl
136 '(sb-c::simple-compiler-note
137 "&OPTIONAL and &KEY found in the same lambda list: ~S"
138 #+sb-eval sb-kernel:lexical-environment-too-complex
139 sb-kernel:undefined-alien-style-warning
140 sb-grovel-unknown-constant-condition ; defined above.
141 sb-ext:implicit-generic-function-warning ;; Controversial.
142 sb-int:package-at-variance
143 sb-kernel:uninteresting-redefinition
144 ;; BEWARE: the below four are controversial to include here.
145 sb-kernel:redefinition-with-defun
146 sb-kernel:redefinition-with-defgeneric
147 sb-kernel:redefinition-with-defmethod
148 sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
149 '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
150 "A suggested value to which to set or bind *uninteresting-conditions*.")
151
152 (defvar *uninteresting-conditions* '()
153 "Conditions that may be skipped while compiling or loading Lisp code.")
154 (defvar *uninteresting-compiler-conditions* '()
155 "Additional conditions that may be skipped while compiling Lisp code.")
156 (defvar *uninteresting-loader-conditions*
157 (append
158 '("Overwriting already existing readtable ~S." ;; from named-readtables
159 #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
160 #+clisp '(clos::simple-gf-replacing-method-warning))
161 "Additional conditions that may be skipped while loading Lisp code."))
162
163 ;;;; ----- Filtering conditions while building -----
164 (with-upgradability ()
165 (defun call-with-muffled-compiler-conditions (thunk)
166 "Call given THUNK in a context where uninteresting conditions and compiler conditions are muffled"
167 (call-with-muffled-conditions
168 thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*)))
169 (defmacro with-muffled-compiler-conditions ((&optional) &body body)
170 "Trivial syntax for CALL-WITH-MUFFLED-COMPILER-CONDITIONS"
171 `(call-with-muffled-compiler-conditions #'(lambda () ,@body)))
172 (defun call-with-muffled-loader-conditions (thunk)
173 "Call given THUNK in a context where uninteresting conditions and loader conditions are muffled"
174 (call-with-muffled-conditions
175 thunk (append *uninteresting-conditions* *uninteresting-loader-conditions*)))
176 (defmacro with-muffled-loader-conditions ((&optional) &body body)
177 "Trivial syntax for CALL-WITH-MUFFLED-LOADER-CONDITIONS"
178 `(call-with-muffled-loader-conditions #'(lambda () ,@body))))
179
180
181 ;;;; Handle warnings and failures
182 (with-upgradability ()
183 (define-condition compile-condition (condition)
184 ((context-format
185 :initform nil :reader compile-condition-context-format :initarg :context-format)
186 (context-arguments
187 :initform nil :reader compile-condition-context-arguments :initarg :context-arguments)
188 (description
189 :initform nil :reader compile-condition-description :initarg :description))
190 (:report (lambda (c s)
191 (format s (compatfmt "~@<~A~@[ while ~?~]~@:>")
192 (or (compile-condition-description c) (type-of c))
193 (compile-condition-context-format c)
194 (compile-condition-context-arguments c)))))
195 (define-condition compile-file-error (compile-condition error) ())
196 (define-condition compile-warned-warning (compile-condition warning) ())
197 (define-condition compile-warned-error (compile-condition error) ())
198 (define-condition compile-failed-warning (compile-condition warning) ())
199 (define-condition compile-failed-error (compile-condition error) ())
200
201 (defun check-lisp-compile-warnings (warnings-p failure-p
202 &optional context-format context-arguments)
203 "Given the warnings or failures as resulted from COMPILE-FILE or checking deferred warnings,
204 raise an error or warning as appropriate"
205 (when failure-p
206 (case *compile-file-failure-behaviour*
207 (:warn (warn 'compile-failed-warning
208 :description "Lisp compilation failed"
209 :context-format context-format
210 :context-arguments context-arguments))
211 (:error (error 'compile-failed-error
212 :description "Lisp compilation failed"
213 :context-format context-format
214 :context-arguments context-arguments))
215 (:ignore nil)))
216 (when warnings-p
217 (case *compile-file-warnings-behaviour*
218 (:warn (warn 'compile-warned-warning
219 :description "Lisp compilation had style-warnings"
220 :context-format context-format
221 :context-arguments context-arguments))
222 (:error (error 'compile-warned-error
223 :description "Lisp compilation had style-warnings"
224 :context-format context-format
225 :context-arguments context-arguments))
226 (:ignore nil))))
227
228 (defun check-lisp-compile-results (output warnings-p failure-p
229 &optional context-format context-arguments)
230 "Given the results of COMPILE-FILE, raise an error or warning as appropriate"
231 (unless output
232 (error 'compile-file-error :context-format context-format :context-arguments context-arguments))
233 (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments)))
234
235
236 ;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman.
237 ;;;
238 ;;; To support an implementation, three functions must be implemented:
239 ;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings
240 ;;; See their respective docstrings.
241 (with-upgradability ()
242 (defun reify-simple-sexp (sexp)
243 "Given a simple SEXP, return a representation of it as a portable SEXP.
244 Simple means made of symbols, numbers, characters, simple-strings, pathnames, cons cells."
245 (etypecase sexp
246 (symbol (reify-symbol sexp))
247 ((or number character simple-string pathname) sexp)
248 (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))
249 (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list))))))
250
251 (defun unreify-simple-sexp (sexp)
252 "Given the portable output of REIFY-SIMPLE-SEXP, return the simple SEXP it represents"
253 (etypecase sexp
254 ((or symbol number character simple-string pathname) sexp)
255 (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp))))
256 ((simple-vector 2) (unreify-symbol sexp))
257 ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp (aref sexp 0)) 'vector))))
258
259 #+clozure
260 (progn
261 (defun reify-source-note (source-note)
262 (when source-note
263 (with-accessors ((source ccl::source-note-source) (filename ccl:source-note-filename)
264 (start-pos ccl:source-note-start-pos) (end-pos ccl:source-note-end-pos)) source-note
265 (declare (ignorable source))
266 (list :filename filename :start-pos start-pos :end-pos end-pos
267 #|:source (reify-source-note source)|#))))
268 (defun unreify-source-note (source-note)
269 (when source-note
270 (destructuring-bind (&key filename start-pos end-pos source) source-note
271 (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos
272 :source (unreify-source-note source)))))
273 (defun unsymbolify-function-name (name)
274 (if-let (setfed (gethash name ccl::%setf-function-name-inverses%))
275 `(setf ,setfed)
276 name))
277 (defun symbolify-function-name (name)
278 (if (and (consp name) (eq (first name) 'setf))
279 (let ((setfed (second name)))
280 (gethash setfed ccl::%setf-function-names%))
281 name))
282 (defun reify-function-name (function-name)
283 (let ((name (or (first function-name) ;; defun: extract the name
284 (let ((sec (second function-name)))
285 (or (and (atom sec) sec) ; scoped method: drop scope
286 (first sec)))))) ; method: keep gf name, drop method specializers
287 (list name)))
288 (defun unreify-function-name (function-name)
289 function-name)
290 (defun nullify-non-literals (sexp)
291 (typecase sexp
292 ((or number character simple-string symbol pathname) sexp)
293 (cons (cons (nullify-non-literals (car sexp))
294 (nullify-non-literals (cdr sexp))))
295 (t nil)))
296 (defun reify-deferred-warning (deferred-warning)
297 (with-accessors ((warning-type ccl::compiler-warning-warning-type)
298 (args ccl::compiler-warning-args)
299 (source-note ccl:compiler-warning-source-note)
300 (function-name ccl:compiler-warning-function-name)) deferred-warning
301 (list :warning-type warning-type :function-name (reify-function-name function-name)
302 :source-note (reify-source-note source-note)
303 :args (destructuring-bind (fun &rest more)
304 args
305 (cons (unsymbolify-function-name fun)
306 (nullify-non-literals more))))))
307 (defun unreify-deferred-warning (reified-deferred-warning)
308 (destructuring-bind (&key warning-type function-name source-note args)
309 reified-deferred-warning
310 (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-whining-conditions*))
311 'ccl::compiler-warning)
312 :function-name (unreify-function-name function-name)
313 :source-note (unreify-source-note source-note)
314 :warning-type warning-type
315 :args (destructuring-bind (fun . more) args
316 (cons (symbolify-function-name fun) more))))))
317 #+(or cmucl scl)
318 (defun reify-undefined-warning (warning)
319 ;; Extracting undefined-warnings from the compilation-unit
320 ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
321 (list*
322 (c::undefined-warning-kind warning)
323 (c::undefined-warning-name warning)
324 (c::undefined-warning-count warning)
325 (mapcar
326 #'(lambda (frob)
327 ;; the lexenv slot can be ignored for reporting purposes
328 `(:enclosing-source ,(c::compiler-error-context-enclosing-source frob)
329 :source ,(c::compiler-error-context-source frob)
330 :original-source ,(c::compiler-error-context-original-source frob)
331 :context ,(c::compiler-error-context-context frob)
332 :file-name ,(c::compiler-error-context-file-name frob) ; a pathname
333 :file-position ,(c::compiler-error-context-file-position frob) ; an integer
334 :original-source-path ,(c::compiler-error-context-original-source-path frob)))
335 (c::undefined-warning-warnings warning))))
336
337 #+sbcl
338 (defun reify-undefined-warning (warning)
339 ;; Extracting undefined-warnings from the compilation-unit
340 ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
341 (list*
342 (sb-c::undefined-warning-kind warning)
343 (sb-c::undefined-warning-name warning)
344 (sb-c::undefined-warning-count warning)
345 (mapcar
346 #'(lambda (frob)
347 ;; the lexenv slot can be ignored for reporting purposes
348 `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob)
349 :source ,(sb-c::compiler-error-context-source frob)
350 :original-source ,(sb-c::compiler-error-context-original-source frob)
351 :context ,(sb-c::compiler-error-context-context frob)
352 :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname
353 :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer
354 :original-source-path ,(sb-c::compiler-error-context-original-source-path frob)))
355 (sb-c::undefined-warning-warnings warning))))
356
357 (defun reify-deferred-warnings ()
358 "return a portable S-expression, portably readable and writeable in any Common Lisp implementation
359 using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by
360 WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
361 #+allegro
362 (list :functions-defined excl::.functions-defined.
363 :functions-called excl::.functions-called.)
364 #+clozure
365 (mapcar 'reify-deferred-warning
366 (if-let (dw ccl::*outstanding-deferred-warnings*)
367 (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
368 (ccl::deferred-warnings.warnings mdw))))
369 #+(or cmucl scl)
370 (when lisp::*in-compilation-unit*
371 ;; Try to send nothing through the pipe if nothing needs to be accumulated
372 `(,@(when c::*undefined-warnings*
373 `((c::*undefined-warnings*
374 ,@(mapcar #'reify-undefined-warning c::*undefined-warnings*))))
375 ,@(loop :for what :in '(c::*compiler-error-count*
376 c::*compiler-warning-count*
377 c::*compiler-note-count*)
378 :for value = (symbol-value what)
379 :when (plusp value)
380 :collect `(,what . ,value))))
381 #+sbcl
382 (when sb-c::*in-compilation-unit*
383 ;; Try to send nothing through the pipe if nothing needs to be accumulated
384 `(,@(when sb-c::*undefined-warnings*
385 `((sb-c::*undefined-warnings*
386 ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings*))))
387 ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count*
388 sb-c::*compiler-error-count*
389 sb-c::*compiler-warning-count*
390 sb-c::*compiler-style-warning-count*
391 sb-c::*compiler-note-count*)
392 :for value = (symbol-value what)
393 :when (plusp value)
394 :collect `(,what . ,value)))))
395
396 (defun unreify-deferred-warnings (reified-deferred-warnings)
397 "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate the corresponding
398 deferred warnings as to be handled at the end of the current WITH-COMPILATION-UNIT.
399 Handle any warning that has been resolved already,
400 such as an undefined function that has been defined since.
401 One of three functions required for deferred-warnings support in ASDF."
402 (declare (ignorable reified-deferred-warnings))
403 #+allegro
404 (destructuring-bind (&key functions-defined functions-called)
405 reified-deferred-warnings
406 (setf excl::.functions-defined.
407 (append functions-defined excl::.functions-defined.)
408 excl::.functions-called.
409 (append functions-called excl::.functions-called.)))
410 #+clozure
411 (let ((dw (or ccl::*outstanding-deferred-warnings*
412 (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t)))))
413 (appendf (ccl::deferred-warnings.warnings dw)
414 (mapcar 'unreify-deferred-warning reified-deferred-warnings)))
415 #+(or cmucl scl)
416 (dolist (item reified-deferred-warnings)
417 ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
418 ;; For *undefined-warnings*, the adjustment is a list of initargs.
419 ;; For everything else, it's an integer.
420 (destructuring-bind (symbol . adjustment) item
421 (case symbol
422 ((c::*undefined-warnings*)
423 (setf c::*undefined-warnings*
424 (nconc (mapcan
425 #'(lambda (stuff)
426 (destructuring-bind (kind name count . rest) stuff
427 (unless (case kind (:function (fboundp name)))
428 (list
429 (c::make-undefined-warning
430 :name name
431 :kind kind
432 :count count
433 :warnings
434 (mapcar #'(lambda (x)
435 (apply #'c::make-compiler-error-context x))
436 rest))))))
437 adjustment)
438 c::*undefined-warnings*)))
439 (otherwise
440 (set symbol (+ (symbol-value symbol) adjustment))))))
441 #+sbcl
442 (dolist (item reified-deferred-warnings)
443 ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
444 ;; For *undefined-warnings*, the adjustment is a list of initargs.
445 ;; For everything else, it's an integer.
446 (destructuring-bind (symbol . adjustment) item
447 (case symbol
448 ((sb-c::*undefined-warnings*)
449 (setf sb-c::*undefined-warnings*
450 (nconc (mapcan
451 #'(lambda (stuff)
452 (destructuring-bind (kind name count . rest) stuff
453 (unless (case kind (:function (fboundp name)))
454 (list
455 (sb-c::make-undefined-warning
456 :name name
457 :kind kind
458 :count count
459 :warnings
460 (mapcar #'(lambda (x)
461 (apply #'sb-c::make-compiler-error-context x))
462 rest))))))
463 adjustment)
464 sb-c::*undefined-warnings*)))
465 (otherwise
466 (set symbol (+ (symbol-value symbol) adjustment)))))))
467
468 (defun reset-deferred-warnings ()
469 "Reset the set of deferred warnings to be handled at the end of the current WITH-COMPILATION-UNIT.
470 One of three functions required for deferred-warnings support in ASDF."
471 #+allegro
472 (setf excl::.functions-defined. nil
473 excl::.functions-called. nil)
474 #+clozure
475 (if-let (dw ccl::*outstanding-deferred-warnings*)
476 (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
477 (setf (ccl::deferred-warnings.warnings mdw) nil)))
478 #+(or cmucl scl)
479 (when lisp::*in-compilation-unit*
480 (setf c::*undefined-warnings* nil
481 c::*compiler-error-count* 0
482 c::*compiler-warning-count* 0
483 c::*compiler-note-count* 0))
484 #+sbcl
485 (when sb-c::*in-compilation-unit*
486 (setf sb-c::*undefined-warnings* nil
487 sb-c::*aborted-compilation-unit-count* 0
488 sb-c::*compiler-error-count* 0
489 sb-c::*compiler-warning-count* 0
490 sb-c::*compiler-style-warning-count* 0
491 sb-c::*compiler-note-count* 0)))
492
493 (defun save-deferred-warnings (warnings-file)
494 "Save forward reference conditions so they may be issued at a latter time,
495 possibly in a different process."
496 (with-open-file (s warnings-file :direction :output :if-exists :supersede
497 :element-type *default-stream-element-type*
498 :external-format *utf-8-external-format*)
499 (with-safe-io-syntax ()
500 (let ((*read-eval* t))
501 (write (reify-deferred-warnings) :stream s :pretty t :readably t))
502 (terpri s))))
503
504 (defun warnings-file-type (&optional implementation-type)
505 "The pathname type for warnings files on given IMPLEMENTATION-TYPE,
506 where NIL designates the current one"
507 (case (or implementation-type *implementation-type*)
508 ((:acl :allegro) "allegro-warnings")
509 ;;((:clisp) "clisp-warnings")
510 ((:cmu :cmucl) "cmucl-warnings")
511 ((:sbcl) "sbcl-warnings")
512 ((:clozure :ccl) "ccl-warnings")
513 ((:scl) "scl-warnings")))
514
515 (defvar *warnings-file-type* nil
516 "Pathname type for warnings files, or NIL if disabled")
517
518 (defun enable-deferred-warnings-check ()
519 "Enable the saving of deferred warnings"
520 (setf *warnings-file-type* (warnings-file-type)))
521
522 (defun disable-deferred-warnings-check ()
523 "Disable the saving of deferred warnings"
524 (setf *warnings-file-type* nil))
525
526 (defun warnings-file-p (file &optional implementation-type)
527 "Is FILE a saved warnings file for the given IMPLEMENTATION-TYPE?
528 If that given type is NIL, use the currently configured *WARNINGS-FILE-TYPE* instead."
529 (if-let (type (if implementation-type
530 (warnings-file-type implementation-type)
531 *warnings-file-type*))
532 (equal (pathname-type file) type)))
533
534 (defun check-deferred-warnings (files &optional context-format context-arguments)
535 "Given a list of FILES containing deferred warnings saved by CALL-WITH-SAVED-DEFERRED-WARNINGS,
536 re-intern and raise any warnings that are still meaningful."
537 (let ((file-errors nil)
538 (failure-p nil)
539 (warnings-p nil))
540 (handler-bind
541 ((warning #'(lambda (c)
542 (setf warnings-p t)
543 (unless (typep c 'style-warning)
544 (setf failure-p t)))))
545 (with-compilation-unit (:override t)
546 (reset-deferred-warnings)
547 (dolist (file files)
548 (unreify-deferred-warnings
549 (handler-case
550 (with-safe-io-syntax ()
551 (let ((*read-eval* t))
552 (read-file-form file)))
553 (error (c)
554 ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging
555 (push c file-errors)
556 nil))))))
557 (dolist (error file-errors) (error error))
558 (check-lisp-compile-warnings
559 (or failure-p warnings-p) failure-p context-format context-arguments)))
560
561 #|
562 Mini-guide to adding support for deferred warnings on an implementation.
563
564 First, look at what such a warning looks like:
565
566 (describe
567 (handler-case
568 (and (eval '(lambda () (some-undefined-function))) nil)
569 (t (c) c)))
570
571 Then you can grep for the condition type in your compiler sources
572 and see how to catch those that have been deferred,
573 and/or read, clear and restore the deferred list.
574
575 Also look at
576 (macroexpand-1 '(with-compilation-unit () foo))
577 |#
578
579 (defun call-with-saved-deferred-warnings (thunk warnings-file &key source-namestring)
580 "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK
581 and save those warnings to the given file for latter use,
582 possibly in a different process. Otherwise just call THUNK."
583 (declare (ignorable source-namestring))
584 (if warnings-file
585 (with-compilation-unit (:override t #+sbcl :source-namestring #+sbcl source-namestring)
586 (unwind-protect
587 (let (#+sbcl (sb-c::*undefined-warnings* nil))
588 (multiple-value-prog1
589 (funcall thunk)
590 (save-deferred-warnings warnings-file)))
591 (reset-deferred-warnings)))
592 (funcall thunk)))
593
594 (defmacro with-saved-deferred-warnings ((warnings-file &key source-namestring) &body body)
595 "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS"
596 `(call-with-saved-deferred-warnings
597 #'(lambda () ,@body) ,warnings-file :source-namestring ,source-namestring)))
598
599
600 ;;; from ASDF
601 (with-upgradability ()
602 (defun current-lisp-file-pathname ()
603 "Portably return the PATHNAME of the current Lisp source file being compiled or loaded"
604 (or *compile-file-pathname* *load-pathname*))
605
606 (defun load-pathname ()
607 "Portably return the LOAD-PATHNAME of the current source file or fasl"
608 *load-pathname*) ;; magic no longer needed for GCL.
609
610 (defun lispize-pathname (input-file)
611 "From a INPUT-FILE pathname, return a corresponding .lisp source pathname"
612 (make-pathname :type "lisp" :defaults input-file))
613
614 (defun compile-file-type (&rest keys)
615 "pathname TYPE for lisp FASt Loading files"
616 (declare (ignorable keys))
617 #-(or clasp ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
618 #+(or clasp ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)))
619
620 (defun call-around-hook (hook function)
621 "Call a HOOK around the execution of FUNCTION"
622 (call-function (or hook 'funcall) function))
623
624 (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
625 "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*"
626 (let* ((keys
627 (remove-plist-keys `(#+(or (and allegro (not (version>= 8 2)))) :external-format
628 ,@(unless output-file '(:output-file))) keys)))
629 (if (absolute-pathname-p output-file)
630 ;; what cfp should be doing, w/ mp* instead of mp
631 (let* ((type (pathname-type (apply 'compile-file-type keys)))
632 (defaults (make-pathname
633 :type type :defaults (merge-pathnames* input-file))))
634 (merge-pathnames* output-file defaults))
635 (funcall *output-translation-function*
636 (apply 'compile-file-pathname input-file keys)))))
637
638 (defvar *compile-check* nil
639 "A hook for user-defined compile-time invariants")
640
641 (defun* (compile-file*) (input-file &rest keys
642 &key (compile-check *compile-check*) output-file warnings-file
643 #+clisp lib-file #+(or clasp ecl mkcl) object-file #+sbcl emit-cfasl
644 &allow-other-keys)
645 "This function provides a portable wrapper around COMPILE-FILE.
646 It ensures that the OUTPUT-FILE value is only returned and
647 the file only actually created if the compilation was successful,
648 even though your implementation may not do that. It also checks an optional
649 user-provided consistency function COMPILE-CHECK to determine success;
650 it will call this function if not NIL at the end of the compilation
651 with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE
652 where TMP-FILE is the name of a temporary output-file.
653 It also checks two flags (with legacy british spelling from ASDF1),
654 *COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR*
655 with appropriate implementation-dependent defaults,
656 and if a failure (respectively warnings) are reported by COMPILE-FILE,
657 it will consider that an error unless the respective behaviour flag
658 is one of :SUCCESS :WARN :IGNORE.
659 If WARNINGS-FILE is defined, deferred warnings are saved to that file.
660 On ECL or MKCL, it creates both the linkable object and loadable fasl files.
661 On implementations that erroneously do not recognize standard keyword arguments,
662 it will filter them appropriately."
663 #+(or clasp ecl)
664 (when (and object-file (equal (compile-file-type) (pathname object-file)))
665 (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%"
666 'compile-file* output-file object-file)
667 (rotatef output-file object-file))
668 (let* ((keywords (remove-plist-keys
669 `(:output-file :compile-check :warnings-file
670 #+clisp :lib-file #+(or clasp ecl mkcl) :object-file) keys))
671 (output-file
672 (or output-file
673 (apply 'compile-file-pathname* input-file :output-file output-file keywords)))
674 (physical-output-file (physicalize-pathname output-file))
675 #+(or clasp ecl)
676 (object-file
677 (unless (use-ecl-byte-compiler-p)
678 (or object-file
679 #+ecl (compile-file-pathname output-file :type :object)
680 #+clasp (compile-file-pathname output-file :output-type :object))))
681 #+mkcl
682 (object-file
683 (or object-file
684 (compile-file-pathname output-file :fasl-p nil)))
685 (tmp-file (tmpize-pathname physical-output-file))
686 #+sbcl
687 (cfasl-file (etypecase emit-cfasl
688 (null nil)
689 ((eql t) (make-pathname :type "cfasl" :defaults physical-output-file))
690 (string (parse-namestring emit-cfasl))
691 (pathname emit-cfasl)))
692 #+sbcl
693 (tmp-cfasl (when cfasl-file (make-pathname :type "cfasl" :defaults tmp-file)))
694 #+clisp
695 (tmp-lib (make-pathname :type "lib" :defaults tmp-file)))
696 (multiple-value-bind (output-truename warnings-p failure-p)
697 (with-enough-pathname (input-file :defaults *base-build-directory*)
698 (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file))
699 (with-muffled-compiler-conditions ()
700 (or #-(or clasp ecl mkcl)
701 (apply 'compile-file input-file :output-file tmp-file
702 #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords)
703 #-sbcl keywords)
704 #+ecl (apply 'compile-file input-file :output-file
705 (if object-file
706 (list* object-file :system-p t keywords)
707 (list* tmp-file keywords)))
708 #+clasp (apply 'compile-file input-file :output-file
709 (if object-file
710 (list* object-file :output-type :object #|:system-p t|# keywords)
711 (list* tmp-file keywords)))
712 #+mkcl (apply 'compile-file input-file
713 :output-file object-file :fasl-p nil keywords)))))
714 (cond
715 ((and output-truename
716 (flet ((check-flag (flag behaviour)
717 (or (not flag) (member behaviour '(:success :warn :ignore)))))
718 (and (check-flag failure-p *compile-file-failure-behaviour*)
719 (check-flag warnings-p *compile-file-warnings-behaviour*)))
720 (progn
721 #+(or clasp ecl mkcl)
722 (when (and #+(or clasp ecl) object-file)
723 (setf output-truename
724 (compiler::build-fasl tmp-file
725 #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (list object-file))))
726 (or (not compile-check)
727 (apply compile-check input-file
728 :output-file output-truename
729 keywords))))
730 (delete-file-if-exists physical-output-file)
731 (when output-truename
732 #+clasp (when output-truename (rename-file-overwriting-target tmp-file output-truename))
733 ;; see CLISP bug 677
734 #+clisp
735 (progn
736 (setf tmp-lib (make-pathname :type "lib" :defaults output-truename))
737 (unless lib-file (setf lib-file (make-pathname :type "lib" :defaults physical-output-file)))
738 (rename-file-overwriting-target tmp-lib lib-file))
739 #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file))
740 (rename-file-overwriting-target output-truename physical-output-file)
741 (setf output-truename (truename physical-output-file)))
742 #+clasp (delete-file-if-exists tmp-file)
743 #+clisp (progn (delete-file-if-exists tmp-file) ;; this one works around clisp BUG 677
744 (delete-file-if-exists tmp-lib))) ;; this one is "normal" defensive cleanup
745 (t ;; error or failed check
746 (delete-file-if-exists output-truename)
747 #+clisp (delete-file-if-exists tmp-lib)
748 #+sbcl (delete-file-if-exists tmp-cfasl)
749 (setf output-truename nil)))
750 (values output-truename warnings-p failure-p))))
751
752 (defun load* (x &rest keys &key &allow-other-keys)
753 "Portable wrapper around LOAD that properly handles loading from a stream."
754 (with-muffled-loader-conditions ()
755 (etypecase x
756 ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream)
757 (apply 'load x keys))
758 ;; Genera can't load from a string-input-stream
759 ;; ClozureCL 1.6 can only load from file input stream
760 ;; Allegro 5, I don't remember but it must have been broken when I tested.
761 #+(or allegro clozure genera)
762 (stream ;; make do this way
763 (let ((*package* *package*)
764 (*readtable* *readtable*)
765 (*load-pathname* nil)
766 (*load-truename* nil))
767 (eval-input x))))))
768
769 (defun load-from-string (string)
770 "Portably read and evaluate forms from a STRING."
771 (with-input-from-string (s string) (load* s))))
772
773 ;;; Links FASLs together
774 (with-upgradability ()
775 (defun combine-fasls (inputs output)
776 "Combine a list of FASLs INPUTS into a single FASL OUTPUT"
777 #-(or abcl allegro clisp clozure cmucl lispworks sbcl scl xcl)
778 (not-implemented-error 'combine-fasls "~%inputs: ~S~%output: ~S" inputs output)
779 #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0
780 #+(or allegro clisp cmucl sbcl scl xcl) (concatenate-files inputs output)
781 #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
782 #+lispworks
783 (let (fasls)
784 (unwind-protect
785 (progn
786 (loop :for i :in inputs
787 :for n :from 1
788 :for f = (add-pathname-suffix
789 output (format nil "-FASL~D" n))
790 :do (copy-file i f)
791 (push f fasls))
792 (ignore-errors (lispworks:delete-system :fasls-to-concatenate))
793 (eval `(scm:defsystem :fasls-to-concatenate
794 (:default-pathname ,(pathname-directory-pathname output))
795 :members
796 ,(loop :for f :in (reverse fasls)
797 :collect `(,(namestring f) :load-only t))))
798 (scm:concatenate-system output :fasls-to-concatenate :force t))
799 (loop :for f :in fasls :do (ignore-errors (delete-file f)))
800 (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))))