From 37a89ced8b86b051a6308a3c9e857625d826875c Mon Sep 17 00:00:00 2001 From: Cyrus Harmon Date: Sat, 26 Jun 2010 05:03:58 +0000 Subject: [PATCH] 1.0.39.22: "upgrade" to ASDF 2.003 --- contrib/asdf/asdf.lisp | 154 ++++++++++++++++++++++++++---------------------- version.lisp-expr | 2 +- 2 files changed, 86 insertions(+), 70 deletions(-) diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp index f8b1990..83ad94c 100644 --- a/contrib/asdf/asdf.lisp +++ b/contrib/asdf/asdf.lisp @@ -69,9 +69,8 @@ ;;;; See more at the end of the file. (eval-when (:load-toplevel :compile-toplevel :execute) - (let* ((asdf-version - ;; the 1+ helps the version bumping script discriminate - (subseq "VERSION:2.102" (1+ (length "VERSION")))) + (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate + (subseq "VERSION:2.003" (1+ (length "VERSION")))) ; NB: same as 2.105. (existing-asdf (find-package :asdf)) (vername '#:*asdf-version*) (versym (and existing-asdf @@ -345,9 +344,15 @@ You can compare this string with e.g.: Defaults to `t`.") -(defvar *compile-file-warnings-behaviour* :warn) +(defvar *compile-file-warnings-behaviour* :warn + "How should ASDF react if it encounters a warning when compiling a +file? Valid values are :error, :warn, and :ignore.") -(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) +(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn + "How should ASDF react if it encounters a failure \(per the +ANSI spec of COMPILE-FILE\) when compiling a file? Valid values are +:error, :warn, and :ignore. Note that ASDF ALWAYS raises an error +if it fails to create an output file when compiling.") (defvar *verbose-out* nil) @@ -1086,14 +1091,6 @@ called with an object of type asdf:system." (defparameter *system-definition-search-functions* '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf)) -(defun sysdef-find-asdf (system) - (let ((name (coerce-name system))) - (when (equal name "asdf") - (eval - `(defsystem :asdf - :pathname ,(or *compile-file-truename* *load-truename*) - :depends-on () :components ()))))) - (defun system-definition-pathname (system) (let ((system-name (coerce-name system))) (or @@ -1207,37 +1204,50 @@ to ~S which is not a directory.~@:>" 0))) (defun find-system (name &optional (error-p t)) - (let* ((name (coerce-name name)) - (in-memory (system-registered-p name)) - (on-disk (system-definition-pathname name))) - (when (and on-disk - (or (not in-memory) - (< (car in-memory) (safe-file-write-date on-disk)))) - (let ((package (make-temporary-package))) - (unwind-protect - (handler-bind - ((error (lambda (condition) - (error 'load-system-definition-error - :name name :pathname on-disk - :condition condition)))) - (let ((*package* package)) - (asdf-message - "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" - on-disk *package*) - (load on-disk))) - (delete-package package)))) - (let ((in-memory (system-registered-p name))) - (if in-memory - (progn (when on-disk (setf (car in-memory) - (safe-file-write-date on-disk))) - (cdr in-memory)) - (when error-p (error 'missing-component :requires name)))))) + (catch 'find-system + (let* ((name (coerce-name name)) + (in-memory (system-registered-p name)) + (on-disk (system-definition-pathname name))) + (when (and on-disk + (or (not in-memory) + (< (car in-memory) (safe-file-write-date on-disk)))) + (let ((package (make-temporary-package))) + (unwind-protect + (handler-bind + ((error (lambda (condition) + (error 'load-system-definition-error + :name name :pathname on-disk + :condition condition)))) + (let ((*package* package)) + (asdf-message + "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" + on-disk *package*) + (load on-disk))) + (delete-package package)))) + (let ((in-memory (system-registered-p name))) + (if in-memory + (progn (when on-disk (setf (car in-memory) + (safe-file-write-date on-disk))) + (cdr in-memory)) + (when error-p (error 'missing-component :requires name))))))) (defun register-system (name system) (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system))) +(defun sysdef-find-asdf (system) + (let ((name (coerce-name system))) + (when (equal name "asdf") + (let* ((registered (cdr (gethash name *defined-systems*))) + (asdf (or registered + (make-instance + 'system :name "asdf" + :source-file (or *compile-file-truename* *load-truename*))))) + (unless registered + (register-system "asdf" asdf)) + (throw 'find-system asdf))))) + ;;;; ------------------------------------------------------------------------- ;;;; Finding components @@ -1758,12 +1768,18 @@ recursive calls to traverse.") (setf (gethash (type-of operation) (component-operation-times c)) (get-universal-time))) +(declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys) + (values t t t)) + compile-file*)) + ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy (defmethod perform ((operation compile-op) (c cl-source-file)) #-:broken-fasl-loader (let ((source-file (component-pathname c)) - (output-file (car (output-files operation c)))) + (output-file (car (output-files operation c))) + (*compile-file-warnings-behaviour* (operation-on-warnings operation)) + (*compile-file-failure-behaviour* (operation-on-failure operation))) (multiple-value-bind (output warnings-p failure-p) (apply #'compile-file* source-file :output-file output-file (compile-op-flags operation)) @@ -2081,24 +2097,18 @@ details." ,(determine-system-pathname pathname pathname-arg-p) ',component-options)))))) - (defun class-for-type (parent type) - (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*) - (find-symbol (symbol-name type) - (load-time-value - (package-name :asdf))))) - (class (dolist (symbol (if (keywordp type) - extra-symbols - (cons type extra-symbols))) - (when (and symbol - (find-class symbol nil) - (subtypep symbol 'component)) - (return (find-class symbol)))))) - (or class - (and (eq type :file) - (or (module-default-component-class parent) - (find-class *default-component-class*))) - (sysdef-error "~@" type)))) + (or (loop :for symbol :in (list + (unless (keywordp type) type) + (find-symbol (symbol-name type) *package*) + (find-symbol (symbol-name type) :asdf)) + :for class = (and symbol (find-class symbol nil)) + :when (and class (subtypep class 'component)) + :return class) + (and (eq type :file) + (or (module-default-component-class parent) + (find-class *default-component-class*))) + (sysdef-error "~@" type))) (defun maybe-add-tree (tree op1 op2 c) "Add the node C at /OP1/OP2 in TREE, unless it's there already. @@ -2948,23 +2958,29 @@ effectively disabling the output translation facility." (when (probe-file x) (delete-file x))) -(defun compile-file* (input-file &rest keys) +(defun compile-file* (input-file &rest keys &key &allow-other-keys) (let* ((output-file (apply 'compile-file-pathname* input-file keys)) (tmp-file (tmpize-pathname output-file)) - (successp nil)) - (unwind-protect - (multiple-value-bind (output-truename warnings-p failure-p) - (apply 'compile-file input-file :output-file tmp-file keys) - (if failure-p - (setf output-truename nil) - (setf successp t)) - (values output-truename warnings-p failure-p)) + (status :error)) + (multiple-value-bind (output-truename warnings-p failure-p) + (apply 'compile-file input-file :output-file tmp-file keys) (cond - (successp - (delete-file-if-exists output-file) - (rename-file tmp-file output-file)) + (failure-p + (setf status *compile-file-failure-behaviour*)) + (warnings-p + (setf status *compile-file-warnings-behaviour*)) (t - (delete-file-if-exists tmp-file)))))) + (setf status :success))) + (ecase status + ((:success :warn :ignore) + (delete-file-if-exists output-file) + (when output-truename + (rename-file output-truename output-file) + (setf output-truename output-file))) + (:error + (delete-file-if-exists output-truename) + (setf output-truename nil))) + (values output-truename warnings-p failure-p)))) #+abcl (defun translate-jar-pathname (source wildcard) diff --git a/version.lisp-expr b/version.lisp-expr index 6fad98b..4fc5dc0 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.39.21" +"1.0.39.22" -- 1.7.10.4