diff --git a/asdf.lisp b/asdf.lisp index fcdef3c24eb01f86989d480c63dd3a58953d95f9..9475935ffc5b67e08360dbc1a56f69d045d68d88 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -763,32 +763,20 @@ to `~a` which is not a directory.~@:>" (defmethod source-file-type ((c html-file) (s module)) "html") (defmethod source-file-type ((c static-file) (s module)) nil) -#+(or) -(defmethod component-relative-pathname ((component source-file)) - (multiple-value-bind (relative path name) - (split-path-string (component-name component)) - (let ((type (source-file-type component (component-system component))) - (relative-pathname (slot-value component 'relative-pathname)) - (*default-pathname-defaults* (component-parent-pathname component))) - (if relative-pathname - (merge-pathnames - relative-pathname - (if type - (make-pathname :name name :type type) - name)) - (make-pathname :directory `(,relative ,@path) :name name :type type))))) - +(defun merge-component-relative-pathname (pathname name type) + (multiple-value-bind (relative path filename) + (split-path-string name) + (merge-pathnames + (or pathname (make-pathname :directory `(,relative ,@path))) + (if type + (make-pathname :name filename :type type) + filename)))) (defmethod component-relative-pathname ((component source-file)) - (multiple-value-bind (relative path name) - (split-path-string (component-name component)) - (let ((type (source-file-type component (component-system component))) - (relative-pathname (slot-value component 'relative-pathname))) - (merge-pathnames - (or relative-pathname (make-pathname :directory `(,relative ,@path))) - (if type - (make-pathname :name name :type type) - name))))) + (merge-component-relative-pathname + (slot-value component 'relative-pathname) + (component-name component) + (source-file-type component (component-system component)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; operations diff --git a/test/script-support.lisp b/test/script-support.lisp index 5f5407f43402ca35e5168e9e606fd66fada04608..b82b3dab127e14e206694d16b30756a421f6bc4e 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -3,6 +3,9 @@ #+allegro (setf excl:*warn-on-nested-reader-conditionals* nil) +#+common-lisp-controller +(setf common-lisp-controller:*redirect-fasl-files-to-cache* nil) + ;;; code adapted from cl-launch (any errors in transcription are mine!) ;; http://www.cliki.net/cl-launch (defun leave-lisp (message return) diff --git a/test/test-module-pathnames.script b/test/test-module-pathnames.script index 10383b25dbd545215a0589a3dd274a0e4b0c9b96..dcdd1fd99f748d50c498a96103d94f86fbae07d0 100644 --- a/test/test-module-pathnames.script +++ b/test/test-module-pathnames.script @@ -14,8 +14,9 @@ (level1 (submodule system "sources/level1")) (static (submodule level1 "level2/static.file")) (test-tmp (submodule level1 "test-tmp.cl"))) - (assert (equal (pathname-foo (asdf:component-relative-pathname test-tmp)) - '((:relative) "test-tmp" "cl")) + (assert (member (pathname-foo (asdf:component-relative-pathname test-tmp)) + '(((:relative) "test-tmp" "cl") + (nil "test-tmp" "cl")) :test 'equal) nil "Didn't get the name of test-tmp.cl right") (assert (equal diff --git a/test/test-retry-loading-component-1.script b/test/test-retry-loading-component-1.script index 995ef442c9684d9639e5d23f9ebdd00ee0310efa..6f2aff23cdb97afdb6759e9b8f879f4e43f5ec55 100644 --- a/test/test-retry-loading-component-1.script +++ b/test/test-retry-loading-component-1.script @@ -25,6 +25,7 @@ (assert (eq mode :external) nil "Mode of ~s was not external" name) (let ((restart (find-restart name c))) (assert restart) + (format t "~&restart: ~S~&" restart) (when restart (invoke-restart restart))))))) (asdf:oos 'asdf:load-op 'try-reloading-1)) (assert *caught-error*)