Commit 450f759f authored by Robert Goldman's avatar Robert Goldman

Fix for issue #34.

Jingtao Xu discovered that package-inferred-system's could not handle
files with different extensions, because the "lisp" extension was
hard-coded into the system search function for

This commit fixes that issue and adds a test.  Thanks to Jingtao Xu
for the fix.
parent 00d8461e
......@@ -6,6 +6,9 @@ cl-asdf (2:3.3.5-1) unstable; urgency=low IN PROGRESS
* A number of fixes for Lispworks compatibility (thanks to Martin
* Fixes for SBCL from Eric Timmons.
* Add support for source files with different file extensions to
package-inferred-systems. Thanks to Jingtao Xu for identifying
the bug and providing a fix.
cl-asdf (2:3.3.4-1) unstable; urgency=low
Bug fix release:
......@@ -125,28 +125,40 @@ otherwise return a default system name computed from PACKAGE-NAME."
(equal (slot-value child 'relative-pathname) subpath))))))))
;; sysdef search function to push into *system-definition-search-functions*
(defun sysdef-package-inferred-system-search (system)
(let ((primary (primary-system-name system)))
(unless (equal primary system)
(defun sysdef-package-inferred-system-search (system-name)
"Takes SYSTEM-NAME and returns an initialized SYSTEM object, or NIL. Made to be added to
(let ((primary (primary-system-name system-name)))
;; this function ONLY does something if the primary system name is NOT the same as
;; SYSTEM-NAME. It is used to find the systems with names that are relative to
;; the primary system's name, and that are not explicitly specified in the system
;; definition
(unless (equal primary system-name)
(let ((top (find-system primary nil)))
(when (typep top 'package-inferred-system)
(if-let (dir (component-pathname top))
(let* ((sub (subseq system (1+ (length primary))))
(f (probe-file* (subpathname dir sub :type "lisp")
(let* ((sub (subseq system-name (1+ (length primary))))
(component-type (class-for-type
(or (module-default-component-class top)
(file-type (file-type (make-instance component-type)))
(f (probe-file* (subpathname dir sub :type file-type)
:truename *resolve-symlinks*)))
(when (file-pathname-p f)
(let ((dependencies (package-inferred-system-file-dependencies f system))
(previous (registered-system system))
(let ((dependencies (package-inferred-system-file-dependencies f system-name))
(previous (registered-system system-name))
(around-compile (around-compile-hook top)))
(if (same-package-inferred-system-p previous system dir sub around-compile dependencies)
(if (same-package-inferred-system-p previous system-name dir sub around-compile dependencies)
(eval `(defsystem ,system
(eval `(defsystem ,system-name
:class package-inferred-system
:default-component-class ,component-type
:source-file ,(system-source-file top)
:pathname ,dir
:depends-on ,dependencies
:around-compile ,around-compile
:components ((cl-source-file "lisp" :pathname ,sub)))))))))))))))
:components ((,component-type file-type :pathname ,sub)))))))))))))))
(with-upgradability ()
(pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*)
(defsystem package-inferred-system-test-2
:class :package-inferred-system
:depends-on ("package-inferred-system-test-2/utilities")
(defpackage package-inferred-system-test-2/utilities
(:use :cl))
;; -*- mode: common-lisp -*-
(register-directory (subpathname *test-directory* "package-inferred-extension-test/"))
(assert (load-system "package-inferred-system-test-2"))
(assert (find-package* '#:package-inferred-system-test-2/utilities))
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