Commit 0a621ca2 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.121: integrate deferred-warnings support to asdf/defsystem

Also, have convenience methods for operation and component designators.
Enhance the incidental traversal functions.
Move compile-file error handling to lisp-build.

Passes tests on CCL and SBCL.
parent fb3d1204
...@@ -2,24 +2,57 @@ ...@@ -2,24 +2,57 @@
;;;; Actions ;;;; Actions
(asdf/package:define-package :asdf/action (asdf/package:define-package :asdf/action
(:nicknames :asdf-action)
(:recycle :asdf/action :asdf) (:recycle :asdf/action :asdf)
(:use :common-lisp :asdf/driver :asdf/upgrade (:use :common-lisp :asdf/driver :asdf/upgrade
:asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation) :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation)
#+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:type-of) #+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:type-of)
(:intern #:stamp #:done-p) (:intern #:stamp #:done-p)
(:export (:export
#:action #:action #:define-convenience-action-methods
#:explain #:operation-description #:explain #:operation-description
#:downward-operation #:upward-operation #:downward-operation #:upward-operation #:sibling-operation
#:operation-error #:error-component #:error-operation
#:component-depends-on #:component-self-dependencies #:component-depends-on #:component-self-dependencies
#:input-files #:output-files #:output-file #:operation-done-p #:input-files #:output-files #:output-file #:operation-done-p
#:action-status #:action-stamp #:action-done-p #:action-status #:action-stamp #:action-done-p
#:component-operation-time #:mark-operation-done #:compute-action-stamp #:component-operation-time #:mark-operation-done #:compute-action-stamp
#:perform #:perform-with-restarts #:retry #:accept #:feature)) #:perform #:perform-with-restarts #:retry #:accept #:feature
#:gather-actions #:operated-components
#:traverse-sub-actions #:dependency-files
))
(in-package :asdf/action) (in-package :asdf/action)
(deftype action () '(cons operation component)) ;; a step to be performed while building the system (deftype action () '(cons operation component)) ;; a step to be performed while building the system
(declaim (ftype (function (t &rest t) t) operated-components traverse-actions)
(ftype (function (t t &rest t) t)
traverse-sub-actions dependency-files))
;;;; Convenience methods
(defmacro define-convenience-action-methods
(function (operation component &rest more-args) &key if-no-operation if-no-component)
(let ((rest (gensym "REST"))
(found (gensym "FOUND")))
`(progn
(defmethod ,function ((,operation symbol) ,component
,@(when more-args `(&rest ,rest))
,@(when (member '&key more-args) `(&key &allow-other-keys)))
(if ,operation
,(if more-args
`(apply ',function (make-operation ,operation) ,component ,rest)
`(,function (make-operation ,operation) ,component))
,if-no-operation))
(defmethod ,function ((,operation operation) ,component
,@(when more-args `(&rest ,rest))
,@(when (member '&key more-args) `(&key &allow-other-keys)))
(if (typep ,component 'component)
(error "No defined method for ~S on ~S" ',function ,component)
(let ((,found (find-component () ,component)))
(if ,found
,(if more-args
`(apply ',function ,operation ,found ,rest)
`(,function ,operation ,found))
,if-no-component)))))))
;;;; self-description ;;;; self-description
...@@ -30,23 +63,17 @@ You can put together sentences using this phrase.")) ...@@ -30,23 +63,17 @@ You can put together sentences using this phrase."))
(defmethod operation-description (operation component) (defmethod operation-description (operation component)
(format nil (compatfmt "~@<~A on ~A~@:>") (format nil (compatfmt "~@<~A on ~A~@:>")
(class-of operation) component)) (class-of operation) component))
(define-convenience-action-methods operation-description (operation component))
(defgeneric* explain (operation component)) (defgeneric* explain (operation component))
(defmethod explain ((o operation) (c component)) (defmethod explain ((o operation) (c component))
(asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (operation-description o c))) (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (operation-description o c)))
(define-convenience-action-methods explain (operation component))
(defun* format-action (stream action &optional colon-p at-sign-p)
;;;; Error (assert (null colon-p)) (assert (null at-sign-p))
(destructuring-bind (operation . component) action
(define-condition operation-error (error) ;; Bad, backward-compatible name (princ (operation-description operation component) stream)))
;; We want to rename it to action-error, but that breaks upgrade on SBCL.
;; Before to rename it, fix these other culprits, too:
;; cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
((component :reader error-component :initarg :component)
(operation :reader error-operation :initarg :operation))
(:report (lambda (c s)
(format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
(type-of c) (error-operation c) (error-component c)))))
;;;; Dependencies ;;;; Dependencies
...@@ -68,6 +95,8 @@ You can put together sentences using this phrase.")) ...@@ -68,6 +95,8 @@ You can put together sentences using this phrase."))
should usually append the results of CALL-NEXT-METHOD to the should usually append the results of CALL-NEXT-METHOD to the
list.")) list."))
(defgeneric* component-self-dependencies (operation component)) (defgeneric* component-self-dependencies (operation component))
(define-convenience-action-methods component-depends-on (operation component))
(define-convenience-action-methods component-self-dependencies (operation component))
(defmethod component-depends-on ((o operation) (c component)) (defmethod component-depends-on ((o operation) (c component))
(cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies (cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies
...@@ -82,17 +111,34 @@ You can put together sentences using this phrase.")) ...@@ -82,17 +111,34 @@ You can put together sentences using this phrase."))
;; These together handle actions that propagate along the component hierarchy. ;; These together handle actions that propagate along the component hierarchy.
;; Downward operations like load-op or compile-op propagate down the hierarchy: ;; Downward operations like load-op or compile-op propagate down the hierarchy:
;; operation on a parent depends-on operation on its children. ;; operation on a parent depends-on operation on its children.
(defclass downward-operation (operation) ()) ;; By default, an operation propagates itself, but it may propagate another one instead.
(defclass downward-operation (operation)
((downward-operation
:initform nil :initarg :downward-operation :reader downward-operation)))
(defmethod component-depends-on ((o downward-operation) (c parent-component))
`((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method)))
;; Upward operations like prepare-op propagate up the component hierarchy: ;; Upward operations like prepare-op propagate up the component hierarchy:
;; operation on a child depends-on operation on its parent. ;; operation on a child depends-on operation on its parent.
(defclass upward-operation (operation) ()) ;; By default, an operation propagates itself, but it may propagate another one instead.
(defclass upward-operation (operation)
(defmethod component-depends-on ((o downward-operation) (c parent-component)) ((upward-operation
`((,o ,@(component-children c)) ,@(call-next-method))) :initform nil :initarg :downward-operation :reader upward-operation)))
;; For backward-compatibility reasons, a system inherits from module and is a child-component ;; For backward-compatibility reasons, a system inherits from module and is a child-component
;; so we must guard against this case. ASDF3: remove that. ;; so we must guard against this case. ASDF3: remove that.
(defmethod component-depends-on ((o upward-operation) (c child-component)) (defmethod component-depends-on ((o upward-operation) (c child-component))
`(,@(if-let (p (component-parent c)) `((,o ,p))) ,@(call-next-method))) `(,@(if-let (p (component-parent c))
`((,(or (upward-operation o) o) ,p))) ,@(call-next-method)))
;; Sibling operations propagate to siblings in the component hierarchy:
;; operation on a child depends-on operation on its parent.
;; By default, an operation propagates itself, but it may propagate another one instead.
(defclass sibling-operation (operation)
((sibling-operation
:initform nil :initarg :sibling-operation :reader sibling-operation)))
(defmethod component-depends-on ((o sibling-operation) (c component))
`((,(or (sibling-operation o) o)
,@(loop :for dep :in (component-sibling-dependencies c)
:collect (resolve-dependency-spec c dep)))
,@(call-next-method)))
;;;; Inputs, Outputs, and invisible dependencies ;;;; Inputs, Outputs, and invisible dependencies
...@@ -100,6 +146,9 @@ You can put together sentences using this phrase.")) ...@@ -100,6 +146,9 @@ You can put together sentences using this phrase."))
(defgeneric* input-files (operation component)) (defgeneric* input-files (operation component))
(defgeneric* operation-done-p (operation component) (defgeneric* operation-done-p (operation component)
(:documentation "Returns a boolean, which is NIL if the action is forced to be performed again")) (:documentation "Returns a boolean, which is NIL if the action is forced to be performed again"))
(define-convenience-action-methods output-files (operation component))
(define-convenience-action-methods input-files (operation component))
(define-convenience-action-methods operation-done-p (operation component))
(defmethod operation-done-p ((o operation) (c component)) (defmethod operation-done-p ((o operation) (c component))
(declare (ignorable o c)) (declare (ignorable o c))
...@@ -145,6 +194,9 @@ You can put together sentences using this phrase.")) ...@@ -145,6 +194,9 @@ You can put together sentences using this phrase."))
;;;; Done performing ;;;; Done performing
(defgeneric* component-operation-time (operation component)) ;; ASDF3: hide it behind plan-action-stamp (defgeneric* component-operation-time (operation component)) ;; ASDF3: hide it behind plan-action-stamp
(define-convenience-action-methods component-operation-time (operation component))
(defgeneric* mark-operation-done (operation component)) ;; ASDF3: hide it behind (setf plan-action-stamp) (defgeneric* mark-operation-done (operation component)) ;; ASDF3: hide it behind (setf plan-action-stamp)
(defgeneric* compute-action-stamp (plan operation component &key just-done) (defgeneric* compute-action-stamp (plan operation component &key just-done)
(:documentation "Has this action been successfully done already, (:documentation "Has this action been successfully done already,
...@@ -188,6 +240,7 @@ in some previous image, or T if it needs to be done.") ...@@ -188,6 +240,7 @@ in some previous image, or T if it needs to be done.")
(defgeneric* perform-with-restarts (operation component)) (defgeneric* perform-with-restarts (operation component))
(defgeneric* perform (operation component)) (defgeneric* perform (operation component))
(define-convenience-action-methods perform (operation component))
(defmethod perform :before ((o operation) (c component)) (defmethod perform :before ((o operation) (c component))
(ensure-all-directories-exist (output-files o c))) (ensure-all-directories-exist (output-files o c)))
......
...@@ -15,10 +15,10 @@ ...@@ -15,10 +15,10 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.120" ;; to be automatically updated by bin/bump-revision :version "2.26.121" ;; to be automatically updated by bin/bump-revision
:depends-on () :depends-on ()
:components ((:module "build" :components ((:file "asdf")))) :components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf)))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op asdf/defsystem))))
#-asdf2.27 #-asdf2.27
(defmethod perform :before (defmethod perform :before
......
...@@ -8,6 +8,8 @@ ...@@ -8,6 +8,8 @@
:asdf/lisp-build :asdf/operate :asdf/output-translations) :asdf/lisp-build :asdf/operate :asdf/output-translations)
(:export (:export
#:*asdf-verbose* #:*asdf-verbose*
#:operation-error #:compile-error #:compile-failed #:compile-warned
#:error-component #:error-operation
#:component-load-dependencies #:component-load-dependencies
#:enable-asdf-binary-locations-compatibility #:enable-asdf-binary-locations-compatibility
#:operation-forced #:operation-forced
...@@ -17,6 +19,17 @@ ...@@ -17,6 +19,17 @@
#:system-definition-pathname)) #:system-definition-pathname))
(in-package :asdf/backward-interface) (in-package :asdf/backward-interface)
(define-condition operation-error (error) ;; Bad, backward-compatible name
;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
((component :reader error-component :initarg :component)
(operation :reader error-operation :initarg :operation))
(:report (lambda (c s)
(format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
(type-of c) (error-operation c) (error-component c)))))
(define-condition compile-error (operation-error) ())
(define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ())
(defun* component-load-dependencies (component) (defun* component-load-dependencies (component)
;; Old deprecated name for the same thing. Please update your software. ;; Old deprecated name for the same thing. Please update your software.
(component-sibling-dependencies component)) (component-sibling-dependencies component))
......
...@@ -15,7 +15,6 @@ ...@@ -15,7 +15,6 @@
#:compiled-file #:precompiled-system #:prebuilt-system #:compiled-file #:precompiled-system #:prebuilt-system
#:operation-monolithic-p #:operation-monolithic-p
#:user-system-p #:user-system #:trivial-system-p #:user-system-p #:user-system #:trivial-system-p
#:gather-actions #:operated-components
#+ecl #:make-build #+ecl #:make-build
#:register-pre-built-system #:register-pre-built-system
#:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library
...@@ -192,23 +191,6 @@ ...@@ -192,23 +191,6 @@
(remf args :ld-flags) (remf args :ld-flags)
args)) args))
(defclass filtered-sequential-plan (sequential-plan)
((action-filter :initarg :action-filter :reader plan-action-filter)))
(defmethod action-valid-p ((plan filtered-sequential-plan) o c)
(and (funcall (plan-action-filter plan) o c) (call-next-method)))
(defun* gather-actions (operation component &key other-systems (filter t))
;; This function creates a list of sub-actions performed
;; while building the targeted action.
;; This list may be restricted to sub-components of SYSTEM
;; if OTHER-SYSTEMS is NIL (default).
(traverse operation component
:plan-class 'filtered-sequential-plan
:action-filter (ensure-function filter)
:force (if other-systems :all t)
:force-not (if other-systems nil :all)))
(defun* bundlable-file-p (pathname) (defun* bundlable-file-p (pathname)
(let ((type (pathname-type pathname))) (let ((type (pathname-type pathname)))
(declare (ignorable type)) (declare (ignorable type))
...@@ -217,19 +199,6 @@ ...@@ -217,19 +199,6 @@
#+mkcl (equal type (compile-file-type :fasl-p nil)) #+mkcl (equal type (compile-file-type :fasl-p nil))
#+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal type (compile-file-type))))) #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal type (compile-file-type)))))
(defun* operated-components (system &key (goal-operation 'load-op) (keep-operation goal-operation)
(component-type t) (keep-component t) other-systems)
(let ((goal-op (make-operation goal-operation)))
(flet ((filter (o c)
(declare (ignore o))
(or (eq c system)
(typep c component-type))))
(loop :for (o . c) :in (gather-actions goal-op system
:other-systems other-systems
:filter #'filter)
:when (and (typep o keep-operation) (typep c keep-component))
:collect c))))
(defgeneric* trivial-system-p (component)) (defgeneric* trivial-system-p (component))
(defun* user-system-p (s) (defun* user-system-p (s)
......
...@@ -190,14 +190,9 @@ another pathname in a degenerate way.")) ...@@ -190,14 +190,9 @@ another pathname in a degenerate way."))
;;;; component pathnames ;;;; component pathnames
(defun* component-parent-pathname (component) (defgeneric* component-parent-pathname (component))
;; No default anymore (in particular, no *default-pathname-defaults*). (defmethod component-parent-pathname (component)
;; If you force component to have a NULL pathname, you better arrange (component-pathname (component-parent component)))
;; for any of its children to explicitly provide a proper absolute pathname
;; wherever a pathname is actually wanted.
(let ((parent (component-parent component)))
(when parent
(component-pathname parent))))
(defmethod component-pathname ((component component)) (defmethod component-pathname ((component component))
(if (slot-boundp component 'absolute-pathname) (if (slot-boundp component 'absolute-pathname)
......
...@@ -33,7 +33,8 @@ ...@@ -33,7 +33,8 @@
;; If no absolute pathname was found, we return NIL. ;; If no absolute pathname was found, we return NIL.
(check-type pathname (or null string pathname)) (check-type pathname (or null string pathname))
(absolutize-pathnames (absolutize-pathnames
(list pathname (load-pathname) *default-pathname-defaults* (getcwd)) (list pathname (load-pathname) *default-pathname-defaults*
#-(or abcl gcl genera) (getcwd))
:resolve-symlinks *resolve-symlinks*)) :resolve-symlinks *resolve-symlinks*))
......
...@@ -158,7 +158,8 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -158,7 +158,8 @@ Going forward, we recommend new users should be using the source-registry.
(let* ((file (probe-file* (let* ((file (probe-file*
(absolutize-pathnames (absolutize-pathnames
(list (make-pathname :name name :type "asd") (list (make-pathname :name name :type "asd")
defaults *default-pathname-defaults* (getcwd)) defaults *default-pathname-defaults*
#-(or abcl gcl genera) (getcwd))
:resolve-symlinks truename) :resolve-symlinks truename)
:truename truename))) :truename truename)))
(when file (when file
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.120: Another System Definition Facility. ;;; This is ASDF 2.26.121: Another System Definition Facility.
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
(:use :common-lisp :asdf/driver :asdf/upgrade (:use :common-lisp :asdf/driver :asdf/upgrade
:asdf/component :asdf/system :asdf/find-component :asdf/operation :asdf/action) :asdf/component :asdf/system :asdf/find-component :asdf/operation :asdf/action)
(:export (:export
#:compile-error #:compile-failed #:compile-warned #:try-recompiling #:try-recompiling
#:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
#:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations #:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations
#:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
...@@ -15,16 +15,8 @@ ...@@ -15,16 +15,8 @@
#:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source)) #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source))
(in-package :asdf/lisp-action) (in-package :asdf/lisp-action)
;;;; Conditions
(define-condition compile-error (operation-error) ())
(define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ())
;;;; Component classes ;;;; Component classes
(defclass cl-source-file (source-file) (defclass cl-source-file (source-file)
((type :initform "lisp"))) ((type :initform "lisp")))
(defclass cl-source-file.cl (cl-source-file) (defclass cl-source-file.cl (cl-source-file)
...@@ -34,7 +26,6 @@ ...@@ -34,7 +26,6 @@
;;;; Operation classes ;;;; Operation classes
(defclass basic-load-op (operation) ()) (defclass basic-load-op (operation) ())
(defclass basic-compile-op (operation) (defclass basic-compile-op (operation)
((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
...@@ -42,12 +33,15 @@ ...@@ -42,12 +33,15 @@
:initform nil))) :initform nil)))
;;; Our default operations: loading into the current lisp image ;;; Our default operations: loading into the current lisp image
(defclass load-op (basic-load-op downward-operation) ()) (defclass load-op (basic-load-op downward-operation sibling-operation) ())
(defclass prepare-op (upward-operation) ()) (defclass prepare-op (upward-operation sibling-operation)
(defclass compile-op (basic-compile-op downward-operation) ()) ((sibling-operation :initform 'load-op :allocation :class)))
(defclass compile-op (basic-compile-op downward-operation)
((downward-operation :initform 'load-op :allocation :class)))
(defclass load-source-op (basic-load-op downward-operation) ()) (defclass load-source-op (basic-load-op downward-operation) ())
(defclass prepare-source-op (upward-operation) ()) (defclass prepare-source-op (upward-operation sibling-operation)
((sibling-operation :initform 'load-source-op :allocation :class)))
(defclass test-op (operation) ()) (defclass test-op (operation) ())
...@@ -58,11 +52,6 @@ ...@@ -58,11 +52,6 @@
(defmethod operation-description ((o prepare-op) (c component)) (defmethod operation-description ((o prepare-op) (c component))
(declare (ignorable o)) (declare (ignorable o))
(format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c)) (format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c))
(defmethod component-depends-on ((o prepare-op) (c component))
(declare (ignorable o))
`((load-op ,@(loop :for dep :in (component-sibling-dependencies c)
:collect (resolve-dependency-spec c dep)))
,@(call-next-method)))
(defmethod perform ((o prepare-op) (c component)) (defmethod perform ((o prepare-op) (c component))
(declare (ignorable o c)) (declare (ignorable o c))
nil) nil)
...@@ -79,7 +68,7 @@ ...@@ -79,7 +68,7 @@
(format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c)) (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c))
(defmethod operation-description ((o compile-op) (c parent-component)) (defmethod operation-description ((o compile-op) (c parent-component))
(declare (ignorable o)) (declare (ignorable o))
(format nil (compatfmt "~@<compiled ~3i~_~A~@:>") c)) (format nil (compatfmt "~@<completing compilation for ~3i~_~A~@:>") c))
(defgeneric* call-with-around-compile-hook (component thunk)) (defgeneric* call-with-around-compile-hook (component thunk))
(defmethod call-with-around-compile-hook ((c component) function) (defmethod call-with-around-compile-hook ((c component) function)
(call-around-hook (around-compile-hook c) function)) (call-around-hook (around-compile-hook c) function))
...@@ -89,44 +78,47 @@ ...@@ -89,44 +78,47 @@
(input-file (first (input-files o c))) (input-file (first (input-files o c)))
;; on some implementations, there are more than one output-file, ;; on some implementations, there are more than one output-file,
;; but the first one should always be the primary fasl that gets loaded. ;; but the first one should always be the primary fasl that gets loaded.
(output-file (first (output-files o c)))) (outputs (output-files o c)))
(multiple-value-bind (output warnings-p failure-p) (multiple-value-bind (output warnings-p failure-p)
(call-with-around-compile-hook (destructuring-bind
c #'(lambda (&rest flags) (output-file &optional #+(or ecl mkcl) object-file #+sbcl warnings-file) outputs
(with-muffled-compiler-conditions () (call-with-around-compile-hook
(apply 'compile-file* input-file c #'(lambda (&rest flags)
:output-file output-file (with-muffled-compiler-conditions ()
:external-format (component-external-format c) (apply 'compile-file* input-file
(append flags (compile-op-flags o)))))) :output-file output-file
(unless output :external-format (component-external-format c)
(error 'compile-error :component c :operation o)) (append
(when failure-p #+(or ecl mkcl) (list :object-file object-file)
(case *compile-file-failure-behaviour* #+sbcl (list :warnings-file warnings-file)
(:warn (warn flags (compile-op-flags o)))))))
(compatfmt "~@<COMPILE-FILE failed while performing ~A.~@:>") (check-lisp-compile-results output warnings-p failure-p
(operation-description o c))) "~/asdf-action::format-action/" (list (cons o c))))))
(:error (error 'compile-failed :component c :operation o))
(:ignore nil))) (defun* report-file-p (f)
(when warnings-p (equal (pathname-type f) "build-report"))
(case *compile-file-warnings-behaviour* (defun* perform-lisp-warnings-check (o c)
(:warn (warn (check-deferred-warnings
(compatfmt "~@<COMPILE-FILE warned while performing ~A.~@:>") (remove-if-not #'warnings-file-p (input-files o c))
(operation-description o c))) "~/asdf-action::format-action/" (list (cons o c)))
(:error (error 'compile-warned :component c :operation o)) (let* ((output (output-files o c))
(:ignore nil)))))) (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)) (defmethod perform ((o compile-op) (c cl-source-file))
(perform-lisp-compilation o c)) (perform-lisp-compilation o c))
(defmethod output-files ((o compile-op) (c cl-source-file)) (defmethod output-files ((o compile-op) (c cl-source-file))
(declare (ignorable o)) (declare (ignorable o))
(let* ((i (first (input-files o c))) (let* ((i (first (input-files o c)))
(f (compile-file-pathname (f (compile-file-pathname
i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)) i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)))
#+mkcl (o (compile-file-pathname i :fasl-p nil))) ;; object file `(,f ;; the fasl is the primary output, in first position
#+ecl (if (use-ecl-byte-compiler-p) #+ecl ,@(unless (use-ecl-byte-compiler-p)
(list f) (compile-file-pathname i :type :object))
(list f (compile-file-pathname i :type :object))) #+mkcl ,(compile-file-pathname i :fasl-p nil) ;; object file
#+mkcl (list f o) #+sbcl ,@(unless (builtin-system-p (component-system c))
#-(or ecl mkcl) (list f))) `(,(make-pathname :type "sbcl-warnings" :defaults f))))))
(defmethod component-depends-on ((o compile-op) (c component)) (defmethod component-depends-on ((o compile-op) (c component))
(declare (ignorable o)) (declare (ignorable o))
`((prepare-op ,c) ,@(call-next-method))) `((prepare-op ,c) ,@(call-next-method)))
...@@ -136,6 +128,25 @@ ...@@ -136,6 +128,25 @@
(defmethod output-files ((o compile-op) (c static-file)) (defmethod output-files ((o compile-op) (c static-file))
(declare (ignorable o c)) (declare (ignorable o c))
nil) nil)
(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")))))
;;; load-op ;;; load-op
(defmethod operation-description ((o load-op) (c cl-source-file)) (defmethod operation-description ((o load-op) (c cl-source-file))
...@@ -143,7 +154,7 @@ ...@@ -143,7 +154,7 @@
(format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c)) (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c))
(defmethod operation-description ((o load-op) (c parent-component)) (defmethod operation-description ((o load-op) (c parent-component))
(declare (ignorable o)) (declare (ignorable o))
(format nil (compatfmt "~@<loaded ~3i~_~A~@:>") c)) (format nil (compatfmt "~@<completing load for ~3i~_~A~@:>") c))
(defmethod operation-description ((o load-op) component) (defmethod operation-description ((o load-op) component)
(declare (ignorable o)) (declare (ignorable o))
(format nil (compatfmt "~@<loading ~3i~_~A~@:>") (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
...@@ -167,10 +178,10 @@ ...@@ -167,10 +178,10 @@
nil) nil)
(defmethod component-depends-on ((o load-op) (c component)) (defmethod component-depends-on ((o load-op) (c component))
(declare (ignorable o)) (declare (ignorable o))
`((prepare-op ,c) ,@(call-next-method))) ;; NB: even though compile-op depends-on on prepare-op,
(defmethod component-depends-on ((o load-op) (c source-file)) ;; it is not needed-in-image-p, whereas prepare-op is,
(declare (ignorable o)) ;; so better not omit prepare-op and think it will happen.
`((compile-op ,c) ,@(call-next-method))) `((prepare-op ,c) (compile-op ,c) ,@(call-next-method)))
;;;; prepare-source-op, load-source-op ;;;; prepare-source-op, load-source-op
...@@ -179,9 +190,6 @@ ...@@ -179,9 +190,6 @@
(defmethod operation-description ((o prepare-source-op) (c component)) (defmethod operation-description ((o prepare-source-op) (c component))
(declare (ignorable o)) (declare (ignorable o))
(format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:>") c)) (format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:>") c))
(defmethod component-depends-on ((o prepare-source-op) (c source-file))
(declare (ignorable o))
`((load-source-op ,@(component-sibling-dependencies c)) ,@(call-next-method)))
(defmethod input-files ((o prepare-source-op) (c component)) (defmethod input-files ((o prepare-source-op) (c component))
(declare (ignorable o c)) (declare (ignorable o c))
nil) nil)
......
...@@ -10,6 +10,9 @@ ...@@ -10,6 +10,9 @@
#:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
#:*output-translation-function* #:*output-translation-function*
#:*optimization-settings* #:*previous-optimization-settings* #:*optimization-settings* #:*previous-optimization-settings*
#:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
#:compile-warned-warning #:compile-failed-warning
#:check-lisp-compile-results #:check-lisp-compile-warnings
#:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions* #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
#:*deferred-warnings* #:*deferred-warnings*
;; Functions & Macros ;; Functions & Macros
...@@ -18,8 +21,8 @@ ...@@ -18,8 +21,8 @@
#:call-with-muffled-loader-conditions #:with-muffled-loader-conditions #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
#:reify-simple-sexp #:unreify-simple-sexp #:reify-simple-sexp #:unreify-simple-sexp
#:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-warnings #:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-warnings
#:reset-deferred-warnings #:save-deferred-warnings #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings
#:with-saved-deferred-warnings #:with-saved-deferred-warnings #:warnings-file-p
#:call-with-asdf-compilation-unit #:with-asdf-compilation-unit #:call-with-asdf-compilation-unit #:with-asdf-compilation-unit
#:current-lisp-file-pathname #:load-pathname #:current-lisp-file-pathname #:load-pathname
#:lispize-pathname #:compile-file-type #:call-around-hook #:lispize-pathname #:compile-file-type #:call-around-hook
...@@ -114,6 +117,57 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when ...@@ -114,6 +117,57 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
`(call-with-muffled-loader-conditions #'(lambda () ,@body))) `(call-with-muffled-loader-conditions #'(lambda () ,@body)))
;;;; Handle warnings and failures
(define-condition compile-condition (condition)
((context-format
:initform nil :reader compile-condition-context-format :initarg :context-format)
(context-arguments
:initform nil :reader compile-condition-context-arguments :initarg :context-arguments)
(description
:initform nil :reader compile-condition-description :initarg :description))
(:report (lambda (c s)
(format s (compatfmt "~@<~A~@[ while ~?~]~@:>")
(or (compile-condition-description c) (type-of c))
(compile-condition-context-format c)
(compile-condition-context-arguments c)))))
(define-condition compile-file-error (compile-condition error) ())
(define-condition compile-warned-warning (compile-condition warning) ())
(define-condition compile-warned-error (compile-condition error) ())
(define-condition compile-failed-warning (compile-condition warning) ())
(define-condition compile-failed-error (compile-condition error) ())