Changeset 13888

Timestamp:

Jun 24, 2010, 7:42:04 PM (14 years ago)

Author:

R. Matthew Emerson

Message:

ASDF 2.003 from upstream.

File:

• trunk/source/tools/asdf.lisp (modified) (15 diffs)

trunk/source/tools/asdf.lisp

@@ -48 +48 @@
 #+xcvb (module ())
 
-(cl:in-package :cl-user)
-
-#|(declaim (optimize (speed 2) (debug 2) (safety 3))
-#+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))|#
-
-#+ecl (require :cmp)
-
-;;;; Create packages in a way that is compatible with hot-upgrade.
-;;;; See https://bugs.launchpad.net/asdf/+bug/485687
-;;;; See more at the end of the file.
-
-#+gcl
-(eval-when (:compile-toplevel :load-toplevel)
-  (defpackage :asdf-utilities (:use :cl))
-  (defpackage :asdf (:use :cl :asdf-utilities)))
-
-(eval-when (:load-toplevel :compile-toplevel :execute)
+(cl:in-package :cl)
+(defpackage :asdf-bootstrap (:use :cl))
+(in-package :asdf-bootstrap)
+
+;; Implementation-dependent tweaks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults.
   #+allegro
   (setf excl::*autoload-package-name-alist*
         (remove "asdf" excl::*autoload-package-name-alist*
                 :test 'equalp :key 'car))
-  (let* ((asdf-version
-          ;; the 1+ helps the version bumping script discriminate
-          (subseq "VERSION:2.002" (1+ (length "VERSION"))))
+  #+ecl (require :cmp)
+  #+gcl
+  (eval-when (:compile-toplevel :load-toplevel)
+    (defpackage :asdf-utilities (:use :cl))
+    (defpackage :asdf (:use :cl :asdf-utilities))))
+
+;;;; Create packages in a way that is compatible with hot-upgrade.
+;;;; See https://bugs.launchpad.net/asdf/+bug/485687
+;;;; 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.003" (1+ (length "VERSION")))) ; NB: same as 2.105.
          (existing-asdf (find-package :asdf))
          (vername '#:*asdf-version*)
@@ -156 +156 @@
             ((pkgdcl (name &key nicknames use export
                            redefined-functions unintern fmakunbound shadow)
-               `(ensure-package
-                 ',name :nicknames ',nicknames :use ',use :export ',export
-                 :shadow ',shadow
-                 :unintern ',(append #-(or gcl ecl) redefined-functions
-                                     unintern)
-                 :fmakunbound ',(append #+(or gcl ecl) redefined-functions
-                                        fmakunbound))))
+                 `(ensure-package
+                   ',name :nicknames ',nicknames :use ',use :export ',export
+                   :shadow ',shadow
+                   :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
+                   :fmakunbound ',(append fmakunbound))))
           (pkgdcl
            :asdf-utilities
@@ -291 +289 @@
             #:ensure-output-translations
             #:apply-output-translations
+            #:compile-file*
             #:compile-file-pathname*
             #:enable-asdf-binary-locations-compatibility
@@ -346 +345 @@
 Defaults to `t`.")
 
-(defvar *compile-file-warnings-behaviour* :warn)
-
-(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :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
+        "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)
@@ -367 +372 @@
 ;;;; -------------------------------------------------------------------------
 ;;;; ASDF Interface, in terms of generic functions.
-
-(defgeneric perform-with-restarts (operation component))
-(defgeneric perform (operation component))
-(defgeneric operation-done-p (operation component))
-(defgeneric explain (operation component))
-(defgeneric output-files (operation component))
-(defgeneric input-files (operation component))
+(defmacro defgeneric* (name formals &rest options)
+  `(progn
+     #+(or gcl ecl) (fmakunbound ',name)
+     (defgeneric ,name ,formals ,@options)))
+
+(defgeneric* perform-with-restarts (operation component))
+(defgeneric* perform (operation component))
+(defgeneric* operation-done-p (operation component))
+(defgeneric* explain (operation component))
+(defgeneric* output-files (operation component))
+(defgeneric* input-files (operation component))
 (defgeneric component-operation-time (operation component))
 
-(defgeneric system-source-file (system)
+(defgeneric* system-source-file (system)
   (:documentation "Return the source file in which system is defined."))
 
@@ -398 +407 @@
 (defgeneric version-satisfies (component version))
 
-(defgeneric find-component (base path)
+(defgeneric* find-component (base path)
   (:documentation "Finds the component with PATH starting from BASE module;
 if BASE is nil, then the component is assumed to be a system."))
@@ -1083 +1092 @@
   '(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)))
@@ -1204 +1205 @@
 
 (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)
@@ -1234 +1236 @@
   (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)))))
 
 
@@ -1755 +1769 @@
         (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
@@ -1760 +1778 @@
   #-: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
+        (apply #'compile-file* source-file :output-file output-file
                (compile-op-flags operation))
       (when warnings-p
@@ -1938 +1958 @@
 ;;;; Invoking Operations
 
-(defgeneric operate (operation-class system &key &allow-other-keys))
+(defgeneric* operate (operation-class system &key &allow-other-keys))
 
 (defmethod operate (operation-class system &rest args
@@ -2078 +2098 @@
                ',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 "~@<don't recognize component type ~A~@:>" 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 "~@<don't recognize component type ~A~@:>" type)))
 
 (defun maybe-add-tree (tree op1 op2 c)
@@ -2929 +2943 @@
    t))
 
-(defun compile-file-pathname* (input-file &rest keys)
-  (apply-output-translations
-   (apply #'compile-file-pathname
-          (truenamize (lispize-pathname input-file))
-          keys)))
+(defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
+  (or output-file
+      (apply-output-translations
+       (apply 'compile-file-pathname
+              (truenamize (lispize-pathname input-file))
+              keys))))
+
+(defun tmpize-pathname (x)
+  (make-pathname
+   :name (format nil "ASDF-TMP-~A" (pathname-name x))
+   :defaults x))
+
+(defun delete-file-if-exists (x)
+  (when (probe-file x)
+    (delete-file x)))
+
+(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))
+         (status :error))
+    (multiple-value-bind (output-truename warnings-p failure-p)
+        (apply 'compile-file input-file :output-file tmp-file keys)
+      (cond
+        (failure-p
+         (setf status *compile-file-failure-behaviour*))
+        (warnings-p
+         (setf status *compile-file-warnings-behaviour*))
+        (t
+         (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
@@ -3365 +3413 @@
 ;;;; Done!
 (when *load-verbose*
-  (asdf-message ";; ASDF, version ~a" (asdf-version)))
+  (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
 
 #+allegro