lisp-action.lisp 10.7 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 8
  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache
   :asdf/component :asdf/system :asdf/find-component :asdf/find-system
9
   :asdf/operation :asdf/action)
10
  (:export
11
   #:try-recompiling
12
   #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
13
   #:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations
14 15
   #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
   #:call-with-around-compile-hook
16 17
   #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source
   #:lisp-compilation-output-files #:flags))
18 19 20 21
(in-package :asdf/lisp-action)


;;;; Component classes
22 23 24 25 26 27 28
(with-upgradability ()
  (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"))))
29 30 31


;;;; Operation classes
32 33 34 35
(with-upgradability ()
  (defclass basic-load-op (operation) ())
  (defclass basic-compile-op (operation)
    ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
36
     (flags :initarg :flags :accessor compile-op-flags :initform nil))))
37 38

;;; Our default operations: loading into the current lisp image
39
(with-upgradability ()
40
  (defclass prepare-op (upward-operation sideway-operation)
41
    ((sideway-operation :initform 'load-op :allocation :class)))
42
  (defclass load-op (basic-load-op downward-operation sideway-operation selfward-operation)
43
    ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p,
44
    ;; so we need to directly depend on prepare-op for its side-effects in the current image.
45
    ((selfward-operation :initform '(prepare-op compile-op) :allocation :class)))
46
  (defclass compile-op (basic-compile-op downward-operation selfward-operation)
47 48
    ((selfward-operation :initform 'prepare-op :allocation :class)
     (downward-operation :initform 'load-op :allocation :class)))
49

50
  (defclass prepare-source-op (upward-operation sideway-operation)
51
    ((sideway-operation :initform 'load-source-op :allocation :class)))
52
  (defclass load-source-op (basic-load-op downward-operation selfward-operation)
53
    ((selfward-operation :initform 'prepare-source-op :allocation :class)))
54

55
  (defclass test-op (selfward-operation)
56
    ((selfward-operation :initform 'load-op :allocation :class))))
57 58 59 60 61


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

;;; prepare-op
62 63 64 65 66 67 68 69 70 71 72 73 74
(with-upgradability ()
  (defmethod action-description ((o prepare-op) (c component))
    (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))
    (if-let (it (system-source-file s)) (list it))))
75 76

;;; compile-op
77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99
(with-upgradability ()
  (defmethod action-description ((o compile-op) (c component))
    (declare (ignorable o))
    (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c))
  (defmethod action-description ((o compile-op) (c parent-component))
    (declare (ignorable o))
    (format nil (compatfmt "~@<completing compilation for ~3i~_~A~@:>") c))
  (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.
          (outputs (output-files o c)))
      (multiple-value-bind (output warnings-p failure-p)
          (destructuring-bind
              (output-file
               &optional
                 #+clisp lib-file
                 #+(or ecl mkcl) object-file
100
                 warnings-file) outputs
101 102
            (call-with-around-compile-hook
             c #'(lambda (&rest flags)
103 104 105 106 107 108 109 110
                   (apply 'compile-file* input-file
                          :output-file output-file
                          :external-format (component-external-format c)
                          :warnings-file warnings-file
                          (append
                           #+clisp (list :lib-file lib-file)
                           #+(or ecl mkcl) (list :object-file object-file)
                           flags (compile-op-flags o))))))
111 112 113 114
        (check-lisp-compile-results output warnings-p failure-p
                                    "~/asdf-action::format-action/" (list (cons o c))))))

  (defun report-file-p (f)
115
    (equalp (pathname-type f) "build-report"))
116 117 118 119 120 121 122 123 124 125 126 127 128 129 130
  (defun perform-lisp-warnings-check (o c)
    (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~%"))))))
  (defmethod perform ((o compile-op) (c cl-source-file))
    (perform-lisp-compilation o c))
131
  (defun lisp-compilation-output-files (o c)
132 133 134 135 136 137 138 139 140 141
    (let* ((i (first (input-files o c)))
           (f (compile-file-pathname
               i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)))
      `(,f ;; the fasl is the primary output, in first position
        #+clisp
        ,@`(,(make-pathname :type "lib" :defaults f))
        #+ecl
        ,@(unless (use-ecl-byte-compiler-p)
            `(,(compile-file-pathname i :type :object)))
        #+mkcl
142 143 144
        ,(compile-file-pathname i :fasl-p nil) ;; object file
        ,@(when (and *warnings-file-type* (not (builtin-system-p (component-system c))))
            `(,(make-pathname :type *warnings-file-type* :defaults f))))))
145 146
  (defmethod output-files ((o compile-op) (c cl-source-file))
    (lisp-compilation-output-files o c))
147 148 149 150 151 152 153
  (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)
  (defmethod perform ((o compile-op) (c system))
154
    (when (and *warnings-file-type* (not (builtin-system-p c)))
155 156
      (perform-lisp-warnings-check o c)))
  (defmethod input-files ((o compile-op) (c system))
157 158 159 160 161 162
    (when (and *warnings-file-type* (not (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)))))
163 164 165
  (defmethod output-files ((o compile-op) (c system))
    (when (and *warnings-file-type* (not (builtin-system-p c)))
      (if-let ((pathname (component-pathname c)))
166
        (list (subpathname pathname (coerce-filename c) :type "build-report"))))))
167 168

;;; load-op
169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190
(with-upgradability ()
  (defmethod action-description ((o load-op) (c cl-source-file))
    (declare (ignorable o))
    (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c))
  (defmethod action-description ((o load-op) (c parent-component))
    (declare (ignorable o))
    (format nil (compatfmt "~@<completing load for ~3i~_~A~@:>") c))
  (defmethod action-description ((o load-op) component)
    (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)))))
  (defun perform-lisp-load-fasl (o c)
    (if-let (fasl (first (input-files o c)))
191
      (load* fasl)))
192 193 194 195
  (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))
196
    nil))
197 198 199 200 201


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

;;; prepare-source-op
202 203 204 205 206 207 208 209 210 211 212 213 214
(with-upgradability ()
  (defmethod action-description ((o prepare-source-op) (c component))
    (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))
    (if-let (it (system-source-file s)) (list it)))
  (defmethod perform ((o prepare-source-op) (c component))
    (declare (ignorable o c))
    nil))
215 216

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

  (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))
238 239 240


;;;; test-op
241 242 243 244 245 246 247
(with-upgradability ()
  (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))
248
    nil))
249