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