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

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
push
resbcl
reccl
reecl
regcl
?
??
???
????
?????
generate-asdf.lisp
# Temporary files from documentation build
doc/asdf/
......@@ -53,4 +54,4 @@ debian/files
debian/patches/
.pc
/.DS_Store
\ No newline at end of file
/.DS_Store
......@@ -43,7 +43,7 @@ archive:
--eval "(rewrite-license)" --eval "(quit)"
bin/make-tarball
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 > $@
push:
git status
git push --tags cl.net release master
......@@ -139,8 +143,8 @@ test-upgrade:
{ echo "upgrade FAILED" ; exit 1 ;} ;; esac ; \
done ; done 2>&1 | tee tmp/results/${lisp}-upgrade.text
test-forward-references:
${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
test-lisp:
@cd test; ${MAKE} clean;./run-tests.sh ${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)
replace-sbcl-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)
replace-ccl-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))'
WRONGFUL_TAGS := 1.37 1.1720 README RELEASE STABLE
# 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)
(:export
#:action
#:explain #:operation-description
#:downward-operation #:upward-operation
#:file-component
#: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
(:documentation
"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
list."))
(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))
t)
(defmethod output-files ((o operation) (c component))
(declare (ignorable o c))
nil)
(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))
nil)
;;;; 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))
:directory)
(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 ()
((stamp
: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.")
(done-p
: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))
nil)
(defmethod perform ((o operation) (c source-file))
(sysdef-error
(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)
(loop
(restart-case
(return (call-next-method))
(retry ()
:report
(lambda (s)
(format s (compatfmt "~@<Retry ~A.~@:>")
(operation-description operation component))))
(accept ()
:report
(lambda (s)
(format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
(operation-description operation component)))
(mark-operation-done operation component)
(return)))))
......@@ -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 ()
:components
((:file "asdf")))
......
This diff is collapsed.
This diff is collapsed.
;;;; -------------------------------------------------------------------------
;;; 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
#:%refresh-component-inline-methods
#:%resolve-if-component-dep-fails))
(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
(pushnew
(eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
,@body))
(component-inline-methods ret)))))))
(defun* %refresh-component-inline-methods (component rest)
(%remove-component-inline-methods component)
(%define-component-inline-methods component rest))
;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute
;; and the companion asdf:feature pseudo-dependency.
;; This won't recurse into dependencies to accumulate feature conditions.
;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL
;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles.
(defun %resolve-if-component-dep-fails (if-component-dep-fails component)
(asdf-message "The system definition for ~S uses deprecated ~
ASDF option :IF-COMPONENT-DEP-DAILS. ~
Starting with ASDF 2.27, please use :IF-FEATURE instead"
(coerce-name (component-system component)))
;; This only supports the pattern of use of the "feature" seen in the wild
(check-type component parent-component)
(check-type if-component-dep-fails (member :fail :ignore :try-next))
(unless (eq if-component-dep-fails :fail)
(loop :with o = (make-instance 'compile-op)
:for c :in (component-children component) :do
(loop :for (feature? feature) :in (component-depends-on o c)
:when (eq feature? 'feature) :do
(setf (component-if-feature c) feature)))))
......@@ -5,19 +5,21 @@
NEWVER="${1}"
PROG="$0"
ASDFDIR="$(cd $(dirname $PROG)/.. ; /bin/pwd)" ## readlink -f doesn't work on BSD
ASDFLISP=${ASDFDIR}/asdf.lisp
ASDFASD=${ASDFDIR}/asdf.asd
if [ -z "$NEWVER" ] ; then
OLDVER="$(grep ' (asdf-version "' $ASDFLISP | cut -d\" -f2)"
OLDVER="$(grep ' (asdf-version "' ${ASDFDIR}/header.lisp | cut -d\" -f2)"
NEWVER="$(echo $OLDVER | perl -npe 's/([0-9].[0-9]+)(\.([0-9]+))?/"${1}.".($3+1)/e')"
fi
echo "Setting ASDF version to $NEWVER"
perl -i.bak -npe 's/^( \(asdf-version "|;;; This is ASDF )[0-9.]+("\)|:)/${1}'"$NEWVER"'${2}/' $ASDFLISP
perl -i.bak -npe 's/^( :version ")[0-9.]+(")/${1}'"$NEWVER"'${2}/' $ASDFASD
for i in ${ASDFDIR}/header.lisp ${ASDFDIR}/upgrade.lisp ; do
perl -i.bak -npe 's/^( \(asdf-version "|;;; This is ASDF )[0-9.]+("\)|:)/${1}'"$NEWVER"'${2}/' $i
done
for i in ${ASDFDIR}/asdf.asd ; do # ${ASDFDIR}/generate-asdf.asd
perl -i.bak -npe 's/^( :version ")[0-9.]+(")/${1}'"$NEWVER"'${2}/' $i
done
cat<<EOF
To complete the version change, you may:
git add -u
git commit
git commit -a
git tag $NEWVER
EOF
......@@ -16,10 +16,6 @@ fi
mkdir tmp
archive_file="tmp/asdf-$tag.tar.gz"
echo "Create tmp/asdf.tar.gz with tag $tag"
git archive $tag --prefix="asdf/" --format=tar | \
gzip > $archive_file
echo "Extract tmp/asdf.lisp"
tar --to-stdout -zxf $archive_file asdf/asdf.lisp > tmp/asdf.lisp
This diff is collapsed.
This diff is collapsed.
;;;; -------------------------------------------------------------------------
;;;; Concatenate-source
(defpackage :asdf/concatenate-source
(:use :common-lisp :asdf/utility :asdf/os
:asdf/component :asdf/operation :asdf/system :asdf/find-system :asdf/defsystem
:asdf/action :asdf/lisp-action :asdf/bundle)
(:export
#:concatenate-source-op
#:load-concatenated-source-op
#:compile-concatenated-source-op
#:load-compiled-concatenated-source-op
#:monolithic-concatenate-source-op
#:monolithic-load-concatenated-source-op
#:monolithic-compile-concatenated-source-op
#:monolithic-load-compiled-concatenated-source-op
#:concatenated-source-system
#:system-concatenated-source-file
#:system-translate-output-p))
(in-package :asdf/concatenate-source)
;;;
;;; Concatenate sources
;;;
(defclass concatenate-source-op (operation) ())
(defclass load-concatenated-source-op (basic-load-op operation) ())
(defclass compile-concatenated-source-op (basic-compile-op operation) ())
(defclass load-compiled-concatenated-source-op (basic-load-op operation) ())
(defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ())
(defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ())
(defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ())
(defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ())
(defclass concatenated-source-system (system)
((concatenated-source-file
:initform nil :initarg :concatenated-source-file :reader system-concatenated-source-file)
(translate-output-p
:initform t :initarg :translate-output-p :reader system-translate-output-p)))
(defmethod system-concatenated-source-file ((s system))
(declare (ignorable s))
nil)
(defmethod system-translate-output-p ((s system))
(declare (ignorable s))
t)
(defmethod input-files ((o concatenate-source-op) (s system))
(loop :with op = (make-operation 'compile-op)
:with components = (gather-components op s
:include-self nil
:filter-type 'source-file
:other-systems (operation-monolithic-p o))
:with non-cl-source-files = nil
:with encoding = (or (component-encoding s) *default-encoding*)
:with other-encodings = '()
:with around-compile = (around-compile-hook s)
:with other-around-compile = '()
:for (o . c) :in components
:do (cond
((typep c 'cl-source-file)
(let ((e (component-encoding c)))
(unless (equal e encoding)
(pushnew e other-encodings :test 'equal)))
(let ((a (around-compile-hook c)))
(unless (equal a around-compile)
(pushnew a other-around-compile :test 'equal))))
(t
(push c non-cl-source-files)))
:append (input-files o c) :into inputs
:finally
(when non-cl-source-files
(warn "~S depends on these non CL source files: ~A"
'concatenated-source-op non-cl-source-files))
(when other-encodings
(warn "~S uses encoding ~A but has sources that use these encodings: ~A"
'concatenated-source-op encoding other-encodings))
(when other-around-compile
(warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
'concatenated-source-op around-compile other-around-compile))
(return inputs)))
(defmethod output-files ((o concatenate-source-op) (s system))
(declare (ignorable o))
(let ((of (or (system-concatenated-source-file s) (strcat (coerce-name s) ".lisp")))
(top (system-translate-output-p s)))
(values (list (system-relative-pathname s of)) (not top))))
(defmethod input-files ((o load-concatenated-source-op) (s system))
(output-files (find-operation o 'concatenate-source-op) s))
(defmethod input-files ((o compile-concatenated-source-op) (s system))
(output-files (find-operation o 'concatenate-source-op) s))
(defmethod output-files ((o compile-concatenated-source-op) (s system))
(let ((input (first (input-files o s))))
(list (compile-file-pathname input))))
(defmethod input-files ((o load-compiled-concatenated-source-op) (s system))
(output-files (find-operation o 'compile-concatenated-source-op) s))
(defmethod perform ((o concatenate-source-op) (s system))
(let ((inputs (input-files o s))
(output (output-file o s)))
(concatenate-files inputs output)))
(defmethod perform ((o load-concatenated-source-op) (s system))
(perform-lisp-load-source o s))
(defmethod perform ((o compile-concatenated-source-op) (s system))
(perform-lisp-compilation o s))
(defmethod perform ((o load-compiled-concatenated-source-op) (s system))
(perform-lisp-load-fasl o s))
(defmethod component-depends-on ((o concatenate-source-op) (s system))
(declare (ignorable o s)) nil)
(defmethod component-depends-on ((o load-concatenated-source-op) (s system))
(declare (ignorable o s)) `((prepare-op ,s) (concatenate-source-op ,s)))
(defmethod component-depends-on ((o compile-concatenated-source-op) (s system))
(declare (ignorable o s)) `((concatenate-source-op ,s)))
(defmethod component-depends-on ((o load-compiled-concatenated-source-op) (s system))
(declare (ignorable o s)) `((compile-concatenated-source-op ,s)))
(defmethod component-depends-on ((o monolithic-concatenate-source-op) (s system))
(declare (ignorable o s)) nil)
(defmethod component-depends-on ((o monolithic-load-concatenated-source-op) (s system))
(declare (ignorable o s)) `((monolithic-concatenate-source-op ,s)))
(defmethod component-depends-on ((o monolithic-compile-concatenated-source-op) (s system))
(declare (ignorable o s)) `((monolithic-concatenate-source-op ,s)))
(defmethod component-depends-on ((o monolithic-load-compiled-concatenated-source-op) (s system))
(declare (ignorable o s)) `((monolithic-compile-concatenated-source-op ,s)))
This diff is collapsed.
;;;; -------------------------------------------------------------------------
;;;; Defsystem
(defpackage :asdf/defsystem
(:use :common-lisp :asdf/utility :asdf/pathname
:asdf/component :asdf/system :asdf/find-system :asdf/find-component
:asdf/lisp-action :asdf/operate
:asdf/backward-internals)
#+gcl<2.7 (:shadowing-import-from :asdf/implementation #:type-of)
(:export
#:defsystem #:do-defsystem #:parse-component-form
#:*default-component-class*
))
(in-package :asdf/defsystem)
;;; Pathname
(defun* determine-system-pathname (pathname)
;; The defsystem macro calls us to determine
;; the pathname of a system as follows:
;; 1. the one supplied,
;; 2. derived from *load-pathname* via load-pathname
;; 3. taken from the *default-pathname-defaults* via default-directory
(let* ((file-pathname (load-pathname))
(directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
(or (and pathname (subpathname directory-pathname pathname :type :directory))
directory-pathname
(default-directory))))
;;; Component class
(defvar *default-component-class* 'cl-source-file)
(defun* class-for-type (parent type)
(or (loop :for symbol :in (list
type
(find-symbol* type *package* nil)
(find-symbol* type :asdf/interface nil))
:for class = (and symbol (find-class* symbol nil))
:when (and class
(#-cormanlisp subtypep #+cormanlisp cl::subclassp
class (find-class* 'component)))
:return class)
(and (eq type :file)
(find-class*
(or (loop :for p = parent :then (component-parent p) :while p
:thereis (module-default-component-class p))
*default-component-class*) nil))
(sysdef-error "don't recognize component type ~A" type)))
;;; Check inputs
(define-condition duplicate-names (system-definition-error)
((name :initarg :name :reader duplicate-names-name))
(:report (lambda (c s)
(format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
(duplicate-names-name c)))))
(defun* sysdef-error-component (msg type name value)
(sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
type name value))
(defun* check-component-input (type name weakly-depends-on
depends-on components in-order-to)
"A partial test of the values of a component."
(unless (listp depends-on)
(sysdef-error-component ":depends-on must be a list."
type name depends-on))
(unless (listp weakly-depends-on)
(sysdef-error-component ":weakly-depends-on must be a list."
type name weakly-depends-on))
(unless (listp components)
(sysdef-error-component ":components must be NIL or a list of components."
type name components))
(unless (and (listp in-order-to) (listp (car in-order-to)))
(sysdef-error-component ":in-order-to must be NIL or a list of components."
type name in-order-to)))
;;; Main parsing function
(defun* parse-component-form (parent options &key previous-serial-component)
(destructuring-bind
(type name &rest rest &key
;; the following list of keywords is reproduced below in the
;; remove-keys form. important to keep them in sync
components pathname
perform explain output-files operation-done-p
weakly-depends-on depends-on serial in-order-to
do-first if-component-dep-fails
(version nil versionp)
;; list ends
&allow-other-keys) options
(declare (ignorable perform explain output-files operation-done-p))
(check-component-input type name weakly-depends-on depends-on components in-order-to)
(when (and parent
(find-component parent name)
(not ;; ignore the same object when rereading the defsystem
(typep (find-component parent name)
(class-for-type parent type))))
(error 'duplicate-names :name name))
(when versionp
(unless (parse-version version nil)
(warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
version name parent)))
(when do-first (error "DO-FIRST is not supported anymore since ASDF 2.27"))
(let* ((args `(:name ,(coerce-name name)
:pathname ,pathname
,@(when parent `(:parent ,parent))
,@(remove-keys
'(components pathname if-component-dep-fails
perform explain output-files operation-done-p
weakly-depends-on depends-on serial in-order-to)
rest)))
(ret (find-component parent name)))
(when weakly-depends-on
(appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
(when previous-serial-component
(push previous-serial-component depends-on))
(if ret ; preserve identity
(apply 'reinitialize-instance ret args)
(setf ret (apply 'make-instance (class-for-type parent type) args)))
(component-pathname ret) ; eagerly compute the absolute pathname
(when (typep ret 'parent-component)
(setf (component-children ret)
(loop
:with previous-component = nil
:for c-form :in components
:for c = (parse-component-form ret c-form
:previous-serial-component previous-component)
:for name = (component-name c)
:collect c
:when serial :do (setf previous-component name)))
(compute-children-by-name ret))
(setf (component-sibling-dependencies ret) depends-on) ;; Used by POIU. ASDF3: rename to component-depends-on
(setf (component-in-order-to ret) in-order-to)
(%refresh-component-inline-methods ret rest)
(when if-component-dep-fails (%resolve-if-component-dep-fails if-component-dep-fails ret))
ret)))
(defun* do-defsystem (name &rest options
&key pathname (class 'system)
defsystem-depends-on &allow-other-keys)
;; The system must be registered before we parse the body,
;; otherwise we recur when trying to find an existing system
;; of the same name to reuse options (e.g. pathname) from.
;; To avoid infinite recursion in cases where you defsystem a system
;; that is registered to a different location to find-system,
;; we also need to remember it in a special variable *systems-being-defined*.
(with-system-definitions ()
(let* ((name (coerce-name name))
(load-pathname (load-pathname))
(registered (system-registered-p name))
(registered! (if registered
(rplaca registered (safe-file-write-date load-pathname))
(register-system (make-instance 'system :name name :source-file load-pathname))))
(system (reset-system (cdr registered!)