Commit 26714b10 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Tweak ASDF and tests to fix previous commit.

parent 65d72494
Loading
Loading
Loading
Loading
+6 −1
Original line number Diff line number Diff line
@@ -4,7 +4,8 @@
(uiop/package:define-package :asdf/cache
  (:use :uiop/common-lisp :uiop :asdf/upgrade)
  (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
           #:set-asdf-cache-entry #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring
           #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
	   #:do-asdf-cache #:normalize-namestring
           #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*))
(in-package :asdf/cache)

@@ -22,6 +23,10 @@
               (setf (gethash key *asdf-cache*) value-list)
               value-list)))

  (defun unset-asdf-cache-entry (key)
    (when *asdf-cache*
      (remhash key *asdf-cache*)))

  (defun consult-asdf-cache (key &optional thunk)
    (if *asdf-cache*
        (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
+7 −2
Original line number Diff line number Diff line
@@ -3,7 +3,7 @@

(uiop/package:define-package :asdf/find-component
  (:recycle :asdf/find-component :asdf)
  (:use :uiop/common-lisp :uiop :asdf/upgrade
  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache
   :asdf/component :asdf/system :asdf/find-system)
  (:export
   #:find-component
@@ -106,7 +106,12 @@
            (or (null c)
                (and (typep c 'missing-dependency)
                     (eq (missing-required-by c) component)
                     (equal (missing-requires c) name))))))))
                     (equal (missing-requires c) name))))
	  (unless (component-parent component)
	    (let ((name (coerce-name name)))
	      (unset-asdf-cache-entry `(find-system ,name))
	      (unset-asdf-cache-entry `(locate-system ,name))))))))


  (defun resolve-dependency-spec (component dep-spec)
    (let ((component (find-component () component)))
+14 −10
Original line number Diff line number Diff line
@@ -18,7 +18,7 @@
   #:find-system-if-being-defined
   #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
   #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
   #:clear-defined-systems #:*defined-systems*
   #:clear-defined-system #:clear-defined-systems #:*defined-systems*
   #:*immutable-systems*
   ;; defined in source-registry, but specially mentioned here:
   #:initialize-source-registry #:sysdef-source-registry-search))
@@ -89,15 +89,18 @@ of which is a system object.")
                      (get-file-stamp file))
                    system)))))

  (defun clear-defined-system (system)
    (let ((name (coerce-name system)))
      (remhash name *defined-systems*)
      (unset-asdf-cache-entry `(locate-system ,name))
      (unset-asdf-cache-entry `(find-system ,name))
      nil))

  (defun clear-defined-systems ()
    ;; Invalidate all systems but ASDF itself, if registered.
    (let ((asdf (cdr (system-registered-p :asdf))))
      (setf *defined-systems* (make-hash-table :test 'equal))
      (when asdf
        (setf (component-version asdf) *asdf-version*)
        (setf (builtin-system-p asdf) t)
        (register-system asdf)))
    (values))
    (loop :for name :being :the :hash-keys :of *defined-systems*
	  :unless (equal name "asdf")
	    :do (clear-defined-system name)))

  (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)

@@ -256,7 +259,7 @@ Going forward, we recommend new users should be using the source-registry.

  (defun find-system-if-being-defined (name)
    ;; notable side effect: mark the system as being defined, to avoid infinite loops
    (values (gethash `(find-system ,(coerce-name name)) *asdf-cache*)))
    (first (gethash `(find-system ,(coerce-name name)) *asdf-cache*)))

  (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
    ;; Tries to load system definition with canonical NAME from PATHNAME.
@@ -389,7 +392,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
            (multiple-value-bind (foundp found-system pathname previous previous-time)
                (locate-system name)
              (when (and found-system (eq found-system previous)
                         (or (gethash `(find-system ,name) *asdf-cache*)
                         (or (first (gethash `(find-system ,name) *asdf-cache*))
                             (and *immutable-systems* (gethash name *immutable-systems*))))
                (return found-system))
              (assert (eq foundp (and (or found-system pathname previous) t)))
@@ -423,5 +426,6 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
          (reinitialize-source-registry-and-retry ()
            :report (lambda (s)
                      (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
	    (unset-asdf-cache-entry `(locate-system ,name))
            (initialize-source-registry)))))))
+0 −1
Original line number Diff line number Diff line
@@ -23,4 +23,3 @@
         (exe (asdf::output-file 'program-op :hello-world-example))
         (dll-dest (subpathname exe dll-orig)))
    (copy-file dll-orig dll-dest)))
+25 −20
Original line number Diff line number Diff line
@@ -2,7 +2,7 @@

(DBG :foo (current-lisp-file-pathname))

(unless (or #+(or allegro clisp clozure cmu (and ecl (not ecl-bytecmp)) gcl lispworks mkcl sbcl scl) t)
(unless (or #+(or allegro clisp clozure cmu (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl scl) t)
  (DBG "Creating images is not supported on your CL implementation")
  (leave-test "Skipping test" 0))

@@ -38,19 +38,24 @@
 0)
(assert (probe-file* img) () "Can't find image file ~S" img)

(assert-equal (run-program
(assert-equal
 (nest
  #+lispworks (last)
  (run-program
   (symbol-call :lisp-invocation :lisp-invocation-arglist
		:image-path (native-namestring img)
		:eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)")
               :output :lines)
   :output :lines :error-output t))
 '("hello, world"))

(assert-equal (run-program
#-(or lispworks scl) ;; These can't be passed arguments the normal way
(assert-equal
 (run-program
  (symbol-call :lisp-invocation :lisp-invocation-arglist
	       :image-path (native-namestring img)
	       :eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)"
	       :arguments '("a" "b c" "d"))
               :output :lines)
  :output :lines :error-output t)
 '("hello, world"
   "You passed 3 arguments:"
   "  \"a\""
@@ -80,10 +85,10 @@

(assert (probe-file* exe) () "Can't find executable file ~S" exe)

(assert-equal (run-program `(,(native-namestring exe)) :output :lines)
(assert-equal (run-program `(,(native-namestring exe)) :output :lines :error-output t)
              '("hello, world"))

(assert-equal (run-program `(,(native-namestring exe) "a" "b c" "d") :output :lines)
(assert-equal (run-program `(,(native-namestring exe) "a" "b c" "d") :output :lines :error-output t)
              '("hello, world"
                "You passed 3 arguments:"
                "  \"a\""
Loading