Merge branch 'master' of ssh://common-lisp.net/project/asdf/public_html/asdf

  :licence "MIT"

  :description "Another System Definition Facility"

  :long-description "ASDF builds Common Lisp software organized into defined systems."

  :version "3.1.0.91" ;; to be automatically updated by make bump-version

  :version "3.1.0.94" ;; to be automatically updated by make bump-version

  :depends-on ()

  #+asdf3 :encoding #+asdf3 :utf-8

  :class #.(if (find-class 'package-system nil) 'package-system 'system)

    ;; your component-depends-on method better gathered the correct dependencies in the correct order.

    (while-collecting (collect)

      (map-direct-dependencies

       o c #'(lambda (sub-o sub-c)

       t o c #'(lambda (sub-o sub-c)

                 (loop :for f :in (funcall key sub-o sub-c)

                       :when (funcall test f) :do (collect f))))))

  (defmethod input-files ((o bundle-op) (c system))

  (defmethod input-files ((o gather-op) (c system))

    (unless (eq (bundle-type o) :no-output-file)

      (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files)))

                                                       :keep-operation 'load-op))

                 (while-collecting (x) ;; resolve the sideway-dependencies of s

                   (map-direct-dependencies

                    'load-op s

                    t 'load-op s

                    #'(lambda (o c)

                        (when (and (typep o 'load-op) (typep c 'system))

                          (x c)))))))

#+ecl

(with-upgradability ()

  ;; I think that Juanjo intended for this to be,

  ;; but it breaks 4 tests in what looks like to be a compiler bug, so I'll punt for now.

  ;; I think that Juanjo intended for this to be.

  ;; But it might break systems with missing dependencies,

  ;; and there is a weird bug in test-xach-update-bug.script

  ;;(unless (use-ecl-byte-compiler-p)

  ;;  (setf *load-system-operation* 'load-fasl-op))

;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-

;;; This is ASDF 3.1.0.91: Another System Definition Facility.

;;; This is ASDF 3.1.0.94: Another System Definition Facility.

;;;

;;; Feedback, bug reports, and patches are all welcome:

;;; please mail to <asdf-devel@common-lisp.net>.

   :asdf/operation :asdf/action :asdf/lisp-action)

  (:export

   #:component-operation-time #:mark-operation-done

   #:plan-traversal #:sequential-plan #:*default-plan-class*

   #:plan #:plan-traversal #:sequential-plan #:*default-plan-class*

   #:planned-action-status #:plan-action-status #:action-already-done-p

   #:circular-dependency #:circular-dependency-actions

   #:node-for #:needed-in-image-p

   #:plan-record-dependency

   #: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

   #:compute-action-stamp #:traverse-action

   #:circular-dependency #:circular-dependency-actions

   #:call-while-visiting-action #:while-visiting-action

   #:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p

;;;; Generic plan traversal class

(with-upgradability ()

  (defclass plan-traversal ()

  (defclass plan () ())

  (defclass plan-traversal (plan)

    ((system :initform nil :initarg :system :accessor plan-system)

     (forced :initform nil :initarg :force :accessor plan-forced)

     (forced-not :initform nil :initarg :force-not :accessor plan-forced-not)

(with-upgradability ()

  (defgeneric action-valid-p (plan operation component)

    (:documentation "Is this action valid to include amongst dependencies?"))

  (defmethod action-valid-p ((plan plan-traversal) (o operation) (c component))

  (defmethod action-valid-p ((plan t) (o operation) (c component))

    (if-let (it (component-if-feature c)) (featurep it) t))

  (defmethod action-valid-p ((plan t) (o null) (c t)) nil)

  (defmethod action-valid-p ((plan t) (o t) (c null)) nil)

  (defmethod action-valid-p ((plan null) (o operation) (c component)) t))

;;;; Is the action needed in this image?

(with-upgradability ()

  (defgeneric needed-in-image-p (operation component)

;;;; Visiting dependencies of an action and computing action stamps

(with-upgradability ()

  (defun map-direct-dependencies (operation component fun)

  (defun (map-direct-dependencies) (plan operation component fun)

    (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)

           :for dep-o = (find-operation operation dep-o-spec)

           :when dep-o

           :do (loop :for dep-c-spec :in dep-c-specs

                     :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec))

                     :when dep-c

                     :when (and dep-c (action-valid-p plan dep-o dep-c))

                       :do (funcall fun dep-o dep-c))))

  (defun reduce-direct-dependencies (operation component combinator seed)

  (defun (reduce-direct-dependencies) (plan operation component combinator seed)

    (map-direct-dependencies

     operation component

     plan 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 (direct-dependencies) (plan operation component)

    (reduce-direct-dependencies plan operation component #'acons nil))

  ;; In a distant future, get-file-stamp, component-operation-time and latest-stamp

  ;; shall also be parametrized by the plan, or by a second model object,

  ;; so they need not refer to the state of the filesystem,

  ;; and the stamps could be cryptographic checksums rather than timestamps.

  ;; Such a change remarkably would only affect VISIT-DEPENDENCIES and COMPUTE-ACTION-STAMP.

  (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)

  ;; Such a change remarkably would only affect COMPUTE-ACTION-STAMP.

  (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done)

    ;; Given an action, figure out at what time in the past it has been done,

    ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but

    ;; hasn't been done in the current image yet, then it can have a non-T timestamp,

    ;; yet a NIL done-in-image-p flag.

    (let* ((stamp-lookup #'(lambda (o c)

                             (if-let (it (plan-action-status plan o c)) (action-stamp it) t)))

           (out-files (output-files o c))

           (in-files (input-files o c))

           ;; Three kinds of actions:

    (nest

     (block ())

     (let ((dep-stamp ; collect timestamp from dependencies (or T if forced or out-of-date)

             (reduce-direct-dependencies

              plan o c

              #'(lambda (o c stamp)

                  (if-let (it (plan-action-status plan o c))

                    (latest-stamp stamp (action-stamp it))

                    t))

              nil)))

       ;; out-of-date dependency: don't bother expensively querying the filesystem

       (when (and (eq dep-stamp t) (not just-done)) (return (values t nil))))

     ;; collect timestamps from inputs, and exit early if any is missing

     (let* ((in-files (input-files o c))

            (in-stamps (mapcar #'get-file-stamp in-files))

            (missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f))

            (latest-in (stamps-latest (cons dep-stamp in-stamps))))

       (when (and missing-in (not just-done)) (return (values t nil))))

     ;; collect timestamps from outputs, and exit early if any is missing

     (let* ((out-files (output-files o c))

            (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))

            (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))

            (earliest-out (stamps-earliest out-stamps)))

       (when (and missing-out (not just-done)) (return (values t nil))))

     (let* (;; There are three kinds of actions:

            (out-op (and out-files t)) ; those that create files on the filesystem

            ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image

            ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing

            ;; When was the thing last actually done? (Now, or ask.)

            (op-time (or just-done (component-operation-time o c)))

           ;; Accumulated timestamp from dependencies (or T if forced or out-of-date)

           (dep-stamp (visit-dependencies plan o c stamp-lookup))

            ;; Time stamps from the files at hand, and whether any is missing

           (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))

           (in-stamps (mapcar #'get-file-stamp in-files))

           (missing-in

             (loop :for f :in in-files :for s :in in-stamps :unless s :collect f))

           (missing-out

             (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))

            (all-present (not (or missing-in missing-out)))

            ;; Has any input changed since we last generated the files?

           (earliest-out (stamps-earliest out-stamps))

           (latest-in (stamps-latest (cons dep-stamp in-stamps)))

            (up-to-date-p (stamp<= latest-in earliest-out))

            ;; If everything is up to date, the latest of inputs and outputs is our stamp

            (done-stamp (stamps-latest (cons latest-in out-stamps))))

                ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]"

               (action-description o c)

               missing-in (length missing-in) (and missing-in missing-out)

              missing-out (length missing-out)))

               missing-out (length missing-out))))

     ;; Note that we use stamp<= instead of stamp< to play nice with generated files.

     ;; Any race condition is intrinsic to the limited timestamp resolution.

     (if (or just-done ;; The done-stamp is valid: if we're just done, or

        (when (and status (or (action-done-p status) (action-planned-p status) (not eniip)))

          (return (action-stamp status))) ; Already visited with sufficient need-in-image level!

        (labels ((visit-action (niip) ; We may visit the action twice, once with niip NIL, then T

                   (visit-dependencies plan operation component ; recursively traverse dependencies

                                       #'(lambda (o c) (traverse-action plan o c niip)))

                   (map-direct-dependencies ; recursively traverse dependencies

                    plan operation component #'(lambda (o c) (traverse-action plan o c niip)))

                   (multiple-value-bind (stamp done-p) ; AFTER dependencies have been traversed,

                       (compute-action-stamp plan operation component) ; compute action stamp

                     (let ((add-to-plan-p (or (eql stamp t) (and niip (not done-p)))))

    (when (action-planned-p new-status)

      (push (cons o c) (plan-actions-r p)))))

;;;; high-level interface: traverse, perform-plan, plan-operates-on-p

;;;; High-level interface: traverse, perform-plan, plan-operates-on-p

(with-upgradability ()

  (defgeneric make-plan (plan-class operation component &key &allow-other-keys)

    (:documentation

  (defvar *default-plan-class* 'sequential-plan)

  (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys)

    (let ((plan (apply 'make-instance

                       (or plan-class *default-plan-class*)

    (let ((plan (apply 'make-instance (or plan-class *default-plan-class*)

                       :system (component-system c) keys)))

      (traverse-action plan o c t)

      plan))

      plan))

  (define-convenience-action-methods traverse-sub-actions (operation component &key))

  (defmethod traverse-sub-actions ((operation operation) (component component) &rest keys &key &allow-other-keys)

    (apply 'traverse-actions (direct-dependencies operation component)

  (defmethod traverse-sub-actions ((operation operation) (component component)

                                   &rest keys &key &allow-other-keys)

    (apply 'traverse-actions (direct-dependencies t operation component)

           :system (component-system component) keys))

  (defmethod plan-actions ((plan filtered-sequential-plan))

  :components ((:file "file1") (:file "file3")))

(defsystem :test-asdf/bundle-2

  :depends-on (:test-asdf/bundle-1) :components ((:file "file2")))

  :depends-on (:test-asdf/bundle-1) :components

  ((:file "file2")

   (:file "invalid-file" :if-feature (:not :common-lisp))))

(defsystem :test-asdf/force

  :depends-on (:test-asdf/force1)