diff --git a/make-target-2-load.lisp b/make-target-2-load.lisp index 2ea2f7522..ab94822ba 100644 --- a/make-target-2-load.lisp +++ b/make-target-2-load.lisp @@ -537,6 +537,23 @@ Please check that all strings which were not recognizable to the compiler (scan-format-control-strings) +(macrolet ((def-backward-compatible-sb-c-specials (pairs) ; for UIOP + ASDF + `(progn + ,@(mapcar (lambda (pair) + `(define-symbol-macro ,(car pair) + (,(sb-int:package-symbolicate "SB-C" "CU-" (cdr pair) "-COUNT") + sb-c::*compilation-unit*))) + pairs)))) + ;; coece to a strict boolean + (define-symbol-macro sb-c::*in-compilation-unit* (not (null sb-c::*compilation-unit*))) + ;; the "specials" are all SETFable when and only when *IN-COMPILATION-UNIT* is T + (def-backward-compatible-sb-c-specials + sb-c::((*aborted-compilation-unit-count* . "ABORTED") + (*compiler-error-count* . "ERROR") + (*compiler-warning-count* . "WARNING") + (*compiler-style-warning-count* . "STYLE-WARNING") + (*compiler-note-count* . "NOTE")))) + #+sb-devel (rename-package "COMMON-LISP" "COMMON-LISP" '("SB-XC" "CL")) diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index b2b1234ad..598f76798 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -517,13 +517,23 @@ has written, having proved that it is unreachable.")) ;;;; condition system interface -;;; Keep track of how many times each kind of condition happens. -(defvar *compiler-error-count*) -(defvar *compiler-warning-count*) -(defvar *compiler-style-warning-count*) -(defvar *compiler-note-count*) - -(defvar *methods-in-compilation-unit*) +(defstruct (compilation-unit (:conc-name cu-) (:predicate nil) (:copier nil) + (:constructor make-compilation-unit ())) + ;; Count of the number of compilation units dynamically enclosed by + ;; the current active WITH-COMPILATION-UNIT that were unwound out of. + (aborted-count 0 :type fixnum) + ;; Keep track of how many times each kind of condition happens. + (error-count 0 :type fixnum) + (warning-count 0 :type fixnum) + (style-warning-count 0 :type fixnum) + (note-count 0 :type fixnum) + ;; hash-table of hash-tables: + ;; outer: GF-Name -> hash-table + ;; inner: (qualifiers . specializers) -> lambda-list + (methods nil :type (or null hash-table))) +;;; This is a CUNIT if we are within a WITH-COMPILATION-UNIT form (which +;;; normally causes nested uses to be no-ops). +(defvar *compilation-unit* nil) ;;; Keep track of whether any surrounding COMPILE or COMPILE-FILE call ;;; should return WARNINGS-P or FAILURE-P. @@ -535,21 +545,21 @@ has written, having proved that it is unreachable.")) ;;; counter and print the error message. (defun compiler-error-handler (condition) (signal condition) - (incf *compiler-error-count*) + (incf (cu-error-count *compilation-unit*)) (setf *warnings-p* t *failure-p* t) (print-compiler-condition condition) (continue condition)) (defun compiler-warning-handler (condition) (signal condition) - (incf *compiler-warning-count*) + (incf (cu-warning-count *compilation-unit*)) (setf *warnings-p* t *failure-p* t) (print-compiler-condition condition) (muffle-warning condition)) (defun compiler-style-warning-handler (condition) (signal condition) - (incf *compiler-style-warning-count*) + (incf (cu-style-warning-count *compilation-unit*)) (setf *warnings-p* t) (print-compiler-condition condition) (muffle-warning condition)) @@ -576,7 +586,7 @@ has written, having proved that it is unreachable.")) (= inhibit-warnings 3)) (policy *lexenv* (= inhibit-warnings 3))) (with-condition (condition datum args) - (incf *compiler-note-count*) + (incf (cu-note-count *compilation-unit*)) (print-compiler-message *error-output* (format nil "note: ~~A") diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 1057db8f6..cefcd5d75 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1658,8 +1658,8 @@ possible.") (current-defmethod (destructuring-bind (name qualifiers specializers lambda-list) (cdr spec) - (let* ((gfs (or *methods-in-compilation-unit* - (setf *methods-in-compilation-unit* + (let* ((gfs (or (cu-methods *compilation-unit*) + (setf (cu-methods *compilation-unit*) (make-hash-table :test #'equal)))) (methods (or (gethash name gfs) (setf (gethash name gfs) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 7b1855872..b374ded9f 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -50,14 +50,6 @@ ;;; identifiable compilation. (defvar *source-info* nil) -;;; This is true if we are within a WITH-COMPILATION-UNIT form (which -;;; normally causes nested uses to be no-ops). -(defvar *in-compilation-unit* nil) - -;;; Count of the number of compilation units dynamically enclosed by -;;; the current active WITH-COMPILATION-UNIT that were unwound out of. -(defvar *aborted-compilation-unit-count*) - ;;; Mumble conditional on *COMPILE-PROGRESS*. (defun maybe-mumble (&rest foo) (when *compile-progress* @@ -171,22 +163,22 @@ Examples: (*source-namestring* (awhen (or source-namestring *source-namestring*) (possibly-base-stringize it)))) - (if (and *in-compilation-unit* (not override)) + (if (and *compilation-unit* (not override)) ;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is ;; ordinarily (unless OVERRIDE) basically a no-op. (unwind-protect (multiple-value-prog1 (funcall fn) (setf succeeded-p t)) (unless succeeded-p - (incf *aborted-compilation-unit-count*))) - (let ((*aborted-compilation-unit-count* 0) - (*compiler-error-count* 0) - (*compiler-warning-count* 0) - (*compiler-style-warning-count* 0) - (*compiler-note-count* 0) - (*undefined-warnings* nil) - *argument-mismatch-warnings* - *methods-in-compilation-unit* - (*in-compilation-unit* t)) + (incf (cu-aborted-count *compilation-unit*)))) + ;; (Were it not for UIOP+ASDF touching *undefined-warnings*, it should be an alist + ;; of hash-tables, the alist keys denoting the KINDs of warnings and the + ;; hash-table keys being the NAMEs that have been warned about of each KIND. + ;; Currently NOTE-NAME-DEFINED takes time proportional to the number of warnings + ;; issued, which may number in the hundredsd. Perhaps some trick with a SETF + ;; function will work to convert between pretend and actual representation) + (let ((*undefined-warnings* nil) ; UIOP both reads and writes this + *argument-mismatch-warnings* ; bound in SIMPLE-EVAL-LOCALLY also + (*compilation-unit* (make-compilation-unit))) (handler-bind ((parse-unknown-type (lambda (c) (note-undefined-reference @@ -195,7 +187,7 @@ Examples: (unwind-protect (multiple-value-prog1 (funcall fn) (setf succeeded-p t)) (unless succeeded-p - (incf *aborted-compilation-unit-count*)) + (incf (cu-aborted-count *compilation-unit*))) (summarize-compilation-unit (not succeeded-p))))))))) (if policy (let ((*policy* (process-optimize-decl policy (unless override *policy*))) @@ -226,7 +218,7 @@ Examples: ;;; aborted by throwing out. ABORT-COUNT is the number of dynamically ;;; enclosed nested compilation units that were aborted. (defun summarize-compilation-unit (abort-p) - (let (summary) + (let ((cu *compilation-unit*) summary) (unless abort-p (let ((undefs (sort *undefined-warnings* #'string< :key (lambda (x) @@ -287,11 +279,11 @@ Examples: more kind name)))))))))) (unless (and (not abort-p) - (zerop *aborted-compilation-unit-count*) - (zerop *compiler-error-count*) - (zerop *compiler-warning-count*) - (zerop *compiler-style-warning-count*) - (zerop *compiler-note-count*)) + (zerop (cu-aborted-count cu)) + (zerop (cu-error-count cu)) + (zerop (cu-warning-count cu)) + (zerop (cu-style-warning-count cu)) + (zerop (cu-note-count cu))) (fresh-line *error-output*) (pprint-logical-block (*error-output* nil :per-line-prefix "; ") (format *error-output* "~&compilation unit ~:[finished~;aborted~]" @@ -307,11 +299,11 @@ Examples: ~[~:;~:*~& caught ~W WARNING condition~:P~]~ ~[~:;~:*~& caught ~W STYLE-WARNING condition~:P~]~ ~[~:;~:*~& printed ~W note~:P~]" - *aborted-compilation-unit-count* - *compiler-error-count* - *compiler-warning-count* - *compiler-style-warning-count* - *compiler-note-count*)) + (cu-aborted-count cu) + (cu-error-count cu) + (cu-warning-count cu) + (cu-style-warning-count cu) + (cu-note-count cu))) (terpri *error-output*) (force-output *error-output*)))) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index a9a997574..a41f97665 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -496,9 +496,9 @@ (defun compute-gf-ftype (name) (let ((gf (and (fboundp name) (fdefinition name))) - (methods-in-compilation-unit (and (boundp 'sb-c::*methods-in-compilation-unit*) - sb-c::*methods-in-compilation-unit* - (gethash name sb-c::*methods-in-compilation-unit*)))) + (methods-in-compilation-unit (binding* ((cu sb-c::*compilation-unit* :exit-if-null) + (methods (sb-c::cu-methods cu) :exit-if-null)) + (gethash name methods)))) (cond ((generic-function-p gf) (let* ((ll (generic-function-lambda-list gf)) ;; If the GF has &REST without &KEY then we don't augment