Commit d1a0cebb authored by Robert Goldman's avatar Robert Goldman

Merge branch 'iss23' into 'master'

Iss23

See merge request !132
parents a65c4cd3 c213e319
......@@ -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
......
;;;---------------------------------------------------------------------------
;;; 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")))
......@@ -108,4 +108,3 @@
:version "0"
:depends-on (:test-asdf/all)
:components ((:file "properly-upgraded")))
;;; -*- 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)))
......@@ -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)))
......
......@@ -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)
......
......@@ -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))
......
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