Commit 5187114d authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.31.3: ensure upgrade before find-system. Also tweak primary/secondary output.

If you let find-system inside with-system-definitions before you upgrade ASDF,
you might have bad surprises when you upgrade then a previous definition survives.
parent feadbfaf
......@@ -74,7 +74,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.31.2" ;; to be automatically updated by make bump-version
:version "2.31.3" ;; 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.
......
......@@ -147,24 +147,33 @@
;;;; compatfmt: avoid fancy format directives when unsupported
(eval-when (:load-toplevel :compile-toplevel :execute)
(defun remove-substrings (substrings string)
(defun frob-substrings (string substrings &optional frob)
(declare (optimize (speed 0) (safety 3) (debug 3)))
(let ((length (length string)) (stream nil))
(labels ((emit (start end)
(when (and (zerop start) (= end length))
(return-from remove-substrings string))
(labels ((emit-string (x &optional (start 0) (end (length x)))
(when (< start end)
(unless stream (setf stream (make-string-output-stream)))
(write-string string stream :start start :end end)))
(write-string x stream :start start :end end)))
(emit-substring (start end)
(when (and (zerop start) (= end length))
(return-from frob-substrings string))
(emit-string string start end))
(recurse (substrings start end)
(cond
((>= start end))
((null substrings) (emit start end))
(t (let* ((sub (first substrings))
((null substrings) (emit-substring start end))
(t (let* ((sub-spec (first substrings))
(sub (if (consp sub-spec) (car sub-spec) sub-spec))
(fun (if (consp sub-spec) (cdr sub-spec) frob))
(found (search sub string :start2 start :end2 end))
(more (rest substrings)))
(cond
(found
(recurse more start found)
(etypecase fun
(null)
(string (emit-string fun))
(function (funcall fun sub #'emit-string)))
(recurse substrings (+ found (length sub)) end))
(t
(recurse more start end))))))))
......@@ -173,7 +182,7 @@
(defmacro compatfmt (format)
#+(or gcl genera)
(remove-substrings `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")) format)
(frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")))
#-(or gcl genera) format))
......@@ -7,7 +7,7 @@
:asdf/component :asdf/system :asdf/cache)
(:export
#:remove-entry-from-registry #:coerce-entry-to-directory
#:coerce-name #:primary-system-name
#:coerce-name #:primary-system-name #:coerce-filename
#:find-system #:locate-system #:load-asd #:with-system-definitions
#:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems
#:system-definition-error #:missing-component #:missing-requires #:missing-parent
......@@ -69,6 +69,9 @@
;; the first of the slash-separated components.
(first (split-string (coerce-name name) :separator "/")))
(defun coerce-filename (name)
(frob-substrings (coerce-name name) '("/" ":" "\\") "--"))
(defvar *defined-systems* (make-hash-table :test 'equal)
"This is a hash table whose keys are strings, being the
names of the systems, and whose values are pairs, the first
......@@ -272,6 +275,12 @@ Going forward, we recommend new users should be using the source-registry.
(let ((*systems-being-defined* (make-hash-table :test 'equal)))
(call-with-asdf-cache thunk))))
(defun clear-systems-being-defined ()
(when *systems-being-defined*
(clrhash *systems-being-defined*)))
(register-hook-function '*post-upgrade-cleanup-hook* 'clear-systems-being-defined)
(defmacro with-system-definitions ((&optional) &body body)
`(call-with-system-definitions #'(lambda () ,@body)))
......
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.31.2: Another System Definition Facility.
;;; This is ASDF 2.31.3: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -5,7 +5,8 @@
(:recycle :asdf/lisp-action :asdf)
(:intern #:proclamations #:flags)
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade
:asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/operation :asdf/action)
:asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/find-system
:asdf/operation :asdf/action)
(:export
#:try-recompiling
#:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
......@@ -159,7 +160,7 @@
(defmethod output-files ((o compile-op) (c system))
(when (and *warnings-file-type* (not (builtin-system-p c)))
(if-let ((pathname (component-pathname c)))
(list (subpathname pathname (component-name c) :type "build-report"))))))
(list (subpathname pathname (coerce-filename c) :type "build-report"))))))
;;; load-op
(with-upgradability ()
......
......@@ -16,29 +16,8 @@
(in-package :asdf/operate)
(with-upgradability ()
(defgeneric* (operate) (operation component &key &allow-other-keys))
(define-convenience-action-methods
operate (operation component &key)
:operation-initargs t ;; backward-compatibility with ASDF1. Yuck.
:if-no-component (error 'missing-component :requires component))
(defvar *systems-being-operated* nil
"A boolean indicating that some systems are being operated on")
(defmethod operate :around (operation component
&key verbose
(on-warnings *compile-file-warnings-behaviour*)
(on-failure *compile-file-failure-behaviour*) &allow-other-keys)
(declare (ignorable operation component))
;; Setup proper bindings around any operate call.
(with-system-definitions ()
(let* ((*verbose-out* (and verbose *standard-output*))
(*compile-file-warnings-behaviour* on-warnings)
(*compile-file-failure-behaviour* on-failure))
(call-next-method))))
(defmethod operate ((operation operation) (component component)
&rest args &key version &allow-other-keys)
(defgeneric* (operate) (operation component &key &allow-other-keys)
(:documentation
"Operate does three things:
1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs.
......@@ -57,30 +36,60 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
without recursively forcing the other systems we depend on.
:ALL to force all systems including other systems we depend on to be rebuilt (resp. not).
(SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list
:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced."
(let* (;; I'd like to remove-plist-keys :force :force-not :verbose,
:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced."))
(define-convenience-action-methods
operate (operation component &key)
;; I'd like to at least remove-plist-keys :force :force-not :verbose,
;; but swank.asd relies on :force (!).
(systems-being-operated *systems-being-operated*)
:operation-initargs t ;; backward-compatibility with ASDF1. Yuck.
:if-no-component (error 'missing-component :requires component))
(defvar *systems-being-operated* nil
"A boolean indicating that some systems are being operated on")
(defmethod operate :around (operation component &rest keys
&key verbose
(on-warnings *compile-file-warnings-behaviour*)
(on-failure *compile-file-failure-behaviour*) &allow-other-keys)
(declare (ignorable operation component))
(let* ((systems-being-operated *systems-being-operated*)
(*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))
(system (component-system component)))
(operation-name (reify-symbol (etypecase operation
(operation (type-of operation))
(symbol operation))))
(component-path (typecase component
(component (component-find-path component))
(t component))))
;; Before we operate on any system, make sure ASDF is up-to-date,
;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
(unless systems-being-operated
(let ((operation-name (reify-symbol (type-of operation)))
(component-path (component-find-path component)))
(when (upgrade-asdf)
;; If we were upgraded, restart OPERATE the hardest of ways, for
;; its function may have been redefined, its symbol uninterned, its package deleted.
(return-from operate
(apply (find-symbol* 'operate :asdf)
(unreify-symbol operation-name)
component-path args)))))
(setf (gethash (coerce-name system) *systems-being-operated*) system)
component-path keys))))
;; Setup proper bindings around any operate call.
(with-system-definitions ()
(let* ((*verbose-out* (and verbose *standard-output*))
(*compile-file-warnings-behaviour* on-warnings)
(*compile-file-failure-behaviour* on-failure))
(call-next-method)))))
(defmethod operate :before ((operation operation) (component component)
&key version &allow-other-keys)
(let ((system (component-system component)))
(setf (gethash (coerce-name system) *systems-being-operated*) system))
(unless (version-satisfies component version)
(error 'missing-component-of-version :requires component :version version))
(let ((plan (apply 'traverse operation system args)))
(error 'missing-component-of-version :requires component :version version)))
(defmethod operate ((operation operation) (component component)
&rest keys &key &allow-other-keys)
(let ((plan (apply 'traverse operation component keys)))
(perform-plan plan)
(values operation plan))))
(values operation plan)))
(defun oos (operation component &rest args &key &allow-other-keys)
(apply 'operate operation component args))
......
......@@ -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.31.2")
(asdf-version "2.31.3")
(existing-version (asdf-version)))
(setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version)))
......
......@@ -5,9 +5,9 @@
(:recycle :asdf/utility :asdf)
(:use :asdf/common-lisp :asdf/package)
;; import and reexport a few things defined in :asdf/common-lisp
(:import-from :asdf/common-lisp #:compatfmt #:loop* #:remove-substrings
(:import-from :asdf/common-lisp #:compatfmt #:loop* #:frob-substrings
#+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
(:export #:compatfmt #:loop* #:remove-substrings #:compatfmt
(:export #:compatfmt #:loop* #:frob-substrings #:compatfmt
#+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
(:export
;; magic helper to define debugging functions:
......
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