Commit f3af2006 authored by Robert Goldman's avatar Robert Goldman

Quash some BAD-SYSTEM-NAME warnings.

I'm sick of Stas's social engineering attempt to stoke anger about
this warning, so I'm specifically quashing warnings from "cl-ppcre."
parent 903419f4
...@@ -17,6 +17,7 @@ ...@@ -17,6 +17,7 @@
#: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 #:bad-system-name #:non-toplevel-system #:non-system-system #:bad-system-name
#:*known-name-exception-systems*
#:sysdef-error-component #:check-component-input #:sysdef-error-component #:check-component-input
#:explain)) #:explain))
(in-package :asdf/parse-defsystem) (in-package :asdf/parse-defsystem)
...@@ -344,6 +345,8 @@ system names contained using COERCE-NAME. Return the result." ...@@ -344,6 +345,8 @@ system names contained using COERCE-NAME. Return the result."
(coerce-name (component-system component)))) (coerce-name (component-system component))))
component))) component)))
(defparameter* *known-name-exception-systems* '("cl-ppcre"))
(defun register-system-definition (defun register-system-definition
(name &rest options &key pathname (class 'system) (source-file () sfp) (name &rest options &key pathname (class 'system) (source-file () sfp)
defsystem-depends-on &allow-other-keys) defsystem-depends-on &allow-other-keys)
...@@ -357,12 +360,21 @@ system names contained using COERCE-NAME. Return the result." ...@@ -357,12 +360,21 @@ system names contained using COERCE-NAME. Return the result."
(with-asdf-session ()) (with-asdf-session ())
(let* ((name (coerce-name name)) (let* ((name (coerce-name name))
(source-file (if sfp source-file (resolve-symlinks* (load-pathname)))))) (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))))
(flet ((fix-case (x) (if (logical-pathname-p source-file) (string-downcase x) x)))) (flet ((fix-case (x) (if (logical-pathname-p source-file) (string-downcase x) x))
(known-exception (name)
;; is NAME a known exception that should be screened out
;; of checking for BAD-SYSTEM-NAME?
(member-if #'(lambda (x) (uiop:string-prefix-p x name))
*known-name-exception-systems*))))
(let* ((asd-name (and source-file (let* ((asd-name (and source-file
(equal "asd" (fix-case (pathname-type source-file))) (equal "asd" (fix-case (pathname-type source-file)))
(fix-case (pathname-name source-file)))) (fix-case (pathname-name source-file))))
;; note that PRIMARY-NAME is a *syntactically* primary name --
;; so "cl-ppcre-test" (grrr.....) is a PRIMARY-NAME.
(primary-name (primary-system-name name))) (primary-name (primary-system-name name)))
(when (and asd-name (not (equal asd-name primary-name))) (when (and asd-name
(not (equal asd-name primary-name))
(not (known-exception primary-name)))
(warn (make-condition 'bad-system-name :source-file source-file :name 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, (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. ;; so that in case it fails, there is no incomplete object polluting the build.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment