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

2.26.1: Automatic self-upgrade in more situations for robustness;

to this end, refactor operate with new variable *systems-being-operated*
and new gf plan-operates-on-p.
Remove obsolete asdf-ecl now superseded by asdf-bundle.
Simplify a few functions.
parent 8e4389ec
;;; Copyright (c) 2005 - 2007, Michael Goffioul (michael dot goffioul at swing dot be)
;;; Copyright (c) 2008 - 2012, Juan Jose Garcia Ripoll
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; See file 'ecl/Copyright' for full details.
;;;
;;; ECL SPECIFIC OPERATIONS FOR ASDF
;;;
#+xcvb (module (:depends-on ("asdf")))
(in-package :asdf)
;;;
;;; COMPILE-OP / LOAD-OP (in asdf.lisp)
;;;
;;; In ECL, these operations produce both FASL files and the
;;; object files that they are built from. Having both of them allows
;;; us to later on reuse the object files for bundles, libraries,
;;; standalone executables, etc.
;;;
;;;
;;; BUNDLE-OP
;;;
;;; This operation takes all components from one or more systems and
;;; creates a single output file, which may be a FASL, a statically
;;; linked library, a shared library, etc The different targets are
;;; defined by specialization.
;;;
(defclass bundle-op (operation)
((type :reader bundle-op-type)
(monolithic :initform nil :reader bundle-op-monolithic-p)
(name-suffix :initarg :name-suffix :initform nil)
(build-args :initarg :args :initform nil :accessor bundle-op-build-args)
(lisp-files :initform nil :accessor bundle-op-lisp-files)))
(defclass fasl-op (bundle-op)
((type :initform :fasl)))
(defclass lib-op (bundle-op)
((type :initform :lib)))
(defclass dll-op (bundle-op)
((type :initform :dll)))
(defclass monolithic-bundle-op (bundle-op)
((monolithic :initform t)
(prologue-code :accessor monolithic-op-prologue-code)
(epilogue-code :accessor monolithic-op-epilogue-code)))
(defclass monolithic-fasl-op (monolithic-bundle-op fasl-op) ())
(defclass monolithic-lib-op (monolithic-bundle-op lib-op)
((type :initform :lib)))
(defclass monolithic-dll-op (monolithic-bundle-op dll-op)
((type :initform :dll)))
(defclass program-op (monolithic-bundle-op)
((type :initform :program)))
(defmethod initialize-instance :after ((instance bundle-op) &rest initargs
&key (name-suffix nil name-suffix-p)
&allow-other-keys)
(declare (ignorable initargs name-suffix))
(unless name-suffix-p
(setf (slot-value instance 'name-suffix)
(if (bundle-op-monolithic-p instance) "-mono" "")))
(when (typep instance 'monolithic-bundle-op)
(destructuring-bind (&rest original-initargs
&key lisp-files prologue-code epilogue-code
&allow-other-keys)
(slot-value instance 'original-initargs)
(setf (slot-value instance 'original-initargs)
(remove-keys '(lisp-files epilogue-code prologue-code) original-initargs)
(bundle-op-lisp-files instance) lisp-files
(monolithic-op-prologue-code instance) prologue-code
(monolithic-op-epilogue-code instance) epilogue-code)))
(setf (bundle-op-build-args instance)
(remove-keys '(type monolithic name-suffix)
(slot-value instance 'original-initargs))))
(defmethod bundle-op-build-args :around ((op lib-op))
(declare (ignorable op))
(let ((args (call-next-method)))
(remf args :ld-flags)
args))
(defvar *force-load-p* nil)
(defmethod operation-done-p :around ((operation load-op) c)
(declare (ignorable operation c))
(if *force-load-p* nil (call-next-method)))
(defun gather-components (op-type system &key filter-system filter-type include-self)
;; This function creates a list of components, matched together with an
;; operation. This list may be restricted to sub-components of SYSTEM if
;; GATHER-ALL = NIL (default), and it may include the system itself.
(let* ((operation (make-instance op-type))
(*force-load-p* t)
(tree (traverse (make-instance 'load-op) system)))
(append
(loop :for (op . component) :in tree
:when (and (typep op 'load-op)
(typep component filter-type)
(or (not filter-system) (eq (component-system component) filter-system)))
:collect (progn
(when (eq component system) (setf include-self nil))
(cons operation component)))
(and include-self (list (cons operation system))))))
;;;
;;; BUNDLE-SUB-OPERATIONS
;;;
;;; Builds a list of pairs (operation . component) which contains all the
;;; dependencies of this bundle. This list is used by TRAVERSE and also
;;; by INPUT-FILES. The dependencies depend on the strategy, as explained
;;; below.
;;;
(defgeneric bundle-sub-operations (operation component))
;;;
;;; First we handle monolithic bundles. These are standalone systems
;;; which contain everything, including other ASDF systems required
;;; by the current one. A PROGRAM is always monolithic.
;;;
;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
;;;
;;; Gather the static libraries of all components.
;;;
(defmethod bundle-sub-operations ((o monolithic-bundle-op) c)
(declare (ignorable o))
(gather-components 'lib-op c :filter-type 'system :include-self t))
;;;
;;; STATIC LIBRARIES
;;;
;;; Gather the object files of all components and, if monolithic, also
;;; of systems and subsystems.
;;;
(defmethod bundle-sub-operations ((o lib-op) c)
(gather-components 'compile-op c
:filter-system (and (not (bundle-op-monolithic-p o)) c)
:filter-type '(not system)))
(defmethod bundle-sub-operations ((o monolithic-lib-op) c)
(declare (ignorable o))
(gather-components 'compile-op c
:filter-system nil
:filter-type '(not system)))
;;;
;;; SHARED LIBRARIES
;;;
;;; Gather the dynamically linked libraries of all components.
;;; They will be linked into this new shared library, together
;;; with the static library of this module.
;;;
(defmethod bundle-sub-operations ((o dll-op) c)
(declare (ignorable o))
(list (cons (make-instance 'lib-op) c)))
;;;
;;; FASL FILES
;;;
;;; Gather the statically linked library of this component.
;;;
(defmethod bundle-sub-operations ((o fasl-op) c)
(declare (ignorable o))
(list (cons (make-instance 'lib-op) c)))
(defmethod component-depends-on ((o bundle-op) (c system))
(loop :for (op . dep) :in (bundle-sub-operations o c)
:when (typep dep 'system)
:collect (list (class-name (class-of op))
(component-name dep))))
(defmethod component-depends-on ((o lib-op) (c system))
(declare (ignorable o))
(list (list 'compile-op (component-name c))))
(defmethod component-depends-on ((o bundle-op) c)
(declare (ignorable o c))
nil)
(defmethod input-files ((o bundle-op) (c system))
(loop :for (sub-op . sub-c) :in (bundle-sub-operations o c)
:nconc (output-files sub-op sub-c)))
(defmethod output-files ((o bundle-op) (c system))
(let ((name (concatenate 'base-string (component-name c)
(slot-value o 'name-suffix))))
(list (merge-pathnames* (compile-file-pathname name :type (bundle-op-type o))
(component-relative-pathname c)))))
(defmethod output-files ((o fasl-op) (c system))
(declare (ignorable o c))
(loop :for file :in (call-next-method)
:collect (make-pathname :type "fasb" :defaults file)))
(defmethod perform ((o bundle-op) (c t))
(declare (ignorable o c))
t)
(defmethod operation-done-p ((o bundle-op) (c source-file))
(declare (ignorable o c))
t)
(defmethod perform ((o bundle-op) (c system))
(let* ((object-files (remove "fas" (input-files o c)
:key #'pathname-type :test #'string=))
(output (output-files o c)))
(ensure-directories-exist (first output))
(apply #'c::builder (bundle-op-type o) (first output)
:lisp-files (append object-files (bundle-op-lisp-files o))
(append (bundle-op-build-args o)
(when (and (typep o 'monolithic-bundle-op)
(monolithic-op-prologue-code o))
`(:prologue-code ,(monolithic-op-prologue-code o)))
(when (and (typep o 'monolithic-bundle-op)
(monolithic-op-epilogue-code o))
`(:epilogue-code ,(monolithic-op-epilogue-code o)))))))
(defun select-operation (monolithic type)
(ecase type
((:binary)
(if monolithic 'monolithic-binary-op 'binary-op))
((:dll :shared-library)
(if monolithic 'monolithic-dll-op 'dll-op))
((:lib :static-library)
(if monolithic 'monolithic-lib-op 'lib-op))
((:fasl)
(if monolithic 'monolithic-fasl-op 'fasl-op))
((:program)
'program-op)))
(defun make-build (system &rest args &key (monolithic nil) (type :fasl)
(move-here nil move-here-p)
&allow-other-keys)
(let* ((operation-name (select-operation monolithic type))
(move-here-path (if (and move-here
(typep move-here '(or pathname string)))
(pathname move-here)
(merge-pathnames "./asdf-output/")))
(operation (apply #'operate operation-name
system
(remove-keys '(monolithic type move-here) args)))
(system (find-system system))
(files (and system (output-files operation system))))
(if (or move-here (and (null move-here-p)
(member operation-name '(:program :binary))))
(loop :with dest-path = (truename (ensure-directories-exist move-here-path))
:for f in files
:for new-f = (make-pathname :name (pathname-name f)
:type (pathname-type f)
:defaults dest-path)
:do (progn
(when (probe-file new-f)
(delete-file new-f))
(rename-file f new-f))
:collect new-f)
files)))
;;;
;;; LOAD-FASL-OP
;;;
;;; This is like ASDF's LOAD-OP, but using monolithic fasl files.
;;;
(defclass load-fasl-op (operation) ())
(defun trivial-system-p (c)
(every #'(lambda (c) (typep c 'compiled-file)) (module-components c)))
(defmethod component-depends-on ((o load-fasl-op) (c system))
(declare (ignorable o))
(unless (trivial-system-p c)
(subst 'load-fasl-op 'load-op
(subst 'fasl-op 'compile-op
(component-depends-on (make-instance 'load-op) c)))))
(defmethod input-files ((o load-fasl-op) (c system))
(declare (ignore o))
(unless (trivial-system-p c)
(output-files (make-instance 'fasl-op) c)))
(defmethod perform ((o load-fasl-op) (c t))
(declare (ignore o c))
nil)
(defmethod perform ((o load-fasl-op) (c system))
(let ((l (input-files o c)))
(and l
(load (first l))
(loop :for i :in (module-components c)
:do (setf (gethash 'load-op (component-operation-times i))
(get-universal-time))))))
;;;
;;; PRECOMPILED FILES
;;;
;;; This component can be used to distribute ASDF libraries in precompiled
;;; form. Only useful when the dependencies have also been precompiled.
;;;
(defclass compiled-file (component)
((type :initform nil)))
(defmethod output-files (o (c compiled-file))
(declare (ignore o c))
nil)
(defmethod input-files (o (c compiled-file))
(declare (ignore o c))
nil)
(defmethod perform ((o load-op) (c compiled-file))
(declare (ignore o))
(load (component-pathname c)))
(defmethod perform ((o load-fasl-op) (c compiled-file))
(declare (ignore o))
(load (component-pathname c)))
(defmethod perform (o (c compiled-file))
(declare (ignore o c))
nil)
;;;
;;; Pre-built systems
;;;
(defclass prebuilt-system (system)
((static-library :accessor prebuilt-system-static-library :initarg :lib)))
(defmethod output-files ((o lib-op) (c prebuilt-system))
(declare (ignore o))
(values (list (prebuilt-system-static-library c))
t)) ; Advertise that we do not want this path renamed
(defmethod perform ((o lib-op) (c prebuilt-system))
(car (output-files o c)))
(defmethod component-depends-on ((o lib-op) (c prebuilt-system))
(declare (ignorable o c))
nil)
(defmethod bundle-sub-operations ((o lib-op) (c prebuilt-system))
(declare (ignorable o c))
nil)
(defmethod bundle-sub-operations ((o monolithic-lib-op) (c prebuilt-system))
(declare (ignorable o))
(error "Prebuilt system ~S shipped with ECL can not be used in a monolithic library operation." c))
(defmethod bundle-sub-operations ((o monolithic-bundle-op) (c prebuilt-system))
(declare (ignorable o c))
nil)
;;;
;;; PREBUILT SYSTEM CREATOR
;;;
(defclass binary-op (bundle-op)
())
(defclass monolithic-binary-op (binary-op monolithic-bundle-op)
())
(defun binary-op-dependencies (o s)
(multiple-value-bind (lib-op fasl-op)
(if (bundle-op-monolithic-p o)
(values 'monolithic-lib-op 'monolithic-fasl-op)
(values 'lib-op 'fasl-op))
(list (list (make-instance lib-op :args (bundle-op-build-args o))
s)
(list (make-instance fasl-op :args (bundle-op-build-args o))
s))))
(defmethod component-depends-on ((o binary-op) (s system))
(loop :for dep :in (binary-op-dependencies o s)
:append (apply #'component-depends-on dep)))
(defmethod input-files ((o binary-op) (s system))
(loop :for dep :in (binary-op-dependencies o s)
:append (apply #'input-files dep)))
(defmethod output-files ((o binary-op) (s system))
(list* (merge-pathnames* (make-pathname :name (component-name s)
:type "asd")
(component-relative-pathname s))
(loop :for dep :in (binary-op-dependencies o s)
:append (apply #'output-files dep))))
(defmethod perform ((o binary-op) (s system))
(let* ((dependencies (binary-op-dependencies o s))
(library (first (apply #'output-files (first dependencies))))
(fasl (first (apply #'output-files (second dependencies))))
(filename (first (output-files o s)))
(name (component-name s))
(name-keyword (intern (string name) (find-package :keyword))))
(loop :for dep :in dependencies
:do (apply #'perform dep))
(with-open-file (s filename :direction :output :if-exists :supersede
:if-does-not-exist :create)
(format s ";;; Prebuilt ASDF definition for system ~A" name)
(format s ";;; Built for ~A ~A on a ~A/~A ~A"
(lisp-implementation-type)
(lisp-implementation-version)
(software-type)
(machine-type)
(software-version))
(let ((*package* (find-package :keyword)))
(pprint `(defsystem ,name-keyword
:class asdf::prebuilt-system
:components ((:compiled-file ,(pathname-name fasl)))
:lib ,(make-pathname :name (pathname-name library)
:type (pathname-type library)))
s)))))
;;;
;;; Final integration steps
;;;
(export '(make-build load-fasl-op))
(pushnew '("fasb" . si::load-binary) ext:*load-hooks* :test 'equal :key 'car)
......@@ -14,11 +14,10 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26" ;; to be automatically updated by bin/bump-revision
:version "2.26.1" ;; to be automatically updated by bin/bump-revision
:depends-on ()
:components
((:file "asdf")
#+ecl (:file "asdf-ecl" :depends-on ("asdf"))))
((:file "asdf")))
;; The method below ensures that before we compile asdf, we load it as source.
;; This ensures that when we compile asdf, it won't remove symbols and packages
......
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26: Another System Definition Facility.
;;; This is ASDF 2.26.1: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......@@ -118,7 +118,7 @@
;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(asdf-version "2.26")
(asdf-version "2.26.1")
(existing-asdf (find-class 'component nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
......@@ -1636,12 +1636,8 @@ Note that this does NOT in any way cause the code of the system to be unloaded."
FN should be a function of one argument. It will be
called with an object of type asdf:system."
(maphash #'(lambda (_ datum)
(declare (ignore _))
(destructuring-bind (_ . def) datum
(declare (ignore _))
(funcall fn def)))
*defined-systems*))
(loop :for (nil . system) :being :the hash-values :of *defined-systems*
:do (funcall fn system)))
;;; for the sake of keeping things reasonably neat, we adopt a
;;; convention that functions in this list are prefixed SYSDEF-
......@@ -1795,6 +1791,8 @@ Going forward, we recommend new users should be using the source-registry.
(defvar *systems-being-defined* nil
"A hash-table of systems currently being defined keyed by name, or NIL")
(defvar *systems-being-operated* nil
"A boolean indicating that some systems are being operated on")
(defun* find-system-if-being-defined (name)
(when *systems-being-defined*
......@@ -2357,7 +2355,7 @@ recursive calls to traverse.")
(r* (svref x 0))
(c x)))
(r* (l)
(dolist (x l) (r x))))
(map () #'r l)))
(r* l))))
(defmethod traverse ((operation operation) (c component))
......@@ -2618,10 +2616,9 @@ recursive calls to traverse.")
(defmethod operation-done-p ((o load-source-op) (c source-file))
(declare (ignorable o))
(if (or (not (component-property c 'last-loaded-as-source))
(> (safe-file-write-date (component-pathname c))
(component-property c 'last-loaded-as-source)))
nil t))
(and (component-property c 'last-loaded-as-source)
(<= (safe-file-write-date (component-pathname c))
(component-property c 'last-loaded-as-source))))
(defmethod operation-description ((operation load-source-op) component)
(declare (ignorable operation))
......@@ -2657,6 +2654,7 @@ recursive calls to traverse.")
(defgeneric* operate (operation-class system &key &allow-other-keys))
(defgeneric* perform-plan (plan &key))
(defgeneric* plan-operates-on-p (plan component))
;;;; Separating this into a different function makes it more forward-compatible
(defun* cleanup-upgraded-asdf (old-version)
......@@ -2691,6 +2689,10 @@ recursive calls to traverse.")
(operate 'load-op :asdf :verbose nil))
(cleanup-upgraded-asdf version)))
(defmethod plan-operates-on-p ((plan list) (component-path list))
(find component-path (mapcar 'cdr plan)
:test 'equal :key 'component-find-path))
(defmethod perform-plan ((steps list) &key)
(let ((*package* *package*)
(*readtable* *readtable*))
......@@ -2699,34 +2701,40 @@ recursive calls to traverse.")
(perform-with-restarts op component)))))
(defmethod operate (operation-class system &rest args
&key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
&allow-other-keys)
&key verbose version force &allow-other-keys)
(declare (ignore force))
(with-system-definitions ()
(let* ((op (apply 'make-instance operation-class
:original-initargs args
args))
(*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
(let* ((*asdf-verbose* verbose)
(*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
(op (apply 'make-instance operation-class
:original-initargs args args))
(system (etypecase system
(system system)
((or string symbol) (find-system system)))))
(unless (version-satisfies system version)
(error 'missing-component-of-version :requires system :version version))
(let ((steps (traverse op system)))
(when (and (not (equal '("asdf") (component-find-path system)))
(find '("asdf") (mapcar 'cdr steps)
:test 'equal :key 'component-find-path)
(upgrade-asdf))
;; If we needed to upgrade ASDF to achieve our goal,
;; then do it specially as the first thing, then
;; invalidate all existing system
;; retry the whole thing with the new OPERATE function,
;; which on some implementations
;; has a new symbol shadowing the current one.
(return-from operate
(apply (find-symbol* 'operate :asdf) operation-class system args)))
(perform-plan steps)
(values op steps)))))
((or string symbol) (find-system system))))
(systems-being-operated *systems-being-operated*)
(*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal))))
(check-type system system)
(setf (gethash (coerce-name system) *systems-being-operated*) system)
(flet ((upgrade ()
;; If we needed to upgrade ASDF to achieve our goal,
;; then do it specially as the first thing,
;; which will invalidate all existing systems;
;; afterwards, retry the whole thing with the new OPERATE function,
;; which on some implementations
;; has a new symbol shadowing the current one.
(unless (gethash "asdf" *systems-being-operated*)
(upgrade-asdf)
(return-from operate
(apply (find-symbol* 'operate :asdf) operation-class system args)))))
(when systems-being-operated ;; Upgrade if loading a system from another one.
(upgrade))
(unless (version-satisfies system version)
(error 'missing-component-of-version :requires system :version version))
(let ((plan (traverse op system)))
(when (plan-operates-on-p plan '("asdf"))
(upgrade)) ;; Upgrade early if the plan involves upgrading asdf at any time.
(perform-plan plan)
(values op plan))))))
(defun* oos (operation-class system &rest args &key force verbose version
&allow-other-keys)
......@@ -3918,9 +3926,7 @@ effectively disabling the output translation facility."
(if output-file keys (remove-keyword :output-file keys))))))
(defun* tmpize-pathname (x)
(make-pathname
:name (strcat "ASDF-TMP-" (pathname-name x))
:defaults x))
(make-pathname :name (strcat "ASDF-TMP-" (pathname-name x)) :defaults x))
(defun* delete-file-if-exists (x)
(when (and x (probe-file* x))
......@@ -4133,9 +4139,7 @@ with a different configuration, so the configuration would be re-read then."
(collect-sub*directories subdir collectp recursep collector))))
(defun* collect-sub*directories-asd-files
(directory &key
(exclude *default-source-registry-exclusions*)
collect)
(directory &key (exclude *default-source-registry-exclusions*) collect)
(collect-sub*directories
directory
(constantly t)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment