lisp-action.lisp 10.5 KB
Newer Older
1
2
3
;;;; -------------------------------------------------------------------------
;;;; Actions to build Common Lisp software

4
5
(asdf/package:define-package :asdf/lisp-action
  (:recycle :asdf/lisp-action :asdf)
6
  (:intern #:proclamations #:flags)
7
  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
8
   :asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/operation :asdf/action)
9
  (:export
10
   #:try-recompiling
11
   #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
12
   #:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations
13
14
   #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
   #:call-with-around-compile-hook
15
   #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source #:flags))
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
(in-package :asdf/lisp-action)


;;;; Component classes
(defclass cl-source-file (source-file)
  ((type :initform "lisp")))
(defclass cl-source-file.cl (cl-source-file)
  ((type :initform "cl")))
(defclass cl-source-file.lsp (cl-source-file)
  ((type :initform "lsp")))


;;;; Operation classes
(defclass basic-load-op (operation) ())
(defclass basic-compile-op (operation)
  ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
   (flags :initarg :flags :accessor compile-op-flags
          :initform nil)))

;;; Our default operations: loading into the current lisp image
36
37
38
39
40
(defclass load-op (basic-load-op downward-operation sibling-operation) ())
(defclass prepare-op (upward-operation sibling-operation)
  ((sibling-operation :initform 'load-op :allocation :class)))
(defclass compile-op (basic-compile-op downward-operation)
  ((downward-operation :initform 'load-op :allocation :class)))
41
42

(defclass load-source-op (basic-load-op downward-operation) ())
43
44
(defclass prepare-source-op (upward-operation sibling-operation)
  ((sibling-operation :initform 'load-source-op :allocation :class)))
45
46
47
48
49
50
51

(defclass test-op (operation) ())


;;;; prepare-op, compile-op and load-op

;;; prepare-op
52
(defmethod action-description ((o prepare-op) (c component))
53
54
55
56
57
58
59
60
61
62
  (declare (ignorable o))
  (format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c))
(defmethod perform ((o prepare-op) (c component))
  (declare (ignorable o c))
  nil)
(defmethod input-files ((o prepare-op) (c component))
  (declare (ignorable o c))
  nil)
(defmethod input-files ((o prepare-op) (s system))
  (declare (ignorable o))
63
  (if-let (it (system-source-file s)) (list it)))
64
65

;;; compile-op
66
(defmethod action-description ((o compile-op) (c component))
67
68
  (declare (ignorable o))
  (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c))
69
(defmethod action-description ((o compile-op) (c parent-component))
70
  (declare (ignorable o))
71
  (format nil (compatfmt "~@<completing compilation for ~3i~_~A~@:>") c))
72
73
74
75
76
77
78
79
80
(defgeneric* call-with-around-compile-hook (component thunk))
(defmethod call-with-around-compile-hook ((c component) function)
  (call-around-hook (around-compile-hook c) function))
(defun* perform-lisp-compilation (o c)
  (let (;; Before 2.26.53, that was unfortunately component-pathname. Now,
        ;; we consult input-files, the first of which should be the one to compile-file
        (input-file (first (input-files o c)))
        ;; on some implementations, there are more than one output-file,
        ;; but the first one should always be the primary fasl that gets loaded.
81
        (outputs (output-files o c)))
82
    (multiple-value-bind (output warnings-p failure-p)
83
        (destructuring-bind
84
85
86
87
88
            (output-file
             &optional
               #+clisp lib-file
               #+(or ecl mkcl) object-file
               #+(or clozure sbcl) warnings-file) outputs
89
90
91
92
93
94
95
          (call-with-around-compile-hook
           c #'(lambda (&rest flags)
                 (with-muffled-compiler-conditions ()
                   (apply 'compile-file* input-file
                          :output-file output-file
                          :external-format (component-external-format c)
                      (append
96
                       #+clisp (list :lib-file lib-file)
97
                       #+(or ecl mkcl) (list :object-file object-file)
98
                       #+(or clozure sbcl) (list :warnings-file warnings-file)
99
100
101
102
103
104
105
                       flags (compile-op-flags o)))))))
      (check-lisp-compile-results output warnings-p failure-p
                                  "~/asdf-action::format-action/" (list (cons o c))))))

(defun* report-file-p (f)
  (equal (pathname-type f) "build-report"))
(defun* perform-lisp-warnings-check (o c)
106
107
108
109
110
111
112
113
114
115
116
117
  (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-files o c)))
         (actual-warnings-files (loop :for w :in expected-warnings-files
                                      :when (get-file-stamp w)
                                        :collect w
                                      :else :do (warn "Missing warnings file ~S while ~A"
                                                      w (action-description o c)))))
    (check-deferred-warnings actual-warnings-files)
    (let* ((output (output-files o c))
           (report (find-if #'report-file-p output)))
      (when report
        (with-open-file (s report :direction :output :if-exists :supersede)
          (format s ":success~%"))))))
118
119
120
121
122
123
(defmethod perform ((o compile-op) (c cl-source-file))
  (perform-lisp-compilation o c))
(defmethod output-files ((o compile-op) (c cl-source-file))
  (declare (ignorable o))
  (let* ((i (first (input-files o c)))
         (f (compile-file-pathname
124
125
             i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)))
    `(,f ;; the fasl is the primary output, in first position
126
127
      #+clisp
      ,@`(,(make-pathname :type "lib" :defaults f))
128
129
130
131
132
133
134
135
136
      #+(or clozure sbcl)
      ,@(let ((s (component-system c)))
          (unless (builtin-system-p s) ; includes ASDF itself
            `(,(make-pathname :type (warnings-file-type) :defaults f))))
      #+ecl
      ,@(unless (use-ecl-byte-compiler-p)
          `(,(compile-file-pathname i :type :object)))
      #+mkcl
      ,(compile-file-pathname i :fasl-p nil)))) ;; object file
137
138
139
140
141
142
143
144
145
(defmethod component-depends-on ((o compile-op) (c component))
  (declare (ignorable o))
  `((prepare-op ,c) ,@(call-next-method)))
(defmethod perform ((o compile-op) (c static-file))
  (declare (ignorable o c))
  nil)
(defmethod output-files ((o compile-op) (c static-file))
  (declare (ignorable o c))
  nil)
146
147
(defmethod perform ((o compile-op) (c system))
  (declare (ignorable o c))
148
  #+(or clozure sbcl) (perform-lisp-warnings-check o c))
149
#+(or clozure sbcl)
150
151
(defmethod input-files ((o compile-op) (c system))
  (declare (ignorable o c))
152
153
154
155
156
157
158
  (when *warnings-file-type*
    (unless (builtin-system-p c)
      ;; The most correct way to do it would be to use:
      ;; (traverse-sub-actions o c :other-systems nil :keep-operation 'compile-op :keep-component 'cl-source-file)
      ;; but it's expensive and we don't care too much about file order or ASDF extensions.
      (loop :for sub :in (sub-components c :type 'cl-source-file)
            :nconc (remove-if-not 'warnings-file-p (output-files o sub))))))
159
#+(or clozure sbcl)
160
(defmethod output-files ((o compile-op) (c system))
161
  (when (and *warnings-file-type* (not (builtin-system-p c)))
162
163
    (if-let ((pathname (component-pathname c)))
      (list (subpathname pathname (component-name c) :type "build-report")))))
164
165

;;; load-op
166
(defmethod action-description ((o load-op) (c cl-source-file))
167
168
  (declare (ignorable o))
  (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c))
169
(defmethod action-description ((o load-op) (c parent-component))
170
  (declare (ignorable o))
171
  (format nil (compatfmt "~@<completing load for ~3i~_~A~@:>") c))
172
(defmethod action-description ((o load-op) component)
173
174
175
176
177
178
179
180
181
182
183
184
  (declare (ignorable o))
  (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
          component))
(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
  (loop
    (restart-case
        (return (call-next-method))
      (try-recompiling ()
        :report (lambda (s)
                  (format s "Recompile ~a and try loading it again"
                          (component-name c)))
        (perform (find-operation o 'compile-op) c)))))
185
(defun* perform-lisp-load-fasl (o c)
186
  (if-let (fasl (first (input-files o c)))
187
    (with-muffled-loader-conditions () (load* fasl))))
188
189
190
191
192
193
194
(defmethod perform ((o load-op) (c cl-source-file))
  (perform-lisp-load-fasl o c))
(defmethod perform ((o load-op) (c static-file))
  (declare (ignorable o c))
  nil)
(defmethod component-depends-on ((o load-op) (c component))
  (declare (ignorable o))
195
196
197
198
  ;; NB: even though compile-op depends-on on prepare-op,
  ;; it is not needed-in-image-p, whereas prepare-op is,
  ;; so better not omit prepare-op and think it will happen.
  `((prepare-op ,c) (compile-op ,c) ,@(call-next-method)))
199
200
201
202
203


;;;; prepare-source-op, load-source-op

;;; prepare-source-op
204
(defmethod action-description ((o prepare-source-op) (c component))
205
206
207
208
209
210
211
  (declare (ignorable o))
  (format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:>") c))
(defmethod input-files ((o prepare-source-op) (c component))
  (declare (ignorable o c))
  nil)
(defmethod input-files ((o prepare-source-op) (s system))
  (declare (ignorable o))
212
  (if-let (it (system-source-file s)) (list it)))
213
214
215
216
217
(defmethod perform ((o prepare-source-op) (c component))
  (declare (ignorable o c))
  nil)

;;; load-source-op
218
(defmethod action-description ((o load-source-op) c)
219
220
  (declare (ignorable o))
  (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") c))
221
(defmethod action-description ((o load-source-op) (c parent-component))
222
223
224
225
226
  (declare (ignorable o))
  (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c))
(defmethod component-depends-on ((o load-source-op) (c component))
  (declare (ignorable o))
  `((prepare-source-op ,c) ,@(call-next-method)))
227
(defun* perform-lisp-load-source (o c)
228
  (call-with-around-compile-hook
229
   c #'(lambda ()
230
         (with-muffled-loader-conditions ()
231
232
233
           (load* (first (input-files o c))
                  :external-format (component-external-format c))))))

234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
(defmethod perform ((o load-source-op) (c cl-source-file))
  (perform-lisp-load-source o c))
(defmethod perform ((o load-source-op) (c static-file))
  (declare (ignorable o c))
  nil)
(defmethod output-files ((o load-source-op) (c component))
  (declare (ignorable o c))
  nil)


;;;; test-op
(defmethod perform ((o test-op) (c component))
  (declare (ignorable o c))
  nil)
(defmethod operation-done-p ((o test-op) (c system))
  "Testing a system is _never_ done."
  (declare (ignorable o c))
  nil)
(defmethod component-depends-on ((o test-op) (c system))
  (declare (ignorable o))
  `((load-op ,c) ,@(call-next-method)))