Commit 7c151aab authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.26.62: split into many packages, quick-build style.

TODO: Create a define-package that can make it upgrade itself.
parent 610ca233
# really this is private to my build process
# Temporary files from documentation build
......@@ -53,4 +54,4 @@ debian/files
\ No newline at end of file
......@@ -43,7 +43,7 @@ archive:
--eval "(rewrite-license)" --eval "(quit)"
archive-copy: archive
archive-copy: archive tmp/asdf.lisp
git checkout release
bin/rsync-cp tmp/asdf*.tar.gz $(webhome_private)/archives
bin/link-tarball $(clnet_home)
......@@ -51,6 +51,10 @@ archive-copy: archive
${MAKE} push
git checkout master
tmp/asdf.lisp: $(wildcard *.lisp)
mkdir -p tmp
cat header.lisp package.lisp implementation.lisp utility.lisp upgrade.lisp pathname.lisp os.lisp component.lisp system.lisp find-system.lisp find-component.lisp lisp-build.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp configuration.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp user.lisp footer.lisp > $@
git status
git push --tags release master
......@@ -139,8 +143,8 @@ test-upgrade:
{ echo "upgrade FAILED" ; exit 1 ;} ;; esac ; \
done ; done 2>&1 | tee tmp/results/${lisp}-upgrade.text
${SBCL} --noinform --no-userinit --no-sysinit --load asdf.lisp --load test/script-support.lisp --eval '(asdf-test::exit-lisp 0)' 2>&1 | cmp - /dev/null
test-forward-references: tmp/asdf.lisp
${SBCL} --noinform --no-userinit --no-sysinit --load tmp/asdf.lisp --load test/script-support.lisp --eval '(asdf-test::exit-lisp 0)' 2>&1 | cmp - /dev/null
@cd test; ${MAKE} clean;./ ${lisp} ${test-glob}
......@@ -173,13 +177,13 @@ debian-package: mrproper
# Replace SBCL's ASDF with the current one. -- Not recommended now that SBCL has ASDF2.
# for casual users, just use (asdf:load-system :asdf)
${SBCL} --eval '(compile-file "asdf.lisp" :output-file (format nil "~Aasdf/asdf.fasl" (sb-int:sbcl-homedir-pathname)))' --eval '(quit)'
replace-sbcl-asdf: tmp/asdf.lisp
${SBCL} --eval '(compile-file "$<" :output-file (format nil "~Aasdf/asdf.fasl" (sb-int:sbcl-homedir-pathname)))' --eval '(quit)'
# Replace CCL's ASDF with the current one. -- Not recommended now that CCL has ASDF2.
# for casual users, just use (asdf:load-system :asdf)
${CCL} --eval '(progn(compile-file "asdf.lisp" :output-file (compile-file-pathname (format nil "~Atools/asdf.lisp" (ccl::ccl-directory))))(quit))'
replace-ccl-asdf: tmp/asdf.lisp
${CCL} --eval '(progn(compile-file "$<" :output-file (compile-file-pathname (format nil "~Atools/asdf.lisp" (ccl::ccl-directory))))(quit))'
# Delete wrongful tags from local repository
;;;; -------------------------------------------------------------------------
;;;; Actions
(defpackage :asdf/action
(:use :common-lisp :asdf/implementation :asdf/utility :asdf/pathname :asdf/os
:asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation)
#+gcl<2.7 (:shadowing-import-from :asdf/implementation #:type-of)
#:explain #:operation-description
#:downward-operation #:upward-operation
#:source-file #:c-source-file #:java-source-file
#:static-file #:doc-file #:html-file
#:operation-error #:error-component #:error-operation
#:component-depends-on #:component-self-dependencies
#:input-files #:output-files #:output-file #:operation-done-p
#:action-status #:action-stamp #:action-done-p
#:component-operation-time #:mark-operation-done #:compute-action-stamp
#:perform #:perform-with-restarts #:retry #:accept))
(in-package :asdf/action)
(deftype action () '(cons operation component)) ;; a step to be performed while building the system
;;;; self-description
(defgeneric* operation-description (operation component) ;; ASDF3: rename to action-description
(:documentation "returns a phrase that describes performing this operation
on this component, e.g. \"loading /a/b/c\".
You can put together sentences using this phrase."))
(defmethod operation-description (operation component)
(format nil (compatfmt "~@<~A on ~A~@:>")
(class-of operation) component))
(defgeneric* explain (operation component))
(defmethod explain ((o operation) (c component))
(asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (operation-description o c)))
;;;; Error
(define-condition operation-error (error) ;; Bad, backward-compatible name
;; We want to rename it to action-error, but that breaks upgrade on SBCL.
;; Before to rename it, fix these other culprits, too:
;; cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
((component :reader error-component :initarg :component)
(operation :reader error-operation :initarg :operation))
(:report (lambda (c s)
(format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
(type-of c) (error-operation c) (error-component c)))))
;;;; Dependencies
(defgeneric* component-depends-on (operation component) ;; ASDF3: rename to component-dependencies
"Returns a list of dependencies needed by the component to perform
the operation. A dependency has one of the following forms:
(<operation> <component>*), where <operation> is a class
designator and each <component> is a component
designator, which means that the component depends on
<operation> having been performed on each <component>; or
(FEATURE <feature>), which means that the component depends
on <feature>'s presence in *FEATURES*.
Methods specialized on subclasses of existing component types
should usually append the results of CALL-NEXT-METHOD to the
(defgeneric* component-self-dependencies (operation component))
(defmethod component-depends-on ((o operation) (c component))
(cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies
(defmethod component-self-dependencies ((o operation) (c component))
(loop :for (o-spec . c-spec) :in (component-depends-on o c)
:unless (eq o-spec 'feature) ;; avoid the FEATURE "feature"
:when (find c c-spec :key #'(lambda (dep) (resolve-dependency-spec c dep)))
:collect (cons (find-operation o o-spec) c)))
;;;; upward-operation, downward-operation
;; These together handle actions that propagate along the component hierarchy.
;; Downward operations like load-op or compile-op propagate down the hierarchy:
;; operation on a parent depends-on operation on its children.
(defclass downward-operation (operation) ())
;; Upward operations like prepare-op propagate up the component hierarchy:
;; operation on a child depends-on operation on its parent.
(defclass upward-operation (operation) ())
(defmethod component-depends-on ((o downward-operation) (c parent-component))
`((,o ,@(component-children c)) ,@(call-next-method)))
;; For backward-compatibility reasons, a system inherits from module and is a child-component
;; so we must guard against this case. ASDF3: remove that.
(defmethod component-depends-on ((o upward-operation) (c child-component))
`(,@(aif (component-parent c) `((,o ,it))) ,@(call-next-method)))
;;;; Inputs, Outputs, and invisible dependencies
(defgeneric* output-files (operation component))
(defgeneric* input-files (operation component))
(defgeneric* operation-done-p (operation component)
(:documentation "Returns a boolean, which is NIL if the action is forced to be performed again"))
(defmethod operation-done-p ((o operation) (c component))
(declare (ignorable o c))
(defmethod output-files ((o operation) (c component))
(declare (ignorable o c))
(defun* output-file (operation component)
"The unique output file of performing OPERATION on COMPONENT"
(let ((files (output-files operation component)))
(assert (length=n-p files 1))
(first files)))
(defmethod input-files ((o operation) (c parent-component))
(declare (ignorable o c))
;;;; File components
(defclass file-component (child-component)
((type :accessor file-type :initarg :type))) ; no default
(defclass source-file (file-component)
((type :initform nil))) ;; NB: many systems have come to rely on this default.
(defclass c-source-file (source-file)
((type :initform "c")))
(defclass java-source-file (source-file)
((type :initform "java")))
(defclass static-file (source-file)
((type :initform nil)))
(defclass doc-file (static-file) ())
(defclass html-file (doc-file)
((type :initform "html")))
(defmethod input-files ((o operation) (c file-component))
(or (loop :for (dep-o) :in (component-self-dependencies o c)
:append (or (output-files dep-o c) (input-files dep-o c)))
;; no non-trivial previous operations needed?
;; I guess we work with the original source file, then
(list (component-pathname c))))
(defmethod source-file-type ((component parent-component) system) ; not just for source-file. ASDF3: rename.
(declare (ignorable component system))
(defmethod source-file-type ((component file-component) system)
(declare (ignorable system))
(file-type component))
;;;; Done performing
(defgeneric* component-operation-time (operation component)) ;; ASDF3: hide it behind plan-action-stamp
(defgeneric* mark-operation-done (operation component)) ;; ASDF3: hide it behind (setf plan-action-stamp)
(defgeneric* compute-action-stamp (plan operation component &key just-done)
(:documentation "Has this action been successfully done already,
and at what known timestamp has it been done at or will it be done at?
Takes two keywords JUST-DONE and PLAN:
JUST-DONE is a boolean that is true if the action was just successfully performed,
at which point we want compute the actual stamp and warn if files are missing;
otherwise we are making plans, anticipating the effects of the action.
PLAN is a plan object modelling future effects of actions,
or NIL to denote what actually happened.
Returns two values:
* a STAMP saying when it was done or will be done,
or T if the action has involves files that need to be recomputed.
* a boolean DONE-P that indicates whether the action has actually been done,
and both its output-files and its in-image side-effects are up to date."))
(defclass action-status ()
:initarg :stamp :reader action-stamp
:documentation "STAMP associated with the ACTION if it has been completed already
in some previous image, or T if it needs to be done.")
:initarg :done-p :reader action-done-p
:documentation "a boolean, true iff the action was already done (before any planned action)."))
(:documentation "Status of an action"))
(defmethod print-object ((status action-status) stream)
(print-unreadable-object (status stream :type t)
(with-slots (stamp done-p) status
(format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p))))
(defmethod component-operation-time ((o operation) (c component))
(gethash (type-of o) (component-operation-times c)))
(defmethod mark-operation-done ((o operation) (c component))
(setf (gethash (type-of o) (component-operation-times c))
(compute-action-stamp nil o c :just-done t)))
;;;; Perform
(defgeneric* perform-with-restarts (operation component))
(defgeneric* perform (operation component))
(defmethod perform :before ((o operation) (c component))
(ensure-all-directories-exist (output-files o c)))
(defmethod perform :after ((o operation) (c component))
(mark-operation-done o c))
(defmethod perform ((o operation) (c parent-component))
(declare (ignorable o c))
(defmethod perform ((o operation) (c source-file))
(compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
(class-of o) (class-of c)))
(defmethod perform-with-restarts (operation component)
;; TOO verbose, especially as the default. Add your own :before method
;; to perform-with-restart or perform if you want that:
#|(when *asdf-verbose* (explain operation component))|#
(perform operation component))
(defmethod perform-with-restarts :around (operation component)
(return (call-next-method))
(retry ()
(lambda (s)
(format s (compatfmt "~@<Retry ~A.~@:>")
(operation-description operation component))))
(accept ()
(lambda (s)
(format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
(operation-description operation component)))
(mark-operation-done operation component)
......@@ -14,7 +14,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.61" ;; to be automatically updated by bin/bump-revision
:version "2.26.62" ;; to be automatically updated by bin/bump-revision
:depends-on ()
((:file "asdf")))
This diff is collapsed.
;;;; -------------------------------------------------------------------------
;;; Backward-compatible interfaces
(defpackage :asdf/backward-interface
(:use :common-lisp :asdf/implementation :asdf/utility :asdf/pathname :asdf/os
:asdf/component :asdf/system :asdf/operation :asdf/action
:asdf/lisp-build :asdf/operate :asdf/output-translations)
(in-package :asdf/backward-interface)
(defvar *asdf-verbose* nil) ; worked around by cl-protobufs. It was a mistake to introduce it. mea culpa -fare
(defun* component-load-dependencies (component)
;; Old deprecated name for the same thing. Please update your software.
(component-sibling-dependencies component))
(defun* merge-component-name-type (name &key type defaults)
;; For backward-compatibility only, for people using internals.
;; Will be removed in a future release, e.g. 2.016.
(coerce-pathname name :type type :defaults defaults))
(defgeneric* operation-forced (operation)) ;; Used by swank.asd for swank-loader.
(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
(defgeneric* operation-on-warnings (operation))
(defgeneric* operation-on-failure (operation))
#-gcl<2.7 (defgeneric* (setf operation-on-warnings) (x operation))
#-gcl<2.7 (defgeneric* (setf operation-on-failure) (x operation))
(defmethod operation-on-warnings ((o operation))
(declare (ignorable o)) *compile-file-warnings-behaviour*)
(defmethod operation-on-failure ((o operation))
(declare (ignorable o)) *compile-file-failure-behaviour*)
(defmethod (setf operation-on-warnings) (x (o operation))
(declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
(defmethod (setf operation-on-failure) (x (o operation))
(declare (ignorable o)) (setf *compile-file-failure-behaviour* x))
(defun* system-definition-pathname (x)
;; As of 2.014.8, we mean to make this function obsolete,
;; but that won't happen until all clients have been updated.
;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
It used to expose ASDF internals with subtle differences with respect to
user expectations, that have been refactored away since.
We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
for a mostly compatible replacement that we're supporting,
if that's whay you mean." ;;)
(system-source-file x))
;;;; ASDF-Binary-Locations compatibility
(defun* enable-asdf-binary-locations-compatibility
(centralize-lisp-binaries nil)
(subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
(include-per-user-information nil)
(map-all-source-files (or #+(or clisp ecl mkcl) t nil))
(source-to-target-mappings nil))
#+(or clisp ecl mkcl)
(when (null map-all-source-files)
(error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
(let* ((fasl-type (fasl-type))
(mapped-files (if map-all-source-files *wild-file*
(make-pathname :type fasl-type :defaults *wild-file*)))
(if centralize-lisp-binaries
,@(when include-per-user-information
(cdr (pathname-directory (user-homedir))))
:implementation ,*wild-inferiors*)
`(:root ,*wild-inferiors* :implementation))))
#+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
#+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
((:root ,*wild-inferiors* ,mapped-files)
(,@destination-directory ,mapped-files))
(t t)
(defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
(declare (ignorable operation-class system args))
(when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
(error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
In case you insist on preserving your previous A-B-L configuration, but
do not know how to achieve the same effect with A-O-T, you may use function
call that function where you would otherwise have loaded and configured A-B-L.")))
;;;; run-shell-command
;; run-shell-command functions for other lisp implementations will be
;; gratefully accepted, if they do the same thing.
;; If the docstring is ambiguous, send a bug report.
;; WARNING! The function below is mostly dysfunctional.
;; For instance, it will probably run fine on most implementations on Unix,
;; which will hopefully use the shell /bin/sh (which we force in some cases)
;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell.
;; But behavior on Windows may vary wildly between implementations,
;; either relying on your having installed a POSIX sh, or going through
;; the CMD.EXE interpreter, for a totally different meaning, depending on
;; what is easily expressible in said implementation.
;; We probably should move this functionality to its own system and deprecate
;; use of it from the asdf package. However, this would break unspecified
;; existing software, so until a clear alternative exists, we can't deprecate
;; it, and even after it's been deprecated, we will support it for a few
;; years so everyone has time to migrate away from it. -- fare 2009-12-01
;; As a suggested replacement which is portable to all ASDF-supported
;; implementations and operating systems except Genera, I recommend
;; xcvb-driver's xcvb-driver:run-program/ and its derivatives.
(defun* run-shell-command (control-string &rest args)
"Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell, with
output to *VERBOSE-OUT*. Returns the shell's exit code."
(let ((command (apply 'format nil control-string args)))
(asdf-message "; $ ~A~%" command)
(ext:run-shell-command command :output *verbose-out*)
;; will this fail if command has embedded quotes - it seems to work
(multiple-value-bind (stdout stderr exit-code)
#-mswindows (vector "/bin/sh" "/bin/sh" "-c" command)
#+mswindows command ; BEWARE!
:input nil :whole nil
#+mswindows :show-window #+mswindows :hide)
(asdf-message "~{~&~a~%~}~%" stderr)
(asdf-message "~{~&~a~%~}~%" stdout)
;; CLISP returns NIL for exit status zero.
(if *verbose-out*
(let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r"
(outstream (ext:run-shell-command new-command :output :stream :wait t)))
(multiple-value-bind (retval out-lines)
(parse-clisp-shell-output outstream)
(ignore-errors (close outstream)))
(asdf-message "~{~&~a~%~}~%" out-lines)
;; there will be no output, just grab up the exit status
(or (ext:run-shell-command command :output nil :wait t) 0))
(nth-value 1
((os-unix-p) "/bin/sh")
((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
(t (error "Unsupported OS")))
(if (os-unix-p) (list "-c" command) '())
:input nil :output *verbose-out* :wait t)))
#+(or cmu scl)
(list "-c" command)
:input nil :output *verbose-out*))
(win32:system command)
#+ecl ;; courtesy of Juan Jose Garcia Ripoll
(ext:system command)
(lisp:system command)
(apply 'system:call-system-showing-output command
:show-cmd nil :prefix "" :output-stream *verbose-out*
(when (os-unix-p) '(:shell-type "/bin/sh")))
(ccl::with-cstrs ((%command command)) (_system %command))
;; This has next to no chance of working on basic Windows!
;; Your best hope is that Cygwin or MSYS is somewhere in the PATH.
(multiple-value-bind (io process exit-code)
(apply #'mkcl:run-program #+windows "sh" #-windows "/bin/sh"
(list "-c" command)
:input nil :output t #|*verbose-out*|# ;; will be *verbose-out* when we support it
#-windows '(:search nil))
(declare (ignore io process))
(apply 'sb-ext:run-program
#+win32 "sh" #-win32 "/bin/sh"
(list "-c" command)
:input nil :output *verbose-out*
#+win32 '(:search t) #-win32 nil))
(ext:run-shell-command command)
#-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl mkcl sbcl scl xcl)
(error "RUN-SHELL-COMMAND not implemented for this Lisp")))
(defun* parse-clisp-shell-output (stream)
"Helper function for running shell commands under clisp. Parses a specially-
crafted output string to recover the exit status of the shell command and a
list of lines of output."
(loop :with status-prefix = "ASDF-EXIT-STATUS "
:with prefix-length = (length status-prefix)
:with exit-status = -1 :with lines = ()
:for line = (read-line stream nil nil)
:while line :do (push line lines) :finally
(let* ((last (car lines))
(status (and last (>= (length last) prefix-length)
(string-equal last status-prefix :end1 prefix-length)
(parse-integer last :start prefix-length :junk-allowed t))))
(when status
(setf exit-status status)
(pop lines) (when (equal "" (car lines)) (pop lines)))
(return (values exit-status (reverse lines))))))
;;;; -------------------------------------------------------------------------
;;; Internal hacks for backward-compatibility
(defpackage :asdf/backward-internals
(:use :common-lisp :asdf/implementation :asdf/utility :asdf/pathname
:asdf/system :asdf/component :asdf/find-system :asdf/action)
(:export ;; for internal use
(in-package :asdf/backward-internals)
;;;; Backward compatibility with "inline methods"
(defparameter +asdf-methods+
'(perform-with-restarts perform explain output-files operation-done-p))
(defun* %remove-component-inline-methods (component)
(dolist (name +asdf-methods+)
(map ()
;; this is inefficient as most of the stored
;; methods will not be for this particular gf
;; But this is hardly performance-critical
#'(lambda (m)
(remove-method (symbol-function name) m))
(component-inline-methods component)))
;; clear methods, then add the new ones
(component-inline-methods component) nil)
(defun* %define-component-inline-methods (ret rest)
(dolist (name +asdf-methods+)
(let ((keyword (intern (symbol-name name) :keyword)))
(loop :for data = rest :then (cddr data)
:for key = (first data)
:for value = (second data)
:while data
:when (eq key keyword) :do
(destructuring-bind (op qual (o c) &body body) value
(eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
(component-inline-methods ret)))))))
(defun* %refresh-component-inline-methods (component rest)
(%remove-component-inline-methods component)
(%define-component-inline-methods component rest))