lisp-build.lisp 40 KB
Newer Older
1
2
3
;;;; -------------------------------------------------------------------------
;;;; Support to build (compile and load) Lisp files

4
5
6
7
8
(uiop/package:define-package :uiop/lisp-build
  (:nicknames :asdf/lisp-build)
  (:recycle :uiop/lisp-build :asdf/lisp-build :asdf)
  (:use :uiop/common-lisp :uiop/package :uiop/utility
   :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image)
9
  (:export
10
   ;; Variables
11
   #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
12
   #:*output-translation-function*
13
   #:*optimization-settings* #:*previous-optimization-settings*
14
   #:*base-build-directory*
15
16
17
   #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
   #:compile-warned-warning #:compile-failed-warning
   #:check-lisp-compile-results #:check-lisp-compile-warnings
18
19
   #:*uninteresting-conditions* #:*usual-uninteresting-conditions*
   #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
20
21
   ;; Types
   #+sbcl #:sb-grovel-unknown-constant-condition
22
   ;; Functions & Macros
23
   #:get-optimization-settings #:proclaim-optimization-settings #:with-optimization-settings
24
25
   #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
   #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
26
   #:reify-simple-sexp #:unreify-simple-sexp
27
   #:reify-deferred-warnings #:unreify-deferred-warnings
28
   #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings
29
   #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type*
30
   #:enable-deferred-warnings-check #:disable-deferred-warnings-check
31
32
   #:current-lisp-file-pathname #:load-pathname
   #:lispize-pathname #:compile-file-type #:call-around-hook
33
   #:compile-file* #:compile-file-pathname* #:*compile-check*
34
   #:load* #:load-from-string #:combine-fasls)
35
  (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
36
(in-package :uiop/lisp-build)
37

38
39
40
41
(with-upgradability ()
  (defvar *compile-file-warnings-behaviour*
    (or #+clisp :ignore :warn)
    "How should ASDF react if it encounters a warning when compiling a file?
42
43
Valid values are :error, :warn, and :ignore.")

44
45
46
  (defvar *compile-file-failure-behaviour*
    (or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
    "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
47
48
when compiling a file, which includes any non-style-warning warning.
Valid values are :error, :warn, and :ignore.
49
Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
50

51
52
53
54
55
  (defvar *base-build-directory* nil
    "When set to a non-null value, it should be an absolute directory pathname,
which will serve as the *DEFAULT-PATHNAME-DEFAULTS* around a COMPILE-FILE,
what more while the input-file is shortened if possible to ENOUGH-PATHNAME relative to it.
This can help you produce more deterministic output for FASLs."))
56
57

;;; Optimization settings
58
(with-upgradability ()
59
60
61
62
  (defvar *optimization-settings* nil
    "Optimization settings to be used by PROCLAIM-OPTIMIZATION-SETTINGS")
  (defvar *previous-optimization-settings* nil
    "Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS")
63
64
  (defparameter +optimization-variables+
    ;; TODO: allegro genera corman mcl
65
66
    (or #+(or abcl xcl) '(system::*speed* system::*space* system::*safety* system::*debug*)
        #+clisp '() ;; system::*optimize* is a constant hash-table! (with non-constant contents)
67
68
69
        #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety*
                    ccl::*nx-debug* ccl::*nx-cspeed*)
        #+(or cmu scl) '(c::*default-cookie*)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
70
71
        #+(and ecl (not clasp)) (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*))
        #+clasp '()
72
73
74
75
        #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*)
        #+lispworks '(compiler::*optimization-level*)
        #+mkcl '(si::*speed* si::*space* si::*safety* si::*debug*)
        #+sbcl '(sb-c::*policy*)))
76
77
  (defun get-optimization-settings ()
    "Get current compiler optimization settings, ready to PROCLAIM again"
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
78
    #-(or abcl allegro clasp clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
79
80
    (warn "~S does not support ~S. Please help me fix that."
          'get-optimization-settings (implementation-type))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
81
    #+(or abcl allegro clasp clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
82
    (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
83
84
85
86
      #.`(loop #+(or allegro clozure)
               ,@'(:with info = #+allegro (sys:declaration-information 'optimize)
                   #+clozure (ccl:declaration-information 'optimize nil))
               :for x :in settings
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
87
               ,@(or #+(or abcl clasp ecl gcl mkcl xcl) '(:for v :in +optimization-variables+))
88
89
               :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order
                            #+clisp (gethash x system::*optimize* 1)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
90
                            #+(or abcl clasp ecl mkcl xcl) (symbol-value v)
91
92
93
                            #+(or cmu scl) (slot-value c::*default-cookie*
                                                       (case x (compilation-speed 'c::cspeed)
                                                             (otherwise x)))
94
                            #+lispworks (slot-value compiler::*optimization-level* x)
95
                            #+sbcl (sb-c::policy-quality sb-c::*policy* x))
96
97
98
99
100
101
               :when y :collect (list x y))))
  (defun proclaim-optimization-settings ()
    "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
    (proclaim `(optimize ,@*optimization-settings*))
    (let ((settings (get-optimization-settings)))
      (unless (equal *previous-optimization-settings* settings)
102
103
        (setf *previous-optimization-settings* settings))))
  (defmacro with-optimization-settings ((&optional (settings *optimization-settings*)) &body body)
104
    #+(or allegro clisp)
105
106
107
108
109
    (let ((previous-settings (gensym "PREVIOUS-SETTINGS")))
      `(let ((,previous-settings (get-optimization-settings)))
         ,@(when settings `((proclaim `(optimize ,@,settings))))
         (unwind-protect (progn ,@body)
           (proclaim `(optimize ,@,previous-settings)))))
110
    #-(or allegro clisp)
111
112
113
    `(let ,(loop :for v :in +optimization-variables+ :collect `(,v ,v))
       ,@(when settings `((proclaim `(optimize ,@,settings))))
       ,@body)))
114
115
116


;;; Condition control
117
118
119
120
(with-upgradability ()
  #+sbcl
  (progn
    (defun sb-grovel-unknown-constant-condition-p (c)
121
      "Detect SB-GROVEL unknown-constant conditions on older versions of SBCL"
122
123
124
125
126
127
128
129
      (and (typep c 'sb-int:simple-style-warning)
           (string-enclosed-p
            "Couldn't grovel for "
            (simple-condition-format-control c)
            " (unknown to the C compiler).")))
    (deftype sb-grovel-unknown-constant-condition ()
      '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p))))

130
  (defvar *usual-uninteresting-conditions*
131
132
133
    (append
     ;;#+clozure '(ccl:compiler-warning)
     #+cmu '("Deleting unreachable code.")
134
135
     #+lispworks '("~S being redefined in ~A (previously in ~A)."
                   "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when.
136
137
138
139
     #+sbcl
     '(sb-c::simple-compiler-note
       "&OPTIONAL and &KEY found in the same lambda list: ~S"
       #+sb-eval sb-kernel:lexical-environment-too-complex
140
       sb-kernel:undefined-alien-style-warning
141
       sb-grovel-unknown-constant-condition ; defined above.
142
       sb-ext:implicit-generic-function-warning ;; Controversial.
143
144
       sb-int:package-at-variance
       sb-kernel:uninteresting-redefinition
145
146
147
148
149
150
       ;; BEWARE: the below four are controversial to include here.
       sb-kernel:redefinition-with-defun
       sb-kernel:redefinition-with-defgeneric
       sb-kernel:redefinition-with-defmethod
       sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
     '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
151
152
153
    "A suggested value to which to set or bind *uninteresting-conditions*.")

  (defvar *uninteresting-conditions* '()
154
155
156
    "Conditions that may be skipped while compiling or loading Lisp code.")
  (defvar *uninteresting-compiler-conditions* '()
    "Additional conditions that may be skipped while compiling Lisp code.")
157
158
159
160
161
  (defvar *uninteresting-loader-conditions*
    (append
     '("Overwriting already existing readtable ~S." ;; from named-readtables
       #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
     #+clisp '(clos::simple-gf-replacing-method-warning))
162
    "Additional conditions that may be skipped while loading Lisp code."))
163
164

;;;; ----- Filtering conditions while building -----
165
166
(with-upgradability ()
  (defun call-with-muffled-compiler-conditions (thunk)
167
    "Call given THUNK in a context where uninteresting conditions and compiler conditions are muffled"
168
    (call-with-muffled-conditions
169
     thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*)))
170
  (defmacro with-muffled-compiler-conditions ((&optional) &body body)
171
    "Trivial syntax for CALL-WITH-MUFFLED-COMPILER-CONDITIONS"
172
173
    `(call-with-muffled-compiler-conditions #'(lambda () ,@body)))
  (defun call-with-muffled-loader-conditions (thunk)
174
    "Call given THUNK in a context where uninteresting conditions and loader conditions are muffled"
175
    (call-with-muffled-conditions
176
     thunk (append *uninteresting-conditions* *uninteresting-loader-conditions*)))
177
  (defmacro with-muffled-loader-conditions ((&optional) &body body)
178
    "Trivial syntax for CALL-WITH-MUFFLED-LOADER-CONDITIONS"
179
    `(call-with-muffled-loader-conditions #'(lambda () ,@body))))
180

181

182
;;;; Handle warnings and failures
183
184
185
186
187
188
189
190
191
(with-upgradability ()
  (define-condition compile-condition (condition)
    ((context-format
      :initform nil :reader compile-condition-context-format :initarg :context-format)
     (context-arguments
      :initform nil :reader compile-condition-context-arguments :initarg :context-arguments)
     (description
      :initform nil :reader compile-condition-description :initarg :description))
    (:report (lambda (c s)
192
193
194
195
               (format s (compatfmt "~@<~A~@[ while ~?~]~@:>")
                       (or (compile-condition-description c) (type-of c))
                       (compile-condition-context-format c)
                       (compile-condition-context-arguments c)))))
196
197
198
199
200
201
202
203
  (define-condition compile-file-error (compile-condition error) ())
  (define-condition compile-warned-warning (compile-condition warning) ())
  (define-condition compile-warned-error (compile-condition error) ())
  (define-condition compile-failed-warning (compile-condition warning) ())
  (define-condition compile-failed-error (compile-condition error) ())

  (defun check-lisp-compile-warnings (warnings-p failure-p
                                                  &optional context-format context-arguments)
204
205
    "Given the warnings or failures as resulted from COMPILE-FILE or checking deferred warnings,
raise an error or warning as appropriate"
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
    (when failure-p
      (case *compile-file-failure-behaviour*
        (:warn (warn 'compile-failed-warning
                     :description "Lisp compilation failed"
                     :context-format context-format
                     :context-arguments context-arguments))
        (:error (error 'compile-failed-error
                       :description "Lisp compilation failed"
                       :context-format context-format
                       :context-arguments context-arguments))
        (:ignore nil)))
    (when warnings-p
      (case *compile-file-warnings-behaviour*
        (:warn (warn 'compile-warned-warning
                     :description "Lisp compilation had style-warnings"
                     :context-format context-format
                     :context-arguments context-arguments))
        (:error (error 'compile-warned-error
                       :description "Lisp compilation had style-warnings"
                       :context-format context-format
                       :context-arguments context-arguments))
        (:ignore nil))))

  (defun check-lisp-compile-results (output warnings-p failure-p
                                             &optional context-format context-arguments)
231
    "Given the results of COMPILE-FILE, raise an error or warning as appropriate"
232
233
234
    (unless output
      (error 'compile-file-error :context-format context-format :context-arguments context-arguments))
    (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments)))
235
236


237
;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman.
238
239
240
241
242
243
;;;
;;; To support an implementation, three functions must be implemented:
;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings
;;; See their respective docstrings.
(with-upgradability ()
  (defun reify-simple-sexp (sexp)
244
245
    "Given a simple SEXP, return a representation of it as a portable SEXP.
Simple means made of symbols, numbers, characters, simple-strings, pathnames, cons cells."
246
247
248
    (etypecase sexp
      (symbol (reify-symbol sexp))
      ((or number character simple-string pathname) sexp)
249
250
      (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))
      (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list))))))
251

252
  (defun unreify-simple-sexp (sexp)
253
    "Given the portable output of REIFY-SIMPLE-SEXP, return the simple SEXP it represents"
254
255
256
    (etypecase sexp
      ((or symbol number character simple-string pathname) sexp)
      (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp))))
257
258
      ((simple-vector 2) (unreify-symbol sexp))
      ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp (aref sexp 0)) 'vector))))
259
260
261
262
263
264
265

  #+clozure
  (progn
    (defun reify-source-note (source-note)
      (when source-note
        (with-accessors ((source ccl::source-note-source) (filename ccl:source-note-filename)
                         (start-pos ccl:source-note-start-pos) (end-pos ccl:source-note-end-pos)) source-note
266
267
268
          (declare (ignorable source))
          (list :filename filename :start-pos start-pos :end-pos end-pos
                #|:source (reify-source-note source)|#))))
269
270
271
272
273
    (defun unreify-source-note (source-note)
      (when source-note
        (destructuring-bind (&key filename start-pos end-pos source) source-note
          (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos
                                 :source (unreify-source-note source)))))
274
275
276
277
278
279
280
281
282
    (defun unsymbolify-function-name (name)
      (if-let (setfed (gethash name ccl::%setf-function-name-inverses%))
        `(setf ,setfed)
        name))
    (defun symbolify-function-name (name)
      (if (and (consp name) (eq (first name) 'setf))
          (let ((setfed (second name)))
            (gethash setfed ccl::%setf-function-names%))
          name))
283
    (defun reify-function-name (function-name)
284
      (let ((name (or (first function-name) ;; defun: extract the name
285
286
287
                      (let ((sec (second function-name)))
                        (or (and (atom sec) sec) ; scoped method: drop scope
                            (first sec)))))) ; method: keep gf name, drop method specializers
288
        (list name)))
289
    (defun unreify-function-name (function-name)
290
      function-name)
291
292
293
294
295
296
    (defun nullify-non-literals (sexp)
      (typecase sexp
        ((or number character simple-string symbol pathname) sexp)
        (cons (cons (nullify-non-literals (car sexp))
                    (nullify-non-literals (cdr sexp))))
        (t nil)))
297
298
299
300
301
    (defun reify-deferred-warning (deferred-warning)
      (with-accessors ((warning-type ccl::compiler-warning-warning-type)
                       (args ccl::compiler-warning-args)
                       (source-note ccl:compiler-warning-source-note)
                       (function-name ccl:compiler-warning-function-name)) deferred-warning
302
        (list :warning-type warning-type :function-name (reify-function-name function-name)
303
              :source-note (reify-source-note source-note)
304
305
306
307
              :args (destructuring-bind (fun &rest more)
                        args
                      (cons (unsymbolify-function-name fun)
                            (nullify-non-literals more))))))
308
309
310
311
312
    (defun unreify-deferred-warning (reified-deferred-warning)
      (destructuring-bind (&key warning-type function-name source-note args)
          reified-deferred-warning
        (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-whining-conditions*))
                            'ccl::compiler-warning)
313
                        :function-name (unreify-function-name function-name)
314
315
                        :source-note (unreify-source-note source-note)
                        :warning-type warning-type
316
317
                        :args (destructuring-bind (fun . more) args
                                (cons (symbolify-function-name fun) more))))))
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
  #+(or cmu scl)
  (defun reify-undefined-warning (warning)
    ;; Extracting undefined-warnings from the compilation-unit
    ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
    (list*
     (c::undefined-warning-kind warning)
     (c::undefined-warning-name warning)
     (c::undefined-warning-count warning)
     (mapcar
      #'(lambda (frob)
          ;; the lexenv slot can be ignored for reporting purposes
          `(:enclosing-source ,(c::compiler-error-context-enclosing-source frob)
            :source ,(c::compiler-error-context-source frob)
            :original-source ,(c::compiler-error-context-original-source frob)
            :context ,(c::compiler-error-context-context frob)
            :file-name ,(c::compiler-error-context-file-name frob) ; a pathname
            :file-position ,(c::compiler-error-context-file-position frob) ; an integer
            :original-source-path ,(c::compiler-error-context-original-source-path frob)))
      (c::undefined-warning-warnings warning))))

338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
  #+sbcl
  (defun reify-undefined-warning (warning)
    ;; Extracting undefined-warnings from the compilation-unit
    ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
    (list*
     (sb-c::undefined-warning-kind warning)
     (sb-c::undefined-warning-name warning)
     (sb-c::undefined-warning-count warning)
     (mapcar
      #'(lambda (frob)
          ;; the lexenv slot can be ignored for reporting purposes
          `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob)
            :source ,(sb-c::compiler-error-context-source frob)
            :original-source ,(sb-c::compiler-error-context-original-source frob)
            :context ,(sb-c::compiler-error-context-context frob)
            :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname
            :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer
            :original-source-path ,(sb-c::compiler-error-context-original-source-path frob)))
      (sb-c::undefined-warning-warnings warning))))

  (defun reify-deferred-warnings ()
    "return a portable S-expression, portably readable and writeable in any Common Lisp implementation
360
361
using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by
WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
362
    #+allegro
363
    (list :functions-defined excl::.functions-defined.
364
          :functions-called excl::.functions-called.)
365
366
367
368
369
    #+clozure
    (mapcar 'reify-deferred-warning
            (if-let (dw ccl::*outstanding-deferred-warnings*)
              (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
                (ccl::deferred-warnings.warnings mdw))))
370
371
372
373
374
375
376
377
378
379
380
381
    #+(or cmu scl)
    (when lisp::*in-compilation-unit*
      ;; Try to send nothing through the pipe if nothing needs to be accumulated
      `(,@(when c::*undefined-warnings*
            `((c::*undefined-warnings*
               ,@(mapcar #'reify-undefined-warning c::*undefined-warnings*))))
        ,@(loop :for what :in '(c::*compiler-error-count*
                                c::*compiler-warning-count*
                                c::*compiler-note-count*)
                :for value = (symbol-value what)
                :when (plusp value)
                  :collect `(,what . ,value))))
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
    #+sbcl
    (when sb-c::*in-compilation-unit*
      ;; Try to send nothing through the pipe if nothing needs to be accumulated
      `(,@(when sb-c::*undefined-warnings*
            `((sb-c::*undefined-warnings*
               ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings*))))
        ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count*
                                sb-c::*compiler-error-count*
                                sb-c::*compiler-warning-count*
                                sb-c::*compiler-style-warning-count*
                                sb-c::*compiler-note-count*)
                :for value = (symbol-value what)
                :when (plusp value)
                  :collect `(,what . ,value)))))

  (defun unreify-deferred-warnings (reified-deferred-warnings)
    "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate the corresponding
399
400
401
402
deferred warnings as to be handled at the end of the current WITH-COMPILATION-UNIT.
Handle any warning that has been resolved already,
such as an undefined function that has been defined since.
One of three functions required for deferred-warnings support in ASDF."
403
    (declare (ignorable reified-deferred-warnings))
404
405
    #+allegro
    (destructuring-bind (&key functions-defined functions-called)
406
        reified-deferred-warnings
407
408
409
410
      (setf excl::.functions-defined.
            (append functions-defined excl::.functions-defined.)
            excl::.functions-called.
            (append functions-called excl::.functions-called.)))
411
412
413
414
415
    #+clozure
    (let ((dw (or ccl::*outstanding-deferred-warnings*
                  (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t)))))
      (appendf (ccl::deferred-warnings.warnings dw)
               (mapcar 'unreify-deferred-warning reified-deferred-warnings)))
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
    #+(or cmu scl)
    (dolist (item reified-deferred-warnings)
      ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
      ;; For *undefined-warnings*, the adjustment is a list of initargs.
      ;; For everything else, it's an integer.
      (destructuring-bind (symbol . adjustment) item
        (case symbol
          ((c::*undefined-warnings*)
           (setf c::*undefined-warnings*
                 (nconc (mapcan
                         #'(lambda (stuff)
                             (destructuring-bind (kind name count . rest) stuff
                               (unless (case kind (:function (fboundp name)))
                                 (list
                                  (c::make-undefined-warning
                                   :name name
                                   :kind kind
                                   :count count
                                   :warnings
                                   (mapcar #'(lambda (x)
                                               (apply #'c::make-compiler-error-context x))
                                           rest))))))
                         adjustment)
                        c::*undefined-warnings*)))
          (otherwise
           (set symbol (+ (symbol-value symbol) adjustment))))))
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
    #+sbcl
    (dolist (item reified-deferred-warnings)
      ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
      ;; For *undefined-warnings*, the adjustment is a list of initargs.
      ;; For everything else, it's an integer.
      (destructuring-bind (symbol . adjustment) item
        (case symbol
          ((sb-c::*undefined-warnings*)
           (setf sb-c::*undefined-warnings*
                 (nconc (mapcan
                         #'(lambda (stuff)
                             (destructuring-bind (kind name count . rest) stuff
                               (unless (case kind (:function (fboundp name)))
                                 (list
                                  (sb-c::make-undefined-warning
                                   :name name
                                   :kind kind
                                   :count count
                                   :warnings
                                   (mapcar #'(lambda (x)
                                               (apply #'sb-c::make-compiler-error-context x))
                                           rest))))))
                         adjustment)
                        sb-c::*undefined-warnings*)))
          (otherwise
           (set symbol (+ (symbol-value symbol) adjustment)))))))

  (defun reset-deferred-warnings ()
    "Reset the set of deferred warnings to be handled at the end of the current WITH-COMPILATION-UNIT.
471
One of three functions required for deferred-warnings support in ASDF."
472
473
474
    #+allegro
    (setf excl::.functions-defined. nil
          excl::.functions-called. nil)
475
476
477
478
    #+clozure
    (if-let (dw ccl::*outstanding-deferred-warnings*)
      (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
        (setf (ccl::deferred-warnings.warnings mdw) nil)))
479
480
481
482
483
484
    #+(or cmu scl)
    (when lisp::*in-compilation-unit*
      (setf c::*undefined-warnings* nil
            c::*compiler-error-count* 0
            c::*compiler-warning-count* 0
            c::*compiler-note-count* 0))
485
486
487
488
489
490
491
492
493
494
495
    #+sbcl
    (when sb-c::*in-compilation-unit*
      (setf sb-c::*undefined-warnings* nil
            sb-c::*aborted-compilation-unit-count* 0
            sb-c::*compiler-error-count* 0
            sb-c::*compiler-warning-count* 0
            sb-c::*compiler-style-warning-count* 0
            sb-c::*compiler-note-count* 0)))

  (defun save-deferred-warnings (warnings-file)
    "Save forward reference conditions so they may be issued at a latter time,
496
possibly in a different process."
497
498
499
    (with-open-file (s warnings-file :direction :output :if-exists :supersede
                       :element-type *default-stream-element-type*
                       :external-format *utf-8-external-format*)
500
501
502
503
504
      (with-safe-io-syntax ()
        (write (reify-deferred-warnings) :stream s :pretty t :readably t)
        (terpri s))))

  (defun warnings-file-type (&optional implementation-type)
505
506
    "The pathname type for warnings files on given IMPLEMENTATION-TYPE,
where NIL designates the current one"
507
    (case (or implementation-type *implementation-type*)
508
509
      ((:acl :allegro) "allegro-warnings")
      ;;((:clisp) "clisp-warnings")
510
511
512
513
      ((:cmu :cmucl) "cmucl-warnings")
      ((:sbcl) "sbcl-warnings")
      ((:clozure :ccl) "ccl-warnings")
      ((:scl) "scl-warnings")))
514

515
  (defvar *warnings-file-type* nil
516
    "Pathname type for warnings files, or NIL if disabled")
517

518
  (defun enable-deferred-warnings-check ()
519
    "Enable the saving of deferred warnings"
520
521
522
    (setf *warnings-file-type* (warnings-file-type)))

  (defun disable-deferred-warnings-check ()
523
    "Disable the saving of deferred warnings"
524
525
    (setf *warnings-file-type* nil))

526
  (defun warnings-file-p (file &optional implementation-type)
527
528
    "Is FILE a saved warnings file for the given IMPLEMENTATION-TYPE?
If that given type is NIL, use the currently configured *WARNINGS-FILE-TYPE* instead."
529
530
531
532
533
534
    (if-let (type (if implementation-type
                      (warnings-file-type implementation-type)
                      *warnings-file-type*))
      (equal (pathname-type file) type)))

  (defun check-deferred-warnings (files &optional context-format context-arguments)
535
    "Given a list of FILES containing deferred warnings saved by CALL-WITH-SAVED-DEFERRED-WARNINGS,
536
re-intern and raise any warnings that are still meaningful."
537
538
539
540
541
542
543
544
545
546
547
548
549
550
    (let ((file-errors nil)
          (failure-p nil)
          (warnings-p nil))
      (handler-bind
          ((warning #'(lambda (c)
                        (setf warnings-p t)
                        (unless (typep c 'style-warning)
                          (setf failure-p t)))))
        (with-compilation-unit (:override t)
          (reset-deferred-warnings)
          (dolist (file files)
            (unreify-deferred-warnings
             (handler-case (safe-read-file-form file)
               (error (c)
551
                 ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
                 (push c file-errors)
                 nil))))))
      (dolist (error file-errors) (error error))
      (check-lisp-compile-warnings
       (or failure-p warnings-p) failure-p context-format context-arguments)))

  #|
  Mini-guide to adding support for deferred warnings on an implementation.

  First, look at what such a warning looks like:

  (describe
  (handler-case
  (and (eval '(lambda () (some-undefined-function))) nil)
  (t (c) c)))

  Then you can grep for the condition type in your compiler sources
  and see how to catch those that have been deferred,
  and/or read, clear and restore the deferred list.

  Also look at
  (macroexpand-1 '(with-compilation-unit () foo))
  |#

576
  (defun call-with-saved-deferred-warnings (thunk warnings-file &key source-namestring)
577
578
579
    "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK
and save those warnings to the given file for latter use,
possibly in a different process. Otherwise just call THUNK."
580
    (declare (ignorable source-namestring))
581
    (if warnings-file
582
        (with-compilation-unit (:override t #+sbcl :source-namestring #+sbcl source-namestring)
583
584
585
          (unwind-protect
               (let (#+sbcl (sb-c::*undefined-warnings* nil))
                 (multiple-value-prog1
586
                     (funcall thunk)
587
588
589
590
                   (save-deferred-warnings warnings-file)))
            (reset-deferred-warnings)))
        (funcall thunk)))

591
  (defmacro with-saved-deferred-warnings ((warnings-file &key source-namestring) &body body)
592
    "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS"
593
594
    `(call-with-saved-deferred-warnings
      #'(lambda () ,@body) ,warnings-file :source-namestring ,source-namestring)))
595
596
597


;;; from ASDF
598
599
(with-upgradability ()
  (defun current-lisp-file-pathname ()
600
    "Portably return the PATHNAME of the current Lisp source file being compiled or loaded"
601
602
603
    (or *compile-file-pathname* *load-pathname*))

  (defun load-pathname ()
604
    "Portably return the LOAD-PATHNAME of the current source file or fasl"
605
    *load-pathname*) ;; magic no longer needed for GCL.
606
607

  (defun lispize-pathname (input-file)
608
    "From a INPUT-FILE pathname, return a corresponding .lisp source pathname"
609
610
611
612
613
    (make-pathname :type "lisp" :defaults input-file))

  (defun compile-file-type (&rest keys)
    "pathname TYPE for lisp FASt Loading files"
    (declare (ignorable keys))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
614
615
    #-(or clasp ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
    #+(or clasp ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)))
616
617

  (defun call-around-hook (hook function)
618
    "Call a HOOK around the execution of FUNCTION"
619
620
621
    (call-function (or hook 'funcall) function))

  (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
622
    "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*"
623
    (let* ((keys
624
             (remove-plist-keys `(#+(or (and allegro (not (version>= 8 2)))) :external-format
625
626
627
628
629
630
631
632
633
634
                                    ,@(unless output-file '(:output-file))) keys)))
      (if (absolute-pathname-p output-file)
          ;; what cfp should be doing, w/ mp* instead of mp
          (let* ((type (pathname-type (apply 'compile-file-type keys)))
                 (defaults (make-pathname
                            :type type :defaults (merge-pathnames* input-file))))
            (merge-pathnames* output-file defaults))
          (funcall *output-translation-function*
                   (apply 'compile-file-pathname input-file keys)))))

635
636
637
  (defvar *compile-check* nil
    "A hook for user-defined compile-time invariants")

638
  (defun* (compile-file*) (input-file &rest keys
639
                                      &key (compile-check *compile-check*) output-file warnings-file
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
640
                                      #+clisp lib-file #+(or clasp ecl mkcl) object-file #+sbcl emit-cfasl
641
642
                                      &allow-other-keys)
    "This function provides a portable wrapper around COMPILE-FILE.
643
644
645
646
647
648
649
650
651
652
653
654
655
It ensures that the OUTPUT-FILE value is only returned and
the file only actually created if the compilation was successful,
even though your implementation may not do that, and including
an optional call to an user-provided consistency check function COMPILE-CHECK;
it will call this function if not NIL at the end of the compilation
with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE
where TMP-FILE is the name of a temporary output-file.
It also checks two flags (with legacy british spelling from ASDF1),
*COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR*
with appropriate implementation-dependent defaults,
and if a failure (respectively warnings) are reported by COMPILE-FILE
with consider it an error unless the respective behaviour flag
is one of :SUCCESS :WARN :IGNORE.
656
If WARNINGS-FILE is defined, deferred warnings are saved to that file.
657
658
659
On ECL or MKCL, it creates both the linkable object and loadable fasl files.
On implementations that erroneously do not recognize standard keyword arguments,
it will filter them appropriately."
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
660
    #+(or clasp ecl) (when (and object-file (equal (compile-file-type) (pathname object-file)))
661
662
663
664
            (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%"
                    'compile-file* output-file object-file)
            (rotatef output-file object-file))
    (let* ((keywords (remove-plist-keys
665
                      `(:output-file :compile-check :warnings-file
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
666
                                     #+clisp :lib-file #+(or clasp ecl mkcl) :object-file) keys))
667
668
669
           (output-file
             (or output-file
                 (apply 'compile-file-pathname* input-file :output-file output-file keywords)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
670
           #+(or clasp ecl)
671
672
673
           (object-file
             (unless (use-ecl-byte-compiler-p)
               (or object-file
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
674
                   #+ecl(compile-file-pathname output-file :type :object)
675
                   #+clasp (compile-file-pathname output-file :output-type :object))))
676
677
           #+mkcl
           (object-file
678
             (or object-file
679
680
                 (compile-file-pathname output-file :fasl-p nil)))
           (tmp-file (tmpize-pathname output-file))
681
682
683
684
685
686
687
688
           #+sbcl
           (cfasl-file (etypecase emit-cfasl
                         (null nil)
                         ((eql t) (make-pathname :type "cfasl" :defaults output-file))
                         (string (parse-namestring emit-cfasl))
                         (pathname emit-cfasl)))
           #+sbcl
           (tmp-cfasl (when cfasl-file (make-pathname :type "cfasl" :defaults tmp-file)))
689
690
691
           #+clisp
           (tmp-lib (make-pathname :type "lib" :defaults tmp-file)))
      (multiple-value-bind (output-truename warnings-p failure-p)
692
693
694
          (with-enough-pathname (input-file :defaults *base-build-directory*)
            (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file))
              (with-muffled-compiler-conditions ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
695
                (or #-(or clasp ecl mkcl)
696
697
698
699
                    (apply 'compile-file input-file :output-file tmp-file
                           #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords)
                           #-sbcl keywords)
                    #+ecl (apply 'compile-file input-file :output-file
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
700
701
702
703
704
705
706
                                (if object-file
                                    (list* object-file :system-p t keywords)
                                    (list* tmp-file keywords)))
                    #+clasp (apply 'compile-file input-file :output-file
                                  (if object-file
                                      (list* object-file :output-type :object #|:system-p t|# keywords)
                                      (list* tmp-file keywords)))
707
708
                    #+mkcl (apply 'compile-file input-file
                                  :output-file object-file :fasl-p nil keywords)))))
709
710
711
712
713
714
715
        (cond
          ((and output-truename
                (flet ((check-flag (flag behaviour)
                         (or (not flag) (member behaviour '(:success :warn :ignore)))))
                  (and (check-flag failure-p *compile-file-failure-behaviour*)
                       (check-flag warnings-p *compile-file-warnings-behaviour*)))
                (progn
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
716
717
                  #+(or clasp ecl mkcl)
                  (when (and #+(or clasp ecl) object-file)
718
                    (setf output-truename
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
719
                          (compiler::build-fasl tmp-file
720
                           #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (list object-file))))
721
                  (or (not compile-check)
722
723
724
                      (apply compile-check input-file
                             :output-file #-(or clasp ecl) output-file #+(or clasp ecl) tmp-file
                             keywords))))
725
726
           (delete-file-if-exists output-file)
           (when output-truename
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
727
             #+clasp (when output-truename (rename-file-overwriting-target tmp-file output-truename))
728
             #+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file))
729
             #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file))
730
731
             (rename-file-overwriting-target output-truename output-file)
             (setf output-truename (truename output-file)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
732
           #+clasp (delete-file-if-exists tmp-file)
733
734
735
           #+clisp (delete-file-if-exists tmp-lib))
          (t ;; error or failed check
           (delete-file-if-exists output-truename)
736
737
           #+clisp (delete-file-if-exists tmp-lib)
           #+sbcl (delete-file-if-exists tmp-cfasl)
738
739
740
741
           (setf output-truename nil)))
        (values output-truename warnings-p failure-p))))

  (defun load* (x &rest keys &key &allow-other-keys)
742
    "Portable wrapper around LOAD that properly handles loading from a stream."
743
744
745
746
747
748
749
750
751
752
753
754
755
756
    (with-muffled-loader-conditions ()
      (etypecase x
        ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream)
         (apply 'load x keys))
        ;; Genera can't load from a string-input-stream
        ;; ClozureCL 1.6 can only load from file input stream
        ;; Allegro 5, I don't remember but it must have been broken when I tested.
        #+(or allegro clozure genera)
        (stream ;; make do this way
         (let ((*package* *package*)
               (*readtable* *readtable*)
               (*load-pathname* nil)
               (*load-truename* nil))
           (eval-input x))))))
757
758
759
760

  (defun load-from-string (string)
    "Portably read and evaluate forms from a STRING."
    (with-input-from-string (s string) (load* s))))
761
762

;;; Links FASLs together
763
764
(with-upgradability ()
  (defun combine-fasls (inputs output)
765
    "Combine a list of FASLs INPUTS into a single FASL OUTPUT"
766
    #-(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl)
767
768
    (error "~A does not support ~S~%inputs ~S~%output  ~S"
           (implementation-type) 'combine-fasls inputs output)
769
    #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0
770
    #+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output)
771
    #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
772
773
774
775
776
777
778
779
    #+lispworks
    (let (fasls)
      (unwind-protect
           (progn
             (loop :for i :in inputs
                   :for n :from 1
                   :for f = (add-pathname-suffix
                             output (format nil "-FASL~D" n))
780
781
                   :do (copy-file i f)
                       (push f fasls))
782
783
784
785
786
787
             (ignore-errors (lispworks:delete-system :fasls-to-concatenate))
             (eval `(scm:defsystem :fasls-to-concatenate
                      (:default-pathname ,(pathname-directory-pathname output))
                      :members
                      ,(loop :for f :in (reverse fasls)
                             :collect `(,(namestring f) :load-only t))))
788
             (delete-file-if-exists output)
789
790
791
             (scm:concatenate-system output :fasls-to-concatenate))
        (loop :for f :in fasls :do (ignore-errors (delete-file f)))
        (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))))