diff --git a/asdf.lisp b/asdf.lisp index c1104e5..c826105 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -745,15 +745,13 @@ to `~a` which is not a directory.~@:>" (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 + (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)) - (make-pathname :directory `(,relative ,@path) :name name :type type))))) + name))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; operations @@ -1637,7 +1635,7 @@ See [implementation-specific-directory-name][] for details.") (defparameter *default-toplevel-directory* (merge-pathnames - (make-pathname :directory '(:relative ".fasls")) + (make-pathname :directory '(:relative ".cache" "common-lisp")) (truename (user-homedir-pathname))) "If \\*centralize-lisp-binaries\\* is true, then compiled lisp files without an explicit mapping \(see \\*source-to-target-mappings\\*\) will be placed in subdirectories of \\*default-toplevel-directory\\*.") @@ -1872,6 +1870,30 @@ applied by the plain `*source-to-target-mappings*`." (setf result (logior result (ash (read-byte s) (* 8 i))))) result)) +(defun parse-file-location-info (s) + (let ((start (file-position s)) + (total-length (read-little-endian s)) + (end-of-header (read-little-endian s)) + (fli-flags (read-little-endian s)) + (local-volume-offset (read-little-endian s)) + (local-offset (read-little-endian s)) + (network-volume-offset (read-little-endian s)) + (remaining-offset (read-little-endian s))) + (declare (ignore total-length end-of-header local-volume-offset)) + (unless (zerop fli-flags) + (cond + ((logbitp 0 fli-flags) + (file-position s (+ start local-offset))) + ((logbitp 1 fli-flags) + (file-position s (+ start + network-volume-offset + #x14)))) + (concatenate 'string + (read-null-terminated-string s) + (progn + (file-position s (+ start remaining-offset)) + (read-null-terminated-string s)))))) + (defun parse-windows-shortcut (pathname) (with-open-file (s pathname :element-type '(unsigned-byte 8)) (handler-case @@ -1902,31 +1924,6 @@ applied by the plain `*source-to-target-mappings*`." (end-of-file () nil)))) -(defun parse-file-location-info (s) - (let ((start (file-position s)) - (total-length (read-little-endian s)) - (end-of-header (read-little-endian s)) - (fli-flags (read-little-endian s)) - (local-volume-offset (read-little-endian s)) - (local-offset (read-little-endian s)) - (network-volume-offset (read-little-endian s)) - (remaining-offset (read-little-endian s))) - (declare (ignore total-length end-of-header local-volume-offset)) - (unless (zerop fli-flags) - (cond - ((logbitp 0 fli-flags) - (file-position s (+ start local-offset))) - ((logbitp 1 fli-flags) - (file-position s (+ start - network-volume-offset - #x14)))) - (concatenate 'string - (read-null-terminated-string s) - (progn - (file-position s (+ start remaining-offset)) - (read-null-terminated-string s)))))) - - (pushnew :asdf *features*) #+sbcl diff --git a/test/script-support.lisp b/test/script-support.lisp index 46540fd..5f5407f 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -30,7 +30,7 @@ (defmacro quit-on-error (&body body) `(handler-case (progn ,@body - (leave-lisp "Script succeeded" 0)) + (leave-lisp "~&Script succeeded~%" 0)) (error (c) (format *error-output* "~a" c) - (leave-lisp "Script failed" 1)))) + (leave-lisp "~&Script failed~%" 1)))) diff --git a/test/test-module-pathnames.asd b/test/test-module-pathnames.asd index b7d3184..c41e36e 100644 --- a/test/test-module-pathnames.asd +++ b/test/test-module-pathnames.asd @@ -7,5 +7,5 @@ :components ((:file "file1") (:file "level2/file2") + (:static-file "level2/static.file") (:static-file "test-tmp.cl"))))) - diff --git a/test/test-module-pathnames.script b/test/test-module-pathnames.script index 68549e3..6783e8e 100644 --- a/test/test-module-pathnames.script +++ b/test/test-module-pathnames.script @@ -1,31 +1,50 @@ ;;; -*- Lisp -*- (load "script-support") (load "../asdf") -(quit-on-error - (setf asdf:*central-registry* '(*default-pathname-defaults*)) - (asdf:operate 'asdf:load-op 'test-module-pathnames)) (quit-on-error + (setf asdf:*central-registry* '(*default-pathname-defaults*)) + (asdf:load-system 'test-module-pathnames) + (flet ((submodule (module name) + (find name (asdf:module-components module) + :key #'asdf:component-name :test #'equal)) + (pathname-foo (x) + (list (pathname-directory x) (pathname-name x) (pathname-type x)))) + (let* ((system (asdf:find-system "test-module-pathnames")) + (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")) + nil + "Didn't get the name of test-tmp.cl right") + (assert (equal + (pathname-foo (asdf:component-relative-pathname static)) + '((:relative "level2") "static" "file")) + nil + "Didn't get the name of static.file right"))) (assert (find-package :test-package) nil "package test-package not found") (assert (find-symbol (symbol-name '*file-tmp*) :test-package) nil "symbol `*file-tmp*` not found") (assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package)) nil "symbol `*file-tmp*` has wrong value") + #| ; must be adapted to ABL (assert (probe-file (merge-pathnames (make-pathname :name "file1" :type (pathname-type (compile-file-pathname "x")) :directory '(:relative "sources" "level1")))) nil "compiled file not found") - + |# (assert (find-symbol (symbol-name '*file-tmp2*) :test-package) nil "symbol `*file-tmp2*` not found") (assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package)) nil "symbol `*file-tmp2*` has wrong value") + #| needs be adapted to ABL (assert (probe-file (merge-pathnames (make-pathname :name "file2" :type (pathname-type (compile-file-pathname "x")) :directory '(:relative "sources" "level1" "level2")))) - nil "compiled file not found")) + nil "compiled file not found")|#)