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.
;;;; Actions
(asdf/package:define-package :asdf/action
+ (:nicknames :asdf-action)
(:recycle :asdf/action :asdf)
(:use :common-lisp :asdf/driver :asdf/upgrade
:asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation)
#+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:type-of)
(:intern #:stamp #:done-p)
(:export
- #:action
+ #:action #:define-convenience-action-methods
#:explain #:operation-description
- #:downward-operation #:upward-operation
- #:operation-error #:error-component #:error-operation
+ #:downward-operation #:upward-operation #:sibling-operation
#:component-depends-on #:component-self-dependencies
#:input-files #:output-files #:output-file #:operation-done-p
#:action-status #:action-stamp #:action-done-p
#: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)
(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
(defmethod operation-description (operation component)
(format nil (compatfmt "~@<~A on ~A~@:>")
(class-of operation) component))
+(define-convenience-action-methods operation-description (operation component))
(defgeneric* explain (operation component))
(defmethod explain ((o operation) (c component))
(asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (operation-description o c)))
+(define-convenience-action-methods explain (operation component))
-
-;;;; Error
-
-(define-condition operation-error (error) ;; Bad, backward-compatible name
- ;; 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)))))
+(defun* format-action (stream action &optional colon-p at-sign-p)
+ (assert (null colon-p)) (assert (null at-sign-p))
+ (destructuring-bind (operation . component) action
+ (princ (operation-description operation component) stream)))
;;;; Dependencies
should usually append the results of CALL-NEXT-METHOD to the
list."))
(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))
(cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies
;; These together handle actions that propagate along the component hierarchy.
;; Downward operations like load-op or compile-op propagate down the hierarchy:
;; 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:
;; operation on a child depends-on operation on its parent.
-(defclass upward-operation (operation) ())
-
-(defmethod component-depends-on ((o downward-operation) (c parent-component))
- `((,o ,@(component-children c)) ,@(call-next-method)))
+;; By default, an operation propagates itself, but it may propagate another one instead.
+(defclass upward-operation (operation)
+ ((upward-operation
+ :initform nil :initarg :downward-operation :reader upward-operation)))
;; For backward-compatibility reasons, a system inherits from module and is a child-component
;; so we must guard against this case. ASDF3: remove that.
(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
(defgeneric* input-files (operation component))
(defgeneric* operation-done-p (operation component)
(: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))
(declare (ignorable o c))
;;;; Done performing
(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* compute-action-stamp (plan operation component &key just-done)
(:documentation "Has this action been successfully done already,
(defgeneric* perform-with-restarts (operation component))
(defgeneric* perform (operation component))
+(define-convenience-action-methods perform (operation component))
(defmethod perform :before ((o operation) (c component))
(ensure-all-directories-exist (output-files o c)))
:licence "MIT"
:description "Another System Definition Facility"
: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 ()
: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
(defmethod perform :before
:asdf/lisp-build :asdf/operate :asdf/output-translations)
(:export
#:*asdf-verbose*
+ #:operation-error #:compile-error #:compile-failed #:compile-warned
+ #:error-component #:error-operation
#:component-load-dependencies
#:enable-asdf-binary-locations-compatibility
#:operation-forced
#:system-definition-pathname))
(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)
;; Old deprecated name for the same thing. Please update your software.
(component-sibling-dependencies component))
#:compiled-file #:precompiled-system #:prebuilt-system
#:operation-monolithic-p
#:user-system-p #:user-system #:trivial-system-p
- #:gather-actions #:operated-components
#+ecl #:make-build
#:register-pre-built-system
#:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library
(remf args :ld-flags)
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)
(let ((type (pathname-type pathname)))
(declare (ignorable type))
#+mkcl (equal type (compile-file-type :fasl-p nil))
#+(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))
(defun* user-system-p (s)
;;;; component pathnames
-(defun* component-parent-pathname (component)
- ;; No default anymore (in particular, no *default-pathname-defaults*).
- ;; If you force component to have a NULL pathname, you better arrange
- ;; 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))))
+(defgeneric* component-parent-pathname (component))
+(defmethod component-parent-pathname (component)
+ (component-pathname (component-parent component)))
(defmethod component-pathname ((component component))
(if (slot-boundp component 'absolute-pathname)
;; If no absolute pathname was found, we return NIL.
(check-type pathname (or null string pathname))
(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*))
(let* ((file (probe-file*
(absolutize-pathnames
(list (make-pathname :name name :type "asd")
- defaults *default-pathname-defaults* (getcwd))
+ defaults *default-pathname-defaults*
+ #-(or abcl gcl genera) (getcwd))
:resolve-symlinks truename)
:truename truename)))
(when file
;; -*- 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:
;;; please mail to <asdf-devel@common-lisp.net>.
(:use :common-lisp :asdf/driver :asdf/upgrade
:asdf/component :asdf/system :asdf/find-component :asdf/operation :asdf/action)
(:export
- #:compile-error #:compile-failed #:compile-warned #:try-recompiling
+ #:try-recompiling
#:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
#: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
#:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source))
(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
-
-
(defclass cl-source-file (source-file)
((type :initform "lisp")))
(defclass cl-source-file.cl (cl-source-file)
;;;; Operation classes
-
(defclass basic-load-op (operation) ())
(defclass basic-compile-op (operation)
((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
:initform nil)))
;;; Our default operations: loading into the current lisp image
-(defclass load-op (basic-load-op downward-operation) ())
-(defclass prepare-op (upward-operation) ())
-(defclass compile-op (basic-compile-op downward-operation) ())
+(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)))
(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) ())
(defmethod operation-description ((o prepare-op) (c component))
(declare (ignorable o))
(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))
(declare (ignorable o c))
nil)
(format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c))
(defmethod operation-description ((o compile-op) (c parent-component))
(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))
(defmethod call-with-around-compile-hook ((c component) function)
(call-around-hook (around-compile-hook c) function))
(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.
- (output-file (first (output-files o c))))
+ (outputs (output-files o c)))
(multiple-value-bind (output warnings-p failure-p)
- (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 flags (compile-op-flags o))))))
- (unless output
- (error 'compile-error :component c :operation o))
- (when failure-p
- (case *compile-file-failure-behaviour*
- (:warn (warn
- (compatfmt "~@<COMPILE-FILE failed while performing ~A.~@:>")
- (operation-description o c)))
- (:error (error 'compile-failed :component c :operation o))
- (:ignore nil)))
- (when warnings-p
- (case *compile-file-warnings-behaviour*
- (:warn (warn
- (compatfmt "~@<COMPILE-FILE warned while performing ~A.~@:>")
- (operation-description o c)))
- (:error (error 'compile-warned :component c :operation o))
- (:ignore nil))))))
+ (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~%")))))
(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
- i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))
- #+mkcl (o (compile-file-pathname i :fasl-p nil))) ;; object file
- #+ecl (if (use-ecl-byte-compiler-p)
- (list f)
- (list f (compile-file-pathname i :type :object)))
- #+mkcl (list f o)
- #-(or ecl mkcl) (list f)))
+ 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
+ #+sbcl ,@(unless (builtin-system-p (component-system c))
+ `(,(make-pathname :type "sbcl-warnings" :defaults f))))))
(defmethod component-depends-on ((o compile-op) (c component))
(declare (ignorable o))
`((prepare-op ,c) ,@(call-next-method)))
(defmethod output-files ((o compile-op) (c static-file))
(declare (ignorable o c))
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
(defmethod operation-description ((o load-op) (c cl-source-file))
(format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c))
(defmethod operation-description ((o load-op) (c parent-component))
(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)
(declare (ignorable o))
(format nil (compatfmt "~@<loading ~3i~_~A~@:>")
nil)
(defmethod component-depends-on ((o load-op) (c component))
(declare (ignorable o))
- `((prepare-op ,c) ,@(call-next-method)))
-(defmethod component-depends-on ((o load-op) (c source-file))
- (declare (ignorable o))
- `((compile-op ,c) ,@(call-next-method)))
+ ;; 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)))
;;;; prepare-source-op, load-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 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))
(declare (ignorable o c))
nil)
#:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
#:*output-translation-function*
#:*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*
#:*deferred-warnings*
;; Functions & Macros
#:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
#:reify-simple-sexp #:unreify-simple-sexp
#:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-warnings
- #:reset-deferred-warnings #:save-deferred-warnings
- #:with-saved-deferred-warnings
+ #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings
+ #:with-saved-deferred-warnings #:warnings-file-p
#:call-with-asdf-compilation-unit #:with-asdf-compilation-unit
#:current-lisp-file-pathname #:load-pathname
#:lispize-pathname #:compile-file-type #:call-around-hook
`(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) ())
+
+(defun* check-lisp-compile-warnings (warnings-p failure-p
+ &optional context-format context-arguments)
+ (when failure-p
+ (case *compile-file-failure-behaviour*
+ (:warn (warn 'compile-failed-warning
+ :description "Lisp compilation failed"
+ :context-format context-format
+ :context-arguments context-arguments))
+ (:error (error 'compile-failed-error
+ :description "Lisp compilation failed"
+ :context-format context-format
+ :context-arguments context-arguments))
+ (:ignore nil)))
+ (when warnings-p
+ (case *compile-file-warnings-behaviour*
+ (:warn (warn 'compile-warned-warning
+ :description "Lisp compilation had style-warnings"
+ :context-format context-format
+ :context-arguments context-arguments))
+ (:error (error 'compile-warned-error
+ :description "Lisp compilation had style-warnings"
+ :context-format context-format
+ :context-arguments context-arguments))
+ (:ignore nil))))
+
+(defun* check-lisp-compile-results (output warnings-p failure-p
+ &optional context-format context-arguments)
+ (unless output
+ (error 'compile-file-error :context-format context-format :context-arguments context-arguments))
+ (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments))
+
+
;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman.
(defun reify-simple-sexp (sexp)
(nconc (mapcan
#'(lambda (stuff)
(destructuring-bind (kind name count . rest) stuff
- (if (and (eq kind :function) (fboundp name))
- nil
- (list
- (sb-c::make-undefined-warning
- :name name
- :kind kind
- :count count
- :warnings
- (mapcar #'(lambda (x)
- (apply #'sb-c::make-compiler-error-context x))
- rest))))))
+ (unless (case kind (:function (fboundp name)))
+ (list
+ (sb-c::make-undefined-warning
+ :name name
+ :kind kind
+ :count count
+ :warnings
+ (mapcar #'(lambda (x)
+ (apply #'sb-c::make-compiler-error-context x))
+ rest))))))
adjustment)
sb-c::*undefined-warnings*)))
(otherwise
"Save forward reference conditions so they may be issued at a latter time,
possibly in a different process."
(with-open-file (s warnings-file :direction :output :if-exists :supersede)
- (if-let ((deferred-warnings (reify-deferred-warnings)))
- (with-safe-io-syntax ()
- (write deferred-warnings :stream s :pretty t :readably t)
- (terpri s))))
+ (with-safe-io-syntax ()
+ (write (reify-deferred-warnings) :stream s :pretty t :readably t)
+ (terpri s)))
(reset-deferred-warnings))
+(defun* warnings-file-p (file)
+ (equal (pathname-type file) "sbcl-warnings"))
+
+(defun* check-deferred-warnings (files &optional context-format context-arguments)
+ (let ((file-errors nil)
+ (failure-p nil)
+ (warnings-p nil))
+ (handler-bind
+ ((warning #'(lambda (c)
+ (setf warnings-p t)
+ (unless (typep c 'style-warning)
+ (setf failure-p t)))))
+ (with-compilation-unit (:override t)
+ (reset-deferred-warnings)
+ (dolist (file files)
+ (unreify-deferred-warnings
+ (handler-case (safe-read-file-form file)
+ (error (c)
+ (delete-file-if-exists file)
+ (push c file-errors)
+ nil))))))
+ (dolist (error file-errors) (error error))
+ (check-lisp-compile-warnings
+ (or failure-p warnings-p) failure-p context-format context-arguments)))
+
+
+;;;; Deferred warnings
+
(defun* call-with-saved-deferred-warnings (thunk warnings-file)
(if warnings-file
(with-compilation-unit (:override t)
(multiple-value-prog1
(with-muffled-compiler-conditions ()
(funcall thunk))
- (save-deferred-warnings warnings-file))))
+ (save-deferred-warnings warnings-file)
+ (reset-deferred-warnings))))
(funcall thunk)))
(defmacro with-saved-deferred-warnings ((warnings-file) &body body)
(defun* call-around-hook (hook function)
(call-function (or hook 'funcall) function))
+(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
+ (let* ((keys
+ (remove-plist-keys `(#+(and allegro (not (version>= 8 2))) :external-format
+ ,@(unless output-file '(:output-file))) keys)))
+ (if (absolute-pathname-p output-file)
+ ;; what cfp should be doing, w/ mp* instead of mp
+ (let* ((type (pathname-type (apply 'compile-file-type keys)))
+ (defaults (make-pathname
+ :type type :defaults (merge-pathnames* input-file))))
+ (merge-pathnames* output-file defaults))
+ (funcall *output-translation-function*
+ (apply 'compile-file-pathname input-file keys)))))
+
(defun* compile-file* (input-file &rest keys
&key compile-check output-file warnings-file
#+(or ecl mkcl) object-file
(setf output-truename nil)))
(values output-truename warnings-p failure-p))))
-(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
- (let* ((keys
- (remove-plist-keys `(#+(and allegro (not (version>= 8 2))) :external-format
- ,@(unless output-file '(:output-file))) keys)))
- (if (absolute-pathname-p output-file)
- ;; what cfp should be doing, w/ mp* instead of mp
- (let* ((type (pathname-type (apply 'compile-file-type keys)))
- (defaults (make-pathname
- :type type :defaults (merge-pathnames* input-file))))
- (merge-pathnames* output-file defaults))
- (funcall *output-translation-function*
- (apply 'compile-file-pathname input-file keys)))))
-
(defun* load* (x &rest keys &key &allow-other-keys)
(etypecase x
((or pathname string #-(or gcl<2.7 clozure allegro) stream)
#:upgrade-asdf #:cleanup-upgraded-asdf #:*post-upgrade-hook*))
(in-package :asdf/operate)
-(defgeneric* operate (operation-class system &key &allow-other-keys))
+(defgeneric* operate (operation component &key &allow-other-keys))
+(define-convenience-action-methods
+ operate (operation component &key)
+ :if-no-component (error 'missing-component :requires component))
(defvar *systems-being-operated* nil
"A boolean indicating that some systems are being operated on")
-(defmethod operate :around (operation-class system
+(defmethod operate :around (operation component
&key verbose
(on-warnings *compile-file-warnings-behaviour*)
(on-failure *compile-file-failure-behaviour*) &allow-other-keys)
- (declare (ignorable operation-class system))
+ (declare (ignorable operation component))
;; Setup proper bindings around any operate call.
(with-system-definitions ()
(let* ((*asdf-verbose* verbose)
(*compile-file-failure-behaviour* on-failure))
(call-next-method))))
-(defmethod operate (operation-class system &rest args &key version &allow-other-keys)
+(defmethod operate ((operation operation) (component component)
+ &rest args &key version &allow-other-keys)
"Operate does three things:
1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs.
:ALL to force all systems including other systems we depend on to be rebuilt (resp. not).
(SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list
:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced."
- (let* ((system (etypecase system
- (system system)
- ((or string symbol) (find-system system))))
- ;; I'd like to remove-plist-keys :force :force-not :verbose,
+ (let* (;; I'd like to remove-plist-keys :force :force-not :verbose,
;; but swank.asd relies on :force (!).
- (op (apply 'make-operation operation-class args))
(systems-being-operated *systems-being-operated*)
- (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal))))
- (check-type system system)
+ (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))
+ (system (component-system component)))
(setf (gethash (coerce-name system) *systems-being-operated*) system)
- (unless (version-satisfies system version)
- (error 'missing-component-of-version :requires system :version version))
+ (unless (version-satisfies component version)
+ (error 'missing-component-of-version :requires component :version version))
;; Before we operate on any system, make sure ASDF is up-to-date,
;; for if an upgrade is attempted at any later time, there may be trouble.
;; If we upgraded, restart the OPERATE from scratch,
;; for the function will have been redefined,
;; maybe from a new symbol for it may have been uninterned.
(if (upgrade-asdf)
- (apply 'symbol-call :asdf 'operate operation-class system args)
- (let ((plan (apply 'traverse op system args)))
+ (apply 'symbol-call :asdf 'operate operation component args)
+ (let ((plan (apply 'traverse operation system args)))
(perform-plan plan)
- (values op plan)))))
+ (values operation plan)))))
-(defun* oos (operation-class system &rest args
- &key force force-not verbose version &allow-other-keys)
- (declare (ignore force force-not verbose version))
- (apply 'operate operation-class system args))
+(defun* oos (operation component &rest args &key &allow-other-keys)
+ (apply 'operate operation component args))
(setf (documentation 'oos 'function)
(format nil "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
(defmethod operation-original-initargs ((context null)) context)
(defclass build-op (operation) ())
+
;;; Current directory
(defun* getcwd ()
- "Get the current working directory as per POSIX getcwd(3)"
- (or #+clisp (ext:default-directory)
+ "Get the current working directory as per POSIX getcwd(3), as a pathname object"
+ (or ;; missing: abcl gcl genera
+ #+allegro (excl::current-directory)
+ #+clisp (ext:default-directory)
#+clozure (ccl:current-directory)
- #+cmu (unix:unix-current-directory)
- #+cormanlisp (pl::get-current-directory)
+ #+(or cmu scl) (parse-native-namestring
+ (nth-value 1 (unix:unix-current-directory)) :ensure-directory t)
+ #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
#+ecl (ext:getcwd)
+ #+gcl (parse-native-namestring
+ (first (symbol-call :asdf/driver :run-program/ '("/bin/pwd") :output :lines)))
+ #+lispworks (system:current-directory)
#+mkcl (mk-ext:getcwd)
- #+sbcl (sb-unix:posix-getcwd/)
+ #+sbcl (parse-native-namestring (sb-unix:posix-getcwd/))
+ #+xcl (extensions:current-directory)
(error "getcwd not supported on your implementation")))
(defun* chdir (x)
(asdf/package:define-package :asdf/plan
(:recycle :asdf/plan :asdf)
(:use :common-lisp :asdf/driver :asdf/upgrade
- :asdf/component :asdf/system :asdf/find-system :asdf/find-component
+ :asdf/component :asdf/operation :asdf/system :asdf/find-system :asdf/find-component
:asdf/operation :asdf/action)
#+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:type-of)
(:export
#:action-index #:action-planned-p #:action-valid-p
#:plan-record-dependency #:visiting-action-p
#:normalize-forced-systems #:action-forced-p #:action-forced-not-p
+ #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies
#:visit-dependencies #:compute-action-stamp #:traverse-action
#:circular-dependency #:circular-dependency-actions
#:call-while-visiting-action #:while-visiting-action
#:traverse #:plan-actions #:perform-plan #:plan-operates-on-p
#:planned-p #:index #:forced #:forced-not #:total-action-count
#:planned-action-count #:planned-output-action-count #:visited-actions
- #:visiting-action-set #:visiting-action-list #:actions-r))
+ #:visiting-action-set #:visiting-action-list #:plan-actions-r
+ #:operated-components #:filtered-sequential-plan
+ #:plan-action-filter #:plan-component-type #:plan-keep-operation #:plan-keep-component
+ #:traverse-actions #:traverse-sub-actions))
(in-package :asdf/plan)
;;;; Planned action status
(defmethod action-forced-not-p (plan operation component)
(and (action-override-p plan operation component 'plan-forced-not)
(not (action-forced-p plan operation component))))
+(defmethod action-forced-p ((plan null) operation component)
+ (declare (ignorable plan operation component))
+ nil)
+(defmethod action-forced-not-p ((plan null) operation component)
+ (declare (ignorable plan operation component))
+ nil)
;;;; action-valid-p
(if-let (it (component-if-feature c)) (featurep it) t))
(defmethod action-valid-p (plan (o null) c) (declare (ignorable plan o c)) nil)
(defmethod action-valid-p (plan o (c null)) (declare (ignorable plan o c)) nil)
+(defmethod action-valid-p ((plan null) operation component)
+ (declare (ignorable plan operation component))
+ (and operation component t))
;;;; Is the action needed in this image?
;;;; Visiting dependencies of an action and computing action stamps
-(defun* visit-dependencies (plan operation component fun &aux stamp)
+(defun* map-direct-dependencies (operation component fun)
(loop :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
:unless (eq dep-o-spec 'feature) ;; avoid the "FEATURE" misfeature
:do (loop :with dep-o = (find-operation operation dep-o-spec)
:for dep-c-spec :in dep-c-specs
:for dep-c = (resolve-dependency-spec component dep-c-spec)
- :when (action-valid-p plan dep-o dep-c)
- :do (latest-stamp-f stamp (funcall fun dep-o dep-c))))
+ :do (funcall fun dep-o dep-c))))
+
+(defun* reduce-direct-dependencies (operation component combinator seed)
+ (map-direct-dependencies
+ operation component
+ (lambda (dep-o dep-c)
+ (setf seed (funcall combinator dep-o dep-c seed))))
+ seed)
+
+(defun* direct-dependencies (operation component)
+ (reduce-direct-dependencies operation component #'acons nil))
+
+(defun* visit-dependencies (plan operation component dependency-stamper &aux stamp)
+ (map-direct-dependencies
+ operation component
+ (lambda (dep-o dep-c)
+ (when (action-valid-p plan dep-o dep-c)
+ (latest-stamp-f stamp (funcall dependency-stamper dep-o dep-c)))))
stamp)
(defmethod compute-action-stamp (plan (o operation) (c component) &key just-done)
(visiting-action-list :initform () :accessor plan-visiting-action-list)))
(defmethod initialize-instance :after ((plan plan-traversal)
- &key (force () fp) (force-not () fnp) system &allow-other-keys)
+ &key (force () fp) (force-not () fnp) system
+ &allow-other-keys)
(with-slots (forced forced-not) plan
(when fp (setf forced (normalize-forced-systems force system)))
(when fnp (setf forced-not (normalize-forced-systems force-not system)))))
processed in order by OPERATE."))
(defgeneric* perform-plan (plan &key))
(defgeneric* plan-operates-on-p (plan component))
+(define-convenience-action-methods traverse (operation component &key))
(defparameter *default-plan-class* 'sequential-plan)
-
+
(defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
(let ((plan (apply 'make-instance
(or plan-class *default-plan-class*)
(traverse-action plan o c t)
(plan-actions plan)))
+
(defmethod perform-plan ((steps list) &key)
(let ((*package* *package*)
(*readtable* *readtable*))
- (with-compilation-unit ()
- (loop :for (op . component) :in steps :do
- (perform-with-restarts op component)))))
+ (loop :for (op . component) :in steps :do
+ (perform-with-restarts op component))))
(defmethod plan-operates-on-p ((plan list) (component-path list))
(find component-path (mapcar 'cdr plan)
:test 'equal :key 'component-find-path))
+
+;;;; Incidental traversals
+
+(defclass filtered-sequential-plan (sequential-plan)
+ ((action-filter :initform t :initarg :action-filter :reader plan-action-filter)
+ (component-type :initform t :initarg :component-type :reader plan-component-type)
+ (keep-operation :initform t :initarg :keep-operation :reader plan-keep-operation)
+ (keep-component :initform t :initarg :keep-component :reader plan-keep-component)))
+
+(defmethod initialize-instance :after ((plan filtered-sequential-plan)
+ &key (force () fp) (force-not () fnp)
+ system other-systems)
+ (declare (ignore force force-not))
+ (with-slots (forced forced-not action-filter) plan
+ (unless fp (setf forced (normalize-forced-systems (if other-systems :all t) system)))
+ (unless fnp (setf forced-not (normalize-forced-systems (if other-systems nil :all) system)))
+ (setf action-filter (ensure-function action-filter))))
+
+(defmethod action-valid-p ((plan filtered-sequential-plan) o c)
+ (and (funcall (plan-action-filter plan) o c)
+ (typep c (plan-component-type plan))
+ (call-next-method)))
+
+(defun* traverse-actions (actions &rest keys &key plan-class &allow-other-keys)
+ (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys)))
+ (loop :for (o . c) :in actions :do
+ (traverse-action plan o c t))
+ (plan-actions plan)))
+
+(defun* traverse-sub-actions (operation component &rest keys)
+ (apply 'traverse-actions (direct-dependencies operation component)
+ :system (component-system component) keys))
+
+(defmethod plan-actions ((plan filtered-sequential-plan))
+ (with-slots (keep-operation keep-component) plan
+ (loop :for (o . c) :in (call-next-method)
+ :when (and (typep o keep-operation)
+ (typep c keep-component))
+ :collect (cons o c))))
+
+(defun* operated-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
+ (remove-duplicates
+ (mapcar 'cdr (apply 'traverse-sub-actions (make-operation goal-operation) system keys))
+ :from-end t))
+
;;;; Pathnames
-(defmethod component-pathname ((system system))
- (and (or (slot-boundp system 'relative-pathname)
- (slot-boundp system 'absolute-pathname)
- (slot-value system 'source-file))
- (call-next-method)))
-
(defmethod system-source-file ((system-name string))
(system-source-file (find-system system-name)))
(defmethod system-source-file ((system-name symbol))
(defun* system-relative-pathname (system name &key type)
(subpathname (system-source-directory system) name :type type))
+(defmethod component-pathname ((system system))
+ (or (call-next-method)
+ (system-source-directory system)))
+
+(defmethod component-relative-pathname ((system system))
+ (parse-unix-namestring
+ (and (slot-boundp system 'relative-pathname)
+ (slot-value system 'relative-pathname))
+ :want-relative t
+ :type :directory
+ :ensure-absolute t
+ :defaults (system-source-directory system)))
+
+(defmethod component-parent-pathname ((system system))
+ (system-source-directory system))
+
+
;;;; Beware of builtin systems
(defgeneric* builtin-system-p (system))
(defmethod builtin-system-p ((s system))
`(;; If you want to trace some stuff while debugging ASDF,
;; here's a nice place to say what.
;; These string designators will be interned in ASDF after it is loaded.
- :absolutize-pathnames
))
(defvar *debug-asdf* nil)
(let ((asdf:*compile-file-failure-behaviour* :warn))
(asdf:load-system 'test-compile-file-failure :force t)
t)
- (asdf:compile-error () nil)))
+ (asdf/lisp-build:compile-file-error () nil)))
#-gcl<2.7
(assert (handler-case
(let ((asdf:*compile-file-failure-behaviour* :error))
(asdf:load-system 'test-compile-file-failure :force t)
nil)
- (asdf:compile-error () t))))
+ (asdf/lisp-build:compile-file-error () t))))
(in-package :asdf-test)
(with-test ()
- (handler-case
- (asdf:oos 'asdf:load-op 'system-does-not-exist)
- (asdf:missing-component-of-version (c)
+ (trace operate)
+ (handler-case
+ (asdf:oos 'asdf:load-op 'system-does-not-exist)
+ (asdf:missing-component-of-version (c)
+ (declare (ignore c))
+ (error "Should not have gotten 'missing-component-of-version, dang"))
+ (asdf:missing-component (c)
+ (format t "got missing-component as expected: - ~%~A~%" c))
+ (:no-error (c)
(declare (ignore c))
- (error "Should not have gotten 'missing-component-of-version, dang"))
- (asdf:missing-component (c)
- (format t "got missing-component as expected: - ~%~A~%" c))
- (:no-error (c)
- (declare (ignore c))
- (error "should have failed, oops"))))
-
-
+ (error "should have failed, oops"))))
;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
- (asdf-version "2.26.120")
+ (asdf-version "2.26.121")
(existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
common-lisp.net / projects/asdf/asdf.git / commitdiff
