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