Commit 03be449f authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

1.705:

* rename :system-dependencies to :defsystem-depends-on. Beware, controversy.
 janderson suggests we should be using defstruct-like options in the name field.
* reorganize a bit the lisp-version-string, include fasl version for CCL
 (more useful than a PPC-only 64-bit flag that should already be redundant with architecture).
* reinstate the perform-with-restarts method for compile-op removed in 1.661:
 it might seem redundant in nested calls, but it actually isn't.
parent 6df0471a
Loading
Loading
Loading
Loading
+60 −35
Original line number Diff line number Diff line
@@ -63,7 +63,7 @@
        (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car))
  (let* ((asdf-version
          ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
          (subseq "VERSION:1.704" (1+ (length "VERSION"))))
          (subseq "VERSION:1.705" (1+ (length "VERSION"))))
         (existing-asdf (find-package :asdf))
         (versym '#:*asdf-version*)
         (existing-version (and existing-asdf
@@ -1674,8 +1674,8 @@ recursive calls to traverse.")
  (perform operation component))

(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
  (let ((state :initial))
    (loop :until (or (eq state :success)
  (loop :with state = :initial
    :until (or (eq state :success)
               (eq state :failure)) :do
    (case state
      (:recompiled
@@ -1691,7 +1691,27 @@ recursive calls to traverse.")
                            (component-name c))
         (setf state :failed-load)
         (call-next-method)
              (setf state :success)))))))
         (setf state :success))))))

(defmethod perform-with-restarts ((o compile-op) (c cl-source-file))
  (loop :with state = :initial
    :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-with-restarts o 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)
@@ -1873,15 +1893,15 @@ details."

(defmacro defsystem (name &body options)
  (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
                            system-dependencies &allow-other-keys)
                            defsystem-depends-on &allow-other-keys)
      options
    (let ((component-options (remove-keys '(:system-dependencies :class) options)))
    (let ((component-options (remove-keys '(:defsystem-depends-on :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
         ,@(loop for system in system-dependencies
              collect `(asdf:load-system ,system))
         ,@(loop :for system :in defsystem-depends-on
             :collect `(asdf:load-system ,system))
         (let ((s (system-registered-p ',name)))
           (cond ((and s (eq (type-of (cdr s)) ',class))
                  (setf (car s) (get-universal-time)))
@@ -1893,8 +1913,7 @@ details."
           (%set-system-source-file *load-truename*
                                    (cdr (system-registered-p ',name))))
         (parse-component-form
          nil (apply
               #'list
          nil (list*
               :module (coerce-name ',name)
               :pathname
               ,(determine-system-pathname pathname pathname-arg-p)
@@ -2198,15 +2217,6 @@ located."
(defun lisp-version-string ()
  (let ((s (lisp-implementation-version)))
    (declare (ignorable s))
    #+(or scl sbcl ecl armedbear cormanlisp mcl) s
    #+cmu (substitute #\- #\/ s)
    #+clozure (format nil "~d.~d~@[-~d~]"
                      ccl::*openmcl-major-version*
                      ccl::*openmcl-minor-version*
                      #+ppc64-target 64
                      #-ppc64-target nil)
    #+lispworks (format nil "~A~@[~A~]" s
                        (when (member :lispworks-64bit *features*) "-64bit"))
    #+allegro (format nil
                      "~A~A~A~A"
                      excl::*common-lisp-version-number*
@@ -2219,8 +2229,23 @@ located."
                       (:-ics "8")
                       (:+ics ""))
                      (if (member :64bit *features*) "-64bit" ""))
    #+clozure (format nil "~d.~d-fasl~d"
                      ccl::*openmcl-major-version*
                      ccl::*openmcl-minor-version*
                      (logand ccl::fasl-version #xFF))
    #+cmu (substitute #\- #\/ s)
    #+digitool (subseq s 8)
    #+ecl (format nil "~A~@[-~A~]" s
                  (let ((vcs-id (funcall (ext:lisp-implementation-vcs-id))))
                    (when (>= (length vcs-id) 8)
                      (subseq vcs-id 0 8))))
    #+lispworks (format nil "~A~@[~A~]" s
                        (when (member :lispworks-64bit *features*) "-64bit"))
    ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant
    #+(or armedbear cormanlisp mcl sbcl scl) s
    #+(or clisp gcl) (subseq s 0 (position #\space s))
    #+digitool (subseq s 8)))
    #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
          ecl gcl lispworks mcl sbcl scl) s))

(defun first-feature (features)
  (labels