common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

make-host-1: better diagnostics on style-warning stoppage

Browse source 
Give with-compilation-unit to finish and print its thing.
This commit is contained in:
Stas Boukarev 2026-09-09 11:00:17 +03:00
parent 0dc9bd7f2f
commit 4669caad14
1 changed files with 15 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
make-host-1.lisp
View file

@ -31,25 +31,30 @@
;; UNDEFINED-VARIABLE does not cause COMPILE-FILE to return warnings-p ;; UNDEFINED-VARIABLE does not cause COMPILE-FILE to return warnings-p
;; unless outside a compilation unit. You find out about it only upon ;; unless outside a compilation unit. You find out about it only upon
;; exit of SUMMARIZE-COMPILATION-UNIT. So we set up a handler for that. ;; exit of SUMMARIZE-COMPILATION-UNIT. So we set up a handler for that.
`(let (warnp style-warnp) `(let (warnp style-warnp
last-form)
(handler-bind ((style-warning (handler-bind ((style-warning
;; Any unmuffled STYLE-WARNING should fail ;; Any unmuffled STYLE-WARNING should fail
;; These would typically be from undefined functions, ;; These would typically be from undefined functions,
;; or optional-and-key when that was visible. ;; or optional-and-key when that was visible.
(lambda (c) (lambda (c)
(signal c) ; won't do SETQ if MUFFLE-WARNING is invoked (signal c) ; won't do SETQ if MUFFLE-WARNING is invoked
(when (and *fail-on-warnings* (if last-form
(string>= (cl:lisp-implementation-version) "2.1")) (setf style-warnp (type-of c))
(cerror "Proceed anyway" (when (and *fail-on-warnings*
"make-host-1 stopped due to~%~a" c)))) (string>= (cl:lisp-implementation-version) "2.1"))
(cerror "Proceed anyway"
"make-host-1 stopped due to~%~a" c)))))
(simple-warning (simple-warning
(lambda (c) (lambda (c)
(declare (ignore c)) (declare (ignore c))
(when (and *fail-on-warnings* (if last-form
(string>= (cl:lisp-implementation-version) "2.1")) (setf warn (type-of c))
(cerror "Proceed anyway" (when (and *fail-on-warnings*
"make-host-1 stopped due to~%~a" c))))) (string>= (cl:lisp-implementation-version) "2.1"))
(with-compilation-unit () ,@forms)) (cerror "Proceed anyway"
"make-host-1 stopped due to~%~a" c))))))
(with-compilation-unit () ,@forms (setf last-form t)))
(when (and (string>= (cl:lisp-implementation-version) "2.1") (when (and (string>= (cl:lisp-implementation-version) "2.1")
(or warnp style-warnp) *fail-on-warnings*) (or warnp style-warnp) *fail-on-warnings*)
(cerror "Proceed anyway" (cerror "Proceed anyway"