diff --git a/find-system.lisp b/find-system.lisp index 8203a30c4f2df27e5734d6c8f31990498ba60b31..7b56b083c3cb25acbaed13ccabcb05a8e0610334 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -256,9 +256,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (map () 'mark-component-preloaded (component-children component)) ;; Mark the timestamps of the common lisp-action operations as 0. (let ((times (component-operation-times component))) - (dolist (o `(,@(when (and (typep component 'system) - (equal (coerce-name component) (primary-system-name component))) - '(define-op)) + (dolist (o `(,@(when (primary-system-p component) '(define-op)) prepare-op compile-op load-op)) (setf (gethash (make-operation o) times) 0)))))) diff --git a/system.lisp b/system.lisp index d2d7cfb94af682d4c5db7615de5e8f7f0112d0e6..94f71a05c6b6619f40a6aaa96f57ad85cdb81914 100644 --- a/system.lisp +++ b/system.lisp @@ -18,7 +18,7 @@ #:mailto #:system-mailto #:long-name #:system-long-name #:source-control #:system-source-control - #:coerce-name #:primary-system-name #:coerce-filename + #:coerce-name #:primary-system-name #:primary-system-p #:coerce-filename #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system (in-package :asdf/system) @@ -123,11 +123,21 @@ a SYMBOL (designing its name, downcased), or a STRING (designing itself)." (string name) (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name)))) - (defun primary-system-name (name) + (defun primary-system-name (system-designator) "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 "/"))) +as a string by / slashes. A component designates its system." + (etypecase system-designator + (string (if-let (p (position #\/ system-designator)) + (subseq system-designator 0 p) system-designator)) + (component (primary-system-name (coerce-name (component-system system-designator)))))) + + (defun primary-system-p (system) + "Given a system designator SYSTEM, return T if it designates a primary system, or else NIL. +Also return NIL if system is neither a SYSTEM nor a string designating one." + (typecase system + (string (not (find #\/ system))) + (system (primary-system-p (coerce-name system))))) (defun coerce-filename (name) "Coerce a system designator NAME into a string suitable as a filename component.