diff --git a/bundle.lisp b/bundle.lisp index a3023417931e69892e6b141099598e45e17e7ed3..5bcf1933e14c64903861f7dd1f5e7450844c2a6b 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -249,7 +249,7 @@ for all the linkable object files associated with the system or its dependencies "--all-systems" ;; These use a different type .fasb or .a instead of .fasl #-(or clasp ecl mkcl) "--system")))) - (format nil "~A~@[~A~]" (component-name c) suffix)))) + (format nil "~A~@[~A~]" (coerce-filename (component-name c)) suffix)))) (type (bundle-pathname-type bundle-type))) (values (list (subpathname (component-pathname c) name :type type)) (eq (class-of o) (coerce-class (component-build-operation c) @@ -420,14 +420,23 @@ or of opaque libraries shipped along the source code.")) ;;; (with-upgradability () (defmethod output-files ((o deliver-asd-op) (s system)) - (list (make-pathname :name (component-name s) :type "asd" + (list (make-pathname :name (coerce-filename (component-name s)) :type "asd" :defaults (component-pathname s)))) + ;; because of name collisions between the output files of different + ;; subclasses of DELIVER-ASD-OP, we cannot trust the file system to + ;; tell us if the output file is up-to-date, so just treat the + ;; operation as never being done. + (defmethod operation-done-p ((o deliver-asd-op) (s system)) + (declare (ignorable o s)) + nil) + (defmethod perform ((o deliver-asd-op) (s system)) + "Write an ASDF system definition for loading S as a delivered system." (let* ((inputs (input-files o s)) (fasl (first inputs)) (library (second inputs)) - (asd (first (output-files o s))) + (asd (output-file o s)) (name (if (and fasl asd) (pathname-name asd) (return-from perform))) (version (component-version s)) (dependencies @@ -439,7 +448,7 @@ or of opaque libraries shipped along the source code.")) :keep-operation 'basic-load-op)) (while-collecting (x) ;; resolve the sideway-dependencies of s (map-direct-dependencies - 'load-op s + 'prepare-op s #'(lambda (o c) (when (and (typep o 'load-op) (typep c 'system)) (x c))))))) @@ -474,7 +483,7 @@ which is probably not what you want; you probably need to tweak your output tran (let* ((input-files (input-files o c)) (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp)) (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp)) - (output-files (output-files o c)) + (output-files (output-files o c)) ; can't use OUTPUT-FILE fn because possibility it's NIL (output-file (first output-files))) (assert (eq (not input-files) (not output-files))) (when input-files diff --git a/test/deliver-bundle.asd b/test/deliver-bundle.asd new file mode 100644 index 0000000000000000000000000000000000000000..aed0ee15ecd96dfec8950079bec59fd9c8d73af1 --- /dev/null +++ b/test/deliver-bundle.asd @@ -0,0 +1,10 @@ +;;;--------------------------------------------------------------------------- +;;; This system is to be used to test the generation of ASD files by +;;; DELIVER-ASD-OP. See test-bundle-asd.script. +;;;--------------------------------------------------------------------------- + + +(defsystem :deliver-bundle + :defsystem-depends-on ("file3-only") + :depends-on ("test-asdf/bundle-2") + :components ((:file "file4"))) diff --git a/test/test-asdf.asd b/test/test-asdf.asd index 43561eeaae6f9f6812a7ff2e9ab0c622d84f71ea..355d9ab2704236ab00ac43c5eb6df71d83997d22 100644 --- a/test/test-asdf.asd +++ b/test/test-asdf.asd @@ -108,4 +108,3 @@ :version "0" :depends-on (:test-asdf/all) :components ((:file "properly-upgraded"))) - diff --git a/test/test-bundle-asd.script b/test/test-bundle-asd.script new file mode 100644 index 0000000000000000000000000000000000000000..767b0a3e32e0b70aa7577e1ee79f29b987df99e7 --- /dev/null +++ b/test/test-bundle-asd.script @@ -0,0 +1,76 @@ +;;; -*- Lisp -*- +(in-package :asdf-test) +(use-package :asdf) + +;;;--------------------------------------------------------------------------- +;;; Test for GitLab issue 23 +;;;--------------------------------------------------------------------------- + +(defparameter *test-system-name* "deliver-bundle") + +(asdf:initialize-source-registry '(:source-registry + (:directory :here) + :ignore-inherited-configuration)) +(asdf:clear-system *test-system-name*) + + +(defparameter *constructed-asdf-file* + (output-file (make-operation 'deliver-asd-op) + (find-system *test-system-name*))) + +(ignore-errors (delete-file *constructed-asdf-file*)) + +(DBG "Writing ASD system definition file:" *constructed-asdf-file*) + +(operate 'deliver-asd-op *test-system-name*) + +(defun load-constructed-asd-file (&optional (constructed-file *constructed-asdf-file*)) + (with-open-file (str constructed-file) + (let* ((sexps + (uiop:with-safe-io-syntax (:package :asdf-user) + (uiop:read-file-forms str)))) + (or (find-if #'(lambda (x) (and (listp x) (eq (car x) 'defsystem))) sexps) + (error "Unable to find generated defsystem."))))) + +(defparameter *defsystem-sexpr* + (load-constructed-asd-file)) + +(DBG "ASDF-created system definition is:") +(DBG (format nil "~s" *defsystem-sexpr*)) + +(assert (equalp (second *defsystem-sexpr*) *test-system-name*)) +(assert (eq (getf *defsystem-sexpr* :class) 'asdf/bundle:prebuilt-system)) +(assert (equalp (getf *defsystem-sexpr* :components) + #-(or clasp ecl mkcl) + `((:compiled-file ,(format nil "~a--system" *test-system-name*))) + #+(or clasp ecl mkcl) + '((:COMPILED-FILE "deliver-bundle")))) +#+(and (or clasp ecl mkcl) linux) +(assert (equalp (getf *defsystem-sexpr* :lib) + "deliver-bundle.a")) +(assert (not (getf *defsystem-sexpr* :defsystem-depends-on))) +(assert (equalp (getf *defsystem-sexpr* :depends-on) (list "test-asdf/bundle-2")) + nil "Dependencies for bundled system are incorrect.") + +(ignore-errors (delete-file *constructed-asdf-file*)) + +(operate 'monolithic-deliver-asd-op *test-system-name*) + +(setf *defsystem-sexpr* + (load-constructed-asd-file)) + +(DBG "ASDF-created MONOLITHIC system definition is:") +(DBG (format nil "~s" *defsystem-sexpr*)) + +(assert (equalp (second *defsystem-sexpr*) *test-system-name*)) +(assert (eq (getf *defsystem-sexpr* :class) 'asdf/bundle:prebuilt-system)) +(assert (equalp (getf *defsystem-sexpr* :components) + #-(or clasp ecl mkcl) + `((:compiled-file ,(format nil "~a--all-systems" *test-system-name*))) + #+ (or clasp ecl mkcl) + '((:COMPILED-FILE "deliver-bundle--all-systems")))) +#+(and (or clasp ecl mkcl) linux) +(assert (equalp (getf *defsystem-sexpr* :lib) + "deliver-bundle--all-systems.a")) +(assert (not (getf *defsystem-sexpr* :defsystem-depends-on))) +(assert (not (getf *defsystem-sexpr* :depends-on))) diff --git a/uiop/configuration.lisp b/uiop/configuration.lisp index a14f8de8728aa9284ed4d3cece0e4dd968963e8f..9d3a5282cb30fff42fc102917bfabc539c955ad9 100644 --- a/uiop/configuration.lisp +++ b/uiop/configuration.lisp @@ -203,7 +203,7 @@ directive.") (if wilden (wilden p) p)))) ((eql :home) (user-homedir-pathname)) ((eql :here) (resolve-absolute-location - (or *here-directory* (pathname-directory-pathname (load-pathname))) + (or *here-directory* (pathname-directory-pathname (truename (load-pathname)))) :ensure-directory t :wilden nil)) ((eql :user-cache) (resolve-absolute-location *user-cache* :ensure-directory t :wilden nil))) diff --git a/uiop/lisp-build.lisp b/uiop/lisp-build.lisp index 9f4f6700a102deabafd3d458ffa167d23039e856..61bc30277e3b2bc0dcb7340c082a36f661c31013 100644 --- a/uiop/lisp-build.lisp +++ b/uiop/lisp-build.lisp @@ -626,7 +626,8 @@ possibly in a different process. Otherwise just call THUNK." (or *compile-file-pathname* *load-pathname*)) (defun load-pathname () - "Portably return the LOAD-PATHNAME of the current source file or fasl" + "Portably return the LOAD-PATHNAME of the current source file or fasl. + May return a relative pathname." *load-pathname*) ;; magic no longer needed for GCL. (defun lispize-pathname (input-file) diff --git a/uiop/stream.lisp b/uiop/stream.lisp index eae37685283a8719267b05184de53d623f83be35..a7fa2669d9c726bd4ca8b3d414f3446ed7205d18 100644 --- a/uiop/stream.lisp +++ b/uiop/stream.lisp @@ -462,6 +462,8 @@ BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" (defun read-file-forms (file &rest keys &key count &allow-other-keys) "Open input FILE with option KEYS (except COUNT), and read its contents as per SLURP-STREAM-FORMS with given COUNT. +If COUNT is null, read to the end of the stream; +if COUNT is an integer, stop after COUNT forms were read. BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" (apply 'call-with-input-file file #'(lambda (input) (slurp-stream-forms input :count count))