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

4
(uiop/package:define-package :asdf/lisp-action
5
  (: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
    (:documentation "Load dependencies necessary for COMPILE-OP or LOAD-OP of a given COMPONENT."))
43
  (defclass load-op (basic-load-op downward-operation selfward-operation)
44
    ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p,
45
    ;; so we need to directly depend on prepare-op for its side-effects in the current image.
46
    ((selfward-operation :initform '(prepare-op compile-op) :allocation :class)))
47
  (defclass compile-op (basic-compile-op downward-operation selfward-operation)
48
    ((selfward-operation :initform 'prepare-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
(with-upgradability ()
  (defmethod action-description ((o prepare-op) (c component))
    (format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c))
  (defmethod perform ((o prepare-op) (c component))
    nil)
  (defmethod input-files ((o prepare-op) (s system))
    (if-let (it (system-source-file s)) (list it))))
69 70

;;; compile-op
71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89
(with-upgradability ()
  (defmethod action-description ((o compile-op) (c component))
    (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c))
  (defmethod action-description ((o compile-op) (c parent-component))
    (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
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
90
                 #+(or clasp ecl mkcl) object-file
91
                 #+clisp lib-file
92 93 94 95 96 97 98
                 warnings-file &rest rest) outputs
            ;; Allow for extra outputs that are not of type warnings-file
            ;; The way we do it is kludgy. In ASDF4, output-files shall not be positional.
            (declare (ignore rest))
            (when warnings-file
              (unless (equal (pathname-type warnings-file) (warnings-file-type))
                (setf warnings-file nil)))
99 100
            (call-with-around-compile-hook
             c #'(lambda (&rest flags)
101 102 103 104 105 106
                   (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)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
107
                           #+(or clasp ecl mkcl) (list :object-file object-file)
108
                           flags (compile-op-flags o))))))
109 110 111 112
        (check-lisp-compile-results output warnings-p failure-p
                                    "~/asdf-action::format-action/" (list (cons o c))))))

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

;;; load-op
167 168 169 170 171
(with-upgradability ()
  (defmethod action-description ((o load-op) (c cl-source-file))
    (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c))
  (defmethod action-description ((o load-op) (c parent-component))
    (format nil (compatfmt "~@<completing load for ~3i~_~A~@:>") c))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
172 173
  (defmethod action-description ((o load-op) (c component))
    (format nil (compatfmt "~@<loading ~3i~_~A~@:>") c))
174 175 176 177 178 179 180 181 182 183 184
  (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)))
185
      (load* fasl)))
186 187 188
  (defmethod perform ((o load-op) (c cl-source-file))
    (perform-lisp-load-fasl o c))
  (defmethod perform ((o load-op) (c static-file))
189
    nil))
190 191 192 193 194


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

;;; prepare-source-op
195 196 197 198 199 200 201
(with-upgradability ()
  (defmethod action-description ((o prepare-source-op) (c component))
    (format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:>") c))
  (defmethod input-files ((o prepare-source-op) (s system))
    (if-let (it (system-source-file s)) (list it)))
  (defmethod perform ((o prepare-source-op) (c component))
    nil))
202 203

;;; load-source-op
204
(with-upgradability ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
205
  (defmethod action-description ((o load-source-op) (c component))
206 207 208 209 210 211
    (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") c))
  (defmethod action-description ((o load-source-op) (c parent-component))
    (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c))
  (defun perform-lisp-load-source (o c)
    (call-with-around-compile-hook
     c #'(lambda ()
212 213
           (load* (first (input-files o c))
                  :external-format (component-external-format c)))))
214 215 216 217 218

  (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))
    nil))
219 220 221


;;;; test-op
222 223 224 225 226
(with-upgradability ()
  (defmethod perform ((o test-op) (c component))
    nil)
  (defmethod operation-done-p ((o test-op) (c system))
    "Testing a system is _never_ done."
227
    nil))
228