Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Jan Moringen
asdf
Commits
64862fff
Commit
64862fff
authored
Nov 18, 2016
by
Francois-Rene Rideau
Browse files
Issue a bad-system-name WARNING for badly-named secondary systems.
parent
ec88be65
Changes
3
Hide whitespace changes
Inline
Side-by-side
interface.lisp
View file @
64862fff
...
...
@@ -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
...
...
parse-defsystem.lisp
View file @
64862fff
...
...
@@ -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
)))
test/test-mutual-redefinition.script
View file @
64862fff
;;-*- 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"))
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment