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

Refactoring: introduce the function REGISTERED-SYSTEM

Introduce the function REGISTERED-SYSTEM to abstract over finding a registered
system by name, without having to take the CDR of the pair with timestamp.

Also, add or improve docstrings for several functions.

This refactoring should not modify any semantics,
except for introducing this new function.
parent 08d59a6d
No related branches found
No related tags found
No related merge requests found
...@@ -9,7 +9,8 @@ ...@@ -9,7 +9,8 @@
#:remove-entry-from-registry #:coerce-entry-to-directory #:remove-entry-from-registry #:coerce-entry-to-directory
#:coerce-name #:primary-system-name #:coerce-filename #:coerce-name #:primary-system-name #:coerce-filename
#:find-system #:locate-system #:load-asd #:find-system #:locate-system #:load-asd
#:system-registered-p #:register-system #:registered-systems* #:registered-systems #:system-registered-p #:registered-system #:register-system
#:registered-systems* #:registered-systems
#:clear-system #:map-systems #:clear-system #:map-systems
#:missing-component #:missing-requires #:missing-parent #:missing-component #:missing-requires #:missing-parent
#:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error
...@@ -51,18 +52,26 @@ ...@@ -51,18 +52,26 @@
format :format-arguments arguments)) format :format-arguments arguments))
(defun coerce-name (name) (defun coerce-name (name)
"Given a designator for a component NAME, return the name as a string.
The designator can be a COMPONENT (designing its name; note that a SYSTEM is a component),
a SYMBOL (designing its name, downcased), or a STRING (designing itself)."
(typecase name (typecase name
(component (component-name name)) (component (component-name name))
(symbol (string-downcase (symbol-name name))) (symbol (string-downcase name))
(string name) (string name)
(t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name)))) (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
(defun primary-system-name (name) (defun primary-system-name (name)
;; When a system name has slashes, the file with defsystem is named by "Given a system designator NAME, return the name of the corresponding primary system,
;; the first of the slash-separated components. after which the .asd file is named. That's the first component when dividing the name
as a string by / slashes."
(first (split-string (coerce-name name) :separator "/"))) (first (split-string (coerce-name name) :separator "/")))
(defun coerce-filename (name) (defun coerce-filename (name)
"Coerce a system designator NAME into a string suitable as a filename component.
The (current) transformation is to replace characters /:\\ each by --,
the former being forbidden in a filename component.
NB: The onus is unhappily on the user to avoid clashes."
(frob-substrings (coerce-name name) '("/" ":" "\\") "--")) (frob-substrings (coerce-name name) '("/" ":" "\\") "--"))
(defvar *defined-systems* (make-hash-table :test 'equal) (defvar *defined-systems* (make-hash-table :test 'equal)
...@@ -73,24 +82,35 @@ system definition was last updated, and the second element ...@@ -73,24 +82,35 @@ system definition was last updated, and the second element
of which is a system object.") of which is a system object.")
(defun system-registered-p (name) (defun system-registered-p (name)
"Return a generalized boolean that is true if a system of given NAME was registered already.
NAME is a system designator, to be normalized by COERCE-NAME.
The value returned if true is a pair of a timestamp and a system object."
(gethash (coerce-name name) *defined-systems*)) (gethash (coerce-name name) *defined-systems*))
(defun registered-system (name)
"Return a system of given NAME was registered already.
NAME is a system designator, to be normalized by COERCE-NAME.
The value returned is a system object, or NIL if not found."
(cdr (system-registered-p name)))
(defun registered-systems* () (defun registered-systems* ()
"Return a list containing every registered system (as a system object)."
(loop :for registered :being :the :hash-values :of *defined-systems* (loop :for registered :being :the :hash-values :of *defined-systems*
:collect (cdr registered))) :collect (cdr registered)))
(defun registered-systems () (defun registered-systems ()
"Return a list of the names of every registered system."
(mapcar 'coerce-name (registered-systems*))) (mapcar 'coerce-name (registered-systems*)))
(defun register-system (system) (defun register-system (system)
"Given a SYSTEM object, register it."
(check-type system system) (check-type system system)
(let ((name (component-name system))) (let ((name (component-name system)))
(check-type name string) (check-type name string)
(asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
(unless (eq system (cdr (gethash name *defined-systems*))) (unless (eq system (registered-system name))
(setf (gethash name *defined-systems*) (setf (gethash name *defined-systems*)
(cons (if-let (file (ignore-errors (system-source-file system))) (cons (ignore-errors (get-file-stamp (system-source-file system)))
(get-file-stamp file))
system))))) system)))))
(defvar *preloaded-systems* (make-hash-table :test 'equal)) (defvar *preloaded-systems* (make-hash-table :test 'equal))
...@@ -126,7 +146,7 @@ downgrade, before you dump an image, use: ...@@ -126,7 +146,7 @@ downgrade, before you dump an image, use:
(defun sysdef-immutable-system-search (requested) (defun sysdef-immutable-system-search (requested)
(let ((name (coerce-name requested))) (let ((name (coerce-name requested)))
(when (and *immutable-systems* (gethash name *immutable-systems*)) (when (and *immutable-systems* (gethash name *immutable-systems*))
(or (cdr (system-registered-p requested)) (or (registered-system requested)
(sysdef-preloaded-system-search name) (sysdef-preloaded-system-search name)
(error 'formatted-system-definition-error (error 'formatted-system-definition-error
:format-control "Requested system ~A is in the *immutable-systems* set, ~ :format-control "Requested system ~A is in the *immutable-systems* set, ~
...@@ -135,7 +155,7 @@ but not loaded in memory" ...@@ -135,7 +155,7 @@ but not loaded in memory"
(defun register-immutable-system (system-name &key (version t)) (defun register-immutable-system (system-name &key (version t))
(let* ((system-name (coerce-name system-name)) (let* ((system-name (coerce-name system-name))
(registered-system (cdr (system-registered-p system-name))) (registered-system (registered-system system-name))
(default-version? (eql version t)) (default-version? (eql version t))
(version (cond ((and default-version? registered-system) (version (cond ((and default-version? registered-system)
(component-version registered-system)) (component-version registered-system))
...@@ -414,7 +434,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -414,7 +434,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(unless (equal name primary-name) (unless (equal name primary-name)
(find-system primary-name nil))) (find-system primary-name nil)))
(or (and *immutable-systems* (gethash name *immutable-systems*) (or (and *immutable-systems* (gethash name *immutable-systems*)
(or (cdr (system-registered-p name)) (or (registered-system name)
(sysdef-preloaded-system-search name))) (sysdef-preloaded-system-search name)))
(multiple-value-bind (foundp found-system pathname previous previous-time) (multiple-value-bind (foundp found-system pathname previous previous-time)
(locate-system name) (locate-system name)
......
...@@ -165,7 +165,8 @@ to load it in current image." ...@@ -165,7 +165,8 @@ to load it in current image."
;; only tries to load its specified target if it's not loaded yet. ;; only tries to load its specified target if it's not loaded yet.
(with-upgradability () (with-upgradability ()
(defun component-loaded-p (component) (defun component-loaded-p (component)
"has given COMPONENT been successfully loaded in the current image (yet)?" "Has given COMPONENT been successfully loaded in the current image (yet)?
Note that this returns true even if the component is not up to date."
(action-already-done-p nil (make-instance 'load-op) (find-component component ()))) (action-already-done-p nil (make-instance 'load-op) (find-component component ())))
(defun already-loaded-systems () (defun already-loaded-systems ()
......
...@@ -118,7 +118,7 @@ otherwise return a default system name computed from PACKAGE-NAME." ...@@ -118,7 +118,7 @@ otherwise return a default system name computed from PACKAGE-NAME."
:truename *resolve-symlinks*))) :truename *resolve-symlinks*)))
(when (file-pathname-p f) (when (file-pathname-p f)
(let ((dependencies (package-inferred-system-file-dependencies f system)) (let ((dependencies (package-inferred-system-file-dependencies f system))
(previous (cdr (system-registered-p system))) (previous (registered-system system))
(around-compile (around-compile-hook top))) (around-compile (around-compile-hook top)))
(if (same-package-inferred-system-p previous system dir sub around-compile dependencies) (if (same-package-inferred-system-p previous system dir sub around-compile dependencies)
previous previous
......
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