Commit a1aa0b12 authored by Robert Goldman's avatar Robert Goldman

Merge branch 'master' of common-lisp.net:asdf/asdf

* 'master' of common-lisp.net:asdf/asdf:
  Define and use not-implemented-error and parameter-error
  Fix warning in test-require
  Bump version to 3.1.7.23
  Include tests for require-system
  Let mark-component-preloaded accept any component designator.
parents ad43c36f 19b4935e
......@@ -75,7 +75,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "3.1.7.22" ;; to be automatically updated by make bump-version
:version "3.1.7.23" ;; to be automatically updated by make bump-version
:depends-on ()
#+asdf3 :encoding #+asdf3 :utf-8
:class #+asdf3.1 package-inferred-system #-asdf3.1 system
......
......@@ -65,7 +65,7 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
@titlepage
@title ASDF: Another System Definition Facility
@subtitle Manual for Version 3.1.7.22
@subtitle Manual for Version 3.1.7.23
@c The following two commands start the copyright page.
@page
@vskip 0pt plus 1filll
......
......@@ -125,8 +125,8 @@
(resolve-dependency-combination component (car dep-spec) (cdr dep-spec)))))
(defmethod resolve-dependency-combination (component combinator arguments)
(error (compatfmt "~@<Bad dependency ~S for ~S~@:>")
(cons combinator arguments) component))
(parameter-error (compatfmt "~@<In ~S, bad dependency ~S for ~S~@:>")
'resolve-dependency-combination (cons combinator arguments) component))
(defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments)
(when (featurep (first arguments))
......
;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
;;; This is ASDF 3.1.7.22: Another System Definition Facility.
;;; This is ASDF 3.1.7.23: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -203,8 +203,9 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms."))
(defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments)
(unless (and (length=n-p arguments 1)
(typep (car arguments) '(or string (and symbol (not null)))))
(error (compatfmt "~@<Bad dependency ~S for ~S. ~S takes one argument, a string or non-null symbol~@:>")
(cons combinator arguments) component combinator))
(parameter-error (compatfmt "~@<In ~S, bad dependency ~S for ~S. ~S takes one argument, a string or non-null symbol~@:>")
'resolve-dependency-combination
(cons combinator arguments) component combinator))
;; :require must be prepared for some implementations providing modules using ASDF,
;; as SBCL used to do, and others may might do. Thus, the system provided in the end
;; would be a downcased name as per module-provide-asdf above. For the same reason,
......@@ -212,10 +213,9 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms."))
;; but must check whether we can use find-system and short-circuit cl:require.
;; Otherwise, calling cl:require could result in nasty reentrant calls between
;; cl:require and asdf:operate that could potentially blow up the stack.
(let* ((module (car arguments))
(let* ((module (car arguments)) ;; NB: we already checked that it was not null
(name (string-downcase module))
(system (find-system name nil)))
(assert module)
(or system (let ((system (make-instance 'require-system :name name)))
(register-system system)
system))))
......@@ -259,10 +259,11 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms."))
;; It is defined here to resolve what would otherwise be forward package references.
(defun mark-component-preloaded (component)
"Mark a component as preloaded."
;; Recurse to children, so asdf/plan will hopefully be happy.
(map () 'mark-component-preloaded (component-children component))
;; Mark the timestamps of the common lisp-action operations as 0.
(let ((times (component-operation-times component)))
(dolist (o '(load-op compile-op prepare-op))
(setf (gethash o times) 0)))))
(let ((component (find-component component nil :registered t)))
;; Recurse to children, so asdf/plan will hopefully be happy.
(map () 'mark-component-preloaded (component-children component))
;; Mark the timestamps of the common lisp-action operations as 0.
(let ((times (component-operation-times component)))
(dolist (o '(load-op compile-op prepare-op))
(setf (gethash o times) 0))))))
(defsystem "require-system" :version "2.0"
:depends-on ("require-system/immutable"))
(defsystem "require-system/preloaded" :version "2.0")
(defsystem "require-system/immutable" :version "2.0")
(defsystem "require-system/not-loaded" :version "2.0")
(defsystem "require-system/ordinary" :version "2.0")
(defsystem "require-system/require"
:version "2.0"
:depends-on ((:require "require-system/module1")
(:require "require-system/module2")))
(defsystem "require-system/depends"
:version "2.0"
:depends-on ("test-asdf/module1"
"require-system-module2"))
......@@ -31,7 +31,8 @@ Some constraints:
#:leave-test #:def-test-system
#:action-name #:in-plan-p
#:test-source #:test-fasl #:resolve-output #:output-location
#:quietly #:join-namestrings))
#:quietly #:join-namestrings
#:clear-cache))
(in-package :asdf-test)
......@@ -729,6 +730,10 @@ is bound, write a message and exit on an error. If
:for (n . morep) :on namestrings
:do (format s "~A~@[~C~]" n (and morep separator)))))
(defun clear-cache ()
;; Or, should we preserve the timestamps?
(clrhash (asymval :*asdf-cache*)))
;; These are shorthands for interactive debugging of test scripts:
(!a
common-lisp-user::debug-asdf debug-asdf
......
;; -*- Lisp -*-
;;; This script verifies the invariants of both
;;; *function* REQUIRE-SYSTEM and *class* REQUIRE-SYSTEM.
;;; Based on work by Daniel Kochmański
(import 'asdf::registered-system)
(DBG "---- Tests related to the behavior of preloaded systems")
(DBG "- Even dummy `preloaded-system' is listed in `already-loaded-systems'")
(register-preloaded-system "test-preloaded-dummy" :version "1.0")
(assert (registered-system "test-preloaded-dummy"))
(assert-equal (component-version (registered-system "test-preloaded-dummy")) "1.0")
(DBG "- Loaded `preloaded-system' is listed in `already-loaded-systems'")
(assert (component-loaded-p (registered-system "test-preloaded-dummy")))
(assert (member "test-preloaded-dummy" (already-loaded-systems) :test #'equal))
(DBG "- Dummy `preloaded-system' doesn't get overwritten by `require-system'")
(require-system "test-preloaded-dummy")
(assert-equal (component-version (registered-system "test-preloaded-dummy")) "1.0")
(DBG "- Dummy `preloaded-system' doesn't get overwritten by `load-system' because there is no alternative in the filesystem")
(load-test-system "test-preloaded-dummy")
(assert-equal (component-version (registered-system "test-preloaded-dummy")) "1.0")
(DBG "- Function `clear-system' doesn't remove `preloaded-system'")
(assert (not (clear-system "test-preloaded-dummy")))
(assert-equal (component-version (registered-system "test-preloaded-dummy")) "1.0")
(DBG "-`preloaded-system' overridden by defsystem")
(def-test-system "test-preloaded-dummy" :version "2.0")
(assert-equal (component-version (registered-system "test-preloaded-dummy")) "2.0")
(DBG "- Function `clear-system' restores `preloaded-system'")
(assert (not (clear-system "test-preloaded-dummy")))
(assert-equal (component-version (registered-system "test-preloaded-dummy")) "1.0")
(DBG "-`preloaded-system' overridden by find-system")
(assert (not (registered-system "require-system/preloaded")))
(register-preloaded-system "require-system/preloaded" :version "1.0")
(assert-equal (component-version (registered-system "require-system/preloaded")) "1.0")
(assert (component-loaded-p (registered-system "require-system/preloaded")))
(find-system "require-system/preloaded")
(assert-equal (component-version (registered-system "require-system/preloaded")) "2.0")
(DBG "-`find-system' doesn't make the new system loaded")
(assert (not (component-loaded-p (registered-system "require-system/preloaded"))))
(DBG "-`load-system' does")
(load-system "require-system/preloaded")
(assert (component-loaded-p (registered-system "require-system/preloaded")))
(DBG "- Function `clear-system' restores registered, preloaded `preloaded-system'")
(assert (not (clear-system "require-system/preloaded")))
(assert-equal (component-version (registered-system "require-system/preloaded")) "1.0")
(assert (component-loaded-p (registered-system "require-system/preloaded")))
(assert (member "require-system/preloaded" (already-loaded-systems) :test #'equal))
(DBG "- Function `require-system' doesn't overwrite `preloaded-system'")
(require-system "require-system/preloaded")
(assert-equal (component-version (registered-system "require-system/preloaded")) "1.0")
(DBG "- Function `require-system' doesn't trigger a side-effect reloading system")
;;; `require-system' called `load-system' regardless if the system was
;;; loaded or not. While the `:force' and `:force-not' flags were
;;; handled correctly, `load-system' had a nasty side-effect which
;;; were overwriting our system loaded in-memory, so the second
;;; `require-system' loaded the new `asd'-defined system.
(require-system "require-system/preloaded")
(assert-equal (component-version (registered-system "require-system/preloaded")) "1.0")
(DBG "- System `preloaded-system' won't be reloaded on `require-system' when cache is empty")
(clear-cache)
(assert-equal (component-version (registered-system "require-system/preloaded")) "1.0")
(require-system "require-system/preloaded")
(assert-equal (component-version (registered-system "require-system/preloaded")) "1.0")
(DBG "- Function `load-system' overwrites `preloaded-system'")
(load-system "require-system/preloaded")
(assert-equal (component-version (registered-system "require-system/preloaded")) "2.0")
(DBG "- Update the preloaded system version after loading from asd")
(register-preloaded-system "require-system/preloaded")
(assert-equal (component-version (registered-system "require-system/preloaded")) "2.0")
(assert (not (clear-system "require-system/preloaded")))
(assert-equal (component-version (registered-system "require-system/preloaded")) "2.0")
;; Not implemented:
#|
(deregister-preloaded-system "require-system/preloaded")
(assert-equal (component-version (registered-system "require-system/preloaded")) "2.0")
(assert (clear-system "require-system/preloaded"))
(assert (not (registered-system "require-system/preloaded")))
|#
(DBG "---- Tests related to the behavior of immutable systems")
(DBG "- Test function `register-immutable-system'")
;; Note: it's not immutable *yet*, but loaded from file.
(assert-equal (component-version (registered-system "require-system/immutable")) "2.0")
(clear-system "require-system/immutable")
(def-test-system "require-system/immutable" :version "1.0"
:depends-on ("require-system/not-loaded")
:components ((:file "file1")))
(assert (not (component-loaded-p "require-system/immutable")))
(assert-equal (component-version (registered-system "require-system/immutable")) "1.0")
(let ((system (registered-system "require-system/immutable")))
(register-immutable-system "require-system/immutable")
(assert (eq system (registered-system "require-system/immutable"))))
(assert (eq 'system (type-of (registered-system "require-system/immutable"))))
(assert-equal 1 (length (component-children (registered-system "require-system/immutable"))))
(assert (not (component-loaded-p "require-system/immutable"))) ;; *not* marked loaded
(assert-equal (component-version (registered-system "require-system/immutable")) "1.0")
(DBG "- Function `require-system' doesn't overwrite `immutable-system'")
(require-system "require-system/immutable")
(assert-equal (component-version (registered-system "require-system/immutable")) "1.0")
(assert (not (component-loaded-p "require-system/immutable"))) ;; *not* marked loaded
(DBG "- Function `load-system' doesn't overwrite `immutable-system'")
(load-system "require-system/immutable")
(assert-equal (component-version (registered-system "require-system/immutable")) "1.0")
(assert (not (component-loaded-p "require-system/immutable"))) ;; *not* marked loaded
(DBG "- Function `load-system' doesn't load an immutable system's dependencies")
(assert (not (component-loaded-p "require-system/not-loaded"))) ;; *not* marked loaded
(DBG "- Function `clear-system' leaves `immutable-system' loaded, but clears build information")
(assert-equal 1 (length (component-children (registered-system "require-system/immutable"))))
(assert (not (component-loaded-p "require-system/immutable"))) ;; still not marked loaded
(clear-system "require-system/immutable")
(assert-equal (component-version (registered-system "require-system/immutable")) "1.0")
(assert-equal 0 (length (component-children (registered-system "require-system/immutable"))))
(assert (component-loaded-p "require-system/immutable")) ;; *YES* marked loaded!
(DBG "- System `immutable-system' won't be reloaded when cache is empty")
(clear-cache)
(load-system "require-system/immutable")
(assert-equal (component-version (registered-system "require-system/immutable")) "1.0")
(DBG "---- Tests related to the behavior of ordinary systems")
(DBG "- Require-system doesn't replace already loaded system")
(def-test-system "require-system/ordinary" :version "1.0")
(asdf::mark-component-preloaded "require-system/ordinary")
(assert (component-loaded-p "require-system/ordinary"))
(require-system "require-system/ordinary")
(assert-equal (component-version (registered-system "require-system/ordinary")) "1.0")
(DBG "- Load-system loads system from the disk")
(clear-cache)
(load-system "require-system/ordinary")
(assert-equal (component-version (registered-system "require-system/ordinary")) "2.0")
;;; We can't actually test portably loading an implementation-dependent module,
;;; because we don't know what modules does implementations ship, so we'll only
;;; test the feature on implementations that support hooking ASDF into CL:REQUIRE
;;; Which is most of the interesting ones, anyway.
(defparameter *mod*
(or
#+abcl :abcl-contrib
#+allegro :yacc
#+clisp "zlib" ;; Has to be lower case!
#+(or clozure cmucl) :defsystem
#+ecl :ecl-curl
#+lispworks "comm"
#+mkcl :walker
#+sbcl :sb-md5
#+scl :http-library))
(unless *mod*
(leave-test "This implementation doesn't provide a known module" 0))
(defun has-module-p (x)
;; note that the spec is case-sensitive, but we'll cast a wider net.
(and (member x *modules* :test 'string-equal) t))
(assert (not (find-system *mod* nil)))
(assert (not (has-module-p *mod*)))
(eval `(def-test-system :require-test :depends-on ((:require ,*mod*))))
(load-system :require-test)
(assert (has-module-p *mod*))
......@@ -622,7 +622,7 @@ in an atomic way if the implementation allows."
`(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
#+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname)))
#-(or abcl allegro clasp clisp clozure cmucl cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
(error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera
(not-implemented-error 'delete-empty-directory "(on your platform)")) ; genera
(defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
"Delete a directory including all its recursive contents, aka rm -rf.
......
......@@ -232,7 +232,7 @@ depending on whether *LISP-INTERACTION* is set, enter debugger or die"
#+sbcl sb-ext:*posix-argv*
#+xcl system:*argv*
#-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
(error "raw-command-line-arguments not implemented yet"))
(not-implemented-error 'raw-command-line-arguments))
(defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
"Extract user arguments from command-line invocation of current process.
......@@ -422,7 +422,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
;; Is it meaningful to run these in the current environment?
;; only if we also track the object files that constitute the "current" image,
;; and otherwise simulate dump-image, including quitting at the end.
#-(or clasp ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image)
#-(or clasp ecl mkcl) (not-implemented-error 'create-image)
#+(or clasp ecl mkcl)
(let ((epilogue-code
(if no-uiop
......
......@@ -30,10 +30,11 @@
#:list-to-hash-set #:ensure-gethash ;; hash-table
#:ensure-function #:access-at #:access-at-count ;; functions
#:call-function #:call-functions #:register-hook-function
#:lexicographic< #:lexicographic<= ;; version
#:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p
#:match-condition-p #:match-any-condition-p ;; conditions
#:call-with-muffled-conditions #:with-muffled-conditions
#:lexicographic< #:lexicographic<=
#:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version
#:not-implemented-error #:parameter-error))
(in-package :uiop/utility)
;;;; Defining functions in a way compatible with hot-upgrade:
......@@ -619,3 +620,41 @@ or a string describing the format-control of a simple-condition."
"Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS"
`(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
;;; Conditions
(with-upgradability ()
(define-condition not-implemented-error (error)
((functionality :initarg :functionality)
(format-control :initarg :format-control)
(format-arguments :initarg :format-arguments))
(:report (lambda (condition stream)
(format stream "Not implemented: ~s~@[ ~?~]"
(slot-value condition 'functionality)
(slot-value condition 'format-control)
(slot-value condition 'format-arguments)))))
(defun not-implemented-error (functionality &optional format-control &rest format-arguments)
(error 'not-implemented-error
:functionality functionality
:format-control format-control
:format-arguments format-arguments))
(define-condition parameter-error (error)
((functionality :initarg :functionality)
(format-control :initarg :format-control)
(format-arguments :initarg :format-arguments))
(:report (lambda (condition stream)
(apply 'format stream
(slot-value condition 'format-control)
(slot-value condition 'functionality)
(slot-value condition 'format-arguments)))))
;; Note that functionality MUST be passed as the second argument to parameter-error, just after
;; the format-control. If you want it to not appear in first position in actual message, use
;; ~* and ~:* to adjust parameter order.
(defun parameter-error (format-control functionality &rest format-arguments)
(error 'parameter-error
:functionality functionality
:format-control format-control
:format-arguments format-arguments)))
......@@ -76,7 +76,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.1.7.22")
(asdf-version "3.1.7.23")
(existing-version (asdf-version)))
(setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version)))
......
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