X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fasdf%2Fasdf.lisp;h=54407010a606e5d1d63f008f6d2e0c50b12591a1;hb=0cff6b0b7e6f1d148586f81f620b9c86ed217caa;hp=4005dc83fac1473ed79c337025286e5564108676;hpb=d43f45c63d6b9257aab54f7773d661431ac9d52d;p=sbcl.git

diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp
index 4005dc8..5440701 100644
--- a/contrib/asdf/asdf.lisp
+++ b/contrib/asdf/asdf.lisp
@@ -1,4 +1,4 @@
-;;; This is asdf: Another System Definition Facility.  1.102
+;;; This is asdf: Another System Definition Facility.  1.130
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome: please mail to
 ;;; <cclan-list@lists.sf.net>.  But note first that the canonical
@@ -13,7 +13,7 @@
 ;;; is the latest development version, whereas the revision tagged
 ;;; RELEASE may be slightly older but is considered `stable'
 
-;;; Copyright (c) 2001-2003 Daniel Barlow and contributors
+;;; Copyright (c) 2001-2008 Daniel Barlow and contributors
 ;;;
 ;;; Permission is hereby granted, free of charge, to any person obtaining
 ;;; a copy of this software and associated documentation files (the
@@ -40,15 +40,14 @@
 (defpackage #:asdf
   (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
            #:system-definition-pathname #:find-component ; miscellaneous
-           #:hyperdocumentation #:hyperdoc
 
-           #:compile-op #:load-op #:load-source-op #:test-system-version
+           #:compile-op #:load-op #:load-source-op
            #:test-op
-           #:operation                  ; operations
-           #:feature                    ; sort-of operation
-           #:version                    ; metaphorically sort-of an operation
+           #:operation           ; operations
+           #:feature             ; sort-of operation
+           #:version             ; metaphorically sort-of an operation
 
-           #:input-files #:output-files #:perform       ; operation methods
+           #:input-files #:output-files #:perform ; operation methods
            #:operation-done-p #:explain
 
            #:component #:source-file
@@ -79,11 +78,13 @@
            #:system-maintainer
            #:system-license
            #:system-licence
+           #:system-source-file
+           #:system-relative-pathname
 
            #:operation-on-warnings
            #:operation-on-failure
 
-           ;#:*component-parent-pathname*
+                                        ;#:*component-parent-pathname*
            #:*system-definition-search-functions*
            #:*central-registry*         ; variables
            #:*compile-file-warnings-behaviour*
@@ -94,38 +95,47 @@
            #:error-component #:error-operation
            #:system-definition-error
            #:missing-component
+           #:missing-component-of-version
            #:missing-dependency
+           #:missing-dependency-of-version
            #:circular-dependency        ; errors
            #:duplicate-names
 
+           #:try-recompiling
            #:retry
            #:accept                     ; restarts
 
-           #:preference-file-for-system/operation
-           #:load-preferences
+           #:standard-asdf-method-combination
+           #:around                     ; protocol assistants
            )
   (:use :cl))
 
-#+nil
-(error "The author of this file habitually uses #+nil to comment out forms.  But don't worry, it was unlikely to work in the New Implementation of Lisp anyway")
 
+#+nil
+(error "The author of this file habitually uses #+nil to comment out ~
+        forms. But don't worry, it was unlikely to work in the New ~
+        Implementation of Lisp anyway")
 
 (in-package #:asdf)
 
-(defvar *asdf-revision* (let* ((v "1.102")
+(defvar *asdf-revision* (let* ((v "1.130")
                                (colon (or (position #\: v) -1))
                                (dot (position #\. v)))
                           (and v colon dot
                                (list (parse-integer v :start (1+ colon)
-                                                    :junk-allowed t)
+                                                      :junk-allowed t)
                                      (parse-integer v :start (1+ dot)
-                                                    :junk-allowed t)))))
+                                                      :junk-allowed t)))))
 
 (defvar *compile-file-warnings-behaviour* :warn)
+
 (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
 
 (defvar *verbose-out* nil)
 
+(defparameter +asdf-methods+
+  '(perform explain output-files operation-done-p))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; utility stuff
 
@@ -138,7 +148,7 @@ and NIL NAME and TYPE components"
   (make-pathname :name nil :type nil :defaults pathname))
 
 (define-modify-macro appendf (&rest args)
-                     append "Append onto list")
+  append "Append onto list")
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; classes, condiitons
@@ -166,12 +176,18 @@ and NIL NAME and TYPE components"
 
 (define-condition missing-component (system-definition-error)
   ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
-   (version :initform nil :reader missing-version :initarg :version)
    (parent :initform nil :reader missing-parent :initarg :parent)))
 
+(define-condition missing-component-of-version (missing-component)
+  ((version :initform nil :reader missing-version :initarg :version)))
+
 (define-condition missing-dependency (missing-component)
   ((required-by :initarg :required-by :reader missing-required-by)))
 
+(define-condition missing-dependency-of-version (missing-dependency
+                                                 missing-component-of-version)
+  ())
+
 (define-condition operation-error (error)
   ((component :reader error-component :initarg :component)
    (operation :reader error-operation :initarg :operation))
@@ -187,7 +203,7 @@ and NIL NAME and TYPE components"
          "Component name: designator for a string composed of portable pathname characters")
    (version :accessor component-version :initarg :version)
    (in-order-to :initform nil :initarg :in-order-to)
-   ;;; XXX crap name
+   ;; XXX crap name
    (do-first :initform nil :initarg :do-first)
    ;; methods defined using the "inline" style inside a defsystem form:
    ;; need to store them somewhere so we can delete them when the system
@@ -216,14 +232,20 @@ and NIL NAME and TYPE components"
 ;;;; methods: components
 
 (defmethod print-object ((c missing-component) s)
-  (format s "~@<component ~S not found~
-             ~@[ or does not match version ~A~]~
+   (format s "~@<component ~S not found~
              ~@[ in ~A~]~@:>"
           (missing-requires c)
-          (missing-version c)
           (when (missing-parent c)
             (component-name (missing-parent c)))))
 
+(defmethod print-object ((c missing-component-of-version) s)
+  (format s "~@<component ~S does not match version ~A~
+              ~@[ in ~A~]~@:>"
+           (missing-requires c)
+           (missing-version c)
+           (when (missing-parent c)
+             (component-name (missing-parent c)))))
+
 (defgeneric component-system (component)
   (:documentation "Find the top-level system containing COMPONENT"))
 
@@ -299,13 +321,13 @@ and NIL NAME and TYPE components"
     (nreverse
      (let ((list nil) (start 0) (words 0) end)
        (loop
-        (when (and max (>= words (1- max)))
-          (return (cons (subseq string start) list)))
-        (setf end (position-if #'is-ws string :start start))
-        (push (subseq string start end) list)
-        (incf words)
-        (unless end (return list))
-        (setf start (1+ end)))))))
+         (when (and max (>= words (1- max)))
+           (return (cons (subseq string start) list)))
+         (setf end (position-if #'is-ws string :start start))
+         (push (subseq string start end) list)
+         (incf words)
+         (unless end (return list))
+         (setf start (1+ end)))))))
 
 (defgeneric version-satisfies (component version))
 
@@ -330,11 +352,11 @@ and NIL NAME and TYPE components"
 
 (defvar *defined-systems* (make-hash-table :test 'equal))
 (defun coerce-name (name)
-   (typecase name
-     (component (component-name name))
-     (symbol (string-downcase (symbol-name name)))
-     (string name)
-     (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
+  (typecase name
+    (component (component-name name))
+    (symbol (string-downcase (symbol-name name)))
+    (string name)
+    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
 
 ;;; for the sake of keeping things reasonably neat, we adopt a
 ;;; convention that functions in this list are prefixed SYSDEF-
@@ -343,8 +365,13 @@ and NIL NAME and TYPE components"
   '(sysdef-central-registry-search))
 
 (defun system-definition-pathname (system)
-  (some (lambda (x) (funcall x system))
-        *system-definition-search-functions*))
+  (let ((system-name (coerce-name system)))
+    (or
+     (some (lambda (x) (funcall x system-name))
+           *system-definition-search-functions*)
+     (let ((system-pair (system-registered-p system-name)))
+       (and system-pair
+            (system-source-file (cdr system-pair)))))))
 
 (defvar *central-registry*
   '(*default-pathname-defaults*
@@ -366,15 +393,15 @@ and NIL NAME and TYPE components"
 (defun make-temporary-package ()
   (flet ((try (counter)
            (ignore-errors
-                   (make-package (format nil "ASDF~D" counter)
-                                 :use '(:cl :asdf)))))
+             (make-package (format nil "ASDF~D" counter)
+                           :use '(:cl :asdf)))))
     (do* ((counter 0 (+ counter 1))
           (package (try counter) (try counter)))
          (package package))))
 
 (defun find-system (name &optional (error-p t))
   (let* ((name (coerce-name name))
-         (in-memory (gethash name *defined-systems*))
+         (in-memory (system-registered-p name))
          (on-disk (system-definition-pathname name)))
     (when (and on-disk
                (or (not in-memory)
@@ -391,7 +418,7 @@ and NIL NAME and TYPE components"
                 *package*)
                (load on-disk))
           (delete-package package))))
-    (let ((in-memory (gethash name *defined-systems*)))
+    (let ((in-memory (system-registered-p name)))
       (if in-memory
           (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
                  (cdr in-memory))
@@ -399,12 +426,13 @@ and NIL NAME and TYPE components"
 
 (defun register-system (name system)
   (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
-  (setf (gethash (coerce-name  name) *defined-systems*)
+  (setf (gethash (coerce-name name) *defined-systems*)
         (cons (get-universal-time) system)))
 
 (defun system-registered-p (name)
   (gethash (coerce-name name) *defined-systems*))
 
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; finding components
 
@@ -484,17 +512,51 @@ system."))
   ;; empty method to disable initarg validity checking
   )
 
-(defgeneric perform (operation component))
-(defgeneric operation-done-p (operation component))
-(defgeneric explain (operation component))
-(defgeneric output-files (operation component))
-(defgeneric input-files (operation component))
+(define-method-combination standard-asdf-method-combination ()
+  ((around-asdf (around))
+   (around (:around))
+   (before (:before))
+   (primary () :required t)
+   (after (:after)))
+  (flet ((call-methods (methods)
+           (mapcar #'(lambda (method)
+                       `(call-method ,method))
+                   methods)))
+    (let* ((form (if (or before after (rest primary))
+                     `(multiple-value-prog1
+                          (progn ,@(call-methods before)
+                                 (call-method ,(first primary)
+                                              ,(rest primary)))
+                        ,@(call-methods (reverse after)))
+                     `(call-method ,(first primary))))
+           (standard-form (if around
+                              `(call-method ,(first around)
+                                            (,@(rest around)
+                                               (make-method ,form)))
+                              form)))
+      (if around-asdf
+          `(call-method ,(first around-asdf)
+                        (,@(rest around-asdf) (make-method ,standard-form)))
+          standard-form))))
+
+(defgeneric perform (operation component)
+  (:method-combination standard-asdf-method-combination))
+(defgeneric operation-done-p (operation component)
+  (:method-combination standard-asdf-method-combination))
+(defgeneric explain (operation component)
+  (:method-combination standard-asdf-method-combination))
+(defgeneric output-files (operation component)
+  (:method-combination standard-asdf-method-combination))
+(defgeneric input-files (operation component)
+  (:method-combination standard-asdf-method-combination))
 
 (defun node-for (o c)
   (cons (class-name (class-of o)) c))
 
 (defgeneric operation-ancestor (operation)
-  (:documentation   "Recursively chase the operation's parent pointer until we get to the head of the tree"))
+  (:documentation
+   "Recursively chase the operation's parent pointer until we get to
+the head of the tree"))
 
 (defmethod operation-ancestor ((operation operation))
   (aif (operation-parent operation)
@@ -522,6 +584,8 @@ system."))
                   :parent o :original-initargs args args)))))
 
 
+(defgeneric component-visited-p (operation component))
+
 (defgeneric visit-component (operation component data))
 
 (defmethod visit-component ((o operation) (c component) data)
@@ -529,8 +593,6 @@ system."))
     (push (cons (node-for o c) data)
           (operation-visited-nodes (operation-ancestor o)))))
 
-(defgeneric component-visited-p (operation component))
-
 (defmethod component-visited-p ((o operation) (c component))
   (assoc (node-for o c)
          (operation-visited-nodes (operation-ancestor o))
@@ -553,11 +615,29 @@ system."))
 (defgeneric component-visiting-p (operation component))
 
 (defmethod component-visiting-p ((o operation) (c component))
-  (let ((node (cons o c)))
+  (let ((node (node-for o c)))
     (member node (operation-visiting-nodes (operation-ancestor o))
             :test 'equal)))
 
-(defgeneric component-depends-on (operation component))
+(defgeneric component-depends-on (operation component)
+  (:documentation
+   "Returns a list of dependencies needed by the component to perform
+    the operation.  A dependency has one of the following forms:
+
+      (<operation> <component>*), where <operation> is a class
+        designator and each <component> is a component
+        designator, which means that the component depends on
+        <operation> having been performed on each <component>; or
+
+      (FEATURE <feature>), which means that the component depends
+        on <feature>'s presence in *FEATURES*.
+
+    Methods specialized on subclasses of existing component types
+    should usually append the results of CALL-NEXT-METHOD to the
+    list."))
+
+(defmethod component-depends-on ((op-spec symbol) (c component))
+  (component-depends-on (make-instance op-spec) c))
 
 (defmethod component-depends-on ((o operation) (c component))
   (cdr (assoc (class-name (class-of o))
@@ -638,16 +718,22 @@ system."))
                                   ;; in-order-to slot with canonicalized
                                   ;; names instead of coercing this late
                                   (coerce-name required-c) required-v)
-                                 (error 'missing-dependency :required-by c
-                                        :version required-v
-                                        :requires required-c)))
+                                 (if required-v
+                                     (error 'missing-dependency-of-version
+                                            :required-by c
+                                            :version required-v
+                                            :requires required-c)
+                                     (error 'missing-dependency
+                                            :required-by c
+                                            :requires required-c))))
                       (op (make-sub-operation c operation dep-c required-op)))
                  (traverse op dep-c)))
              (do-dep (op dep)
                (cond ((eq op 'feature)
                       (or (member (car dep) *features*)
-                          (error 'missing-dependency :required-by c
-                                 :requires (car dep) :version nil)))
+                          (error 'missing-dependency
+                                 :required-by c
+                                 :requires (car dep))))
                      (t
                       (dolist (d dep)
                         (cond ((consp d)
@@ -665,45 +751,51 @@ system."))
       (if (component-visiting-p operation c)
           (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)
+      (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)))
 
@@ -734,8 +826,7 @@ system."))
 
 (defmethod perform :after ((operation operation) (c component))
   (setf (gethash (type-of operation) (component-operation-times c))
-        (get-universal-time))
-  (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
@@ -744,9 +835,7 @@ system."))
   (let ((source-file (component-pathname c))
         (output-file (car (output-files operation c))))
     (multiple-value-bind (output warnings-p failure-p)
-                         (compile-file source-file
-                                       :output-file output-file)
-      ;(declare (ignore output))
+        (compile-file source-file :output-file output-file)
       (when warnings-p
         (case (operation-on-warnings operation)
           (:warn (warn
@@ -774,6 +863,10 @@ system."))
 (defmethod output-files ((operation compile-op) (c static-file))
   nil)
 
+(defmethod input-files ((op compile-op) (c static-file))
+  nil)
+
+
 ;;; load-op
 
 (defclass basic-load-op (operation) ())
@@ -783,8 +876,49 @@ system."))
 (defmethod perform ((o load-op) (c cl-source-file))
   (mapcar #'load (input-files o c)))
 
+(defmethod perform around ((o load-op) (c cl-source-file))
+  (let ((state :initial))
+    (loop until (or (eq state :success)
+                    (eq state :failure)) do
+         (case state
+           (:recompiled
+            (setf state :failure)
+            (call-next-method)
+            (setf state :success))
+           (:failed-load
+            (setf state :recompiled)
+            (perform (make-instance 'asdf:compile-op) c))
+           (t
+            (with-simple-restart
+                (try-recompiling "Recompile ~a and try loading it again"
+                                  (component-name c))
+              (setf state :failed-load)
+              (call-next-method)
+              (setf state :success)))))))
+
+(defmethod perform around ((o compile-op) (c cl-source-file))
+  (let ((state :initial))
+    (loop until (or (eq state :success)
+                    (eq state :failure)) do
+         (case state
+           (:recompiled
+            (setf state :failure)
+            (call-next-method)
+            (setf state :success))
+           (:failed-compile
+            (setf state :recompiled)
+            (perform (make-instance 'asdf:compile-op) c))
+           (t
+            (with-simple-restart
+                (try-recompiling "Try recompiling ~a"
+                                  (component-name c))
+              (setf state :failed-compile)
+              (call-next-method)
+              (setf state :success)))))))
+
 (defmethod perform ((operation load-op) (c static-file))
   nil)
+
 (defmethod operation-done-p ((operation load-op) (c static-file))
   t)
 
@@ -832,77 +966,70 @@ system."))
 (defmethod perform ((operation test-op) (c component))
   nil)
 
-(defgeneric load-preferences (system operation)
-  (:documentation "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 "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))
-  (merge-pathnames
-   (make-pathname :name (component-name s)
-                  :type "lisp"
-                  :directory '(:relative ".asdf"))
-   (truename (user-homedir-pathname))))
+(defmethod operation-done-p ((operation test-op) (c system))
+  "Testing a system is _never_ done."
+  nil)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; invoking operations
 
+(defvar *operate-docstring*
+  "Operate does three things:
+
+1. It creates an instance of `operation-class` using any keyword parameters
+as initargs.
+2. It finds the  asdf-system specified by `system` (possibly loading
+it from disk).
+3. It then calls `traverse` with the operation and system as arguments
+
+The traverse operation is wrapped in `with-compilation-unit` and error
+handling code. If a `version` argument is supplied, then operate also
+ensures that the system found satisfies it using the `version-satisfies`
+method.")
+
 (defun operate (operation-class system &rest args &key (verbose t) version
-                                &allow-other-keys)
+                &allow-other-keys)
   (let* ((op (apply #'make-instance operation-class
                     :original-initargs args
                     args))
-         (*verbose-out* (if verbose *trace-output* (make-broadcast-stream)))
+         (*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
          (system (if (typep system 'component) system (find-system system))))
     (unless (version-satisfies system version)
-      (error 'missing-component :requires system :version version))
+      (error 'missing-component-of-version :requires system :version version))
     (let ((steps (traverse op system)))
       (with-compilation-unit ()
         (loop for (op . component) in steps do
-             (loop
-                (restart-case
-                    (progn (perform op component)
-                           (return))
-                  (retry ()
-                    :report
-                    (lambda (s)
-                      (format s "~@<Retry performing ~S on ~S.~@:>"
-                              op component)))
-                  (accept ()
-                    :report
-                    (lambda (s)
-                      (format s
-                              "~@<Continue, treating ~S on ~S as ~
-                               having been successful.~@:>"
-                              op component))
-                    (setf (gethash (type-of op)
-                                   (component-operation-times component))
-                          (get-universal-time))
-                    (return)))))))))
-
-(defun oos (&rest args)
-  "Alias of OPERATE function"
-  (apply #'operate args))
+                 (loop
+                   (restart-case
+                       (progn (perform op component)
+                              (return))
+                     (retry ()
+                       :report
+                       (lambda (s)
+                         (format s "~@<Retry performing ~S on ~S.~@:>"
+                                 op component)))
+                     (accept ()
+                       :report
+                       (lambda (s)
+                         (format s "~@<Continue, treating ~S on ~S as ~
+                                   having been successful.~@:>"
+                                 op component))
+                       (setf (gethash (type-of op)
+                                      (component-operation-times component))
+                             (get-universal-time))
+                       (return)))))))))
+
+(setf (documentation 'operate 'function)
+      *operate-docstring*)
+
+(defun oos (operation-class system &rest args &key force (verbose t) version)
+  (declare (ignore force verbose version))
+  (apply #'operate operation-class system args))
+
+(setf (documentation 'oos 'function)
+      (format nil
+              "Short for _operate on system_ and an alias for the `operate` function. ~&~&~a"
+              *operate-docstring*))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; syntax
@@ -917,38 +1044,45 @@ system."))
     (aux key arglist)))
 
 (defmacro defsystem (name &body options)
-  (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options
+  (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
+                            &allow-other-keys)
+      options
     (let ((component-options (remove-keyword :class options)))
       `(progn
-        ;; system must be registered before we parse the body, otherwise
-        ;; we recur when trying to find an existing system of the same name
-        ;; to reuse options (e.g. pathname) from
-        (let ((s (system-registered-p ',name)))
-          (cond ((and s (eq (type-of (cdr s)) ',class))
-                 (setf (car s) (get-universal-time)))
-                (s
-                 #+clisp
-                 (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
-                 #-clisp
-                 (change-class (cdr s) ',class))
-                (t
-                 (register-system (quote ,name)
-                                  (make-instance ',class :name ',name)))))
-        (parse-component-form nil (apply
-                                   #'list
-                                   :module (coerce-name ',name)
-                                   :pathname
-                                   (or ,pathname
-                                       (pathname-sans-name+type
-                                        (resolve-symlinks  *load-truename*))
-                                       *default-pathname-defaults*)
-                                   ',component-options))))))
+         ;; system must be registered before we parse the body, otherwise
+         ;; we recur when trying to find an existing system of the same name
+         ;; to reuse options (e.g. pathname) from
+         (let ((s (system-registered-p ',name)))
+           (cond ((and s (eq (type-of (cdr s)) ',class))
+                  (setf (car s) (get-universal-time)))
+                 (s
+                  #+clisp
+                  (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
+                  #-clisp
+                  (change-class (cdr s) ',class))
+                 (t
+                  (register-system (quote ,name)
+                                   (make-instance ',class :name ',name)))))
+         (parse-component-form nil (apply
+                                    #'list
+                                    :module (coerce-name ',name)
+                                    :pathname
+                                    ;; to avoid a note about unreachable code
+                                    ,(if pathname-arg-p
+                                         pathname
+                                         `(or (when *load-truename*
+                                                (pathname-sans-name+type
+                                                 (resolve-symlinks
+                                                  *load-truename*)))
+                                              *default-pathname-defaults*))
+                                    ',component-options))))))
 
 
 (defun class-for-type (parent type)
   (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
                               (find-symbol (symbol-name type)
-                                           #.(package-name *package*))))
+                                           (load-time-value
+                                            (package-name :asdf)))))
          (class (dolist (symbol (if (keywordp type)
                                     extra-symbols
                                     (cons type extra-symbols)))
@@ -997,6 +1131,7 @@ Returns the new tree (which probably shares structure with the old one)"
 (defvar *serial-depends-on*)
 
 (defun parse-component-form (parent options)
+
   (destructuring-bind
         (type name &rest rest &key
               ;; the following list of keywords is reproduced below in the
@@ -1007,14 +1142,15 @@ Returns the new tree (which probably shares structure with the old one)"
               depends-on serial in-order-to
               ;; list ends
               &allow-other-keys) options
+    (declare (ignorable perform explain output-files operation-done-p))
     (check-component-input type name weakly-depends-on depends-on components in-order-to)
 
     (when (and parent
-             (find-component parent name)
-             ;; ignore the same object when rereading the defsystem
-             (not
-              (typep (find-component parent name)
-                     (class-for-type parent type))))
+               (find-component parent name)
+               ;; ignore the same object when rereading the defsystem
+               (not
+                (typep (find-component parent name)
+                       (class-for-type parent type))))
       (error 'duplicate-names :name name))
 
     (let* ((other-args (remove-keys
@@ -1031,8 +1167,7 @@ Returns the new tree (which probably shares structure with the old one)"
       (when (boundp '*serial-depends-on*)
         (setf depends-on
               (concatenate 'list *serial-depends-on* depends-on)))
-      (apply #'reinitialize-instance
-             ret
+      (apply #'reinitialize-instance ret
              :name (coerce-name name)
              :pathname pathname
              :parent parent
@@ -1058,9 +1193,9 @@ Returns the new tree (which probably shares structure with the old one)"
                              name-hash)
                     (error 'duplicate-names
                            :name (component-name c))
-                  (setf (gethash (component-name c)
-                                 name-hash)
-                        t)))))
+                    (setf (gethash (component-name c)
+                                   name-hash)
+                          t)))))
 
       (setf (slot-value ret 'in-order-to)
             (union-of-dependencies
@@ -1069,23 +1204,30 @@ Returns the new tree (which probably shares structure with the old one)"
                (load-op (load-op ,@depends-on))))
             (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
 
-      (loop for (n v) in `((perform ,perform) (explain ,explain)
-                           (output-files ,output-files)
-                           (operation-done-p ,operation-done-p))
-            do (map 'nil
-                    ;; this is inefficient as most of the stored
-                    ;; methods will not be for this particular gf n
-                    ;; But this is hardly performance-critical
-                    (lambda (m) (remove-method (symbol-function n) m))
-                    (component-inline-methods ret))
-            when v
-            do (destructuring-bind (op qual (o c) &body body) v
-                 (pushnew
-                  (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
-                          ,@body))
-                  (component-inline-methods ret))))
+      (%remove-component-inline-methods ret rest)
+
       ret)))
 
+(defun %remove-component-inline-methods (ret rest)
+  (loop for name in +asdf-methods+
+        do (map 'nil
+                ;; this is inefficient as most of the stored
+                ;; methods will not be for this particular gf n
+                ;; But this is hardly performance-critical
+                (lambda (m)
+                  (remove-method (symbol-function name) m))
+                (component-inline-methods ret)))
+  ;; clear methods, then add the new ones
+  (setf (component-inline-methods ret) nil)
+  (loop for name in +asdf-methods+
+        for v = (getf rest (intern (symbol-name name) :keyword))
+        when v do
+        (destructuring-bind (op qual (o c) &body body) v
+          (pushnew
+           (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
+                             ,@body))
+           (component-inline-methods ret)))))
+
 (defun check-component-input (type name weakly-depends-on depends-on components in-order-to)
   "A partial test of the values of a component."
   (when weakly-depends-on (warn "We got one! XXXXX"))
@@ -1100,7 +1242,7 @@ Returns the new tree (which probably shares structure with the old one)"
                             type name components))
   (unless (and (listp in-order-to) (listp (car in-order-to)))
     (sysdef-error-component ":in-order-to must be NIL or a list of components."
-                           type name in-order-to)))
+                            type name in-order-to)))
 
 (defun sysdef-error-component (msg type name value)
   (sysdef-error (concatenate 'string msg
@@ -1148,7 +1290,7 @@ output to *VERBOSE-OUT*.  Returns the shell's exit code."
      :shell-type "/bin/sh"
      :output-stream *verbose-out*)
 
-    #+clisp                             ;XXX not exactly *verbose-out*, I know
+    #+clisp                     ;XXX not exactly *verbose-out*, I know
     (ext:run-shell-command  command :output :terminal :wait t)
 
     #+openmcl
@@ -1163,14 +1305,36 @@ output to *VERBOSE-OUT*.  Returns the shell's exit code."
     (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
     ))
 
-
-(defgeneric hyperdocumentation (package name doc-type))
-(defmethod hyperdocumentation ((package symbol) name doc-type)
-  (hyperdocumentation (find-package package) name doc-type))
-
-(defun hyperdoc (name doc-type)
-  (hyperdocumentation (symbol-package name) name doc-type))
-
+(defgeneric system-source-file (system)
+  (:documentation "Return the source file in which system is defined."))
+
+(defmethod system-source-file ((system-name t))
+  (system-source-file (find-system system-name)))
+
+(defmethod system-source-file ((system system))
+  (let ((pn (and (slot-boundp system 'relative-pathname)
+                 (make-pathname
+                  :type "asd"
+                  :name (asdf:component-name system)
+                  :defaults (asdf:component-relative-pathname system)))))
+    (when pn
+      (probe-file pn))))
+
+(defun system-source-directory (system-name)
+  (make-pathname :name nil
+                 :type nil
+                 :defaults (system-source-file system-name)))
+
+(defun system-relative-pathname (system pathname &key name type)
+  ;; you're not allowed to muck with the return value of pathname-X
+  (let ((directory (copy-list (pathname-directory pathname))))
+    (when (eq (car directory) :absolute)
+      (setf (car directory) :relative))
+    (merge-pathnames
+     (make-pathname :name (or name (pathname-name pathname))
+                    :type (or type (pathname-type pathname))
+                    :directory directory)
+     (system-source-directory system))))
 
 (pushnew :asdf *features*)
 
@@ -1191,7 +1355,7 @@ output to *VERBOSE-OUT*.  Returns the shell's exit code."
 
   (defun contrib-sysdef-search (system)
     (let ((home (sb-ext:posix-getenv "SBCL_HOME")))
-      (when home
+      (when (and home (not (string= home "")))
         (let* ((name (coerce-name system))
                (home (truename home))
                (contrib (merge-pathnames
@@ -1205,7 +1369,7 @@ output to *VERBOSE-OUT*.  Returns the shell's exit code."
 
   (pushnew
    '(let ((home (sb-ext:posix-getenv "SBCL_HOME")))
-      (when home
+      (when (and home (not (string= home "")))
         (merge-pathnames "site-systems/" (truename home))))
    *central-registry*)
 
@@ -1218,4 +1382,3 @@ output to *VERBOSE-OUT*.  Returns the shell's exit code."
   (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
 
 (provide 'asdf)
-