2.014.5: Fix forcing of specific systems.

  :licence "MIT"

  :description "Another System Definition Facility"

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

  :version "2.014.4" ;; to be automatically updated by bin/bump-revision

  :version "2.014.5" ;; to be automatically updated by bin/bump-revision

  :depends-on ()

  :components

  ((:file "asdf")

;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-

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

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

;;;

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

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

         ;; "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.014.4")

         (asdf-version "2.014.5")

         (existing-asdf (fboundp 'find-system))

         (existing-version *asdf-version*)

         (already-there (equal asdf-version existing-version)))

                  '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))

  (defun* get-uid ()

    #+allegro (excl.osi:getuid)

    #+ccl (ccl::getuid)

    #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")

                  :for f = (ignore-errors (read-from-string s))

                  :when f :return (funcall f))

                   '(ffi:c-inline () () :int "getuid()" :one-liner t)

                   '(ext::getuid))

    #+sbcl (sb-unix:unix-getuid)

    #-(or allegro clisp cmu ecl sbcl scl)

    #-(or allegro ccl clisp cmu ecl sbcl scl)

    (let ((uid-string

           (with-output-to-string (*verbose-out*)

             (run-shell-command "id -ur"))))

  (funcall collect x))

(defmethod do-traverse ((operation operation) (c component) collect)

  (let ((flag nil)) ;; return value: must we rebuild this and its dependencies?

  (let ((*forcing* *forcing*)

        (flag nil)) ;; return value: must we rebuild this and its dependencies?

    (labels

        ((update-flag (x)

           (when x

             (setf flag t)))

           (orf flag x))

         (dep (op comp)

           (update-flag (do-dep operation c collect op comp))))

      ;; Have we been visited yet? If so, just process the result.

      (setf (visiting-component operation c) t)

      (unwind-protect

           (progn

             (let ((f (operation-forced

                       (operation-ancestor operation))))

               (when (and f (or (not (consp f)) ;; T or :ALL

                                (and (typep c 'system) ;; list of names of systems to force

                                     (member (component-name c) f

                                             :test #'string=))))

                 (setf *forcing* t)))

             ;; first we check and do all the dependencies for the module.

             ;; Operations planned in this loop will show up

             ;; in the results, and are consumed below.

                                         :try-next)

                                     (not at-least-one))

                            (error error)))))))

               (update-flag

                (or

                 *forcing*

                 (not (operation-done-p operation c))

               (update-flag (or *forcing* (not (operation-done-p operation c))))

                 ;; For sub-operations, check whether

                 ;; the original ancestor operation was forced,

                 ;; or names us amongst an explicit list of things to force...

                 ;; except that this check doesn't distinguish

                 ;; between all the things with a given name. Sigh.

                 ;; BROKEN!

                 (let ((f (operation-forced

                           (operation-ancestor operation))))

                   (and f (or (not (consp f)) ;; T or :ALL

                              (and (typep c 'system) ;; list of names of systems to force

                                   (member (component-name c) f

                                           :test #'string=)))))))

               (when flag

                 (let ((do-first (cdr (assoc (class-name (class-of operation))

                                             (component-do-first c)))))

      (r* l))))

(defmethod traverse ((operation operation) (c component))

  ;; cerror'ing a feature that seems to have NEVER EVER worked

  ;; ever since danb created it in his 2003-03-16 commit e0d02781.

  ;; It was both fixed and disabled in the 1.700 rewrite.

  (when (consp (operation-forced operation))

    (setf (operation-forced operation)

          (mapcar #'coerce-name (operation-forced operation))))

      exit-code)

    #+clisp                    ;XXX not exactly *verbose-out*, I know

    (or (ext:run-shell-command  command :output :terminal :wait t) 0)

    (or (ext:run-shell-command command :output (and *verbose-out* :terminal) :wait t) 0)

    #+clozure

    (nth-value 1