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

2.32.13: fix dependency issues for monolithic-fasl-op

Rename sibling-operation sideway-operation,
sibling-dependencies sideway-dependencies.
No one in quicklisp was using the old name.
Introduce selfward-operation for the common pattern.

Have a prepare-fasl-op to gracefully propagate fasl-op.

Reset component-depends-on when upgrading.

Refactor concatenate-source-op in a likewise fashion.
parent e6f50e36
......@@ -9,8 +9,8 @@
(:export
#:action #:define-convenience-action-methods
#:explain #:action-description
#:downward-operation #:upward-operation #:sibling-operation
#:component-depends-on #:component-self-dependencies
#:downward-operation #:upward-operation #:sideway-operation #:selfward-operation
#:component-depends-on
#: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
......@@ -88,7 +88,7 @@ You can put together sentences using this phrase."))
;;;; Dependencies
(with-upgradability ()
(defgeneric component-depends-on (operation component) ;; ASDF4: 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:
......@@ -106,19 +106,15 @@ You can put together sentences using this phrase."))
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))
(define-convenience-action-methods component-depends-on (operation component))
(define-convenience-action-methods component-self-dependencies (operation component))
(defmethod component-depends-on :around ((o operation) (c component))
(do-asdf-cache `(component-depends-on ,o ,c)
(call-next-method)))
(defmethod component-depends-on ((o operation) (c component))
(cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies
(cdr (assoc (type-of o) (component-in-order-to c))))) ; User-specified in-order dependencies
(defmethod component-self-dependencies ((o operation) (c component))
;; NB: result in the same format as component-depends-on
(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 (list o-spec c))))
;;;; upward-operation, downward-operation
;; These together handle actions that propagate along the component hierarchy.
......@@ -128,7 +124,7 @@ You can put together sentences using this phrase."))
(with-upgradability ()
(defclass downward-operation (operation)
((downward-operation
:initform nil :initarg :downward-operation :reader downward-operation)))
:initform nil :initarg :downward-operation :reader downward-operation :allocation :class)))
(defmethod component-depends-on ((o downward-operation) (c parent-component))
`((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method)))
;; Upward operations like prepare-op propagate up the component hierarchy:
......@@ -136,7 +132,7 @@ You can put together sentences using this phrase."))
;; By default, an operation propagates itself, but it may propagate another one instead.
(defclass upward-operation (operation)
((upward-operation
:initform nil :initarg :downward-operation :reader upward-operation)))
:initform nil :initarg :downward-operation :reader upward-operation :allocation :class)))
;; For backward-compatibility reasons, a system inherits from module and is a child-component
;; so we must guard against this case. ASDF4: remove that.
(defmethod component-depends-on ((o upward-operation) (c child-component))
......@@ -145,13 +141,22 @@ You can put together sentences using this phrase."))
;; Sibling operations propagate to siblings in the component hierarchy:
;; operation on a child depends-on operation on its parent.
;; By default, an operation propagates itself, but it may propagate another one instead.
(defclass sibling-operation (operation)
((sibling-operation
:initform nil :initarg :sibling-operation :reader sibling-operation)))
(defmethod component-depends-on ((o sibling-operation) (c component))
`((,(or (sibling-operation o) o)
,@(loop :for dep :in (component-sibling-dependencies c)
(defclass sideway-operation (operation)
((sideway-operation
:initform nil :initarg :sideway-operation :reader sideway-operation :allocation :class)))
(defmethod component-depends-on ((o sideway-operation) (c component))
`((,(or (sideway-operation o) o)
,@(loop :for dep :in (component-sideway-dependencies c)
:collect (resolve-dependency-spec c dep)))
,@(call-next-method)))
;; Selfward operations propagate to themselves a sub-operation:
;; they depend on some other operation being acted on the same component.
(defclass selfward-operation (operation)
((selfward-operation
:initform nil :initarg :selfward-operation :reader selfward-operation :allocation :class)))
(defmethod component-depends-on ((o selfward-operation) (c component))
`(,@(loop :for op :in (ensure-list (selfward-operation o))
:collect `(,op ,c))
,@(call-next-method))))
......@@ -201,17 +206,16 @@ You can put together sentences using this phrase."))
(do-asdf-cache `(input-files ,operation ,component)
(call-next-method)))
(defmethod input-files ((o operation) (c parent-component))
(defmethod input-files ((o operation) (c component))
(declare (ignorable o c))
nil)
(defmethod input-files ((o operation) (c 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
(if-let ((pathname (component-pathname c)))
(and (file-pathname-p pathname) (list pathname))))))
(defmethod input-files ((o selfward-operation) (c component))
`(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o))
:append (or (output-files dep-o c) (input-files dep-o c)))
(if-let ((pathname (component-pathname c)))
(and (file-pathname-p pathname) (list pathname))))
,@(call-next-method))))
;;;; Done performing
......
......@@ -74,7 +74,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.32.12" ;; to be automatically updated by make bump-version
:version "2.32.13" ;; 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.
......
......@@ -34,7 +34,7 @@
(defun component-load-dependencies (component)
;; Old deprecated name for the same thing. Please update your software.
(component-sibling-dependencies component))
(component-sideway-dependencies component))
(defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader.
(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
......
......@@ -7,13 +7,14 @@
:asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
:asdf/action :asdf/lisp-action :asdf/plan :asdf/operate)
(:export
#:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-pathname-type
#:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op
#:monolithic-op #:monolithic-bundle-op #:bundlable-file-p #:direct-dependency-files
#:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op
#:program-op
#:compiled-file #:precompiled-system #:prebuilt-system
#:operation-monolithic-p
#:bundle-op #:bundle-op-build-args #:bundle-type
#:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files
#:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
#:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op
#:lib-op #:monolithic-lib-op
#:dll-op #:monolithic-dll-op
#:binary-op #:monolithic-binary-op
#:program-op #:compiled-file #:precompiled-system #:prebuilt-system
#:user-system-p #:user-system #:trivial-system-p
#+ecl #:make-build
#:register-pre-built-system
......@@ -29,27 +30,34 @@
#+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p)
#+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p)))
(defclass fasl-op (bundle-op)
;; create a single fasl for the entire library
;; create a single fasl for the entire library
(defclass basic-fasl-op (bundle-op basic-compile-op)
((bundle-type :initform :fasl)))
(defclass load-fasl-op (basic-load-op)
;; load a single fasl for the entire library
())
(defclass lib-op (bundle-op)
;; On ECL: compile the system and produce linkable .a library for it.
;; On others: just compile the system.
(defclass prepare-fasl-op (sideway-operation)
((sideway-operation :initform 'load-fasl-op)))
(defclass fasl-op (basic-fasl-op selfward-operation)
((selfward-operation :initform '(prepare-fasl-op #+ecl lib-op))))
(defclass load-fasl-op (basic-load-op selfward-operation)
((selfward-operation :initform '(prepare-op fasl-op))))
;; NB: since the monolithic-op's can't be sideway-operation's,
;; if we wanted lib-op, dll-op, binary-op to be sideway-operation's,
;; we'd have to have the monolithic-op not inherit from the main op,
;; but instead inherit from a basic-FOO-op as with basic-fasl-op above.
;; On ECL: compile the system and produce linkable ".a" library for it.
;; On others: just compile the system.
(defclass lib-op (bundle-op basic-compile-op)
((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)))
(defclass dll-op (bundle-op)
(defclass dll-op (bundle-op basic-compile-op)
;; Link together all the dynamic library used by this system into a single one.
((bundle-type :initform :dll)))
(defclass binary-op (bundle-op)
(defclass binary-op (bundle-op basic-compile-op selfward-operation)
;; On ECL: produce lib and fasl for the system.
;; On "normal" Lisps: produce just the fasl.
())
((selfward-operation :initform '(lib-op fasl-op))))
(defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies
......@@ -57,25 +65,30 @@
((prologue-code :accessor monolithic-op-prologue-code)
(epilogue-code :accessor monolithic-op-epilogue-code)))
(defclass monolithic-binary-op (binary-op monolithic-bundle-op)
(defclass monolithic-binary-op (monolithic-bundle-op basic-compile-op sideway-operation selfward-operation)
;; On ECL: produce lib and fasl for combined system and dependencies.
;; On "normal" Lisps: produce an image file from system and dependencies.
())
((selfward-operation :initform '(monolithic-fasl-op monolithic-lib-op))))
(defclass monolithic-fasl-op (monolithic-bundle-op fasl-op)
(defclass monolithic-fasl-op (monolithic-bundle-op basic-fasl-op selfward-operation)
;; Create a single fasl for the system and its dependencies.
())
((selfward-operation :initform 'load-fasl-op)))
(defclass monolithic-lib-op (monolithic-bundle-op lib-op)
(defclass monolithic-lib-op (monolithic-bundle-op basic-compile-op sideway-operation selfward-operation)
;; ECL: Create a single linkable library for the system and its dependencies.
((bundle-type :initform :lib)))
((bundle-type :initform :lib)
(selfward-operation :initform 'lib-op)
(sideway-operation :initform 'lib-op)))
(defclass monolithic-dll-op (monolithic-bundle-op dll-op)
((bundle-type :initform :dll)))
(defclass monolithic-dll-op (monolithic-bundle-op basic-compile-op sideway-operation selfward-operation)
((bundle-type :initform :dll)
(selfward-operation :initform 'dll-op)
(sideway-operation :initform 'dll-op)))
(defclass program-op (monolithic-bundle-op)
(defclass program-op (monolithic-bundle-op selfward-operation)
;; All: create an executable file from the system and its dependencies
((bundle-type :initform :program)))
((bundle-type :initform :program)
(selfward-operation :initform #+(or mkcl ecl) 'monolithic-lib-op #-(or mkcl ecl) 'load-op)))
(defun bundle-pathname-type (bundle-type)
(etypecase bundle-type
......@@ -195,47 +208,33 @@
(defmethod component-depends-on ((o monolithic-lib-op) (c system))
(declare (ignorable o))
`((lib-op ,@(required-components c :other-systems t :component-type 'system
:goal-operation 'load-op
:keep-operation 'compile-op))))
:goal-operation (find-operation o 'load-op)
:keep-operation 'compile-op))
,@(call-next-method)))
(defmethod component-depends-on ((o monolithic-fasl-op) (c system))
(declare (ignorable o))
`((fasl-op ,@(required-components c :other-systems t :component-type 'system
:goal-operation 'load-fasl-op
:keep-operation 'fasl-op))))
(defmethod component-depends-on ((o program-op) (c system))
(declare (ignorable o))
#+(or ecl mkcl) (component-depends-on (make-operation 'monolithic-lib-op) c)
#-(or ecl mkcl) `((load-op ,c)))
(defmethod component-depends-on ((o binary-op) (c system))
(declare (ignorable o))
`((fasl-op ,c)
(lib-op ,c)))
(defmethod component-depends-on ((o monolithic-binary-op) (c system))
`((,(find-operation o 'monolithic-fasl-op) ,c)
(,(find-operation o 'monolithic-lib-op) ,c)))
:goal-operation (find-operation o 'load-fasl-op)
:keep-operation 'fasl-op))
,@(call-next-method)))
(defmethod component-depends-on ((o lib-op) (c system))
(declare (ignorable o))
`((compile-op ,@(required-components c :other-systems nil :component-type '(not system)
:goal-operation 'load-op
:keep-operation 'compile-op))))
:goal-operation (find-operation o 'load-op)
:keep-operation 'compile-op))
,@(call-next-method)))
#-ecl
(defmethod component-depends-on ((o fasl-op) (c system))
(declare (ignorable o))
#+ecl `((lib-op ,c))
#-ecl
(component-depends-on (find-operation o 'lib-op) c))
`(,@(component-depends-on (find-operation o 'lib-op) c)
,@(call-next-method)))
(defmethod component-depends-on ((o dll-op) c)
(component-depends-on (find-operation o 'lib-op) c))
(defmethod component-depends-on ((o bundle-op) c)
(declare (ignorable o c))
nil)
`(,@(component-depends-on (find-operation o 'lib-op) c)
,@(call-next-method)))
(defmethod component-depends-on :around ((o bundle-op) (c component))
(declare (ignorable o c))
......@@ -300,7 +299,7 @@
(with-upgradability ()
(defmethod component-depends-on ((o load-fasl-op) (c system))
(declare (ignorable o))
`((,o ,@(loop :for dep :in (component-sibling-dependencies c)
`((,o ,@(loop :for dep :in (component-sideway-dependencies c)
:collect (resolve-dependency-spec c dep)))
(,(if (user-system-p c) 'fasl-op 'load-op) ,c)
,@(call-next-method)))
......
......@@ -14,7 +14,7 @@
#:static-file #:doc-file #:html-file
#:file-type
#:source-file-type #:source-file-explicit-type ;; backward-compatibility
#:component-in-order-to #:component-sibling-dependencies
#:component-in-order-to #:component-sideway-dependencies
#:component-if-feature #:around-compile-hook
#:component-description #:component-long-description
#:component-version #:version-satisfies
......@@ -33,7 +33,7 @@
#:components-by-name #:components
#:children #:children-by-name #:default-component-class
#:author #:maintainer #:licence #:source-file #:defsystem-depends-on
#:sibling-dependencies #:if-feature #:in-order-to #:inline-methods
#:sideway-dependencies #:if-feature #:in-order-to #:inline-methods
#:relative-pathname #:absolute-pathname #:operation-times #:around-compile
#:%encoding #:properties #:component-properties #:parent))
(in-package :asdf/component)
......@@ -77,7 +77,7 @@ another pathname in a degenerate way."))
(version :accessor component-version :initarg :version :initform nil)
(description :accessor component-description :initarg :description :initform nil)
(long-description :accessor component-long-description :initarg :long-description :initform nil)
(sibling-dependencies :accessor component-sibling-dependencies :initform nil)
(sideway-dependencies :accessor component-sideway-dependencies :initform nil)
(if-feature :accessor component-if-feature :initform nil :initarg :if-feature)
;; In the ASDF object model, dependencies exist between *actions*,
;; where an action is a pair of an operation and a component.
......
......@@ -22,21 +22,29 @@
;;; Concatenate sources
;;;
(with-upgradability ()
(defclass concatenate-source-op (bundle-op)
(defclass basic-concatenate-source-op (bundle-op)
((bundle-type :initform "lisp")))
(defclass load-concatenated-source-op (basic-load-op operation)
((bundle-type :initform :no-output-file)))
(defclass compile-concatenated-source-op (basic-compile-op bundle-op)
((bundle-type :initform :fasl)))
(defclass load-compiled-concatenated-source-op (basic-load-op operation)
((bundle-type :initform :no-output-file)))
(defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ())
(defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ())
(defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-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 concatenate-source-op (basic-concatenate-source-op) ())
(defclass load-concatenated-source-op (basic-load-concatenated-source-op)
((selfward-operation :initform '(prepare-op concatenate-source-op))))
(defclass compile-concatenated-source-op (basic-compile-concatenated-source-op)
((selfward-operation :initform '(prepare-op concatenate-source-op))))
(defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
((selfward-operation :initform '(prepare-op compile-concatenated-source-op))))
(defmethod input-files ((operation concatenate-source-op) (s system))
(defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op) ())
(defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op)
((selfward-operation :initform 'monolithic-concatenate-source-op)))
(defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op)
((selfward-operation :initform 'monolithic-concatenate-source-op)))
(defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
((selfward-operation :initform 'monolithic-compile-concatenated-source-op)))
(defmethod input-files ((operation basic-concatenate-source-op) (s system))
(loop :with encoding = (or (component-encoding s) *default-encoding*)
:with other-encodings = '()
:with around-compile = (around-compile-hook s)
......@@ -62,43 +70,17 @@
(warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
operation around-compile other-around-compile))
(return inputs)))
(defmethod output-files ((o basic-compile-concatenated-source-op) (s system))
(lisp-compilation-output-files o s))
(defmethod input-files ((o load-concatenated-source-op) (s system))
(direct-dependency-files o s))
(defmethod input-files ((o compile-concatenated-source-op) (s system))
(direct-dependency-files o 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))
(direct-dependency-files o s))
(defmethod perform ((o concatenate-source-op) (s system))
(defmethod perform ((o basic-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))
(defmethod perform ((o basic-load-concatenated-source-op) (s system))
(perform-lisp-load-source o s))
(defmethod perform ((o compile-concatenated-source-op) (s system))
(defmethod perform ((o basic-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))))
(defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system))
(perform-lisp-load-fasl o s)))
......@@ -178,7 +178,7 @@
:when serial :do (setf previous-component name)))
(compute-children-by-name component))
;; Used by POIU. ASDF4: rename to component-depends-on?
(setf (component-sibling-dependencies component) depends-on)
(setf (component-sideway-dependencies component) depends-on)
(%refresh-component-inline-methods component rest)
(when if-component-dep-fails
(%resolve-if-component-dep-fails if-component-dep-fails component))
......
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.32.12: Another System Definition Facility.
;;; This is ASDF 2.32.13: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -24,20 +24,23 @@
#:search-for-system-definition #:find-component #:component-find-path
#:compile-system #:load-system #:load-systems
#:require-system #:test-system #:clear-system
#:operation #:upward-operation #:downward-operation #:make-operation
#:operation #:make-operation #:find-operation
#:upward-operation #:downward-operation #:sideway-operation #:selfward-operation
#:build-system #:build-op
#:load-op #:prepare-op #:compile-op
#:prepare-source-op #:load-source-op #:test-op
#:feature #:version #:version-satisfies #:upgrade-asdf
#:implementation-identifier #:implementation-type #:hostname
#:input-files #:output-files #:output-file #:perform
#:operation-done-p #:explain #:action-description #:component-sibling-dependencies
#:operation-done-p #:explain #:action-description #:component-sideway-dependencies
#:needed-in-image-p
;; #:run-program ; we can't export it, because SB-GROVEL :use's both ASDF and SB-EXT.
#:component-load-dependencies #:run-shell-command ; deprecated, do not use
#:bundle-op #:precompiled-system #:compiled-file #:bundle-system
#:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system
#+ecl #:make-build
#:program-op #:load-fasl-op #:fasl-op #:lib-op #:binary-op
#:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op
#:lib-op #:dll-op #:binary-op #:program-op
#:monolithic-lib-op #:monolithic-dll-op #:monolithic-binary-op
#:concatenate-source-op
#:load-concatenated-source-op
#:compile-concatenated-source-op
......
......@@ -13,7 +13,8 @@
#:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations
#:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
#:call-with-around-compile-hook
#:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source #:flags))
#:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source
#:lisp-compilation-output-files #:flags))
(in-package :asdf/lisp-action)
......@@ -37,17 +38,23 @@
;;; Our default operations: loading into the current lisp image
(with-upgradability ()
(defclass load-op (basic-load-op downward-operation sibling-operation) ())
(defclass prepare-op (upward-operation sibling-operation)
((sibling-operation :initform 'load-op :allocation :class)))
(defclass compile-op (basic-compile-op downward-operation)
((downward-operation :initform 'load-op :allocation :class)))
(defclass prepare-op (upward-operation sideway-operation)
((sideway-operation :initform 'load-op)))
(defclass load-op (basic-load-op downward-operation sideway-operation selfward-operation)
;; NB: even though compile-op depends-on on prepare-op it is not needed-in-image-p,
;; so we need to directly depend on prepare-op for its side-effects in the current image.
((selfward-operation :initform '(prepare-op compile-op))))
(defclass compile-op (basic-compile-op downward-operation selfward-operation)
((selfward-operation :initform 'prepare-op)
(downward-operation :initform 'load-op)))
(defclass load-source-op (basic-load-op downward-operation) ())
(defclass prepare-source-op (upward-operation sibling-operation)
((sibling-operation :initform 'load-source-op :allocation :class)))
(defclass prepare-source-op (upward-operation sideway-operation)
((sideway-operation :initform 'load-source-op)))
(defclass load-source-op (basic-load-op downward-operation selfward-operation)
((selfward-operation :initform 'prepare-source-op)))
(defclass test-op (operation) ()))
(defclass test-op (selfward-operation)
((selfward-operation :initform 'load-op))))
;;;; prepare-op, compile-op and load-op
......@@ -123,8 +130,7 @@
(format s ":success~%"))))))
(defmethod perform ((o compile-op) (c cl-source-file))
(perform-lisp-compilation o c))
(defmethod output-files ((o compile-op) (c cl-source-file))
(declare (ignorable o))
(defun lisp-compilation-output-files (o c)
(let* ((i (first (input-files o c)))
(f (compile-file-pathname
i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)))
......@@ -138,9 +144,8 @@
,(compile-file-pathname i :fasl-p nil) ;; object file
,@(when (and *warnings-file-type* (not (builtin-system-p (component-system c))))
`(,(make-pathname :type *warnings-file-type* :defaults f))))))
(defmethod component-depends-on ((o compile-op) (c component))
(declare (ignorable o))
`((prepare-op ,c) ,@(call-next-method)))
(defmethod output-files ((o compile-op) (c cl-source-file))
(lisp-compilation-output-files o c))
(defmethod perform ((o compile-op) (c static-file))
(declare (ignorable o c))
nil)
......@@ -190,13 +195,7 @@
(perform-lisp-load-fasl o c))
(defmethod perform ((o load-op) (c static-file))
(declare (ignorable o c))
nil)
(defmethod component-depends-on ((o load-op) (c component))
(declare (ignorable o))
;; NB: even though compile-op depends-on on prepare-op,
;; it is not needed-in-image-p, whereas prepare-op is,
;; so better not omit prepare-op and think it will happen.
`((prepare-op ,c) (compile-op ,c) ,@(call-next-method))))
nil))
;;;; prepare-source-op, load-source-op
......@@ -224,9 +223,6 @@
(defmethod action-description ((o load-source-op) (c parent-component))
(declare (ignorable o))
(format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c))
(defmethod component-depends-on ((o load-source-op) (c component))
(declare (ignorable o))
`((prepare-source-op ,c) ,@(call-next-method)))
(defun perform-lisp-load-source (o c)
(call-with-around-compile-hook
c #'(lambda ()
......@@ -252,9 +248,5 @@
(defmethod operation-done-p ((o test-op) (c system))
"Testing a system is _never_ done."
(declare (ignorable o c))
nil)
(defmethod component-depends-on ((o test-op) (c system))
(declare (ignorable o))
`((load-op ,c) ,@(call-next-method))))
nil))
......@@ -438,6 +438,7 @@ processed in order by OPERATE."))
(defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
(remove-duplicates
(mapcar 'cdr (apply 'traverse-sub-actions goal-operation system keys))
(mapcar 'cdr (apply 'traverse-sub-actions goal-operation system
(remove-plist-key :goal-operation keys)))
:from-end t)))
......@@ -26,9 +26,9 @@
(output-files mcso sys)
(input-files mccso sys))
;; on ECL, we get un-equal pathnames.
(assert-pathname-equal
(output-file mccso sys)
(test-fasl "test-concatenate-source--all-systems.lisp"))
(assert-pathnames-equal
(output-files mccso sys)
(list (test-fasl "test-concatenate-source--all-systems.lisp")))
(assert-pathnames-equal
(output-files mccso sys)
(input-files mlccso sys))
......
......@@ -106,7 +106,7 @@
asdf/component:parent
asdf/component:properties
asdf/component:relative-pathname
asdf/component:sibling-dependencies
asdf/component:sideway-dependencies
asdf/component:version
asdf/lisp-action:flags
asdf/operation:feature
......
;;; -*- Lisp -*-
(trace load compile-file perform-plan asdf/plan:traverse-action) ;; perform asdf/plan:compute-action-stamp
(setf asdf/cache:*asdf-cache* nil) ;; disable cache between those two very different compilations.
#+gcl (trace load compile-file asdf:perform asdf::perform-plan)
(progn
(let ((foo :test-asdf-location-change))
(DBG "load foo. Should load from xach-foo-1/")
(setf *central-registry* (list (subpathname *test-directory* "xach-foo-1/")))
(load-system foo)
(let ((foo1 (find-system foo))
(loaded (find-symbol* :loaded :first-version)))
(assert-equal (symbol-value loaded) t)
(DBG "load foo again. Should not do anything -- already loaded")
(setf (symbol-value loaded) :test-that-we-dont-reload)
(load-system foo)
(assert-equal (symbol-value loaded) :test-that-we-dont-reload)
(defparameter foo :test-asdf-location-change)
(assert (not (find-package :second-version)))
(DBG "Now, change registry so foo is found from xach-foo-2/")
(setf *central-registry* (list (subpathname *test-directory* "xach-foo-2/")))
(DBG "load foo yet again. It should see the pathname has changed and load it anew")
(load-system foo)
(let ((foo2 (find-system foo)))
(assert (eq foo1 foo2)) ;; the object should be the same
(assert (symbol-value (find-symbol* :loaded :second-version)))
(assert-equal 42 (symbol-call :second-version :wtf))))))
(DBG "load foo. Should load from xach-foo-1/")
(setf *central-registry* (list (subpathname *test-directory* "xach-foo-1/")))
(defparameter foo1 (find-system foo))
(assert-pathname-equal
(subpathname *test-directory* "xach-foo-1/test-asdf-location-change.asd")
(system-source-file foo1))
(assert-equal (mapcar 'component-name (component-children foo1)) '("a"))
(assert-pathname-equal
(subpathname *test-directory* "xach-foo-1/a.lisp")
(component-pathname (find-component foo1 "a")))
(assert-equal nil (find-component foo1 "b"))
(load-system foo)
(defparameter loaded (find-symbol* :loaded :first-version))
(assert-equal (symbol-value loaded) t)
(DBG "load foo again. Should not do anything -- already loaded")
(setf (symbol-value loaded) :test-that-we-dont-reload)
(load-system foo)
(assert-equal (symbol-value loaded) :test-that-we-dont-reload)
(assert (not (find-package :second-version)))
(DBG "Now, change registry so foo is found from xach-foo-2/")
(setf *central-registry* (list (subpathname *test-directory* "xach-foo-2/")))
(defparameter foo2 (find-system foo))
(assert (eq foo1 foo2)) ;; the object should be the same
(assert-equal (mapcar 'component-name (component-children foo2)) '("a" "b"))
(assert-pathname-equal
(subpathname *test-directory* "xach-foo-2/test-asdf-location-change.asd")
(system-source-file foo2))
(assert-pathname-equal
(subpathname *test-directory* "xach-foo-2/a.lisp")
(component-pathname (find-component foo2 "a")))
(assert-pathname-equal
(subpathname *test-directory* "xach-foo-2/b.lisp")
(component-pathname (find-component foo2 "b")))
(DBG "load foo yet again. It should see the pathname has changed and load it anew")
(load-system foo)
(assert (symbol-value (find-symbol* :loaded :second-version)))
(assert-equal 42 (symbol-call :second-version :wtf))
......@@ -15,7 +15,8 @@
#:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
#:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions
#:if-let ;; basic flow control
#:while-collecting #:appendf #:length=n-p #:remove-plist-keys #:remove-plist-key ;; lists and plists
#:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
#:remove-plist-keys #:remove-plist-key ;; plists
#:emptyp ;; sequences
#:strcat #:first-char #:last-char #:split-string ;; strings
#:string-prefix-p #:string-enclosed-p #:string-suffix-p
......@@ -154,7 +155,11 @@ Returns two values: \(A B C\) and \(1 2 3\)."
:for i :downfrom n :do
(cond
((zerop i) (return (null l)))
((not (consp l)) (return nil))))))
((not (consp l)) (return nil)))))
(defun ensure-list (x)
(if (listp x) x (list x))))
;;; remove a key from a plist, i.e. for keyword argument cleanup
(with-upgradability ()
......
......@@ -52,7 +52,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
(asdf-version "2.32.12")
(asdf-version "2.32.13")
(existing-version (asdf-version)))
(setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version)))
......@@ -69,7 +69,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
#:find-system #:system-source-file #:system-relative-pathname ;; system
#:find-component ;; find-component
#:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
#:component-depends-on #:component-self-dependencies #:operation-done-p
#:component-depends-on #:operation-done-p #:component-depends-on
#:traverse ;; plan
#:operate ;; operate
#:parse-component-form ;; defsystem
......@@ -83,6 +83,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
(uninterned-symbols