Coverage report: /development/source/library/org/datagraph/spocq-shard/src/core/patches/sbcl-20200809.lisp

KindCoveredAll%
expression27150 18.0
branch026 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; -*- package: cl-user; -*-
2
 
3
 (in-package :sb-c)
4
 
5
 ;;; muffle error-output when a terminated thread is noted as an aborted compilation
6
 ;;; reinstate to diagnose cause
7
 
8
 (declaim (special spocq.i::*task*))
9
 (defun summarize-compilation-unit (abort-p)
10
   (declare (special spocq.i::*task*))
11
   (let (summary)
12
     (unless abort-p
13
       (let ((undefs (sort *undefined-warnings* #'string<
14
                           :key (lambda (x)
15
                                  (let ((x (undefined-warning-name x)))
16
                                    (if (symbolp x)
17
                                        (symbol-name x)
18
                                        (prin1-to-string x))))))
19
             (*last-message-count* (list* 0 nil nil))
20
             (*last-error-context* nil))
21
         (handler-bind ((style-warning #'compiler-style-warning-handler)
22
                        (warning #'compiler-warning-handler))
23
           (dolist (kind '(:variable :function :type))
24
             (let ((names (mapcar #'undefined-warning-name
25
                                  (remove kind undefs :test #'neq
26
                                                      :key #'undefined-warning-kind))))
27
               (when names (push (cons kind names) summary))))
28
           (dolist (undef undefs)
29
             (let ((name (undefined-warning-name undef))
30
                   (kind (undefined-warning-kind undef))
31
                   (warnings (undefined-warning-warnings undef))
32
                   (undefined-warning-count (undefined-warning-count undef)))
33
               (dolist (*compiler-error-context* warnings)
34
                 (if (and (member kind '(:function :type))
35
                          (name-reserved-by-ansi-p name kind))
36
                     (ecase kind
37
                       (:function
38
                        (compiler-warn
39
                         "~@<The function ~S is undefined, and its name is ~
40
                             reserved by ANSI CL so that even if it were ~
41
                             defined later, the code doing so would not be ~
42
                             portable.~:@>" name))
43
                       (:type
44
                        (if (and (consp name) (eq 'quote (car name)))
45
                            (compiler-warn
46
                             "~@<Undefined type ~S. The name starts with ~S: ~
47
                              probably use of a quoted type name in a context ~
48
                              where the name is not evaluated.~:@>"
49
                             name 'quote)
50
                            (compiler-warn
51
                             "~@<Undefined type ~S. Note that name ~S is ~
52
                              reserved by ANSI CL, so code defining a type with ~
53
                              that name would not be portable.~:@>" name
54
                              name))))
55
                     (funcall
56
                      (if (eq kind :variable) #'compiler-warn #'compiler-style-warn)
57
                      (sb-format:tokens "undefined ~(~A~): ~/sb-ext:print-symbol-with-prefix/")
58
                      kind name)))
59
               (let ((warn-count (length warnings)))
60
                 (when (and warnings (> undefined-warning-count warn-count))
61
                   (let ((more (- undefined-warning-count warn-count)))
62
                     (if (eq kind :variable)
63
                         (compiler-warn
64
                          "~W more use~:P of undefined ~(~A~) ~S"
65
                          more kind name)
66
                         (compiler-style-warn
67
                          "~W more use~:P of undefined ~(~A~) ~S"
68
                          more kind name))))))))))
69
     (when *compile-verbose*
70
       (unless (and (not abort-p)
71
                    (zerop *aborted-compilation-unit-count*)
72
                    (zerop *compiler-error-count*)
73
                    (zerop *compiler-warning-count*)
74
                    (zerop *compiler-style-warning-count*)
75
                    (zerop *compiler-note-count*))
76
         (fresh-line *error-output*)
77
         (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
78
           (format *error-output* "~&compilation unit ~:[finished~;aborted~]"
79
                   abort-p)
80
           (format *error-output* "~:[~;~&~:*~s~]"
81
                   spocq.i::*task*)
82
           (dolist (cell summary)
83
             (destructuring-bind (kind &rest names) cell
84
               (format *error-output*
85
                       "~&  Undefined ~(~A~)~p:~
86
                        ~%    ~{~<~% ~1:;~S~>~^ ~}"
87
                       kind (length names) names)))
88
           (format *error-output* "~[~:;~:*~&  caught ~W fatal ERROR condition~:P~]~
89
                                   ~[~:;~:*~&  caught ~W ERROR condition~:P~]~
90
                                   ~[~:;~:*~&  caught ~W WARNING condition~:P~]~
91
                                   ~[~:;~:*~&  caught ~W STYLE-WARNING condition~:P~]~
92
                                   ~[~:;~:*~&  printed ~W note~:P~]"
93
                   *aborted-compilation-unit-count*
94
                   *compiler-error-count*
95
                   *compiler-warning-count*
96
                   *compiler-style-warning-count*
97
                   *compiler-note-count*))
98
         (terpri *error-output*)
99
         (force-output *error-output*)))))
100
 
101
 #+(or) ;; 2.0.7
102
 (defun summarize-compilation-unit (abort-p)
103
   (let (summary)
104
     (unless abort-p
105
       (handler-bind ((style-warning #'compiler-style-warning-handler)
106
                      (warning #'compiler-warning-handler))
107
 
108
         (let ((undefs (sort *undefined-warnings* #'string<
109
                             :key (lambda (x)
110
                                    (let ((x (undefined-warning-name x)))
111
                                      (if (symbolp x)
112
                                          (symbol-name x)
113
                                          (prin1-to-string x)))))))
114
           (dolist (kind '(:variable :function :type))
115
             (let ((names (mapcar #'undefined-warning-name
116
                                    (remove kind undefs :test #'neq
117
                                            :key #'undefined-warning-kind))))
118
               (when names (push (cons kind names) summary))))
119
           (dolist (undef undefs)
120
             (let ((name (undefined-warning-name undef))
121
                   (kind (undefined-warning-kind undef))
122
                   (warnings (undefined-warning-warnings undef))
123
                   (undefined-warning-count (undefined-warning-count undef)))
124
               (dolist (*compiler-error-context* warnings)
125
                 (if #-sb-xc-host (and (member kind '(:function :type))
126
                                       (name-reserved-by-ansi-p name kind)
127
                                       *flame-on-necessarily-undefined-thing*)
128
                     #+sb-xc-host nil
129
                     (ecase kind
130
                       (:function
131
                        (case name
132
                          ((declare)
133
                           (compiler-warn
134
                            "~@<There is no function named ~S. References to ~S ~
135
                             in some contexts (like starts of blocks) have ~
136
                             special meaning, but here it would have to be a ~
137
                             function, and that shouldn't be right.~:@>" name
138
                             name))
139
                          (t
140
                           (compiler-warn
141
                            "~@<The function ~S is undefined, and its name is ~
142
                             reserved by ANSI CL so that even if it were ~
143
                             defined later, the code doing so would not be ~
144
                             portable.~:@>" name))))
145
                       (:type
146
                        (if (and (consp name) (eq 'quote (car name)))
147
                            (compiler-warn
148
                             "~@<Undefined type ~S. The name starts with ~S: ~
149
                              probably use of a quoted type name in a context ~
150
                              where the name is not evaluated.~:@>"
151
                             name 'quote)
152
                            (compiler-warn
153
                             "~@<Undefined type ~S. Note that name ~S is ~
154
                              reserved by ANSI CL, so code defining a type with ~
155
                              that name would not be portable.~:@>" name
156
                              name))))
157
                     (if (eq kind :variable)
158
                         (compiler-warn "undefined ~(~A~): ~S" kind name)
159
                         (compiler-style-warn "undefined ~(~A~): ~S" kind name))))
160
               (let ((warn-count (length warnings)))
161
                 (when (and warnings (> undefined-warning-count warn-count))
162
                   (let ((more (- undefined-warning-count warn-count)))
163
                     (if (eq kind :variable)
164
                         (compiler-warn
165
                          "~W more use~:P of undefined ~(~A~) ~S"
166
                          more kind name)
167
                         (compiler-style-warn
168
                          "~W more use~:P of undefined ~(~A~) ~S"
169
                          more kind name))))))))))
170
 
171
     (unless (or (not *compile-verbose*)
172
                 (and (not abort-p)
173
                      (zerop *aborted-compilation-unit-count*)
174
                      (zerop *compiler-error-count*)
175
                      (zerop *compiler-warning-count*)
176
                      (zerop *compiler-style-warning-count*)
177
                      (zerop *compiler-note-count*)))
178
       (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
179
         (format *error-output* "~&compilation unit ~:[finished~;aborted~]"
180
                 abort-p)
181
         (format *error-output* "~:[~;~&~s~]"
182
                 spocq.i::*task*)
183
         (dolist (cell summary)
184
           (destructuring-bind (kind &rest names) cell
185
             (format *error-output*
186
                     "~&  Undefined ~(~A~)~p:~
187
                      ~%    ~{~<~% ~1:;~S~>~^ ~}"
188
                     kind (length names) names)))
189
         (format *error-output* "~[~:;~:*~&  caught ~W fatal ERROR condition~:P~]~
190
                                 ~[~:;~:*~&  caught ~W ERROR condition~:P~]~
191
                                 ~[~:;~:*~&  caught ~W WARNING condition~:P~]~
192
                                 ~[~:;~:*~&  caught ~W STYLE-WARNING condition~:P~]~
193
                                 ~[~:;~:*~&  printed ~W note~:P~]"
194
                 *aborted-compilation-unit-count*
195
                 *compiler-error-count*
196
                 *compiler-warning-count*
197
                 *compiler-style-warning-count*
198
                 *compiler-note-count*))
199
       (terpri *error-output*)
200
       (force-output *error-output*))))
201