lisp-action.lisp 9.69 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 :common-lisp :asdf/driver :asdf/upgrade
   :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 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35
   #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
   #:call-with-around-compile-hook
   #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source))
(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 52 53 54 55 56 57 58 59 60 61 62

(defclass test-op (operation) ())


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

;;; prepare-op
(defmethod operation-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))
63
  (if-let (it (system-source-file s)) (list it)))
64 65 66 67 68 69 70

;;; compile-op
(defmethod operation-description ((o compile-op) (c component))
  (declare (ignorable o))
  (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c))
(defmethod operation-description ((o compile-op) (c parent-component))
  (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 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108
        (destructuring-bind
            (output-file &optional #+(or ecl mkcl) object-file #+sbcl warnings-file) outputs
          (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
                       #+(or ecl mkcl) (list :object-file object-file)
                       #+sbcl (list :warnings-file warnings-file)
                       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)
  (check-deferred-warnings
   (remove-if-not #'warnings-file-p (input-files o c))
   "~/asdf-action::format-action/" (list (cons o c)))
  (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~%")))))
109 110 111 112 113 114
(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
115 116 117 118 119
             i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)))
    `(,f ;; the fasl is the primary output, in first position
      #+ecl ,@(unless (use-ecl-byte-compiler-p)
                (compile-file-pathname i :type :object))
      #+mkcl ,(compile-file-pathname i :fasl-p nil) ;; object file
120 121 122
      #+sbcl ,@(let ((s (component-system c)))
                 (unless (or (builtin-system-p s) (equal (component-name s) "asdf"))
                   `(,(make-pathname :type "sbcl-warnings" :defaults f)))))))
123 124 125 126 127 128 129 130 131
(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)
132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150
(defmethod perform ((o compile-op) (c system))
  (declare (ignorable o c))
  nil
  #+sbcl (perform-lisp-warnings-check o c))
#+sbcl
(defmethod input-files ((o compile-op) (c system))
  (declare (ignorable o c))
  (unless (builtin-system-p c)
    (loop :for (sub-o . sub-c)
          :in (traverse-sub-actions
               o c :other-systems nil
                   :keep-operation 'compile-op :keep-component 'cl-source-file)
          :append (remove-if-not 'warnings-file-p
                               (output-files sub-o sub-c)))))
#+sbcl
(defmethod output-files ((o compile-op) (c system))
  (unless (builtin-system-p c)
    (if-let ((pathname (component-pathname c)))
      (list (subpathname pathname (component-name c) :type "build-report")))))
151 152 153 154 155 156 157

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


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

;;; prepare-source-op
(defmethod operation-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))
199
  (if-let (it (system-source-file s)) (list it)))
200 201 202 203 204 205 206 207 208 209 210 211 212 213
(defmethod perform ((o prepare-source-op) (c component))
  (declare (ignorable o c))
  nil)

;;; load-source-op
(defmethod operation-description ((o load-source-op) c)
  (declare (ignorable o))
  (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") c))
(defmethod operation-description ((o load-source-op) (c parent-component))
  (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)))
214
(defun* perform-lisp-load-source (o c)
215
  (call-with-around-compile-hook
216
   c #'(lambda ()
217
         (with-muffled-loader-conditions ()
218 219 220
           (load* (first (input-files o c))
                  :external-format (component-external-format c))))))

221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242
(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)))