From 01d921aeb0620df029f5a6c23d41fbfa04f6db91 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Wed, 16 Nov 2016 08:59:48 -0500 Subject: [PATCH] Introduce primary-system-p Tweak primary-system-name to extract a component's system's primary-name. primary-system-p recognizes only systems (not random component) and strings that name them. --- find-system.lisp | 4 +--- system.lisp | 18 ++++++++++++++---- 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/find-system.lisp b/find-system.lisp index 8203a30c4..7b56b083c 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 d2d7cfb94..94f71a05c 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. -- GitLab