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
......@@ -9,7 +9,8 @@
#:remove-entry-from-registry #:coerce-entry-to-directory
#:coerce-name #:primary-system-name #:coerce-filename
#: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
#:missing-component #:missing-requires #:missing-parent
#:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error
......@@ -51,18 +52,26 @@
format :format-arguments arguments))
(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
(component (component-name name))
(symbol (string-downcase (symbol-name name)))
(symbol (string-downcase name))
(string name)
(t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
(defun primary-system-name (name)
;; When a system name has slashes, the file with defsystem is named by
;; the first of the slash-separated components.
"Given a system designator NAME, return the name of the corresponding primary system,
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 "/")))
(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) '("/" ":" "\\") "--"))
(defvar *defined-systems* (make-hash-table :test 'equal)
......@@ -73,24 +82,35 @@ system definition was last updated, and the second element
of which is a system object.")
(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*))
(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* ()
"Return a list containing every registered system (as a system object)."
(loop :for registered :being :the :hash-values :of *defined-systems*
:collect (cdr registered)))
(defun registered-systems ()
"Return a list of the names of every registered system."
(mapcar 'coerce-name (registered-systems*)))
(defun register-system (system)
"Given a SYSTEM object, register it."
(check-type system system)
(let ((name (component-name system)))
(check-type name string)
(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*)
(cons (if-let (file (ignore-errors (system-source-file system)))
(get-file-stamp file))
(cons (ignore-errors (get-file-stamp (system-source-file system)))
(defvar *preloaded-systems* (make-hash-table :test 'equal))
......@@ -126,7 +146,7 @@ downgrade, before you dump an image, use:
(defun sysdef-immutable-system-search (requested)
(let ((name (coerce-name requested)))
(when (and *immutable-systems* (gethash name *immutable-systems*))
(or (cdr (system-registered-p requested))
(or (registered-system requested)
(sysdef-preloaded-system-search name)
(error 'formatted-system-definition-error
:format-control "Requested system ~A is in the *immutable-systems* set, ~
......@@ -135,7 +155,7 @@ but not loaded in memory"
(defun register-immutable-system (system-name &key (version t))
(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))
(version (cond ((and default-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.
(unless (equal name primary-name)
(find-system primary-name nil)))
(or (and *immutable-systems* (gethash name *immutable-systems*)
(or (cdr (system-registered-p name))
(or (registered-system name)
(sysdef-preloaded-system-search name)))
(multiple-value-bind (foundp found-system pathname previous previous-time)
(locate-system name)
......@@ -165,7 +165,8 @@ to load it in current image."
;; only tries to load its specified target if it's not loaded yet.
(with-upgradability ()
(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 ())))
(defun already-loaded-systems ()
......@@ -118,7 +118,7 @@ otherwise return a default system name computed from PACKAGE-NAME."
:truename *resolve-symlinks*)))
(when (file-pathname-p f)
(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)))
(if (same-package-inferred-system-p previous system dir sub around-compile dependencies)
  • could you not rush it? I have another idea in the backlog which doesn't introduce a new function, but I don't want to start another debacle in parallel.

    In essence:

    * find-system-if-being-definded
    may miss a defined system if the cache is cleared. I think we should
    use =(cdr (system-registered-p name))= instead of calling
    =*asdf-cache*=. As a bonus, we'll be able to remove with-asdf-cache
    around the locate-system.
    * search-for-system-definition
    // NB search-for-system-definition can't be considered as preserving
    referential transparency, because it calls
    =*system-definition-search-functions*= and we can't tell whenever they
    have side-effects.
    That will require changing the order of functions used in
    =search-for-system-definition= (=find-system-if-being-defined= should
    go last?) The function will look something like this:
    #+BEGIN_SRC lisp
      (defun search-for-system-definition (system)
        (let ((name (coerce-name system)))
          (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x))))
            (try (lambda (name) (first (consult-asdf-cache `(find-system ,name)))))
            (try 'sysdef-immutable-system-search)
            (map () #'try *system-definition-search-functions*)
            (try 'find-system-if-being-defined))))
    =find system-if-being-defined= was previously in the first place. Also
    =find-system-if-being-defined= includes results
    =sysdef-preloaded-system-search= since the last changes where
    preloaded systems are normal, defined systems, so we can remove that
    This function has to be the *last* in the list, because otherwise we
    would always have the same system here, and that's definetely not what
    we want to have. We definetely want to consult the cache here.
    Edited by Daniel Kochmański
  • I think it's a bug, that find-system-if-being-defined doesn't find a defined system if it's not in the cache, even if it's registered. I've tried to see, if we exploit this misbehaviour and indeed we do, hence the change to search-for-function-definition.

  • that said I didn't put much thought into it yet and I would prefer to focus on !13 (closed)

  • @frideau am I right about find-system-if-being-defined purpose?

  • Great improvement in attitude: asking a question!

    I believe you might be confused about fsibd: its purpose is explicitly to find systems being defined in the current asdf session (as embodied by its cache). It MUST NOT find systems defined before the session was started.

  • I'll improve the comments for this function: everything you get wrong is a bug on my part for not documenting the code enough.

  • I don't see improvement in refraining from personal remarks on the other hand.

    Yes, that's why it should search in defined-systems, which contains systems defined in the current asdf session (cache may be cleared). Cache is meant for speeding up things and resolving circular dependencies, while defined systems are in *defined-systems* hash table (which is accessed indirectly by registered-system, and system-registered-p).

  • 1- A system being defined is not defined yet.

    2- No, the cache is meant for correctness, not just for speed: it imposes a coherent view of the world by any given ASDF session, when multiple filesystem dependent queries might yield inconsistencies that could cause incorrect behavior, infinite loops, etc.

  • As for*defined-systems*, it contains all systems registered, even in previous sessions. (The name is from ASDF 1; I would have called it *registered-systems*.

  • Cache may miss preloaded systems, which are defined systems. I'm not sure if I understand a difference, but could you verify that your assertion, that if the system isn't found in the cache means, that it's not defined? Or if treating *defined-systems* as name suggest won't break the system? Interface inflation would be undesirable, if after all find-system-if-defined can fulfill this very purpose

  • The entire purpose of search-for-system-definition is to NOT CONSULT *defined-systems* but to look for definitions outside of it.

  • (equal "if-being-defined" "if-defined") ===> NIL

  • what does being mean then in that context? If being means

    (consult-asdf-cache `(find-system ,name))

    then it's hard to justify creating a function if its used only in one place. OK, I understand that checking defined systems isn't wanted in search-for-system-definition, then it could look like

      (defun search-for-system-definition (system)
        (let ((name (coerce-name system)))
          (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x))))
            (try (lambda (name) (first (consult-asdf-cache `(find-system ,name)))))
            (try 'sysdef-immutable-system-search)
            (map () #'try *system-definition-search-functions*))
            (try 'sysdef-preloaded-system-search)))

    but again, if you are completely sure, that if-being-defined doesn't look for a defined system, but cached one, then OK. I would double check for a sake of not extending interface unnecessarily. I've elaborated my doubts here, I probably won't have much to add to this (non)issue.

  • Isn't there progressive present in Polish? That'd be interesting. There is in English.

    Being defined == the definition is in progress in the current session. Started but not completed yet. In particular, the system hasn't been registered; and/or its registration could conceivably be undone, if not for search-for-system-definition treating this case specially.

    Can you believe that I actually wrote that code for a reason? You can even look in the git logs what explanation I gave for introducing it, and read the bug report on launchpad.

  • There is progressive in Polish, my English isn't perfect though. Was there a reason to introduce a new function just for one place in the code?

  • Abstraction. The details of how parse-defsystem communicates with fsibd may evolve in the future.

    And now, thanks to you, documentation. See

Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment