diff --git a/interface.lisp b/interface.lisp index d654ae91ba7f69e8eb26d381d04039367088befc..f14aea899c0504f31ef5e802d7aa9558f0bb8304 100644 --- a/interface.lisp +++ b/interface.lisp @@ -124,7 +124,7 @@ #:missing-dependency #:missing-dependency-of-version #:circular-dependency ; errors - #:duplicate-names #:non-toplevel-system #:non-system-system + #:duplicate-names #:non-toplevel-system #:non-system-system #:bad-system-name #:package-inferred-system-missing-package-error #:operation-definition-warning #:operation-definition-error diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index b952635c846f9699cec956fb90c833bb96f982c1..a4ae8e7140b412256e3764b334c18ff28426e11c 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -12,7 +12,7 @@ #:defsystem #:register-system-definition #:class-for-type #:*default-component-class* #:determine-system-directory #:parse-component-form - #:non-toplevel-system #:non-system-system + #:non-toplevel-system #:non-system-system #:bad-system-name #:sysdef-error-component #:check-component-input)) (in-package :asdf/parse-defsystem) @@ -73,6 +73,17 @@ (format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>") (non-toplevel-system-parent c) (non-toplevel-system-name c))))) + (define-condition bad-system-name (warning) + ((name :initarg :name :reader component-name) + (source-file :initarg :source-file :reader system-source-file)) + (:report (lambda (c s) + (let* ((file (system-source-file c)) + (name (component-name c)) + (asd (pathname-name file))) + (format s (compatfmt "~@<System definition file ~S contains definition for system ~S. ~ +Please only define ~S and secondary systems with a name starting with ~S (e.g. ~S) in that file.~@:>") + file name asd (strcat asd "/") (strcat asd "/test")))))) + (defun sysdef-error-component (msg type name value) (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) type name value)) @@ -276,45 +287,49 @@ system names contained using COERCE-NAME. Return the result." ;; To avoid infinite recursion in cases where you defsystem a system ;; that is registered to a different location to find-system, ;; we also need to remember it in the asdf-cache. - (with-asdf-cache () - (let* ((name (coerce-name name)) - (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))) - ;; NB: handle defsystem-depends-on BEFORE to create the system object, - ;; so that in case it fails, there is no incomplete object polluting the build. - (checked-defsystem-depends-on - (let* ((dep-forms (parse-dependency-defs defsystem-depends-on)) - (deps (loop :for spec :in dep-forms - :when (resolve-dependency-spec nil spec) - :collect :it))) - (load-systems* deps) - dep-forms)) - (registered (system-registered-p name)) - (registered! (if registered - (rplaca registered (get-file-stamp source-file)) - (register-system - (make-instance 'system :name name :source-file source-file)))) - (system (reset-system (cdr registered!) - :name name :source-file source-file)) - (component-options - (append - (remove-plist-keys '(:defsystem-depends-on :class) options) - ;; cache defsystem-depends-on in canonical form - (when checked-defsystem-depends-on - `(:defsystem-depends-on ,checked-defsystem-depends-on))))) - ;; This works hand in hand with asdf/find-system:find-system-if-being-defined: - (set-asdf-cache-entry `(find-system ,name) (list system)) - ;; We change-class AFTER we loaded the defsystem-depends-on - ;; since the class might be defined as part of those. - (let ((class (class-for-type nil class))) - (unless (subtypep class 'system) - (error 'non-system-system :name name :class-name (class-name class))) - (unless (eq (type-of system) class) - (change-class system class))) - (parse-component-form - nil (list* - :module name - :pathname (determine-system-directory pathname) - component-options))))) + (nest + (with-asdf-cache ()) + (let* ((name (coerce-name name)) + (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))) + (asd-name (and source-file + (equalp "asd" (pathname-type source-file)) + (pathname-name source-file))) + (primary-name (primary-system-name name))) + (when (and asd-name (not (equal asd-name primary-name))) + (warn (make-condition 'bad-system-name :source-file source-file :name name)))) + (let* (;; NB: handle defsystem-depends-on BEFORE to create the system object, + ;; so that in case it fails, there is no incomplete object polluting the build. + (checked-defsystem-depends-on + (let* ((dep-forms (parse-dependency-defs defsystem-depends-on)) + (deps (loop :for spec :in dep-forms + :when (resolve-dependency-spec nil spec) + :collect :it))) + (load-systems* deps) + dep-forms)) + (registered (system-registered-p name)) + (registered! (if registered + (rplaca registered (get-file-stamp source-file)) + (register-system + (make-instance 'system :name name :source-file source-file)))) + (system (reset-system (cdr registered!) + :name name :source-file source-file)) + (component-options + (append + (remove-plist-keys '(:defsystem-depends-on :class) options) + ;; cache defsystem-depends-on in canonical form + (when checked-defsystem-depends-on + `(:defsystem-depends-on ,checked-defsystem-depends-on)))) + (directory (determine-system-directory pathname))) + ;; This works hand in hand with asdf/find-system:find-system-if-being-defined: + (set-asdf-cache-entry `(find-system ,name) (list system))) + ;; We change-class AFTER we loaded the defsystem-depends-on + ;; since the class might be defined as part of those. + (let ((class (class-for-type nil class))) + (unless (subtypep class 'system) + (error 'non-system-system :name name :class-name (class-name class))) + (unless (eq (type-of system) class) + (change-class system class))) + (parse-component-form nil (list* :module name :pathname directory component-options)))) (defmacro defsystem (name &body options) `(apply 'register-system-definition ',name ',options))) diff --git a/test/test-mutual-redefinition.script b/test/test-mutual-redefinition.script index 52e4422e10692776d0c0413160d00aad3b55a34d..426525fbb3a6be32150756266e94d8731bf0e514 100644 --- a/test/test-mutual-redefinition.script +++ b/test/test-mutual-redefinition.script @@ -1,11 +1,17 @@ ;;-*- Lisp -*- -(load-system 'test-mutual-redefinition-1) (defun current-system-source-file (x) (system-source-file (asdf::registered-system x))) (with-asdf-cache () (DBG "loading test-mutual-redefinition-1") + (let ((warned-p nil)) + (handler-bind ((bad-system-name (lambda (c) + (assert-equal (component-name c) "test-mutual-redefinition-2") + (assert-equal (pathname-name (system-source-file c)) "test-mutual-redefinition-1") + (setf warned-p t)))) + (load-system 'test-mutual-redefinition-1)) + (assert warned-p)) (assert-pathname-equal (test-source "test-mutual-redefinition-1.asd") (current-system-source-file "test-mutual-redefinition-1")) diff --git a/test/test-touch-system-1.script b/test/test-touch-system-1.script index 831d442b072950197cafbda3f20ba690d551c316..b9a63c3e895e9ae4a9485650428a19a2baf01d2f 100644 --- a/test/test-touch-system-1.script +++ b/test/test-touch-system-1.script @@ -30,7 +30,7 @@ (sleep 1) (clear-system :test1) -(touch-file test1.asd) +(touch-file test1.asd :offset 600) (find-system :test1) (defparameter date6 (system-registered-time :test1)) (assert-compare (> date6 date4))