Commit 62b27376 authored by Robert P. Goldman's avatar Robert P. Goldman
parents ddc9bf09 ab797258
......@@ -42,19 +42,18 @@ XCL ?= xcl
# website, tag, install
header_lisp := header.lisp
driver_lisp := package.lisp common-lisp.lisp utility.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp backward-driver.lisp driver.lisp
defsystem_lisp := upgrade.lisp component.lisp system.lisp stamp-cache.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp
driver_lisp := package.lisp common-lisp.lisp utility.lisp os.lisp pathname.lisp filesystem.lisp stream.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp backward-driver.lisp driver.lisp
defsystem_lisp := upgrade.lisp component.lisp system.lisp cache.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp
all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp)
# Making ASDF itself should be our first, default, target:
build/asdf.lisp: $(wildcard *.lisp)
build/asdf.lisp: $(all_lisp)
mkdir -p build
cat $(header_lisp) $(driver_lisp) $(defsystem_lisp) > $@
cat $(all_lisp) > $@
# This quickly locates such mistakes as unbalanced parentheses:
load: build/asdf.lisp
rlwrap sbcl \
`for i in $(driver_lisp) $(defsystem_lisp) ; do echo --load $$i ; done` \
--eval '(in-package :asdf)'
./test/run-tests.sh -t $l $(all_lisp)
install: archive-copy
......@@ -206,7 +205,7 @@ release: TODO test-all test-on-other-machines-too debian-changelog debian-packag
# RELEASE checklist:
# make test-all
# ./bin/bump-version 2.27
# ./bin/bump-version 3.0
# edit debian/changelog
# make release-push archive-copy website debian-package
# dput mentors ../*.changes
......
* Resolve performance degradation issue reported by stassats and fe[nl]ix
** Is it the warnings feature taking too much resources?
** Is output-files and/or input-files being called too much? Cache it!
* fix upgrade on (abcl, clisp, cmucl)
** Extract minimal test case
* Bug found by fe[nl]ix: infinite loop if the definitions in an asd file
......@@ -16,8 +19,6 @@
concatenate all files for the system, then load the result (load-concatenated-source-op),
concatenate all files for the system, then link them and load the result (load-compiled-concatenated-op),
concatenate all files for the system *and* its dependencies, link and load (monolithic-load-compiled-concatenated-op).
* Stop the dynamic ASDFn temporary package madness.
** Just have a single ASDF-USER that :use's ASDF and ASDF-UTILS
* operation cleanup?
** Kill backward-compat functions after all clients have moved on.
** Kill original-initargs -- BEWARE, it currently has clients!
......@@ -5,11 +5,11 @@
(:nicknames :asdf-action)
(:recycle :asdf/action :asdf)
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade
:asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation)
:asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-component :asdf/operation)
(:intern #:stamp #:done-p)
(:export
#:action #:define-convenience-action-methods
#:explain #:operation-description
#:explain #:action-description
#:downward-operation #:upward-operation #:sibling-operation
#:component-depends-on #:component-self-dependencies
#:input-files #:output-files #:output-file #:operation-done-p
......@@ -17,8 +17,7 @@
#:component-operation-time #:mark-operation-done #:compute-action-stamp
#:perform #:perform-with-restarts #:retry #:accept #:feature
#:traverse-actions #:traverse-sub-actions #:required-components ;; in plan
#:action-path #:find-action
))
#:action-path #:find-action))
(in-package :asdf/action)
(deftype action () '(cons operation component)) ;; a step to be performed while building the system
......@@ -52,11 +51,12 @@
(if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
`(apply 'make-operation ,operation :original-initargs ,rest ,rest)
`(make-operation ,operation))
`(find-component () ,component))
`(or (find-component () ,component) ,if-no-component))
,if-no-operation))
(defmethod ,function ((,operation operation) ,component ,@more-args)
(if (typep ,component 'component)
(error "No defined method for ~S on ~S" ',function ,component)
(error "No defined method for ~S on ~/asdf-action:format-action/"
',function (cons ,operation ,component))
(let ((,found (find-component () ,component)))
(if ,found
,(next-method operation found)
......@@ -65,27 +65,27 @@
;;;; self-description
(defgeneric* operation-description (operation component) ;; ASDF3: rename to action-description
(defgeneric* action-description (operation component)
(: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)
(defmethod action-description (operation component)
(format nil (compatfmt "~@<~A on ~A~@:>")
(type-of operation) component))
(defgeneric* (explain) (operation component))
(defmethod explain ((o operation) (c component))
(asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (operation-description o c)))
(asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))
(define-convenience-action-methods explain (operation component))
(defun* format-action (stream action &optional colon-p at-sign-p)
(assert (null colon-p)) (assert (null at-sign-p))
(destructuring-bind (operation . component) action
(princ (operation-description operation component) stream)))
(princ (action-description operation component) stream)))
;;;; Dependencies
(defgeneric* component-depends-on (operation component) ;; ASDF3: rename to component-dependencies
(defgeneric* component-depends-on (operation component) ;; ASDF4: 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:
......@@ -132,7 +132,7 @@ You can put together sentences using this phrase."))
((upward-operation
:initform nil :initarg :downward-operation :reader upward-operation)))
;; For backward-compatibility reasons, a system inherits from module and is a child-component
;; so we must guard against this case. ASDF3: remove that.
;; so we must guard against this case. ASDF4: remove that.
(defmethod component-depends-on ((o upward-operation) (c child-component))
`(,@(if-let (p (component-parent c))
`((,(or (upward-operation o) o) ,p))) ,@(call-next-method)))
......@@ -163,22 +163,23 @@ You can put together sentences using this phrase."))
t)
(defmethod output-files :around (operation component)
"Translate output files, unless asked not to"
"Translate output files, unless asked not to. Memoize the result."
operation component ;; hush genera, not convinced by declare ignorable(!)
(values
(multiple-value-bind (pathnames fixedp) (call-next-method)
;; 1- Make sure we have absolute pathnames
(let* ((directory (pathname-directory-pathname
(component-pathname (find-component () component))))
(absolute-pathnames
(loop
:for pathname :in pathnames
:collect (ensure-pathname-absolute pathname directory))))
;; 2- Translate those pathnames as required
(if fixedp
absolute-pathnames
(mapcar *output-translation-function* absolute-pathnames))))
t))
(do-asdf-cache `(output-files ,operation ,component)
(values
(multiple-value-bind (pathnames fixedp) (call-next-method)
;; 1- Make sure we have absolute pathnames
(let* ((directory (pathname-directory-pathname
(component-pathname (find-component () component))))
(absolute-pathnames
(loop
:for pathname :in pathnames
:collect (ensure-pathname-absolute pathname directory))))
;; 2- Translate those pathnames as required
(if fixedp
absolute-pathnames
(mapcar *output-translation-function* absolute-pathnames))))
t)))
(defmethod output-files ((o operation) (c component))
(declare (ignorable o c))
nil)
......@@ -188,6 +189,11 @@ You can put together sentences using this phrase."))
(assert (length=n-p files 1))
(first files)))
(defmethod input-files :around (operation component)
"memoize input files."
(do-asdf-cache `(input-files ,operation ,component)
(call-next-method)))
(defmethod input-files ((o operation) (c parent-component))
(declare (ignorable o c))
nil)
......@@ -203,11 +209,10 @@ You can put together sentences using this phrase."))
;;;; Done performing
(defgeneric* component-operation-time (operation component)) ;; ASDF3: hide it behind plan-action-stamp
(defgeneric* component-operation-time (operation component)) ;; ASDF4: hide it behind plan-action-stamp
(define-convenience-action-methods component-operation-time (operation component))
(defgeneric* mark-operation-done (operation component)) ;; ASDF3: hide it behind (setf plan-action-stamp)
(defgeneric* mark-operation-done (operation component)) ;; ASDF4: 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?
......@@ -277,12 +282,12 @@ in some previous image, or T if it needs to be done.")
:report
(lambda (s)
(format s (compatfmt "~@<Retry ~A.~@:>")
(operation-description operation component))))
(action-description operation component))))
(accept ()
:report
(lambda (s)
(format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
(operation-description operation component)))
(action-description operation component)))
(mark-operation-done operation component)
(return)))))
......
......@@ -2,7 +2,9 @@
(in-package :asdf)
(defun call-without-redefinition-warnings (thunk)
(handler-bind (#+clozure (ccl:compiler-warning #'muffle-warning))
(handler-bind (((or #+clozure ccl:compiler-warning
#+cmu kernel:simple-style-warning)
#'muffle-warning))
(funcall thunk)))
(defsystem :asdf-driver
......@@ -10,7 +12,8 @@
:description "Runtime support for Common Lisp programs"
:long-description "Basic general-purpose utilities that are in such a need
that you can't portably construct a complete program without using them."
#+asdf2.27 :version #+asdf2.27 (:read-file-form "version.lisp-expr")
#+asdf3 :version #+asdf3 (:read-file-form "version.lisp-expr")
#+asdf3 :encoding #+asdf3 :utf-8
:around-compile call-without-redefinition-warnings
:components
((:static-file "version.lisp-expr")
......@@ -18,11 +21,12 @@ that you can't portably construct a complete program without using them."
(:file "package")
(:file "common-lisp" :depends-on ("package"))
(:file "utility" :depends-on ("common-lisp"))
(:file "os" :depends-on ("utility"))
(:file "pathname" :depends-on ("utility"))
(:file "stream" :depends-on ("pathname"))
(:file "os" :depends-on ("stream"))
(:file "image" :depends-on ("os"))
(:file "run-program" :depends-on ("os"))
(:file "filesystem" :depends-on ("os" "pathname"))
(:file "stream" :depends-on ("filesystem"))
(:file "image" :depends-on ("stream"))
(:file "run-program" :depends-on ("stream"))
(:file "lisp-build" :depends-on ("image"))
(:file "configuration" :depends-on ("image"))
(:file "backward-driver" :depends-on ("lisp-build" "run-program" "configuration"))
......
......@@ -9,16 +9,17 @@
(in-package :asdf)
#+asdf2.27
#+asdf3
(defsystem :asdf/header
;; Note that it's polite to sort the defsystem forms in dependency order,
;; and compulsory to sort them in defsystem-depends-on order.
:version (:read-file-form "version.lisp-expr")
:around-compile call-without-redefinition-warnings ;; we need be the same as asdf-driver
:encoding :utf-8
:components
((:file "header")))
#+asdf2.27
#+asdf3
(defsystem :asdf/defsystem
:licence "MIT"
:description "The defsystem part of ASDF"
......@@ -28,22 +29,23 @@
:build-pathname "build/asdf" ;; our target
:around-compile call-without-redefinition-warnings ;; we need be the same as asdf-driver
:depends-on (:asdf/header :asdf-driver)
:encoding :utf-8
:components
((:file "upgrade")
(:file "component" :depends-on ("upgrade"))
(:file "system" :depends-on ("component"))
(:file "stamp-cache" :depends-on ("upgrade"))
(:file "find-system" :depends-on ("system" "stamp-cache"))
(:file "cache" :depends-on ("upgrade"))
(:file "find-system" :depends-on ("system" "cache"))
(:file "find-component" :depends-on ("find-system"))
(:file "operation" :depends-on ("upgrade"))
(:file "action" :depends-on ("find-component" "operation"))
(:file "action" :depends-on ("find-component" "operation" "cache"))
(:file "lisp-action" :depends-on ("action"))
(:file "plan" :depends-on ("lisp-action" "stamp-cache"))
(:file "plan" :depends-on ("lisp-action" "cache"))
(:file "operate" :depends-on ("plan"))
(:file "output-translations" :depends-on ("operate"))
(:file "source-registry" :depends-on ("find-system"))
(:file "backward-internals" :depends-on ("lisp-action" "operate"))
(:file "defsystem" :depends-on ("backward-internals" "stamp-cache"))
(:file "defsystem" :depends-on ("backward-internals" "cache"))
(:file "bundle" :depends-on ("lisp-action"))
(:file "concatenate-source" :depends-on ("bundle"))
(:file "backward-interface" :depends-on ("operate" "output-translations"))
......@@ -51,7 +53,8 @@
("defsystem" "concatenate-source"
"backward-interface" "backward-internals"
"output-translations" "source-registry"))
(:file "footer" :depends-on ("interface"))))
(:file "user" :depends-on ("interface"))
(:file "footer" :depends-on ("user"))))
(defsystem :asdf
:author ("Daniel Barlow")
......@@ -59,14 +62,17 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.146" ;; to be automatically updated by make bump-version
:version "2.26.162" ;; to be automatically updated by make bump-version
:depends-on ()
#+asdf3 :encoding #+asdf3 :utf-8
;; For most purposes, asdf itself specially counts as a builtin system.
;; If you want to link it or do something forbidden to builtin systems,
;; specify separate dependencies on asdf-driver and asdf-defsystem.
#+asdf3 :builtin-system-p #+asdf3 t
:components
((:module "build"
:components
(#-gcl2.6
(:file "asdf"
#-asdf2.27 :do-first #-asdf2.27 ((compile-op (load-source-op "asdf")))
))))
:in-order-to
(#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op asdf/defsystem))))
#-asdf3 :do-first #+asdf3 :in-order-to ((compile-op (load-source-op "asdf")))))))
:in-order-to (#+asdf3 (prepare-source-op (monolithic-concatenate-source-op :asdf/defsystem))))
......@@ -4,7 +4,7 @@
(asdf/package:define-package :asdf/backward-interface
(:recycle :asdf/backward-interface :asdf)
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade
:asdf/component :asdf/system :asdf/operation :asdf/action
:asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
:asdf/lisp-build :asdf/operate :asdf/output-translations)
(:export
#:*asdf-verbose*
......@@ -70,21 +70,26 @@ if that's whay you mean." ;;)
(&key
(centralize-lisp-binaries nil)
(default-toplevel-directory
(subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
(subpathname (user-homedir-pathname) ".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))
(source-to-target-mappings nil)
(file-types (list (compile-file-type)
#+ecl (compile-file-type :type :object)
#+mkcl (compile-file-type :fasl-p nil)
#+clisp "lib" #+sbcl "cfasl"
#+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
#+(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 (compile-file-type))
(mapped-files (if map-all-source-files *wild-file*
(make-pathname :type fasl-type :defaults *wild-file*)))
(let* ((patterns (if map-all-source-files (list *wild-file*)
(loop :for type :in file-types
:collect (make-pathname :type type :defaults *wild-file*))))
(destination-directory
(if centralize-lisp-binaries
`(,default-toplevel-directory
,@(when include-per-user-information
(cdr (pathname-directory (user-homedir))))
(cdr (pathname-directory (user-homedir-pathname))))
:implementation ,*wild-inferiors*)
`(:root ,*wild-inferiors* :implementation))))
(initialize-output-translations
......@@ -92,8 +97,9 @@ if that's whay you mean." ;;)
,@source-to-target-mappings
#+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))
,@(loop :for pattern :in patterns
:collect `((:root ,*wild-inferiors* ,pattern)
(,@destination-directory ,pattern)))
(t t)
:ignore-inherited-configuration))))
......@@ -126,3 +132,4 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead."
(let ((command (apply 'format nil control-string args)))
(asdf-message "; $ ~A~%" command)
(run-program command :force-shell t :ignore-error-status t :output *verbose-out*)))
......@@ -7,9 +7,11 @@
:asdf/system :asdf/component :asdf/operation
:asdf/find-system :asdf/action :asdf/lisp-action)
(:export ;; for internal use
#:load-sysdef #:make-temporary-package
#:%refresh-component-inline-methods
#:%resolve-if-component-dep-fails
#:make-sub-operation))
#:make-sub-operation
#:load-sysdef #:make-temporary-package))
(in-package :asdf/backward-internals)
;;;; Backward compatibility with "inline methods"
......@@ -55,7 +57,7 @@
(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"
Starting with ASDF 3, 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)
......@@ -67,6 +69,16 @@
:when (eq feature? 'feature) :do
(setf (component-if-feature c) feature)))))
(when-upgrade (:when (fboundp 'make-sub-operation))
(when-upgrading (:when (fboundp 'make-sub-operation))
(defun* make-sub-operation (c o dep-c dep-o)
(declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
;;;; load-sysdef
(defun* load-sysdef (name pathname)
(load-asd pathname :name name))
(defun* make-temporary-package ()
(make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf/interface)))
......@@ -4,14 +4,13 @@
(load (make-pathname :name "prelude" :type "lisp" :defaults *load-pathname*)
:verbose nil :print nil)
(defpackage :asdf-builder (:use :cl :asdf/driver :asdf :fare-utils :inferior-shell))
(defpackage :asdf-builder (:use :cl :asdf/driver :asdf/operate :asdf :fare-utils :inferior-shell))
(in-package :asdf-builder)
(asdf-debug)
(defun build-asdf ()
;; Make sure asdf.lisp is built.
(build-system :asdf/defsystem)
"Make sure asdf.lisp is built"
(load-system :asdf)
(values))
......
;;;; -------------------------------------------------------------------------
;;;; Stamp cache
(asdf/package:define-package :asdf/stamp-cache
(asdf/package:define-package :asdf/cache
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
(:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
#:call-with-stamp-cache #:with-stamp-cache #:*stamp-cache*))
(in-package :asdf/stamp-cache)
#:consult-asdf-cache #:do-asdf-cache
#:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*))
(in-package :asdf/cache)
;;; This stamp cache is useful for:
;; * consistency of stamps used within a single run
;; * fewer accesses to the filesystem
;; * the ability to test with fake timestamps, without touching files
(defvar *stamp-cache* nil)
(defvar *asdf-cache* nil)
(defun compute-file-stamp (file)
(safe-file-write-date file))
(defun register-file-stamp (file &optional (stamp (compute-file-stamp file)))
(if *stamp-cache*
(setf (gethash file *stamp-cache*) stamp)
stamp))
(defun set-asdf-cache-entry (key value-list)
(apply 'values
(if *asdf-cache*
(setf (gethash key *asdf-cache*) value-list)
value-list)))
(defun get-file-stamp (file)
(if *stamp-cache*
(multiple-value-bind (stamp foundp) (gethash file *stamp-cache*)
(defun consult-asdf-cache (key thunk)
(if *asdf-cache*
(multiple-value-bind (results foundp) (gethash key *asdf-cache*)
(if foundp
stamp
(register-file-stamp file)))
(compute-file-stamp file)))
(apply 'values results)
(set-asdf-cache-entry key (multiple-value-list (funcall thunk)))))
(funcall thunk)))
(defmacro do-asdf-cache (key &body body)
`(consult-asdf-cache ,key #'(lambda () ,@body)))
(defun call-with-stamp-cache (thunk &key override)
(if (and *stamp-cache* (not override))
(defun call-with-asdf-cache (thunk &key override)
(if (and *asdf-cache* (not override))
(funcall thunk)
(let ((*stamp-cache* (make-hash-table :test 'equal)))
(let ((*asdf-cache* (make-hash-table :test 'equal)))
(funcall thunk))))
(defmacro with-stamp-cache ((&key override) &body body)
`(call-with-stamp-cache #'(lambda () ,@body) :override ,override))
(defmacro with-asdf-cache ((&key override) &body body)
`(call-with-asdf-cache #'(lambda () ,@body) :override ,override))
(defun compute-file-stamp (file)
(safe-file-write-date file))
(defun register-file-stamp (file &optional (stamp (compute-file-stamp file)))
(set-asdf-cache-entry `(get-file-stamp ,file) (list stamp)))
(defun get-file-stamp (file)
(do-asdf-cache `(get-file-stamp ,file) (compute-file-stamp file)))
......@@ -12,6 +12,7 @@
(:reexport :common-lisp)
(:recycle :asdf/common-lisp :asdf)
#+allegro (:intern #:*acl-warn-save*)
#+cormanlisp (:shadow #:user-homedir-pathname)
#+cormanlisp
(:export
#:logical-pathname #:translate-logical-pathname
......@@ -50,6 +51,9 @@
(deftype logical-pathname () nil)
(defun make-broadcast-stream () *error-output*)
(defun translate-logical-pathname (x) x)
(defun user-homedir-pathname (&optional host)
(declare (ignore host))
(parse-namestring (format nil "~A\\" (cl:user-homedir-pathname))))
(defun file-namestring (p)
(setf p (pathname p))
(format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
......@@ -133,23 +137,40 @@
(setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics
;;;; compatfmt: avoid fancy format directives when unsupported
;;;; Looping
(defmacro loop* (&rest rest)
#-genera `(loop ,@rest)
#+genera `(lisp:loop ,@rest)) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh.
;;;; compatfmt: avoid fancy format directives when unsupported
(eval-when (:load-toplevel :compile-toplevel :execute)
(defun strcat (&rest strings)
(apply 'concatenate 'string strings)))
(defun remove-substrings (substrings string)
(let ((length (length string)) (stream nil))
(labels ((emit (start end)
(when (and (zerop start) (= end length))
(return-from remove-substrings string))
(unless stream (setf stream (make-string-output-stream)))
(write-string string stream :start start :end end))
(recurse (substrings start end)
(cond
((= start end))
((null substrings) (emit start end))
(t (let* ((sub (first substrings))
(found (search sub string))
(more (rest substrings)))
(cond
(found
(recurse more start found)
(recurse more (+ found (length sub)) end))
(t
(recurse more start end))))))))
(recurse substrings 0 length))
(if stream (get-output-stream-string stream) ""))))
(defmacro compatfmt (format)
#+(or gcl genera)
(loop* :for (unsupported . replacement)
:in (append
'(("~3i~_" . ""))
#+(or genera gcl2.6) '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do
(loop :for found = (search unsupported format) :while found :do
(setf format (strcat (subseq format 0 found) replacement
(subseq format (+ found (length unsupported)))))))
format)
(remove-substrings `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")) format)
#-(or gcl genera) format)
......@@ -17,7 +17,6 @@
#:component-if-feature #:around-compile-hook
#:component-description #:component-long-description
#:component-version #:version-satisfies
#:component-properties #:component-property ;; backward-compatibility only. DO NOT USE!
#:component-inline-methods ;; backward-compatibility only. DO NOT USE!
#:component-operation-times ;; For internal use only.
;; portable ASDF encoding and implementation-specific external-format
......@@ -26,6 +25,7 @@
#:component-build-operation
#:module-default-component-class
#:module-components ;; backward-compatibility. DO NOT USE.
#:sub-components
;; Internals we'd like to share with the ASDF package, especially for upgrade purposes
#:name #:version #:description #:long-description #:author #:maintainer #:licence
......@@ -49,9 +49,6 @@ interpreted relative to the pathname of that component's parent.
Despite the function's name, the return value may be an absolute
pathname, because an absolute pathname may be interpreted relative to
another pathname in a degenerate way."))
(defgeneric* component-property (component property))
#-gcl2.6
(defgeneric* (setf component-property) (new-value component property))
(defgeneric* component-external-format (component))
(defgeneric* component-encoding (component))
(defgeneric* version-satisfies (component version))
......@@ -60,7 +57,7 @@ another pathname in a degenerate way."))
;;; TODO: find users, have them stop using that.
(defgeneric* (source-file-type) (component system))
(when-upgrade (:when (find-class 'component nil))
(when-upgrading (:when (find-class 'component nil))
(defmethod reinitialize-instance :after ((c component) &rest initargs &key)
(declare (ignorable c initargs)) (values)))
......@@ -103,11 +100,9 @@ another pathname in a degenerate way."))
(operation-times :initform (make-hash-table)
:accessor component-operation-times)
(around-compile :initarg :around-compile)
(properties) ;; Only for backward-compatibility during upgrades from ASDF2. DO NOT USE.
(%encoding :accessor %component-encoding :initform nil :initarg :encoding)
;; ASDF3: get rid of these "component properties" ?
(properties :accessor component-properties :initarg :properties
:initform nil)
;; For backward-compatibility, this slot is part of component rather than child-component
;; For backward-compatibility, this slot is part of component rather than child-component. ASDF4: don't.
(parent :initarg :parent :initform nil :reader component-parent)
(build-operation
:initarg :build-operation :initform nil :reader component-build-operation)))
......@@ -173,7 +168,7 @@ another pathname in a degenerate way."))
(setf (gethash name hash) c))
hash))))
(when-upgrade (:when (find-class 'module nil))
(when-upgrading (:when (find-class 'module nil))
(defmethod reinitialize-instance :after ((m module) &rest initargs &key)
(declare (ignorable m initargs)) (values))
(defmethod update-instance-for-redefined-class :after
......@@ -230,20 +225,6 @@ another pathname in a degenerate way."))
(file-type component))
;;;; General component-property - ASDF3: remove? Define clean subclasses, not messy "properties".
(defmethod component-property ((c component) property)
(cdr (assoc property (slot-value c 'properties) :test #'equal)))
(defmethod (setf component-property) (new-value (c component) property)
(let ((a (assoc property (slot-value c 'properties) :test #'equal)))
(if a
(setf (cdr a) new-value)
(setf (slot-value c 'properties)
(acons property new-value (slot-value c 'properties)))))
new-value)
;;;; Encodings
(defmethod component-encoding ((c component))
......@@ -277,3 +258,16 @@ another pathname in a degenerate way."))
(defmethod version-satisfies ((cver string) version)
(version-compatible-p cver version))
;;; all sub-components (of a given type)
(defun* sub-components (component &key (type t))
(while-collecting (c)
(labels ((recurse (x)
(when (if-let (it (component-if-feature x)) (featurep it) t)
(when (typep x type)
(c x))
(when (typep x 'parent-component)
(map () #'recurse (component-children x))))))
(recurse component))))
......@@ -4,7 +4,7 @@
(asdf/package:define-package :asdf/configuration
(:recycle :asdf/configuration :asdf)
(:use :asdf/common-lisp :asdf/utility
:asdf/pathname :asdf/stream :asdf/os :asdf/image)
:asdf/os :asdf/pathname :asdf/filesystem :asdf/stream :asdf/image)
(:export
#:get-folder-path
#:user-configuration-directories #:system-configuration-directories
......@@ -15,7 +15,7 @@
#:report-invalid-form #:invalid-configuration #:*ignored-configuration-form*
#:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
#:resolve-location #:location-designator-p #:location-function-p #:*here-directory*
#:resolve-relative-location #:resolve-absolute-location))
#:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration))
(in-package :asdf/configuration)
(define-condition invalid-configuration ()
......@@ -49,7 +49,7 @@
,@(when (os-windows-p)
`(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/")
,(subpathname* (get-folder-path :appdata) "common-lisp/config/")))
,(subpathname (user-homedir) ".config/common-lisp/"))))
,(subpathname (user-homedir-pathname) ".config/common-lisp/"))))
(remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
:from-end t :test 'equal)))
......@@ -227,12 +227,13 @@ directive.")
(return-from resolve-absolute-location
(let ((p (make-pathname* :directory '(:relative))))
(if wilden (wilden p) p))))
((eql :home) (user-homedir))
((eql :home) (user-homedir-pathname))
((eql :here) (resolve-absolute-location
*here-directory* :ensure-directory t :wilden nil))
((eql :user-cache) (resolve-absolute-location
*user-cache* :ensure-directory t :wilden nil)))
:wilden (and wilden (not (pathnamep x)))
:resolve-symlinks *resolve-symlinks*
:want-absolute t))
;; Try to override declaration in previous versions of ASDF.
......@@ -240,21 +241,21 @@ directive.")
(:ensure-directory boolean)) t) resolve-location))