Skip to content
Snippets Groups Projects
Commit c713e0a0 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Remove loop and restart-case from find-system;

the functionality was moved to call-with-asdf-cache before where it belongs.
parent 00256418
No related branches found
No related tags found
No related merge requests found
...@@ -359,68 +359,65 @@ either associated with FOUND-SYSTEM, or with the PREVIOUS system. ...@@ -359,68 +359,65 @@ either associated with FOUND-SYSTEM, or with the PREVIOUS system.
PREVIOUS when not null is a previously loaded SYSTEM object of same name. PREVIOUS when not null is a previously loaded SYSTEM object of same name.
PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
(let* ((name (coerce-name name)) (let* ((name (coerce-name name))
(in-memory (system-registered-p name)) ; load from disk if absent or newer on disk (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
(previous (cdr in-memory)) (previous (cdr in-memory))
(previous (and (typep previous 'system) previous)) (previous (and (typep previous 'system) previous))
(previous-time (car in-memory)) (previous-time (car in-memory))
(found (search-for-system-definition name)) (found (search-for-system-definition name))
(found-system (and (typep found 'system) found)) (found-system (and (typep found 'system) found))
(pathname (ensure-pathname (pathname (ensure-pathname
(or (and (typep found '(or pathname string)) (pathname found)) (or (and (typep found '(or pathname string)) (pathname found))
(and found-system (system-source-file found-system)) (and found-system (system-source-file found-system))
(and previous (system-source-file previous))) (and previous (system-source-file previous)))
:want-absolute t :resolve-symlinks *resolve-symlinks*)) :want-absolute t :resolve-symlinks *resolve-symlinks*))
(foundp (and (or found-system pathname previous) t))) (foundp (and (or found-system pathname previous) t)))
(check-type found (or null pathname system)) (check-type found (or null pathname system))
(unless (check-not-old-asdf-system name pathname) (unless (check-not-old-asdf-system name pathname)
(cond (cond
(previous (setf found nil pathname nil)) (previous (setf found nil pathname nil))
(t (t
(setf found (sysdef-preloaded-system-search "asdf")) (setf found (sysdef-preloaded-system-search "asdf"))
(assert (typep found 'system)) (assert (typep found 'system))
(setf found-system found pathname nil)))) (setf found-system found pathname nil))))
(values foundp found-system pathname previous previous-time))) (values foundp found-system pathname previous previous-time)))
(defmethod find-system ((name string) &optional (error-p t)) (defmethod find-system ((name string) &optional (error-p t))
(with-asdf-cache (:key `(find-system ,name)) (with-asdf-cache (:key `(find-system ,name))
(let ((primary-name (primary-system-name name))) (let ((primary-name (primary-system-name name)))
(unless (equal name primary-name) (unless (equal name primary-name)
(find-system primary-name nil))) (find-system primary-name nil)))
(loop (if-let (x (and *immutable-systems* (gethash name *immutable-systems*)
(restart-case (cdr (system-registered-p name))))
(multiple-value-bind (foundp found-system pathname previous previous-time) x
(locate-system name) (multiple-value-bind (foundp found-system pathname previous previous-time)
(when (and found-system (eq found-system previous) (locate-system name)
(or (first (gethash `(find-system ,name) *asdf-cache*)) (assert (eq foundp (and (or found-system pathname previous) t)))
(and *immutable-systems* (gethash name *immutable-systems*)))) (let ((previous-pathname (and previous (system-source-file previous)))
(return found-system)) (system (or previous found-system)))
(assert (eq foundp (and (or found-system pathname previous) t))) (when (and found-system (not previous))
(let ((previous-pathname (and previous (system-source-file previous))) (register-system found-system))
(system (or previous found-system))) (when (and system pathname)
(when (and found-system (not previous)) (setf (system-source-file system) pathname))
(register-system found-system)) (when (and pathname
(when (and system pathname) (let ((stamp (get-file-stamp pathname)))
(setf (system-source-file system) pathname)) (and stamp
(when (and pathname (not (and previous
(let ((stamp (get-file-stamp pathname))) (or (pathname-equal pathname previous-pathname)
(and stamp (and pathname previous-pathname
(not (and previous (pathname-equal
(or (pathname-equal pathname previous-pathname) (physicalize-pathname pathname)
(and pathname previous-pathname (physicalize-pathname previous-pathname))))
(pathname-equal (stamp<= stamp previous-time))))))
(physicalize-pathname pathname) ;; only load when it's a pathname that is different or has newer content, and not an old asdf
(physicalize-pathname previous-pathname)))) (load-asd pathname :name name)))
(stamp<= stamp previous-time)))))) (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
;; only load when it's a pathname that is different or has newer content, and not an old asdf (cond
(load-asd pathname :name name))) (in-memory
(let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed (when pathname
(return (setf (car in-memory) (get-file-stamp pathname)))
(cond (cdr in-memory))
(in-memory (error-p
(when pathname (error 'missing-component :requires name))
(setf (car in-memory) (get-file-stamp pathname))) (t ;; not found: don't keep negative cache, see lp#1335323
(cdr in-memory)) (unset-asdf-cache-entry `(locate-system ,name))
(error-p (return-from find-system nil)))))))))
(error 'missing-component :requires name))
(t
(return-from find-system nil)))))))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment