[Git][cmucl/cmucl][master] Update to ASDF 3.3.3
Raymond Toy
gitlab at common-lisp.net
Wed Apr 17 19:20:37 UTC 2019
Raymond Toy pushed to branch master at cmucl / cmucl
Commits:
76fd7aef by Raymond Toy at 2019-04-17T19:20:16Z
Update to ASDF 3.3.3
- - - - -
4 changed files:
- src/contrib/asdf/asdf.lisp
- src/contrib/asdf/doc/asdf.html
- src/contrib/asdf/doc/asdf.info
- src/contrib/asdf/doc/asdf.pdf
Changes:
=====================================
src/contrib/asdf/asdf.lisp
=====================================
@@ -1,5 +1,5 @@
;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
-;;; This is ASDF 3.3.2: Another System Definition Facility.
+;;; This is ASDF 3.3.3: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel at common-lisp.net>.
@@ -19,7 +19,7 @@
;;; http://www.opensource.org/licenses/mit-license.html on or about
;;; Monday; July 13, 2009)
;;;
-;;; Copyright (c) 2001-2016 Daniel Barlow and contributors
+;;; Copyright (c) 2001-2019 Daniel Barlow and contributors
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
@@ -45,6 +45,17 @@
;;; The problem with writing a defsystem replacement is bootstrapping:
;;; we can't use defsystem to compile it. Hence, all in one file.
+#+genera
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (multiple-value-bind (system-major system-minor)
+ (sct:get-system-version)
+ (multiple-value-bind (is-major is-minor)
+ (sct:get-system-version "Intel-Support")
+ (unless (or (> system-major 452)
+ (and is-major
+ (or (> is-major 3)
+ (and (= is-major 3) (> is-minor 86)))))
+ (error "ASDF requires either System 453 or later or Intel Support 3.87 or later")))))
;;;; ---------------------------------------------------------------------------
;;;; Handle ASDF package upgrade, including implementation-dependent magic.
;;
@@ -818,10 +829,10 @@ UNINTERN -- Remove symbols here from PACKAGE."
;;;; Early meta-level tweaks
-#+(or allegro clasp clisp clozure cmucl ecl mezzano mkcl sbcl)
+#+(or allegro clasp clisp clozure cmucl ecl lispworks mezzano mkcl sbcl)
(eval-when (:load-toplevel :compile-toplevel :execute)
(when (and #+allegro (member :ics *features*)
- #+(or clasp clisp cmucl ecl mkcl) (member :unicode *features*)
+ #+(or clasp clisp cmucl ecl lispworks mkcl) (member :unicode *features*)
#+clozure (member :openmcl-unicode-strings *features*)
#+sbcl (member :sb-unicode *features*))
;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode
@@ -1043,7 +1054,9 @@ Return a string made of the parts not omitted or emitted by FROB."
#:simple-style-warning #:style-warn ;; simple style warnings
#:match-condition-p #:match-any-condition-p ;; conditions
#:call-with-muffled-conditions #:with-muffled-conditions
- #:not-implemented-error #:parameter-error))
+ #:not-implemented-error #:parameter-error
+ #:symbol-test-to-feature-expression
+ #:boolean-to-feature-expression))
(in-package :uiop/utility)
;;;; Defining functions in a way compatible with hot-upgrade:
@@ -1089,17 +1102,17 @@ to supersede any previous definition."
;;; Magic debugging help. See contrib/debug.lisp
(with-upgradability ()
(defvar *uiop-debug-utility*
- '(or (ignore-errors
- (probe-file (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp")))
- (probe-file (symbol-call :uiop/pathname :subpathname
- (user-homedir-pathname) "common-lisp/asdf/uiop/contrib/debug.lisp")))
+ '(symbol-call :uiop :subpathname (symbol-call :uiop :uiop-directory) "contrib/debug.lisp")
"form that evaluates to the pathname to your favorite debugging utilities")
(defmacro uiop-debug (&rest keys)
+ "Load the UIOP debug utility at compile-time as well as runtime"
`(eval-when (:compile-toplevel :load-toplevel :execute)
(load-uiop-debug-utility , at keys)))
(defun load-uiop-debug-utility (&key package utility-file)
+ "Load the UIOP debug utility in given PACKAGE (default *PACKAGE*).
+Beware: The utility is located by EVAL'uating the UTILITY-FILE form (default *UIOP-DEBUG-UTILITY*)."
(let* ((*package* (if package (find-package package) *package*))
(keyword (read-from-string
(format nil ":DBG-~:@(~A~)" (package-name *package*)))))
@@ -1658,6 +1671,18 @@ message, that takes the functionality as its first argument (that can be skipped
:format-control format-control
:format-arguments format-arguments)))
+(with-upgradability ()
+ (defun boolean-to-feature-expression (value)
+ "Converts a boolean VALUE to a form suitable for testing with #+."
+ (if value
+ '(:and)
+ '(:or)))
+
+ (defun symbol-test-to-feature-expression (name package)
+ "Check if a symbol with a given NAME exists in PACKAGE and returns a
+form suitable for testing with #+."
+ (boolean-to-feature-expression
+ (find-symbol* name package nil))))
(uiop/package:define-package :uiop/version
(:recycle :uiop/version :uiop/utility :asdf)
(:use :uiop/common-lisp :uiop/package :uiop/utility)
@@ -1672,7 +1697,7 @@ message, that takes the functionality as its first argument (that can be skipped
(in-package :uiop/version)
(with-upgradability ()
- (defparameter *uiop-version* "3.3.2")
+ (defparameter *uiop-version* "3.3.3")
(defun unparse-version (version-list)
"From a parsed version (a list of natural numbers), compute the version string"
@@ -2335,8 +2360,8 @@ by the underlying implementation's MAKE-PATHNAME and other primitives"
;; See CLHS make-pathname and 19.2.2.2.3.
;; This will be :unspecific if supported, or NIL if not.
(defparameter *unspecific-pathname-type*
- #+(or abcl allegro clozure cmucl genera lispworks sbcl scl) :unspecific
- #+(or clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl mezzano) nil
+ #+(or abcl allegro clozure cmucl lispworks sbcl scl) :unspecific
+ #+(or genera clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl mezzano) nil
"Unspecific type component to use with the underlying implementation's MAKE-PATHNAME")
(defun make-pathname* (&rest keys &key directory host device name type version defaults
@@ -2574,7 +2599,14 @@ actually-existing directory."
(make-pathname :directory (append (or (normalize-pathname-directory-component
(pathname-directory pathspec))
(list :relative))
- (list (file-namestring pathspec)))
+ (list #-genera (file-namestring pathspec)
+ ;; On Genera's native filesystem (LMFS),
+ ;; directories have a type and version
+ ;; which must be ignored when converting
+ ;; to a directory pathname
+ #+genera (if (typep pathspec 'fs:lmfs-pathname)
+ (pathname-name pathspec)
+ (file-namestring pathspec))))
:name nil :type nil :version nil :defaults pathspec)
(error (c) (call-function on-error (compatfmt "~@<error while trying to create a directory pathname for ~S: ~A~@:>") pathspec c)))))))
@@ -3056,7 +3088,13 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
(or (ignore-errors (truename p))
;; this is here because trying to find the truename of a directory pathname WITHOUT supplying
;; a trailing directory separator, causes an error on some lisps.
- #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d)))))))
+ #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d)))
+ ;; On Genera, truename of a directory pathname will probably fail as Genera
+ ;; will merge in a filename/type/version from *default-pathname-defaults* and
+ ;; will try to get the truename of a file that probably doesn't exist.
+ #+genera (when (directory-pathname-p p)
+ (let ((d (scl:send p :directory-pathname-as-file)))
+ (ensure-directory-pathname (ignore-errors (truename d)) nil)))))))
(defun safe-file-write-date (pathname)
"Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
@@ -4832,7 +4870,6 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
(shell-boolean-exit
(restore-image))))))))
(when forms `(progn , at forms))))))
- #+(or clasp ecl mkcl)
(check-type kind (member :dll :shared-library :lib :static-library
:fasl :fasb :program))
(apply #+clasp 'cmp:builder #+clasp kind
@@ -5209,12 +5246,28 @@ Simple means made of symbols, numbers, characters, simple-strings, pathnames, co
(sb-c::undefined-warning-kind warning)
(sb-c::undefined-warning-name warning)
(sb-c::undefined-warning-count warning)
+ ;; the COMPILER-ERROR-CONTEXT struct has changed in SBCL, which means how we
+ ;; handle deferred warnings must change... TODO: when enough time has
+ ;; gone by, just assume all versions of SBCL are adequately
+ ;; up-to-date, and cut this material.[2018/05/30:rpg]
(mapcar
#'(lambda (frob)
;; the lexenv slot can be ignored for reporting purposes
- `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob)
- :source ,(sb-c::compiler-error-context-source frob)
- :original-source ,(sb-c::compiler-error-context-original-source frob)
+ `(
+ #- #.(uiop/utility:symbol-test-to-feature-expression '#:compiler-error-context-%source '#:sb-c)
+ ,@`(:enclosing-source
+ ,(sb-c::compiler-error-context-enclosing-source frob)
+ :source
+ ,(sb-c::compiler-error-context-source frob)
+ :original-source
+ ,(sb-c::compiler-error-context-original-source frob))
+ #+ #.(uiop/utility:symbol-test-to-feature-expression '#:compiler-error-context-%source '#:sb-c)
+ ,@ `(:%enclosing-source
+ ,(sb-c::compiler-error-context-enclosing-source frob)
+ :%source
+ ,(sb-c::compiler-error-context-source frob)
+ :original-form
+ ,(sb-c::compiler-error-context-original-form frob))
:context ,(sb-c::compiler-error-context-context frob)
:file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname
:file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer
@@ -5565,9 +5618,10 @@ it will filter them appropriately."
(with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file))
(with-muffled-compiler-conditions ()
(or #-(or clasp ecl mkcl)
- (apply 'compile-file input-file :output-file tmp-file
- #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords)
- #-sbcl keywords)
+ (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t))
+ (apply 'compile-file input-file :output-file tmp-file
+ #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords)
+ #-sbcl keywords))
#+ecl (apply 'compile-file input-file :output-file
(if object-file
(list* object-file :system-p t keywords)
@@ -5619,19 +5673,20 @@ it will filter them appropriately."
(defun load* (x &rest keys &key &allow-other-keys)
"Portable wrapper around LOAD that properly handles loading from a stream."
(with-muffled-loader-conditions ()
- (etypecase x
- ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream)
- (apply 'load x keys))
- ;; Genera can't load from a string-input-stream
- ;; ClozureCL 1.6 can only load from file input stream
- ;; Allegro 5, I don't remember but it must have been broken when I tested.
- #+(or allegro clozure genera)
- (stream ;; make do this way
- (let ((*package* *package*)
- (*readtable* *readtable*)
- (*load-pathname* nil)
- (*load-truename* nil))
- (eval-input x))))))
+ (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t))
+ (etypecase x
+ ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream)
+ (apply 'load x keys))
+ ;; Genera can't load from a string-input-stream
+ ;; ClozureCL 1.6 can only load from file input stream
+ ;; Allegro 5, I don't remember but it must have been broken when I tested.
+ #+(or allegro clozure genera)
+ (stream ;; make do this way
+ (let ((*package* *package*)
+ (*readtable* *readtable*)
+ (*load-pathname* nil)
+ (*load-truename* nil))
+ (eval-input x)))))))
(defun load-from-string (string)
"Portably read and evaluate forms from a STRING."
@@ -6930,7 +6985,7 @@ or an indication of failure via the EXIT-CODE of the process"
(uiop/package:define-package :uiop/configuration
(:recycle :uiop/configuration :asdf/configuration) ;; necessary to upgrade from 2.27.
- (:use :uiop/common-lisp :uiop/utility
+ (:use :uiop/package :uiop/common-lisp :uiop/utility
:uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build)
(:export
#:user-configuration-directories #:system-configuration-directories ;; implemented in backward-driver
@@ -6945,7 +7000,8 @@ or an indication of failure via the EXIT-CODE of the process"
#:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache*
#:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
#:resolve-location #:location-designator-p #:location-function-p #:*here-directory*
- #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration))
+ #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration
+ #:uiop-directory))
(in-package :uiop/configuration)
(with-upgradability ()
@@ -7337,7 +7393,28 @@ or just the first one (for direction :output or :io).
"Compute (and return) the location of the default user-cache for translate-output
objects. Side-effects for cached file location computation."
(setf *user-cache* (xdg-cache-home "common-lisp" :implementation)))
- (register-image-restore-hook 'compute-user-cache))
+ (register-image-restore-hook 'compute-user-cache)
+
+ (defun uiop-directory ()
+ "Try to locate the UIOP source directory at runtime"
+ (labels ((pf (x) (ignore-errors (probe-file* x)))
+ (sub (x y) (pf (subpathname x y)))
+ (ssd (x) (ignore-errors (symbol-call :asdf :system-source-directory x))))
+ ;; NB: conspicuously *not* including searches based on #.(current-lisp-pathname)
+ (or
+ ;; Look under uiop if available as source override, under asdf if avaiable as source
+ (ssd "uiop")
+ (sub (ssd "asdf") "uiop/")
+ ;; Look in recommended path for user-visible source installation
+ (sub (user-homedir-pathname) "common-lisp/asdf/uiop/")
+ ;; Look in XDG paths under known package names for user-invisible source installation
+ (xdg-data-pathname "common-lisp/source/asdf/uiop/")
+ (xdg-data-pathname "common-lisp/source/cl-asdf/uiop/") ; traditional Debian location
+ ;; The last one below is useful for Fare, primary (sole?) known user
+ (sub (user-homedir-pathname) "cl/asdf/uiop/")
+ (cerror "Configure source registry to include UIOP source directory and retry."
+ "Unable to find UIOP directory")
+ (uiop-directory)))))
;;; -------------------------------------------------------------------------
;;; Hacks for backward-compatibility with older versions of UIOP
@@ -7372,7 +7449,8 @@ DEPRECATED. Use UIOP:XDG-CONFIG-PATHNAMES instead."
(xdg-config-pathnames "common-lisp"))
(defun system-configuration-directories ()
"Return the list of system configuration directories for common-lisp.
-DEPRECATED. Use UIOP:CONFIG-SYSTEM-PATHNAMES instead."
+DEPRECATED. Use UIOP:SYSTEM-CONFIG-PATHNAMES (with argument \"common-lisp\"),
+instead."
(system-config-pathnames "common-lisp"))
(defun in-first-directory (dirs x &key (direction :input))
"Finds the first appropriate file named X in the list of DIRS for I/O
@@ -7521,7 +7599,7 @@ previously-loaded version of ASDF."
;; "3.4.5.67" would be a development version in the official branch, on top 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 "3.3.2")
+ (asdf-version "3.3.3")
(existing-version (asdf-version)))
(setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version)))
@@ -7534,7 +7612,7 @@ previously-loaded version of ASDF."
;;; Upon upgrade, specially frob some functions and classes that are being incompatibly redefined
(when-upgrading ()
(let* ((previous-version (first *previous-asdf-versions*))
- (redefined-functions ;; List of functions that changes incompatibly since 2.27:
+ (redefined-functions ;; List of functions that changed incompatibly since 2.27:
;; gf signature changed (should NOT happen), defun that became a generic function,
;; method removed that will mess up with new ones (especially :around :before :after,
;; more specific or call-next-method'ed method) and/or semantics otherwise modified. Oops.
@@ -7545,8 +7623,8 @@ previously-loaded version of ASDF."
;; Also note that we don't include the defgeneric=>defun, because they are
;; done directly with defun* and need not trigger a punt on data.
;; See discussion at https://gitlab.common-lisp.net/asdf/asdf/merge_requests/36
- `(,@(when (version<= previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2
- ,@(when (version<= previous-version "3.1.7.20") '(#:find-component))))
+ `(,@(when (version< previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2
+ ,@(when (version< previous-version "3.1.7.20") '(#:find-component))))
(redefined-classes
;; redefining the classes causes interim circularities
;; with the old ASDF during upgrade, and many implementations bork
@@ -7883,9 +7961,9 @@ or NIL for top-level components (a.k.a. systems)"))
(defmethod component-parent ((component null)) nil)
;; Deprecated: Backward compatible way of computing the FILE-TYPE of a component.
- ;; TODO: find users, have them stop using that, remove it for ASDF4.
- (defgeneric source-file-type (component system)
- (:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead."))
+ (with-asdf-deprecation (:style-warning "3.4")
+ (defgeneric source-file-type (component system)
+ (:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead.")))
(define-condition duplicate-names (system-definition-error)
((name :initarg :name :reader duplicate-names-name))
@@ -8222,6 +8300,7 @@ Use of INITARGS is not supported at this time."
#:system-source-file #:system-source-directory #:system-relative-pathname
#:system-description #:system-long-description
#:system-author #:system-maintainer #:system-licence #:system-license
+ #:system-version
#:definition-dependency-list #:definition-dependency-set #:system-defsystem-depends-on
#:system-depends-on #:system-weakly-depends-on
#:component-build-pathname #:build-pathname
@@ -8243,8 +8322,10 @@ Use of INITARGS is not supported at this time."
If no system is found, then signal an error if ERROR-P is true (the default), or else return NIL.
A system designator is usually a string (conventionally all lowercase) or a symbol, designating
the same system as its downcased name; it can also be a system object (designating itself)."))
+
(defgeneric system-source-file (system)
(:documentation "Return the source file in which system is defined."))
+
;; This is bad design, but was the easiest kluge I found to let the user specify that
;; some special actions create outputs at locations controled by the user that are not affected
;; by the usual output-translations.
@@ -8263,6 +8344,7 @@ NB: This interface is subject to change. Please contact ASDF maintainers if you
(with no argument) when running an image dumped from the COMPONENT.
NB: This interface is subject to change. Please contact ASDF maintainers if you use it."))
+
(defmethod component-entry-point ((c component))
nil))
@@ -8287,19 +8369,21 @@ a SYSTEM is redefined and its class is modified."))
(defclass system (module proto-system)
;; Backward-compatibility: inherit from module. ASDF4: only inherit from parent-component.
(;; {,long-}description is now inherited from component, but we add the legacy accessors
- (description :accessor system-description)
- (long-description :accessor system-long-description)
- (author :accessor system-author :initarg :author :initform nil)
- (maintainer :accessor system-maintainer :initarg :maintainer :initform nil)
- (licence :accessor system-licence :initarg :licence
- :accessor system-license :initarg :license :initform nil)
- (homepage :accessor system-homepage :initarg :homepage :initform nil)
- (bug-tracker :accessor system-bug-tracker :initarg :bug-tracker :initform nil)
- (mailto :accessor system-mailto :initarg :mailto :initform nil)
- (long-name :accessor system-long-name :initarg :long-name :initform nil)
+ (description :writer (setf system-description))
+ (long-description :writer (setf system-long-description))
+ (author :writer (setf system-author) :initarg :author :initform nil)
+ (maintainer :writer (setf system-maintainer) :initarg :maintainer :initform nil)
+ (licence :writer (setf system-licence) :initarg :licence
+ :writer (setf system-license) :initarg :license
+ :initform nil)
+ (homepage :writer (setf system-homepage) :initarg :homepage :initform nil)
+ (bug-tracker :writer (setf system-bug-tracker) :initarg :bug-tracker :initform nil)
+ (mailto :writer (setf system-mailto) :initarg :mailto :initform nil)
+ (long-name :writer (setf system-long-name) :initarg :long-name :initform nil)
;; Conventions for this slot aren't clear yet as of ASDF 2.27, but whenever they are, they will be enforced.
;; I'm introducing the slot before the conventions are set for maximum compatibility.
- (source-control :accessor system-source-control :initarg :source-control :initform nil)
+ (source-control :writer (setf system-source-control) :initarg :source-control :initform nil)
+
(builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p)
(build-pathname
:initform nil :initarg :build-pathname :accessor component-build-pathname)
@@ -8375,6 +8459,35 @@ NB: The onus is unhappily on the user to avoid clashes."
(frob-substrings (coerce-name name) '("/" ":" "\\") "--")))
+;;; System virtual slot readers, recursing to the primary system if needed.
+(with-upgradability ()
+ (defvar *system-virtual-slots* '(long-name description long-description
+ author maintainer mailto
+ homepage source-control
+ licence version bug-tracker)
+ "The list of system virtual slot names.")
+ (defun system-virtual-slot-value (system slot-name)
+ "Return SYSTEM's virtual SLOT-NAME value.
+If SYSTEM's SLOT-NAME value is NIL and SYSTEM is a secondary system, look in
+the primary one."
+ (or (slot-value system slot-name)
+ (unless (primary-system-p system)
+ (slot-value (find-system (primary-system-name system))
+ slot-name))))
+ (defmacro define-system-virtual-slot-reader (slot-name)
+ `(defun* ,(intern (concatenate 'string (string :system-)
+ (string slot-name)))
+ (system)
+ (system-virtual-slot-value system ',slot-name)))
+ (defmacro define-system-virtual-slot-readers ()
+ `(progn ,@(mapcar (lambda (slot-name)
+ `(define-system-virtual-slot-reader ,slot-name))
+ *system-virtual-slots*)))
+ (define-system-virtual-slot-readers)
+ (defun system-license (system)
+ (system-virtual-slot-value system 'licence)))
+
+
;;;; Pathnames
(with-upgradability ()
@@ -10786,8 +10899,9 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
(defvar *old-asdf-systems* (make-hash-table :test 'equal))
;; (Private) function to check that a system that was found isn't an asdf downgrade.
- ;; Returns T if everything went right, NIL if the system was an ASDF of the same or older version,
- ;; that shall not be loaded. Also issue a warning if it was a strictly older version of ASDF.
+ ;; Returns T if everything went right, NIL if the system was an ASDF at an older version,
+ ;; or UIOP of the same or older version, that shall not be loaded.
+ ;; Also issue a warning if it was a strictly older version of ASDF.
(defun check-not-old-asdf-system (name pathname)
(or (not (member name '("asdf" "uiop") :test 'equal))
(null pathname)
@@ -10798,9 +10912,12 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
(read-file-form version-pathname :at (if asdfp '(0) '(2 2 2)))))
(old-version (asdf-version)))
(cond
- ;; Don't load UIOP of the exact same version: we already loaded it as part of ASDF.
- ((and (equal old-version version) (equal name "uiop")) nil)
- ((version<= old-version version) t) ;; newer or same version: Good!
+ ;; Same version is OK for ASDF, to allow loading from modified source.
+ ;; However, do *not* load UIOP of the exact same version:
+ ;; it was already loaded it as part of ASDF and would only be double-loading.
+ ;; Be quiet about it, though, since it's a normal situation.
+ ((equal old-version version) asdfp)
+ ((version< old-version version) t) ;; newer version: Good!
(t ;; old version: bad
(ensure-gethash
(list (namestring pathname) version) *old-asdf-systems*
@@ -10962,6 +11079,8 @@ PREVIOUS-PRIMARY when not null is the primary system for the PREVIOUS system."
#:class-for-type #:*default-component-class*
#:determine-system-directory #:parse-component-form
#:non-toplevel-system #:non-system-system #:bad-system-name
+ #:*known-systems-with-bad-secondary-system-names*
+ #:known-system-with-bad-secondary-system-names-p
#:sysdef-error-component #:check-component-input
#:explain))
(in-package :asdf/parse-defsystem)
@@ -11114,7 +11233,7 @@ Please only define ~S and secondary systems with a name starting with ~S (e.g. ~
;;; "inline methods"
(with-upgradability ()
(defparameter* +asdf-methods+
- '(perform-with-restarts perform explain output-files operation-done-p))
+ '(perform-with-restarts perform explain output-files operation-done-p))
(defun %remove-component-inline-methods (component)
(dolist (name +asdf-methods+)
@@ -11127,19 +11246,55 @@ Please only define ~S and secondary systems with a name starting with ~S (e.g. ~
(component-inline-methods component)))
(component-inline-methods component) nil)
+ (defparameter *standard-method-combination-qualifiers*
+ '(:around :before :after))
+
+;;; Find inline method definitions of the form
+;;;
+;;; :perform (test-op :before (operation component) ...)
+;;;
+;;; in REST (which is the plist of all DEFSYSTEM initargs) and define the specified methods.
(defun %define-component-inline-methods (ret rest)
+ ;; find key-value pairs that look like inline method definitions in REST. For each identified
+ ;; definition, parse it and, if it is well-formed, define the method.
(loop* :for (key value) :on rest :by #'cddr
:for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
:when name :do
- (destructuring-bind (op &rest body) value
- (loop :for arg = (pop body)
- :while (atom arg)
- :collect arg :into qualifiers
- :finally
- (destructuring-bind (o c) arg
- (pushnew
- (eval `(defmethod ,name , at qualifiers ((,o ,op) (,c (eql ,ret))) , at body))
- (component-inline-methods ret)))))))
+ ;; parse VALUE as an inline method definition of the form
+ ;;
+ ;; (OPERATION-NAME [QUALIFIER] (OPERATION-PARAMETER COMPONENT-PARAMETER) &rest BODY)
+ (destructuring-bind (operation-name &rest rest) value
+ (let ((qualifiers '()))
+ ;; ensure that OPERATION-NAME is a symbol.
+ (unless (and (symbolp operation-name) (not (null operation-name)))
+ (sysdef-error "Ill-formed inline method: ~S. The first element is not a symbol ~
+ designating an operation but ~S."
+ value operation-name))
+ ;; ensure that REST starts with either a cons (potential lambda list, further checked
+ ;; below) or a qualifier accepted by the standard method combination. Everything else
+ ;; is ill-formed. In case of a valid qualifier, pop it from REST so REST now definitely
+ ;; has to start with the lambda list.
+ (cond
+ ((consp (car rest)))
+ ((not (member (car rest)
+ *standard-method-combination-qualifiers*))
+ (sysdef-error "Ill-formed inline method: ~S. Only a single of the standard ~
+ qualifiers ~{~S~^ ~} is allowed, not ~S."
+ value *standard-method-combination-qualifiers* (car rest)))
+ (t
+ (setf qualifiers (list (pop rest)))))
+ ;; REST must start with a two-element lambda list.
+ (unless (and (listp (car rest))
+ (length=n-p (car rest) 2)
+ (null (cddar rest)))
+ (sysdef-error "Ill-formed inline method: ~S. The operation name ~S is not followed by ~
+ a lambda-list of the form (OPERATION COMPONENT) and a method body."
+ value operation-name))
+ ;; define the method.
+ (destructuring-bind ((o c) &rest body) rest
+ (pushnew
+ (eval `(defmethod ,name , at qualifiers ((,o ,operation-name) (,c (eql ,ret))) , at body))
+ (component-inline-methods ret)))))))
(defun %refresh-component-inline-methods (component rest)
;; clear methods, then add the new ones
@@ -11253,6 +11408,13 @@ system names contained using COERCE-NAME. Return the result."
(coerce-name (component-system component))))
component)))
+ (defparameter* *known-systems-with-bad-secondary-system-names*
+ (list-to-hash-set '("cl-ppcre")))
+ (defun known-system-with-bad-secondary-system-names-p (asd-name)
+ ;; Does .asd file with name ASD-NAME contain known exceptions
+ ;; that should be screened out of checking for BAD-SYSTEM-NAME?
+ (gethash asd-name *known-systems-with-bad-secondary-system-names*))
+
(defun register-system-definition
(name &rest options &key pathname (class 'system) (source-file () sfp)
defsystem-depends-on &allow-other-keys)
@@ -11270,8 +11432,11 @@ system names contained using COERCE-NAME. Return the result."
(let* ((asd-name (and source-file
(equal "asd" (fix-case (pathname-type source-file)))
(fix-case (pathname-name source-file))))
+ ;; note that PRIMARY-NAME is a *syntactically* primary name
(primary-name (primary-system-name name)))
- (when (and asd-name (not (equal asd-name primary-name)))
+ (when (and asd-name
+ (not (equal asd-name primary-name))
+ (not (known-system-with-bad-secondary-system-names-p asd-name)))
(warn (make-condition 'bad-system-name :source-file source-file :name name))))
(let* (;; NB: handle defsystem-depends-on BEFORE to create the system object,
;; so that in case it fails, there is no incomplete object polluting the build.
@@ -11833,8 +11998,17 @@ which is probably not what you want; you probably need to tweak your output tran
:static-library (resolve-symlinks* pathname))))
(defun linkable-system (x)
- (or (if-let (s (find-system x))
+ (or ;; If the system is available as source, use it.
+ (if-let (s (find-system x))
+ (and (output-files 'lib-op s) s))
+ ;; If an ASDF upgrade is available from source, but not a UIOP upgrade to that,
+ ;; then use the asdf/driver system instead of
+ ;; the UIOP that was disabled by check-not-old-asdf-system.
+ (if-let (s (and (equal (coerce-name x) "uiop")
+ (output-files 'lib-op "asdf")
+ (find-system "asdf/driver")))
(and (output-files 'lib-op s) s))
+ ;; If there was no source upgrade, look for modules provided by the implementation.
(if-let (p (system-module-pathname (coerce-name x)))
(make-prebuilt-system x p))))
@@ -12567,7 +12741,7 @@ after having found a .asd file? True by default.")
(recurse-beyond-asds *recurse-beyond-asds*) ignore-cache)
(let ((visited (make-hash-table :test 'equalp)))
(flet ((collectp (dir)
- (unless (and (not ignore-cache) (process-source-registry-cache directory collect))
+ (unless (and (not ignore-cache) (process-source-registry-cache dir collect))
(let ((asds (collect-asds-in-directory dir collect)))
(or recurse-beyond-asds (not asds)))))
(recursep (x) ; x will be a directory pathname
@@ -13225,6 +13399,7 @@ system or its dependencies if it has already been loaded."
#:system-maintainer
#:system-license
#:system-licence
+ #:system-version
#:system-source-file
#:system-source-directory
#:system-relative-pathname
=====================================
src/contrib/asdf/doc/asdf.html
=====================================
The diff for this file was not included because it is too large.
=====================================
src/contrib/asdf/doc/asdf.info
=====================================
The diff for this file was not included because it is too large.
=====================================
src/contrib/asdf/doc/asdf.pdf
=====================================
Binary files a/src/contrib/asdf/doc/asdf.pdf and b/src/contrib/asdf/doc/asdf.pdf differ
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/76fd7aeffcee03106d710b311bc92439b2a88788
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/76fd7aeffcee03106d710b311bc92439b2a88788
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20190417/acdfdf57/attachment-0001.html>
More information about the cmucl-cvs
mailing list