Commit 2f7e523e authored by Robert P. Goldman's avatar Robert P. Goldman
parents 62b27376 3c52e6b7
ASDF: another system definition facility
========================================
If you want to use ASDF, read our manual:
If you cloned our git repository, bootstrap a copy of build/asdf.lisp with:
make
To use ASDF, read our manual:
http://common-lisp.net/project/asdf/asdf.html
......@@ -11,10 +15,11 @@ will get you started as a simple user.
If you want to define your own systems, further read the section
Defining systems with defsystem.
More information and additional links can be found on ASDF's
home page at:
http://common-lisp.net/project/asdf/
last updated Wednesday; May 5, 2010
Last updated Monday, Jan 28, 2013.
* Resolve performance degradation issue reported by stassats and fe[nl]ix
** Is it the warnings feature taking too much resources?
** Is output-files and/or input-files being called too much? Cache it!
* fix upgrade on (abcl, clisp, cmucl)
* fix upgrade on clisp
** Extract minimal test case
* Bug found by fe[nl]ix: infinite loop if the definitions in an asd file
are not in strict defsystem-depends-on dependency order. Document the issue.
......
......@@ -22,7 +22,7 @@ that you can't portably construct a complete program without using them."
(:file "common-lisp" :depends-on ("package"))
(:file "utility" :depends-on ("common-lisp"))
(:file "os" :depends-on ("utility"))
(:file "pathname" :depends-on ("utility"))
(:file "pathname" :depends-on ("utility" "os"))
(:file "filesystem" :depends-on ("os" "pathname"))
(:file "stream" :depends-on ("filesystem"))
(:file "image" :depends-on ("stream"))
......
......@@ -19,6 +19,10 @@
:components
((:file "header")))
#+asdf3
(defsystem :asdf/driver
:depends-on (:asdf-driver))
#+asdf3
(defsystem :asdf/defsystem
:licence "MIT"
......@@ -28,7 +32,7 @@
:build-operation monolithic-concatenate-source-op
:build-pathname "build/asdf" ;; our target
:around-compile call-without-redefinition-warnings ;; we need be the same as asdf-driver
:depends-on (:asdf/header :asdf-driver)
:depends-on (:asdf/header :asdf/driver)
:encoding :utf-8
:components
((:file "upgrade")
......@@ -62,7 +66,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.162" ;; to be automatically updated by make bump-version
:version "2.26.164" ;; 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.
......
......@@ -182,7 +182,7 @@ another pathname in a degenerate way."))
(compute-children-by-name m))))
(defclass module (child-component parent-component)
())
(#+clisp (components))) ;; backward compatibility during upgrade only
;;;; component pathnames
......
......@@ -69,7 +69,7 @@
or its polar opposite,
Drew McDermott's
<a href="http://cs-www.cs.yale.edu/homes/dvm/">YTools</a>
(trying maintain coherence of the current Lisp image at a fine grain),
(trying to maintain coherence of the current Lisp image at a fine grain),
or the newcomer
<a href="http://lisp.ystok.ru/asdlite/">ASDlite</a>
(a somewhat improved incompatible variant of ASDF 1).
......
......@@ -19,7 +19,11 @@
#:inter-directory-separator #:split-native-pathnames-string
#:getenv-pathname #:getenv-pathnames
#:getenv-absolute-directory #:getenv-absolute-directories
#:lisp-implementation-directory #:lisp-implementation-pathname-p))
#:lisp-implementation-directory #:lisp-implementation-pathname-p
;; Simple filesystem operations
#:ensure-all-directories-exist
#:rename-file-overwriting-target
#:delete-file-if-exists))
(in-package :asdf/filesystem)
;;; Native namestrings, as seen by the operating system calls rather than Lisp
......@@ -446,3 +450,19 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
t))
;;; Simple filesystem operations
(defun* ensure-all-directories-exist (pathnames)
(dolist (pathname pathnames)
(ensure-directories-exist (translate-logical-pathname pathname))))
(defun* rename-file-overwriting-target (source target)
#+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic
(posix:copy-file source target :method :rename)
#-clisp
(rename-file source target
#+clozure :if-exists #+clozure :rename-and-delete))
(defun* delete-file-if-exists (x)
(handler-case (delete-file x) (file-error () nil)))
......@@ -18,7 +18,7 @@
#:find-system-if-being-defined #:*systems-being-defined*
#:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
#:system-find-preloaded-system #:register-preloaded-system #:*preloaded-systems*
#:make-defined-systems-table #:*defined-systems*
#:clear-defined-systems #:*defined-systems*
;; defined in source-registry, but specially mentioned here:
#:initialize-source-registry #:sysdef-source-registry-search))
(in-package :asdf/find-system)
......@@ -251,19 +251,20 @@ Going forward, we recommend new users should be using the source-registry.
(defun* load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))))
;; Tries to load system definition with canonical NAME from PATHNAME.
(with-system-definitions ()
(let ((*package* (find-package :asdf-user))
(*default-pathname-defaults*
;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
(pathname-directory-pathname (translate-logical-pathname pathname))))
(handler-bind
((error #'(lambda (condition)
(error 'load-system-definition-error
:name name :pathname pathname
:condition condition))))
(asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
name pathname)
(with-muffled-loader-conditions ()
(load* pathname :external-format external-format))))))
(with-standard-io-syntax
(let ((*package* (find-package :asdf-user))
(*default-pathname-defaults*
;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
(pathname-directory-pathname (translate-logical-pathname pathname))))
(handler-bind
((error #'(lambda (condition)
(error 'load-system-definition-error
:name name :pathname pathname
:condition condition))))
(asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
name pathname)
(with-muffled-loader-conditions ()
(load* pathname :external-format external-format)))))))
(defun* locate-system (name)
"Given a system NAME designator, try to locate where to load the system from.
......@@ -341,3 +342,4 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(register-preloaded-system "asdf")
(register-preloaded-system "asdf-driver")
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.26.162: Another System Definition Facility.
;;; This is ASDF 2.26.164: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......@@ -54,7 +54,7 @@
(declaim (optimize (speed 1) (safety 3) (debug 3)))
(setf ext:*gc-verbose* nil))
#+(or abcl clisp cmu)
#+clisp
(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (member :asdf3 *features*)
(let* ((existing-version
......
......@@ -89,6 +89,8 @@ This is designed to abstract away the implementation specific quit forms."
(defun* raw-print-backtrace (&key (stream *debug-io*) count)
"Print a backtrace, directly accessing the implementation"
(declare (ignorable stream count))
#+abcl
(let ((*debug-io* stream)) (top-level::backtrace-command count))
#+allegro
(let ((*terminal-io* stream)
(*standard-output* stream)
......
......@@ -47,6 +47,7 @@
#:monolithic-compile-concatenated-source-op
#:monolithic-load-compiled-concatenated-source-op
#:operation-monolithic-p
#:required-components
#:component #:parent-component #:child-component #:system #:module
#:file-component #:source-file #:c-source-file #:java-source-file
......
......@@ -12,7 +12,7 @@
#: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))
#:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source #:flags))
(in-package :asdf/lisp-action)
......
......@@ -4,7 +4,7 @@
(asdf/package:define-package :asdf/lisp-build
(:recycle :asdf/interface :asdf :asdf/lisp-build)
(:use :asdf/common-lisp :asdf/package :asdf/utility
:asdf/pathname :asdf/stream :asdf/os :asdf/image)
:asdf/os :asdf/pathname :asdf/filesystem :asdf/stream :asdf/image)
(:export
;; Variables
#:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
......
......@@ -5,7 +5,7 @@
(asdf/package:define-package :asdf/pathname
(:recycle :asdf/pathname :asdf)
(:use :asdf/common-lisp :asdf/package :asdf/utility)
(:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os)
(:export
;; Making and merging pathnames, portably
#:normalize-pathname-directory-component #:denormalize-pathname-directory-component
......
......@@ -6,7 +6,7 @@
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade
:asdf/component :asdf/operation :asdf/system
:asdf/cache :asdf/find-system :asdf/find-component
:asdf/operation :asdf/action)
:asdf/operation :asdf/action :asdf/lisp-action)
(:export
#:component-operation-time #:mark-operation-done
#:plan-traversal #:sequential-plan #:*default-plan-class*
......@@ -421,7 +421,8 @@ processed in order by OPERATE."))
(traverse-action plan o c t))
(plan-actions plan)))
(defmethod traverse-sub-actions (operation component &rest keys &key &allow-other-keys)
(define-convenience-action-methods traverse-sub-actions (o c &key))
(defmethod traverse-sub-actions ((operation operation) (component component) &rest keys &key &allow-other-keys)
(apply 'traverse-actions (direct-dependencies operation component)
:system (component-system component) keys))
......@@ -434,6 +435,6 @@ 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 (make-operation goal-operation) system keys))
(mapcar 'cdr (apply 'traverse-sub-actions goal-operation system keys))
:from-end t))
......@@ -19,9 +19,7 @@
#:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
#:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
#:*default-encoding* #:*utf-8-external-format*
#:ensure-all-directories-exist
#:rename-file-overwriting-target
#:delete-file-if-exists
;; Temporary files
#:*temporary-directory* #:temporary-directory #:default-temporary-directory
#:setup-temporary-directory
#:call-with-temporary-file #:with-temporary-file
......@@ -339,7 +337,7 @@ hopefully, if done consistently, that won't affect program behavior too much.")
"Hook for an extension to define a function to automatically detect a file's encoding")
(defun* detect-encoding (pathname)
(if (and pathname (not (directory-pathname-p pathname)) (probe-file pathname))
(if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname))
(funcall *encoding-detection-hook* pathname)
*default-encoding*))
......@@ -360,22 +358,6 @@ and implementation-defined external-format's")
(funcall *encoding-external-format-hook* encoding))
;;; Simple filesystem operations
(defun* ensure-all-directories-exist (pathnames)
(dolist (pathname pathnames)
(ensure-directories-exist (translate-logical-pathname pathname))))
(defun* rename-file-overwriting-target (source target)
#+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic
(posix:copy-file source target :method :rename)
#-clisp
(rename-file source target
#+clozure :if-exists #+clozure :rename-and-delete))
(defun* delete-file-if-exists (x)
(handler-case (delete-file x) (file-error () nil)))
;;; Using temporary files
(defun* default-temporary-directory ()
(or
......@@ -409,7 +391,7 @@ and implementation-defined external-format's")
:for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
;; TODO: on Unix, do something about umask
;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
;; TODO: on Unix, use CFFI and mkstemp -- but the master is precisely meant to not depend on CFFI or on anything! Grrrr.
;; TODO: on Unix, use CFFI and mkstemp -- but asdf/driver is precisely meant to not depend on CFFI or on anything! Grrrr.
(with-open-file (stream pathname
:direction direction
:element-type element-type
......
......@@ -282,8 +282,8 @@ extract_tagged_asdf () {
}
valid_upgrade_test_p () {
case "${1}:${2}:${3}" in
abcl:2.0[01][1-9]:*|abcl:2.2[1-2]:*)
: Skip, because it is so damn slow ;;
abcl:1.*|abcl:2.00[0-9]:*|abcl:201[0-7]:*)
: "Skip, because it is so slow." ;;
ccl:1.*|ccl:2.0[01]*)
: Skip, because ccl broke old asdf ;;
clisp:1.??*|clisp:2.00[0-7]:*)
......@@ -291,8 +291,9 @@ valid_upgrade_test_p () {
# 2.00[0-7] use UID, which fails on that CLISP and was removed afterwards.
# Note that for the longest time, CLISP has included 2.011 in its distribution.
: ;;
cmucl:1.*|cmucl:2.00*|cmucl:2.01[0-4]:*)
: Skip, CMUCL has problems before 2.014.7 due to source-registry upgrade ;;
cmucl:1.*|cmucl:2.00*|cmucl:2.01[0-7]:*)
: Skip, CMUCL has problems before 2.014.7 due to source-registry upgrade
: Weird unidentified problems before 2.018 ;;
ecl*:1.*|ecl*:2.0[01]*|ecl*:2.20:*)
: Skip, because of various ASDF issues ;;
gcl:1.*|gcl:2.0*|gcl:2.2[0-6]*) : Skip old versions that do not support GCL 2.6 ;;
......@@ -316,7 +317,7 @@ run_upgrade_tests () {
"'(#.(load\"$su\")#.(in-package :asdf-test)#.(test-upgrade $method \"$tag\"))" ||
{ echo "upgrade FAILED for $lisp from $tag using method $method" ;
echo "you can retry just that test with:" ;
echo ASDF_UPGRADE_TEST_TAGS=\"$tag\" ADSF_UPGRADE_TEST_METHODS=\"$method\" ./test/run-tests.sh -u $lisp ;
echo ASDF_UPGRADE_TEST_TAGS=\"$tag\" ASDF_UPGRADE_TEST_METHODS=\"$method\" ./test/run-tests.sh -u $lisp ;
echo "or more interactively (and maybe with rlwrap or in emacs), start with:"
echo "$cmd"
echo "then copy/paste:"
......
......@@ -430,9 +430,9 @@ is bound, write a message and exit on an error. If
(cons (format nil "~{~D~^.~}" ver))
(null "1.0"))))))
(defun test-upgrade (old-method new-method tag) ;; called by run-test
(with-test ()
(verbose t nil)
(when old-method
(cond
((string-equal tag "REQUIRE")
......@@ -443,7 +443,9 @@ is bound, write a message and exit on an error. If
(leave-test "Your Lisp implementation does not provide ASDF. Skipping test.~%" 0)))
(t
(format t "Loading old asdf ~A via ~A~%" tag old-method)
(funcall old-method tag))))
(funcall old-method tag)))
(setf (asymval :*asdf-verbose*) t)
(setf (asymval :*verbose-out*) *standard-output*))
(format t "Now loading new asdf via method ~A~%" new-method)
(funcall new-method)
(format t "Testing it~%")
......
......@@ -2,30 +2,19 @@
;;; test asdf:try-recompiling restart
(defvar *caught-error* nil)
(progn
(DBG "trlc1 1")
(asdf::delete-file-if-exists "try-reloading-dependency.asd")
(setf asdf::*defined-systems* (asdf::make-defined-systems-table))
(DBG "trlc1 2")
(handler-bind ((error (lambda (c)
(format t "~&Caught error ~s" c)
(setf *caught-error* t)
(asdf::concatenate-files
'("try-reloading-dependency.hidden")
"try-reloading-dependency.asd")
(DBG "trlc1 5")
(multiple-value-bind (name mode)
(find-symbol (symbol-name 'retry) :asdf)
(DBG "trlc1 6" name mode)
(assert (eq mode :external) nil "Mode of ~s was not external" name)
(let ((restart (find-restart name c)))
(DBG "trlc1 7" name restart)
(assert restart)
(when restart (invoke-restart restart)))))))
(DBG "trlc1 3")
(asdf:oos 'asdf:load-op 'try-reloading-1))
(DBG "trlc1 4")
(assert *caught-error*))
(delete-file-if-exists "try-reloading-dependency.asd")
(asdf::clear-defined-systems)
(handler-bind
((error #'(lambda (c)
(format t "~&Caught error ~s" c)
(setf *caught-error* t)
(concatenate-files '("try-reloading-dependency.hidden") "try-reloading-dependency.asd")
(DBG "trlc1 5")
(multiple-value-bind (name mode) (find-symbol* :retry :asdf)
(assert (eq mode :external) () "Mode of ~s was not external" name)
(let ((restart (find-restart name c)))
(assert restart)
(when restart (invoke-restart restart)))))))
(load-system 'try-reloading-1))
(assert *caught-error*)
......@@ -54,15 +54,22 @@ 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.26.162")
(asdf-version "2.26.164")
(existing-version (asdf-version)))
(setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version)))
(push existing-version *previous-asdf-versions*)
(when *asdf-verbose*
(format *trace-output*
(compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
existing-version asdf-version)))
(setf *asdf-version* asdf-version)))
existing-version asdf-version))
;; Punt when upgrading from too old a version of ASDF
#+(or abcl clisp cmu)
(when (version< existing-version #+abcl "2.25" #+cmu "2.018" #+clisp "2.27")
(let ((away (format nil "~A-~A" :asdf existing-version)))
(rename-package :asdf away)
(when (or *load-verbose* *asdf-verbose*)
(format *trace-output* "; Renamed package ~A away to ~A~%" :asdf away)))))))
(when-upgrading ()
(let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops.
......@@ -87,12 +94,12 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
#:resolve-relative-location-component #:resolve-absolute-location-component
#:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function
(declare (ignorable redefined-functions uninterned-symbols))
(loop :for name :in (append #-(or clisp ecl) redefined-functions)
(loop :for name :in (append #-(or ecl) redefined-functions)
:for sym = (find-symbol* name :asdf nil) :do
(when sym
(fmakunbound sym)))
(loop :with asdf = (find-package :asdf)
:for name :in (append #+(or clisp ecl) redefined-functions uninterned-symbols) ;XXX
:for name :in (append #+(or ecl) redefined-functions uninterned-symbols) ;XXX
:for sym = (find-symbol* name :asdf nil)
:for base-pkg = (and sym (symbol-package sym)) :do
(when sym
......
......@@ -28,7 +28,8 @@
#:match-condition-p #:match-any-condition-p ;; conditions
#:call-with-muffled-conditions #:with-muffled-conditions
#:load-string #:load-stream
#:parse-version #:unparse-version #:version-compatible-p)) ;; version
#:lexicographic< #:lexicographic<=
#:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version
(in-package :asdf/utility)
;;;; Defining functions in a way compatible with hot-upgrade:
......@@ -314,6 +315,7 @@ instead of a list."
;;; Version handling
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun* unparse-version (version-list)
(format nil "~{~D~^.~}" version-list))
......@@ -344,22 +346,33 @@ in that it doesn't print back to itself, but the list is returned anyway."
(call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string))
version-list)))
(defun* lexicographic< (< x y)
(cond ((null y) nil)
((null x) t)
((funcall < (car x) (car y)) t)
((funcall < (car y) (car x)) nil)
(t (lexicographic< < (cdr x) (cdr y)))))
(defun* lexicographic<= (< x y)
(not (lexicographic< < y x)))
(defun* version< (version1 version2)
(let ((v1 (parse-version version1 nil))
(v2 (parse-version version2 nil)))
(lexicographic< '< v1 v2)))
(defun* version<= (version1 version2)
(not (version< version2 version1)))
(defun* version-compatible-p (provided-version required-version)
"Is the provided version a compatible substitution for the required-version?
If major versions differ, it's not compatible.
If they are equal, then any later version is compatible,
with later being determined by a lexicographical comparison of minor numbers."
(let ((x (parse-version provided-version 'warn))
(y (parse-version required-version 'warn)))
(labels ((bigger (x y)
(cond ((not y) t)
((not x) nil)
((> (car x) (car y)) t)
((= (car x) (car y))
(bigger (cdr x) (cdr y))))))
(and x y (= (car x) (car y))
(or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
(let ((x (parse-version provided-version nil))
(y (parse-version required-version nil)))
(and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x)))))
); eval-when for version support
;;; Condition control
......
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