Commit aba8811b authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Move node visit information from plan to session

Significantly refactor plan internals.

Move visited-actions, visiting-action-set, visiting-action-list,
total-action-count, planned-action-count, planned-output-action-count
from plan to session (remove the plan- prefix to accessors).

Move sysdef-error from component to session.

Remove plan as a parameter of action-valid-p (made simple defun)
and while-visiting-action (both moved to action), but also
map-direct-dependencies, reduce-direct-dependencies, direct-dependencies.

Rename *default-plan-class* to *plan-class*,
plan-record-dependency to record-dependency,
plan-action-status to action-status
plan-forced (accessor) to forced, plan-forced-not (accessor) to forced-not.

Introduce define-op, and visit a suitable action while loading an asd file.
Accumulate inner operate dependencies in a slot definition-dependencies of
a registered system or a newly registered undefined-system.

Introduce reset-session or reset-session-visited in various tests,
so operations aren't considered as layered atop each other, but
as restarting from a fresh planning session.

Use with-asdf-session in required-components, make-plan.

Stop using node-for, use cons directly, now that operations are safe.

Export format-action from action.

Move some conditions and generic functions around and reorder dependencies.
parent a925eda1
......@@ -80,7 +80,7 @@ XCL ?= xcl
header_lisp := header.lisp
driver_lisp := uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp
defsystem_lisp := upgrade.lisp session.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp output-translations.lisp source-registry.lisp package-inferred-system.lisp backward-interface.lisp backward-internals.lisp interface.lisp user.lisp footer.lisp
defsystem_lisp := upgrade.lisp session.lisp component.lisp operation.lisp system.lisp action.lisp find-system.lisp find-component.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp
all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp)
print-% : ; @echo $* = $($*)
......
......@@ -3,15 +3,15 @@
(uiop/package:define-package :asdf/action
(:nicknames :asdf-action)
(:recycle :asdf/action :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/system #:asdf/session :asdf/find-system :asdf/find-component :asdf/operation)
(:recycle :asdf/action :asdf/plan :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/operation)
(:import-from :asdf/operation #:check-operation-constructor)
#-clisp (:unintern #:required-components #:traverse-action #:traverse-sub-actions)
(:export
#:action #:define-convenience-action-methods
#:action-description
#:downward-operation #:upward-operation #:sideway-operation #:selfward-operation #:non-propagating-operation
#:action-description #:format-action
#:downward-operation #:upward-operation #:sideway-operation #:selfward-operation
#:non-propagating-operation
#:component-depends-on
#:input-files #:output-files #:output-file #:operation-done-p
#:action-status #:action-stamp #:action-done-p
......@@ -20,7 +20,9 @@
#:perform #:perform-with-restarts #:retry #:accept
#:action-path #:find-action #:stamp #:done-p
#:operation-definition-warning #:operation-definition-error ;; condition
))
#:action-valid-p
#:circular-dependency #:circular-dependency-actions
#:call-while-visiting-action #:while-visiting-action))
(in-package :asdf/action)
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning
......@@ -461,3 +463,40 @@ in some previous image, or T if it needs to be done.")
(action-description operation component)))
(mark-operation-done operation component)
(return))))))
;;;; Detection of circular dependencies
(with-upgradability ()
(defun (action-valid-p) (operation component)
"Is this action valid to include amongst dependencies?"
;; If either the operation or component was resolved to nil, the action is invalid.
;; :if-feature will invalidate actions on components for which the features don't apply.
(and operation component
(if-let (it (component-if-feature component)) (featurep it) t)))
(define-condition circular-dependency (system-definition-error)
((actions :initarg :actions :reader circular-dependency-actions))
(:report (lambda (c s)
(format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
(circular-dependency-actions c)))))
(defun call-while-visiting-action (operation component fun)
"Detect circular dependencies"
(when (action-valid-p operation component)
(with-accessors ((action-set visiting-action-set)
(action-list visiting-action-list)) *asdf-session*
(let ((action (cons operation component)))
(when (gethash action action-set)
(error 'circular-dependency :actions
(member action (reverse action-list) :test 'equal)))
(setf (gethash action action-set) t)
(push action action-list)
(unwind-protect
(funcall fun)
(pop action-list)
(setf (gethash action action-set) nil))))))
;; Syntactic sugar for call-while-visiting-action
(defmacro while-visiting-action ((o c) &body body)
`(call-while-visiting-action ,o ,c #'(lambda () ,@body))))
......@@ -45,23 +45,23 @@
:components
((:file "upgrade")
(:file "session" :depends-on ("upgrade"))
(:file "component" :depends-on ("upgrade"))
(:file "component" :depends-on ("session"))
(:file "operation" :depends-on ("session"))
(:file "system" :depends-on ("component"))
(:file "find-system" :depends-on ("system" "session"))
(:file "action" :depends-on ("session" "system" "operation"))
(:file "find-system" :depends-on ("session" "system" "action"))
(:file "find-component" :depends-on ("find-system"))
(:file "operation" :depends-on ("find-system"))
(:file "action" :depends-on ("find-component" "operation"))
(:file "lisp-action" :depends-on ("action"))
(:file "plan" :depends-on ("lisp-action"))
(:file "lisp-action" :depends-on ("action" "find-system"))
(:file "plan" :depends-on ("lisp-action" "find-component"))
(:file "operate" :depends-on ("plan"))
(:file "parse-defsystem" :depends-on ("session" "system" "lisp-action" "operate"))
(:file "parse-defsystem" :depends-on ("system" "lisp-action" "operate"))
(:file "bundle" :depends-on ("lisp-action" "operate" "parse-defsystem"))
(:file "concatenate-source" :depends-on ("plan" "parse-defsystem" "bundle"))
(:file "package-inferred-system" :depends-on ("find-system" "parse-defsystem"))
(:file "output-translations" :depends-on ("operate"))
(:file "source-registry" :depends-on ("find-system"))
(:file "package-inferred-system" :depends-on ("system" "find-system" "parse-defsystem"))
(:file "backward-interface" :depends-on ("operate" "output-translations"))
(:file "backward-internals" :depends-on ("find-system" "parse-defsystem"))
(:file "backward-interface" :depends-on ("output-translations"))
(:file "interface" :depends-on
("parse-defsystem" "concatenate-source"
"output-translations" "source-registry" "package-inferred-system"
......@@ -85,4 +85,3 @@
#+asdf3 :builtin-system-p #+asdf3 t
:components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf3 (prepare-op (monolithic-concatenate-source-op "asdf/defsystem"))))
......@@ -3,7 +3,7 @@
(uiop/package:define-package :asdf/backward-interface
(:recycle :asdf/backward-interface :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
:asdf/lisp-action :asdf/plan :asdf/operate :asdf/output-translations)
(:export
......
......@@ -323,9 +323,9 @@ or of opaque libraries shipped along the source code."))
;; your component-depends-on method must gather the correct dependencies in the correct order.
(while-collecting (collect)
(map-direct-dependencies
t o c #'(lambda (sub-o sub-c)
(loop :for f :in (funcall key sub-o sub-c)
:when (funcall test f) :do (collect f))))))
o c #'(lambda (sub-o sub-c)
(loop :for f :in (funcall key sub-o sub-c)
:when (funcall test f) :do (collect f))))))
(defun pathname-type-equal-function (type)
#'(lambda (p) (equalp (pathname-type p) type)))
......@@ -441,7 +441,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
t 'load-op s
'load-op s
#'(lambda (o c)
(when (and (typep o 'load-op) (typep c 'system))
(x c)))))))
......@@ -496,7 +496,6 @@ which is probably not what you want; you probably need to tweak your output tran
(perform-lisp-load-fasl o s))
(defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
#+xcl (declare (ignorable o))
`((load-op ,s) ,@(call-next-method))))
#| ;; Example use:
......
......@@ -2,10 +2,11 @@
;;;; Components
(uiop/package:define-package :asdf/component
(:recycle :asdf/component :asdf/defsystem :asdf/find-system :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade)
(:recycle :asdf/component :asdf/find-component :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session)
(:export
#:component #:component-find-path
#:find-component ;; methods defined in find-component
#:component-name #:component-pathname #:component-relative-pathname
#:component-parent #:component-system #:component-parent-pathname
#:child-component #:parent-component #:module
......@@ -29,7 +30,6 @@
#:sub-components
;; conditions
#:system-definition-error ;; top level, moved here because this is the earliest place for it.
#:duplicate-names
;; Internals we'd like to share with the ASDF package, especially for upgrade purposes
......@@ -81,15 +81,6 @@ or NIL for top-level components (a.k.a. systems)"))
(defgeneric source-file-type (component system)
(:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead."))
(define-condition system-definition-error (error) ()
;; [this use of :report should be redundant, but unfortunately it's not.
;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
;; over print-object; this is always conditions::%print-condition for
;; condition objects, which in turn does inheritance of :report options at
;; run-time. fortunately, inheritance means we only need this kludge here in
;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
#+cmucl (:report print-object))
(define-condition duplicate-names (system-definition-error)
((name :initarg :name :reader duplicate-names-name))
(:report (lambda (c s)
......@@ -150,6 +141,10 @@ or NIL for top-level components (a.k.a. systems)"))
:initarg :build-operation :initform nil :reader component-build-operation))
(:documentation "Base class for all components of a build"))
(defgeneric find-component (base path &key registered)
(:documentation "Find a component by resolving the PATH starting from BASE parent.
If REGISTERED is true, only search currently registered systems."))
(defun component-find-path (component)
"Return a path from a root system to the COMPONENT.
The return value is a list of component NAMES; a list of strings."
......
......@@ -50,9 +50,6 @@
;;;; Finding components
(with-upgradability ()
(defgeneric find-component (base path &key registered)
(:documentation "Find a component by resolving the PATH starting from BASE parent.
If REGISTERED is true, only search currently registered systems."))
(defgeneric resolve-dependency-combination (component combinator arguments)
(:documentation "Return a component satisfying the dependency specification (COMBINATOR . ARGUMENTS)
in the context of COMPONENT"))
......
......@@ -4,16 +4,15 @@
(uiop/package:define-package :asdf/find-system
(:recycle :asdf/find-system :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/session :asdf/component :asdf/system)
:asdf/session :asdf/component :asdf/operation :asdf/action :asdf/system)
(:export
#:remove-entry-from-registry #:coerce-entry-to-directory
#:coerce-name #:primary-system-name #:coerce-filename
#:find-system #:locate-system #:load-asd
#:find-system #:locate-system #:load-asd #:define-op
#:system-registered-p #:registered-system #:register-system
#:registered-systems* #:registered-systems
#:clear-system #:map-systems
#:missing-component #:missing-requires #:missing-parent
#:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error
#:load-system-definition-error #:error-name #:error-pathname #:error-condition
#:*system-definition-search-functions* #:search-for-system-definition
#:*central-registry* #:probe-asd #:sysdef-central-registry-search
......@@ -34,12 +33,6 @@
((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
(parent :initform nil :reader missing-parent :initarg :parent)))
(define-condition formatted-system-definition-error (system-definition-error)
((format-control :initarg :format-control :reader format-control)
(format-arguments :initarg :format-arguments :reader format-arguments))
(:report (lambda (c s)
(apply 'format s (format-control c) (format-arguments c)))))
(define-condition load-system-definition-error (system-definition-error)
((name :initarg :name :reader error-name)
(pathname :initarg :pathname :reader error-pathname)
......@@ -48,11 +41,6 @@
(format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
(error-name c) (error-pathname c) (error-condition c)))))
(defun sysdef-error (format &rest arguments)
(error 'formatted-system-definition-error :format-control
format :format-arguments arguments))
;;; Canonicalizing system names
(defun coerce-name (name)
......@@ -117,7 +105,7 @@ or NIL if not found."
(check-type system system)
(let ((name (component-name system)))
(check-type name string)
(asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
(asdf-message (compatfmt "~&~@<; ~@;Registering system ~3i~_~A~@:>~%") name)
(unless (eq system (registered-system name))
(setf (gethash name *defined-systems*)
(cons (ignore-errors (get-file-stamp (system-source-file system)))
......@@ -395,6 +383,17 @@ Going forward, we recommend new users should be using the source-registry.")
;; the precise protocol between the two functions may change in the future (or not).
(first (gethash `(find-system ,(coerce-name name)) (asdf-cache))))
(defclass define-op (non-propagating-operation) ()
(:documentation "An operation to record dependencies on loading a .asd file."))
(defmethod component-depends-on ((o define-op) (s system))
`((load-op ,@(system-defsystem-depends-on s))
,@(loop* :for (o . c) :in (definition-dependencies s) :collect (list o c))
,@(call-next-method)))
(defmethod component-depends-on ((o operation) (c undefined-system))
(sysdef-error "Trying to use undefined or incompletely defined system ~A" (coerce-name c)))
(defun load-asd (pathname
&key name (external-format (encoding-external-format (detect-encoding pathname)))
&aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
......@@ -402,27 +401,37 @@ Going forward, we recommend new users should be using the source-registry.")
NAME if supplied is the name of a system expected to be defined in that file.
Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
(with-asdf-session ()
(with-standard-io-syntax
(let ((*package* (find-package :asdf-user))
;; Note that our backward-compatible *readtable* is
;; a global readtable that gets globally side-effected. Ouch.
;; Same for the *print-pprint-dispatch* table.
;; We should do something about that for ASDF3 if possible, or else ASDF4.
(*readtable* readtable)
(*print-pprint-dispatch* print-pprint-dispatch)
(*print-readably* nil)
(*default-pathname-defaults*
;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
(pathname-directory-pathname (physicalize-pathname pathname))))
(handler-bind
(((and error (not missing-component))
#'(lambda (condition)
(error 'load-system-definition-error
:name name :pathname pathname :condition condition))))
(asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
name pathname)
(load* pathname :external-format external-format))))))
(nest
(with-asdf-session ())
(with-standard-io-syntax)
(let* ((primary-name (primary-system-name (or name (pathname-name pathname))))
(*package* (find-package :asdf-user))
;; Note that our backward-compatible *readtable* is
;; a global readtable that gets globally side-effected. Ouch.
;; Same for the *print-pprint-dispatch* table.
;; We should do something about that for ASDF3 if possible, or else ASDF4.
(*readtable* readtable)
(*print-pprint-dispatch* print-pprint-dispatch)
(*print-readably* nil)
(*default-pathname-defaults*
;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
(pathname-directory-pathname (physicalize-pathname pathname)))
(operation (make-operation 'define-op))
(system (or (registered-system primary-name)
(let ((system
(make-instance 'undefined-system
:name primary-name :source-file pathname)))
(register-system system)
system)))))
(while-visiting-action (operation system))
(handler-bind
(((and error (not missing-component))
#'(lambda (condition)
(error 'load-system-definition-error
:name name :pathname pathname :condition condition))))
(asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
name pathname)
(load* pathname :external-format external-format))))
(defvar *old-asdf-systems* (make-hash-table :test 'equal))
......
......@@ -4,7 +4,7 @@
(uiop/package:define-package :asdf/lisp-action
(:recycle :asdf/lisp-action :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/find-component :asdf/find-system
:asdf/component :asdf/system :asdf/find-system
:asdf/operation :asdf/action)
(:export
#:try-recompiling
......
......@@ -5,7 +5,7 @@
set here=%~dp0
set header_lisp=header.lisp
set driver_lisp=uiop\package.lisp + uiop\common-lisp.lisp + uiop\utility.lisp + uiop\version.lisp + uiop\os.lisp + uiop\pathname.lisp + uiop\filesystem.lisp + uiop\stream.lisp + uiop\image.lisp + uiop\lisp-build.lisp + uiop\launch-program.lisp + uiop\run-program.lisp + uiop\configuration.lisp + uiop\backward-driver.lisp + uiop\driver.lisp
set defsystem_lisp=upgrade.lisp + session.lisp + component.lisp + system.lisp + find-system.lisp + find-component.lisp + operation.lisp + action.lisp + lisp-action.lisp + plan.lisp + operate.lisp + parse-defsystem.lisp + bundle.lisp + concatenate-source.lisp + output-translations.lisp + source-registry.lisp + package-inferred-system.lisp + backward-interface.lisp + backward-internals.lisp + interface.lisp + user.lisp + footer.lisp
set defsystem_lisp=upgrade.lisp + session.lisp + component.lisp + operation.lisp + system.lisp + action.lisp + find-system.lisp + find-component.lisp + lisp-action.lisp + plan.lisp + operate.lisp + parse-defsystem.lisp + bundle.lisp + concatenate-source.lisp + package-inferred-system.lisp + output-translations.lisp + source-registry.lisp + backward-internals.lisp + backward-interface.lisp + interface.lisp + user.lisp + footer.lisp
%~d0
cd "%~p0"
......
......@@ -6,7 +6,7 @@ here="$(dirname $0)"
header_lisp="header.lisp"
driver_lisp="uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp"
defsystem_lisp="upgrade.lisp session.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp output-translations.lisp source-registry.lisp package-inferred-system.lisp backward-interface.lisp backward-internals.lisp interface.lisp user.lisp footer.lisp"
defsystem_lisp="upgrade.lisp session.lisp component.lisp operation.lisp system.lisp action.lisp find-system.lisp find-component.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp"
all () {
# Default action: bootstrap asdf.lisp
......
......@@ -87,14 +87,27 @@ But do NOT depend on it, for this is deprecated behavior."))
&key version &allow-other-keys)
(unless (version-satisfies component version)
(error 'missing-component-of-version :requires component :version version))
(when *plan*
(plan-record-dependency *plan* operation component)))
(record-dependency nil operation component))
(defun ensure-plan (operation component
&rest keys &key plan-class &allow-other-keys)
(declare (ignore operation))
(let ((session-plan (session-plan *asdf-session*)))
(cond
(session-plan
;; TODO: ensure compatibility between force in the two plans.
session-plan)
(t
(let ((new (apply 'make-instance (or plan-class *plan-class*)
:system (component-system component) keys)))
(setf (session-plan *asdf-session*) new)
new)))))
(defmethod operate ((operation operation) (component component)
&rest keys &key plan-class &allow-other-keys)
(let ((*plan* (apply 'make-plan plan-class operation component #|:parent *plan*|# keys)))
(apply 'perform-plan *plan* keys)
(values operation *plan*)))
(let ((plan (apply 'make-plan plan-class operation component keys)))
(apply 'perform-plan plan keys)
(values operation plan)))
(defun oos (operation component &rest args &key &allow-other-keys)
(apply 'operate operation component args))
......
......@@ -3,7 +3,7 @@
(uiop/package:define-package :asdf/operation
(:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5.
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session)
(:export
#:operation
#:*operations* #:make-operation #:find-operation
......
......@@ -4,8 +4,9 @@
(uiop:define-package :asdf/package-inferred-system
(:recycle :asdf/package-inferred-system :asdf/package-system :asdf)
(:use :uiop/common-lisp :uiop
:asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility
:asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action)
:asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/find-system :asdf/lisp-action
:asdf/parse-defsystem)
(:export
#:package-inferred-system #:sysdef-package-inferred-system-search
#:package-system ;; backward compatibility only. To be removed.
......
This diff is collapsed.
......@@ -2,31 +2,59 @@
;;;; Session cache
(uiop/package:define-package :asdf/session
(:recycle :asdf/session :asdf/cache)
(:recycle :asdf/session :asdf/cache :asdf/component
:asdf/action :asdf/find-system :asdf/plan :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade)
(:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
#:asdf-cache #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
#:do-asdf-cache #:normalize-namestring
#:call-with-asdf-session #:with-asdf-session
#:*asdf-session* #:*asdf-session-class* #:caching-session
#:clear-configuration-and-retry #:retry))
(:export
#:get-file-stamp #:compute-file-stamp #:register-file-stamp
#:asdf-cache #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
#:do-asdf-cache #:normalize-namestring
#:call-with-asdf-session #:with-asdf-session
#:*asdf-session* #:*asdf-session-class* #:session #:session-plan
#:visited-actions #:visiting-action-set #:visiting-action-list
#:total-action-count #:planned-action-count #:planned-output-action-count
#:clear-configuration-and-retry #:retry
;; conditions
#:system-definition-error ;; top level, moved here because this is the earliest place for it.
#:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error))
(in-package :asdf/session)
;;; The ASDF session cache is used to memoize some computations. It is instrumental in achieving:
;; * Consistency in the view of the world relied on by ASDF within a given session.
;; Inconsistencies in file stamps, system definitions, etc., could cause infinite loops
;; (a.k.a. stack overflows) and other erratic behavior.
;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and
;; no expensive recomputations of transitive dependencies for some input-files or output-files.
;; * Testability of ASDF with the ability to fake timestamps without actually touching files.
(with-upgradability ()
;; The session variable.
;; NIL when outside a session.
(defvar *asdf-session* nil)
(defparameter* *asdf-session-class* 'caching-session)
(defclass caching-session ()
((cache :initform (make-hash-table :test 'equal) :reader session-cache)))
(defparameter* *asdf-session-class* 'session
"The default class for sessions")
(defclass session ()
(;; The ASDF session cache is used to memoize some computations.
;; It is instrumental in achieving:
;; * Consistency in the view of the world relied on by ASDF within a given session.
;; Inconsistencies in file stamps, system definitions, etc., could cause infinite loops
;; (a.k.a. stack overflows) and other erratic behavior.
;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and
;; no expensive recomputations of transitive dependencies for input-files or output-files.
;; * Testability of ASDF with the ability to fake timestamps without actually touching files.
(cache
:initform (make-hash-table :test 'equal) :reader session-cache
:documentation "Memoize expensive computations")
(plan
:initform nil :accessor session-plan
:documentation "Dependency graph of actions")
;; Table that to actions already visited while walking the dependencies associates status
(visited-actions :initform (make-hash-table :test 'equal) :accessor visited-actions)
;; Actions that depend on those being currently walked through, to detect circularities
(visiting-action-set ;; as a set
:initform (make-hash-table :test 'equal) :accessor visiting-action-set)
(visiting-action-list :initform () :accessor visiting-action-list) ;; as a list
;; Counts of total actions in plan
(total-action-count :initform 0 :accessor total-action-count)
;; Count of actions that need to be performed
(planned-action-count :initform 0 :accessor planned-action-count)
;; Count of actions that need to be performed that have a non-empty list of output-files.
(planned-output-action-count :initform 0 :accessor planned-output-action-count))
(:documentation "An ASDF session with a cache to memoize some computations"))
(defun asdf-cache ()
(session-cache *asdf-session*))
......@@ -112,5 +140,26 @@
(defun get-file-stamp (file)
(when file
(let ((namestring (normalize-namestring file)))
(do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))))
(do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring)))))
;;; Conditions
(define-condition system-definition-error (error) ()
;; [this use of :report should be redundant, but unfortunately it's not.
;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
;; over print-object; this is always conditions::%print-condition for
;; condition objects, which in turn does inheritance of :report options at
;; run-time. fortunately, inheritance means we only need this kludge here in
;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
#+cmucl (:report print-object))
(define-condition formatted-system-definition-error (system-definition-error)
((format-control :initarg :format-control :reader format-control)
(format-arguments :initarg :format-arguments :reader format-arguments))
(:report (lambda (c s)
(apply 'format s (format-control c) (format-arguments c)))))
(defun sysdef-error (format &rest arguments)
(error 'formatted-system-definition-error :format-control
format :format-arguments arguments)))
......@@ -5,12 +5,12 @@
(:recycle :asdf :asdf/system)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component)
(:export
#:system #:proto-system
#:system #:proto-system #:undefined-system #:reset-system
#:system-source-file #:system-source-directory #:system-relative-pathname
#:reset-system
#:system-description #:system-long-description
#:system-author #:system-maintainer #:system-licence #:system-license
#:system-defsystem-depends-on #:system-depends-on #:system-weakly-depends-on
#:definition-dependencies #:system-defsystem-depends-on
#:system-depends-on #:system-weakly-depends-on
#:component-build-pathname #:build-pathname
#:component-entry-point #:entry-point
#:homepage #:system-homepage
......@@ -59,7 +59,7 @@ NB: This interface is subject to change. Please contact ASDF maintainers if you
(defclass proto-system () ; slots to keep when resetting a system
;; To preserve identity for all objects, we'd need keep the components slots
;; but also to modify parse-component-form to reset the recycled objects.
((name) (source-file) #|(children) (children-by-names)|#)
((name) (source-file))
(:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when
a SYSTEM is redefined and its class is modified."))
......@@ -85,19 +85,24 @@ a SYSTEM is redefined and its class is modified."))
(entry-point
:initform nil :initarg :entry-point :accessor component-entry-point)
(source-file :initform nil :initarg :source-file :accessor system-source-file)
;; This slot contains the *declared* defsystem-depends-on dependencies
(defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on
:initform nil)
;; This slot contains the *inferred* dependencies of define-op
(definition-dependencies :initform nil :accessor definition-dependencies)
;; these two are specially set in parse-component-form, so have no :INITARGs.
(depends-on :reader system-depends-on :initform nil)
(weakly-depends-on :reader system-weakly-depends-on :initform nil))
(:documentation "SYSTEM is the base class for top-level components that users may request
ASDF to build."))
(defclass undefined-system (system) ()
(:documentation "System that was not defined yet."))
(defun reset-system (system &rest keys &key &allow-other-keys)
"Erase any data from a SYSTEM except its basic identity, then reinitialize it
based on supplied KEYS."
(change-class (change-class system 'proto-system) 'system)
(change-class (change-class system 'proto-system) 'undefined-system)
(apply 'reinitialize-instance system keys)))
......
......@@ -32,7 +32,7 @@ Some constraints:
#:action-name #:in-plan-p
#:test-source #:test-fasl #:resolve-output #:output-location
#:quietly #:join-namestrings
#:clear-cache))
#:reset-session #:reset-session-visited))
(in-package :asdf-test)
......@@ -741,14 +741,14 @@ is bound, write a message and exit on an error. If
(assert (asymval '#:*file3* :test-package))))
(defun join-namestrings (namestrings)
(with-output-to-string (s)
(loop :with separator = (acall :inter-directory-separator)
:for (n . morep) :on namestrings
:do (format s "~A~@[~C~]" n (and morep separator)))))
(defun clear-cache ()
;; Or, should we preserve the timestamps?
(clrhash (acall :asdf-cache)))
(format nil (format nil "~~{~~A~~^~A~~}" (acall :inter-directory-separator)) namestrings))
(defun reset-session ()
(set (asym :*asdf-session*) nil))
(defun reset-session-visited ()
(clrhash (acall '#:visited-actions (asymval '#:*asdf-session*))))
;; These are shorthands for interactive debugging of test scripts:
(!a
......
;;; -*- Lisp -*-
(def-test-system test-compile-file-failure
:components ((:file "test-compile-file-failure")))
......@@ -9,6 +8,8 @@
t)
(compile-file-error () nil)))
(reset-session)
(with-expected-failure (#+gcl "GCL failure to report compile-file error")
(assert (handler-case
(let ((*compile-file-failure-behaviour* :error))
......
......@@ -45,15 +45,18 @@
(let ((*compile-file-warnings-behaviour* :ignore))
(load-system :use-foo-only :force t)))
(reset-session)
(handler-bind
((error (lambda (c) (DBG :cfwbi-ufww c))))
(load-system :use-foo-with-wrapper :force t))
(reset-session)
(handler-bind
((error (lambda (c) (DBG :cfwbi-usfo c))))
(let ((*compile-file-warnings-behaviour* :ignore))
(load-system :use-setf-foo-only :force t)))
(reset-session)
(DBG :tdw1 *warnings-file-type*)
(assert
(handler-case
......@@ -67,6 +70,7 @@
(unless *warnings-file-type*
(leave-test "Your Lisp does not support deferred-warnings" 0))
(reset-session)
(assert
(handler-case
(let ((*compile-file-warnings-behaviour* :error))
......@@ -74,6 +78,7 @@
nil)
(compile-warned-error () t)))
(reset-session)
(assert
(handler-case
(let ((*compile-file-warnings-behaviour* :error))
......@@ -81,16 +86,19 @@
nil)
(compile-warned-error () t)))
(reset-session)
(let ((*compile-file-warnings-behaviour* :error))
(load-system :use-then-defun-foo))
(setf *compile-file-warnings-behaviour* :error)
(reset-session)
(load-system :use-setf-then-defun-foo)
;; FIXME: on CCL, the defmacro warning is found while loading the defmacro fasl.
;; We should probably beef up the detection in reify-deferred-warnings,
;; possibly file a bug.
(reset-session)
(with-expected-failure (#+clozure "CCL warns while loading, not compiling")
(assert
(handler-case
......@@ -99,6 +107,7 @@
;;(t (c) (DBG :utdf0 c))
(:no-error (&rest values) (DBG :utdf1 values) nil))))
(reset-session)
(with-expected-failure (#+clozure "CCL warns while loading, not compiling")
(assert
(handler-case
......@@ -107,11 +116,14 @@
;;(t (c) (DBG :ustdf0 c))
(:no-error (&rest values) (DBG :ustdf1 values) nil))))
(reset-session)
(errors #+(or allegro clozure) compile-file-error
#+(or cmucl scl) compile-warned-error
#+sbcl compile-failed-error
(let ((*compile-file-warnings-behaviour* :error))
(load-system :undefined-variables :force t)))
(reset-session)
(errors #+(or allegro clozure) compile-file-error
#+(or cmucl scl) null
#+sbcl compile-failed-error
......
;;; -*- Lisp -*-
(defsystem "test-defsystem-depends-on-circular"
:defsystem-depends-on ("test-defsystem-depends-on-circular"))
......@@ -20,6 +20,7 @@
(assert-equal 0 l-operation:*x*)
(reset-session)
(make :test-defsystem-depends-on-2)
(assert-equal 2 l-operation:*x*) ;; perform called twice, on file and on system.
......@@ -29,10 +30,12 @@
:build-operation "does-not-exist"
:components ((:file "file3")))
(reset-session)
(signals asdf::formatted-system-definition-error (make :test-defsystem-depends-on-3))
(defparameter *newsym* (gentemp (symbol-name 'feature) :keyword))
(reset-session)