lisp-build.lisp - clic - Clic is an command line interactive client for gopher … | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
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… | |
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 #:com… | |
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-conditi… | |
19 ;; Types | |
20 #+sbcl #:sb-grovel-unknown-constant-condition | |
21 ;; Functions & Macros | |
22 #:get-optimization-settings #:proclaim-optimization-settings #:with-o… | |
23 #:call-with-muffled-compiler-conditions #:with-muffled-compiler-condi… | |
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-w… | |
28 #:with-saved-deferred-warnings #:warnings-file-p #: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 f… | |
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… | |
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 fi… | |
49 | |
50 (defvar *base-build-directory* nil | |
51 "When set to a non-null value, it should be an absolute directory pa… | |
52 which will serve as the *DEFAULT-PATHNAME-DEFAULTS* around a COMPILE-FIL… | |
53 what more while the input-file is shortened if possible to ENOUGH-PATHNA… | |
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::*safet… | |
65 #+clisp '() ;; system::*optimize* is a constant hash-table! (wit… | |
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* … | |
71 #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-… | |
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… | |
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-CLEAV… | |
81 #+(or abcl allegro clisp clozure cmucl ecl lispworks mkcl sbcl scl x… | |
82 (let ((settings '(speed space safety debug compilation-speed #+(or c… | |
83 #.`(loop #+(or allegro clozure) | |
84 ,@'(:with info = #+allegro (sys:declaration-information '… | |
85 #+clozure (ccl:declaration-information 'optimize nil)) | |
86 :for x :in settings | |
87 ,@(or #+(or abcl clasp ecl gcl mkcl xcl) '(:for v :in +op… | |
88 :for y = (or #+(or allegro clozure) (second (assoc x info… | |
89 #+clisp (gethash x system::*optimize* 1) | |
90 #+(or abcl ecl mkcl xcl) (symbol-value v) | |
91 #+(or cmucl scl) (slot-value c::*default-coo… | |
92 (case x (compilat… | |
93 (otherwise … | |
94 #+lispworks (slot-value compiler::*optimizat… | |
95 #+sbcl (sb-c::policy-quality sb-c::*policy* … | |
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 *optimizati… | |
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) #-cl… | |
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… | |
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-conditio… | |
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… | |
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 :… | |
153 (when condition | |
154 (list condition))) | |
155 '("No generic function ~S present when encountering macroexpansion … | |
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-readta… | |
165 #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finali… | |
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 co… | |
173 (call-with-muffled-conditions | |
174 thunk (append *uninteresting-conditions* *uninteresting-compiler-co… | |
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 lo… | |
180 (call-with-muffled-conditions | |
181 thunk (append *uninteresting-conditions* *uninteresting-loader-cond… | |
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 :c… | |
192 (context-arguments | |
193 :initform nil :reader compile-condition-context-arguments :initarg… | |
194 (description | |
195 :initform nil :reader compile-condition-description :initarg :desc… | |
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-form… | |
209 "Given the warnings or failures as resulted from COMPILE-FILE or che… | |
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 co… | |
236 "Given the results of COMPILE-FILE, raise an error or warning as app… | |
237 (unless output | |
238 (error 'compile-file-error :context-format context-format :context… | |
239 (check-lisp-compile-warnings warnings-p failure-p context-format con… | |
240 | |
241 | |
242 ;;;; Deferred-warnings treatment, originally implemented by Douglas Katz… | |
243 ;;; | |
244 ;;; To support an implementation, three functions must be implemented: | |
245 ;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-war… | |
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 SE… | |
250 Simple means made of symbols, numbers, characters, simple-strings, pathn… | |
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… | |
255 (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'li… | |
256 | |
257 (defun unreify-simple-sexp (sexp) | |
258 "Given the portable output of REIFY-SIMPLE-SEXP, return the simple S… | |
259 (etypecase sexp | |
260 ((or symbol number character simple-string pathname) sexp) | |
261 (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp … | |
262 ((simple-vector 2) (unreify-symbol sexp)) | |
263 ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp (aref sexp… | |
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:… | |
270 (start-pos ccl:source-note-start-pos) (end-pos … | |
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) sou… | |
277 (ccl::make-source-note :filename filename :start-pos start-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 s… | |
292 (first sec)))))) ; method: keep gf name, dro… | |
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… | |
307 (list :warning-type warning-type :function-name (reify-function-… | |
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 a… | |
315 reified-deferred-warning | |
316 (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-… | |
317 'ccl::compiler-warning) | |
318 :function-name (unreify-function-name function-n… | |
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 "… | |
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-sour… | |
335 :source ,(c::compiler-error-context-source frob) | |
336 :original-source ,(c::compiler-error-context-original-source… | |
337 :context ,(c::compiler-error-context-context frob) | |
338 :file-name ,(c::compiler-error-context-file-name frob) ; a p… | |
339 :file-position ,(c::compiler-error-context-file-position fro… | |
340 :original-source-path ,(c::compiler-error-context-original-s… | |
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 "… | |
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 mea… | |
352 ;; handle deferred warnings must change... TODO: when enough time h… | |
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 '#:comp… | |
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 '#:comp… | |
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) ; … | |
375 :file-position ,(sb-c::compiler-error-context-file-position … | |
376 :original-source-path ,(sb-c::compiler-error-context-origina… | |
377 (sb-c::undefined-warning-warnings warning)))) | |
378 | |
379 (defun reify-deferred-warnings () | |
380 "return a portable S-expression, portably readable and writeable in … | |
381 using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings cu… | |
382 WITH-COMPILATION-UNIT. One of three functions required for deferred-warn… | |
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 acc… | |
394 `(,@(when c::*undefined-warnings* | |
395 `((c::*undefined-warnings* | |
396 ,@(mapcar #'reify-undefined-warning c::*undefined-warning… | |
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 acc… | |
406 `(,@(when sb-c::*undefined-warnings* | |
407 `((sb-c::*undefined-warnings* | |
408 ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warn… | |
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, reinstanti… | |
420 deferred warnings as to be handled at the end of the current WITH-COMPIL… | |
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::%defe… | |
435 (appendf (ccl::deferred-warnings.warnings dw) | |
436 (mapcar 'unreify-deferred-warning reified-deferred-warnin… | |
437 #+(or cmucl scl) | |
438 (dolist (item reified-deferred-warnings) | |
439 ;; Each item is (symbol . adjustment) where the adjustment depends… | |
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… | |
449 (unless (case kind (:function (fboundp na… | |
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… | |
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… | |
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… | |
475 (unless (case kind (:function (fboundp na… | |
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-compi… | |
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 … | |
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… | |
517 possibly in a different process." | |
518 (with-open-file (s warnings-file :direction :output :if-exists :supe… | |
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… | |
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-T… | |
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… | |
557 "Given a list of FILES containing deferred warnings saved by CALL-WI… | |
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 rebui… | |
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-argume… | |
582 | |
583 #| | |
584 Mini-guide to adding support for deferred warnings on an implementatio… | |
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 sou… | |
602 "If WARNINGS-FILE is not nil, record the deferred-warnings around a … | |
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 #+… | |
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-nam… | |
617 "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS" | |
618 `(call-with-saved-deferred-warnings | |
619 #'(lambda () ,@body) ,warnings-file :source-namestring ,source-nam… | |
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 … | |
626 (or *compile-file-pathname* *load-pathname*)) | |
627 | |
628 (defun load-pathname () | |
629 "Portably return the LOAD-PATHNAME of the current source file or fas… | |
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 pat… | |
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-… | |
641 #+(or clasp ecl mkcl) (pathname-type (apply 'compile-file-pathname "… | |
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 … | |
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… | |
651 ,@(unless output-file '(:output-file… | |
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… | |
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… | |
666 #+clisp lib-file #+(or clasp ecl m… | |
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 optio… | |
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-F… | |
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 fi… | |
684 On implementations that erroneously do not recognize standard keyword ar… | |
685 it will filter them appropriately." | |
686 #+(or clasp ecl) | |
687 (when (and object-file (equal (compile-file-type) (pathname object-f… | |
688 (format t "Whoa, some funky ASDF upgrade switched ~S calling conve… | |
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 m… | |
694 (output-file | |
695 (or output-file | |
696 (apply 'compile-file-pathname* input-file :output-file … | |
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 :objec… | |
703 #+clasp (compile-file-pathname output-file :output-ty… | |
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… | |
711 #+sbcl | |
712 (cfasl-file (etypecase emit-cfasl | |
713 (null nil) | |
714 ((eql t) (make-pathname :type "cfasl" :defaults… | |
715 (string (parse-namestring emit-cfasl)) | |
716 (pathname emit-cfasl))) | |
717 #+sbcl | |
718 (tmp-cfasl (when cfasl-file (make-pathname :type "cfasl" :def… | |
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-direct… | |
723 (with-saved-deferred-warnings (warnings-file :source-namestr… | |
724 (with-muffled-compiler-conditions () | |
725 (or #-(or clasp ecl mkcl) | |
726 (let (#+genera (si:*common-lisp-syntax-is-ansi-commo… | |
727 (apply 'compile-file input-file :output-file tmp-f… | |
728 #+sbcl (if emit-cfasl (list* :emit-cfasl tm… | |
729 #-sbcl keywords)) | |
730 #+ecl (apply 'compile-file input-file :output-file | |
731 (if object-file | |
732 (list* object-file :system-p t keywo… | |
733 (list* tmp-file keywords))) | |
734 #+clasp (apply 'compile-file input-file :output-file | |
735 (if object-file | |
736 (list* tmp-object-file :output-typ… | |
737 (list* tmp-file keywords))) | |
738 #+mkcl (apply 'compile-file input-file | |
739 :output-file object-file :fasl-p nil k… | |
740 (cond | |
741 ((and output-truename | |
742 (flet ((check-flag (flag behaviour) | |
743 (or (not flag) (member behaviour '(:success :wa… | |
744 (and (check-flag failure-p *compile-file-failure-behav… | |
745 (check-flag warnings-p *compile-file-warnings-beh… | |
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-obj… | |
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… | |
762 (unless lib-file (setf lib-file (make-pathname :type "lib… | |
763 (rename-file-overwriting-target tmp-lib lib-file)) | |
764 #+sbcl (when cfasl-file (rename-file-overwriting-target tmp… | |
765 #+clasp | |
766 (progn | |
767 ;;; the following 4 rename-file-overwriting-target better… | |
768 #+:target-os-darwin | |
769 (let ((temp-dwarf (pathname (strcat (namestring output-tr… | |
770 (target-dwarf (pathname (strcat (namestring physica… | |
771 (when (probe-file temp-dwarf) | |
772 (rename-file-overwriting-target temp-dwarf target-dwa… | |
773 ;;; need to rename the bc or ll file as well or test-bund… | |
774 ;;; They might not exist with parallel compilation | |
775 (let ((bitcode-src (compile-file-pathname tmp-file :outpu… | |
776 (bitcode-target (compile-file-pathname physical-out… | |
777 (when (probe-file bitcode-src) | |
778 (rename-file-overwriting-target bitcode-src bitcode-t… | |
779 (rename-file-overwriting-target tmp-object-file object-fi… | |
780 (rename-file-overwriting-target output-truename physical-ou… | |
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 w… | |
784 (delete-file-if-exists tmp-lib))) ;; this one … | |
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 s… | |
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 #+cl… | |
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 wh… | |
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" inp… | |
820 #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires AB… | |
821 #+(or allegro clisp cmucl sbcl scl xcl) (concatenate-files inputs ou… | |
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-concatena… | |
834 (eval `(scm:defsystem :fasls-to-concatenate | |
835 (:default-pathname ,(pathname-directory-pathname o… | |
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… | |
840 (loop :for f :in fasls :do (ignore-errors (delete-file f))) | |
841 (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))… |