lisp-action.lisp 9.97 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
                 warnings-file) outputs
93 94
            (call-with-around-compile-hook
             c #'(lambda (&rest flags)
95 96 97 98 99 100
                   (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
101
                           #+(or clasp ecl mkcl) (list :object-file object-file)
102
                           flags (compile-op-flags o))))))
103 104 105 106
        (check-lisp-compile-results output warnings-p failure-p
                                    "~/asdf-action::format-action/" (list (cons o c))))))

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

;;; load-op
161 162 163 164 165
(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
166 167
  (defmethod action-description ((o load-op) (c component))
    (format nil (compatfmt "~@<loading ~3i~_~A~@:>") c))
168 169 170 171 172 173 174 175 176 177 178
  (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)))
179
      (load* fasl)))
180 181 182
  (defmethod perform ((o load-op) (c cl-source-file))
    (perform-lisp-load-fasl o c))
  (defmethod perform ((o load-op) (c static-file))
183
    nil))
184 185 186 187 188


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

;;; prepare-source-op
189 190 191 192 193 194 195
(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))
196 197

;;; load-source-op
198
(with-upgradability ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
199
  (defmethod action-description ((o load-source-op) (c component))
200 201 202 203 204 205
    (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 ()
206 207
           (load* (first (input-files o c))
                  :external-format (component-external-format c)))))
208 209 210 211 212

  (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))
213 214 215


;;;; test-op
216 217 218 219 220
(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."
221
    nil))
222