diff --git a/asdf.lisp b/asdf.lisp index bcc736bd6128bfe209784d4ac47805a79fcc67f0..4f80317a3a30b970f9c1a941bdb66da15ed0ad70 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -1,4 +1,4 @@ -;;; This is asdf: Another System Definition Facility. $Revision: 1.128 $ +;;; This is asdf: Another System Definition Facility. $Revision: 1.129 $ ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; <cclan-list@lists.sf.net>. But note first that the canonical @@ -108,10 +108,6 @@ #:standard-asdf-method-combination #:around ; protocol assistants ) - ;; preference loading - to be expunged - (:export - #:preference-file-for-system/operation - #:load-preferences) (:use :cl)) @@ -122,7 +118,7 @@ (in-package #:asdf) -(defvar *asdf-revision* (let* ((v "$Revision: 1.128 $") +(defvar *asdf-revision* (let* ((v "$Revision: 1.129 $") (colon (or (position #\: v) -1)) (dot (position #\. v))) (and v colon dot @@ -131,11 +127,6 @@ (parse-integer v :start (1+ dot) :junk-allowed t))))) -(defvar *load-preference-files* nil - "If true, then preference files will be loaded. - -This variable will be removed August 2008.") - (defvar *compile-file-warnings-behaviour* :warn) (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) @@ -761,44 +752,52 @@ the head of the tree")) (error 'circular-dependency :components (list c))) (setf (visiting-component operation c) t) (loop for (required-op . deps) in (component-depends-on operation c) - do (do-dep required-op deps)) - ;; constituent bits - (let ((module-ops - (when (typep c 'module) - (let ((at-least-one nil) - (forced nil) - (error nil)) - (loop for kid in (module-components c) - do (handler-case - (appendf forced (traverse operation kid )) - (missing-dependency (condition) - (if (eq (module-if-component-dep-fails c) :fail) - (error condition)) - (setf error condition)) - (:no-error (c) - (declare (ignore c)) - (setf at-least-one t)))) - (when (and (eq (module-if-component-dep-fails c) :try-next) - (not at-least-one)) - (error error)) - forced)))) - ;; now the thing itself - (when (or forced module-ops - (not (operation-done-p operation c)) - (let ((f (operation-forced (operation-ancestor operation)))) - (and f (or (not (consp f)) - (member (component-name - (operation-ancestor operation)) - (mapcar #'coerce-name f) - :test #'string=))))) - (let ((do-first (cdr (assoc (class-name (class-of operation)) - (slot-value c 'do-first))))) - (loop for (required-op . deps) in do-first - do (do-dep required-op deps))) - (setf forced (append (delete 'pruned-op forced :key #'car) - (delete 'pruned-op module-ops :key #'car) - (list (cons operation c)))))) - (setf (visiting-component operation c) nil) + do (do-dep required-op deps)) + (unwind-protect + (progn + (loop for (required-op . deps) in + (component-depends-on operation c) + do (do-dep required-op deps)) + ;; constituent bits + (let ((module-ops + (when (typep c 'module) + (let ((at-least-one nil) + (forced nil) + (error nil)) + (loop for kid in (module-components c) + do (handler-case + (appendf forced (traverse operation kid )) + (missing-dependency (condition) + (if (eq (module-if-component-dep-fails c) + :fail) + (error condition)) + (setf error condition)) + (:no-error (c) + (declare (ignore c)) + (setf at-least-one t)))) + (when (and (eq (module-if-component-dep-fails c) + :try-next) + (not at-least-one)) + (error error)) + forced)))) + ;; now the thing itself + (when (or forced module-ops + (not (operation-done-p operation c)) + (let ((f (operation-forced + (operation-ancestor operation)))) + (and f (or (not (consp f)) + (member (component-name + (operation-ancestor operation)) + (mapcar #'coerce-name f) + :test #'string=))))) + (let ((do-first (cdr (assoc (class-name (class-of operation)) + (slot-value c 'do-first))))) + (loop for (required-op . deps) in do-first + do (do-dep required-op deps))) + (setf forced (append (delete 'pruned-op forced :key #'car) + (delete 'pruned-op module-ops :key #'car) + (list (cons operation c))))))) + (setf (visiting-component operation c) nil)) (visit-component operation c (and forced t)) forced))) @@ -829,9 +828,7 @@ the head of the tree")) (defmethod perform :after ((operation operation) (c component)) (setf (gethash (type-of operation) (component-operation-times c)) - (get-universal-time)) - (when *load-preference-files* - (load-preferences c operation))) + (get-universal-time))) ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy @@ -975,50 +972,6 @@ the head of the tree")) "Testing a system is _never_ done." nil) -(defgeneric load-preferences (system operation) - (:documentation - "Deprecated - will be removed August 2008 - -Called to load system preferences after <perform operation -system>. Typical uses are to set parameters that don't exist until -after the system has been loaded.")) - -(defgeneric preference-file-for-system/operation (system operation) - (:documentation - "Deprecated - will be removed August 2008 - -Returns the pathname of the preference file for this system. -Called by 'load-preferences to determine what file to load.")) - -(defmethod load-preferences ((s t) (operation t)) - ;; do nothing - (values)) - -(defmethod load-preferences ((s system) (operation basic-load-op)) - (let* ((*package* (find-package :common-lisp)) - (file (probe-file (preference-file-for-system/operation s operation)))) - (when file - (when *verbose-out* - (format *verbose-out* - "~&~@<; ~@;loading preferences for ~A/~(~A~) from ~A~@:>~%" - (component-name s) - (type-of operation) file)) - (load file)))) - -(defmethod preference-file-for-system/operation ((system t) (operation t)) - ;; cope with anything other than systems - (preference-file-for-system/operation (find-system system t) operation)) - -(defmethod preference-file-for-system/operation ((s system) (operation t)) - (let ((*default-pathname-defaults* - (make-pathname :name nil :type nil - :defaults *default-pathname-defaults*))) - (merge-pathnames - (make-pathname :name (component-name s) - :type "lisp" - :directory '(:relative ".asdf")) - (truename (user-homedir-pathname))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; invoking operations diff --git a/test/test-preferences-1.lisp b/test/test-preferences-1.lisp deleted file mode 100644 index f4b7111420d56842e61a046c9b3fc355b6a6a3d8..0000000000000000000000000000000000000000 --- a/test/test-preferences-1.lisp +++ /dev/null @@ -1,3 +0,0 @@ -(in-package #:common-lisp-user) - -(defvar *test-preferences-variable-1* :default) diff --git a/test/test-preferences-1.script b/test/test-preferences-1.script deleted file mode 100644 index 2e0b245c0e26db9d5ff4fd99557791f78e5e2173..0000000000000000000000000000000000000000 --- a/test/test-preferences-1.script +++ /dev/null @@ -1,12 +0,0 @@ -;;; -*- Lisp -*- -(load "script-support") -(load "../asdf") -(exit-on-error - (setf asdf:*central-registry* '(*default-pathname-defaults*)) - (in-package :asdf) - (setf asdf::*load-preference-files* t) - (asdf:oos 'asdf:load-op 'test-preferences-system-1) - (assert (eq common-lisp-user::*test-preferences-variable-1* :load)) - (asdf:oos 'asdf:test-op 'test-preferences-system-1) - (assert (eq common-lisp-user::*test-preferences-variable-1* :test)) - ) \ No newline at end of file diff --git a/test/test-preferences-system-1.asd b/test/test-preferences-system-1.asd deleted file mode 100644 index d8f6444afb0aea492ba7c23f7bdba966be77e952..0000000000000000000000000000000000000000 --- a/test/test-preferences-system-1.asd +++ /dev/null @@ -1,35 +0,0 @@ -;;; -*- Lisp -*- -(in-package #:common-lisp) - -(defpackage #:test-preferences-1-asdf-system - (:use #:common-lisp #:asdf)) -(in-package #:asdf) - -(defsystem test-preferences-system-1 - :components - ((:file "test-preferences-1")) - :in-order-to ((test-op (load-op test-preferences-system-1)))) - -(defmethod operation-done-p - ((o test-op) - (c (eql (find-system 'test-preferences-system-1)))) - (values nil)) - -(defmethod load-preferences - ((system (eql (find-system 'test-preferences-system-1))) - (operation test-op)) - ;; the default load-preferences does nothing for anything other than a - ;; basic-load-op. So, ... we hack it - (load (make-pathname - :name "test-preferences-system-test" - :type "lisp" - :defaults *default-pathname-defaults*))) - -(defmethod preference-file-for-system/operation - ((system (eql (find-system 'test-preferences-system-1))) - (operation load-op)) - (make-pathname - :name "test-preferences-system-load" - :type "lisp" - :defaults *default-pathname-defaults*)) - diff --git a/test/test-preferences-system-load.lisp b/test/test-preferences-system-load.lisp deleted file mode 100644 index 0906efcd233c033786b23b380d0e41f7888fce6d..0000000000000000000000000000000000000000 --- a/test/test-preferences-system-load.lisp +++ /dev/null @@ -1,3 +0,0 @@ -(in-package #:common-lisp-user) - -(setf *test-preferences-variable-1* :load) diff --git a/test/test-preferences-system-test.lisp b/test/test-preferences-system-test.lisp deleted file mode 100644 index 8dd07353db94ab606817959774870e868ab13a53..0000000000000000000000000000000000000000 --- a/test/test-preferences-system-test.lisp +++ /dev/null @@ -1,3 +0,0 @@ -(in-package #:common-lisp-user) - -(setf *test-preferences-variable-1* :test) diff --git a/test/test6.script b/test/test6.script deleted file mode 100644 index f86c870ecf5b0dca6f731b5865598c677977f186..0000000000000000000000000000000000000000 --- a/test/test6.script +++ /dev/null @@ -1,19 +0,0 @@ -;;; -*- Lisp -*- - -;; no preference loading by default -(load "script-support") -(load "../asdf") -(in-package #:common-lisp-user) - -(defvar *test6* nil) - -(exit-on-error - (setf asdf:*central-registry* '(*default-pathname-defaults*)) - (defmethod asdf:preference-file-for-system/operation - ((system (eql (asdf:find-system 'test1))) operation) - (merge-pathnames (make-pathname :name "test1" :type "preferences"))) - (asdf:operate 'asdf:load-op 'test1) - (assert (null *test6*))) - - - diff --git a/test/test7.script b/test/test7.script deleted file mode 100644 index 5793d50d32b1f12541c9d72530f2fc324d3b74da..0000000000000000000000000000000000000000 --- a/test/test7.script +++ /dev/null @@ -1,20 +0,0 @@ -;;; -*- Lisp -*- - -;; load preferences if asdf::*load-preference-files* is true -(load "script-support") -(load "../asdf") -(in-package #:common-lisp-user) - -(defvar *test6* nil) - -(exit-on-error - (setf asdf:*central-registry* '(*default-pathname-defaults*)) - (defmethod asdf:preference-file-for-system/operation - ((system (eql (asdf:find-system 'test1))) operation) - (merge-pathnames (make-pathname :name "test1" :type "preferences"))) - (setf asdf::*load-preference-files* t) - (asdf:operate 'asdf:load-op 'test1) - (assert (eq *test6* :yes))) - - -