Skip to content
Snippets Groups Projects
Commit b4333763 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.26.164: upgrade now works on ABCL! But still not on CLISP.

Also, move some functions from stream to filesystem where they belong.
parent ac799f29
No related branches found
No related tags found
No related merge requests found
* Resolve performance degradation issue reported by stassats and fe[nl]ix * Resolve performance degradation issue reported by stassats and fe[nl]ix
** Is it the warnings feature taking too much resources? ** Is it the warnings feature taking too much resources?
** Is output-files and/or input-files being called too much? Cache it! ** 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 ** Extract minimal test case
* Bug found by fe[nl]ix: infinite loop if the definitions in an asd file * 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. 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." ...@@ -22,7 +22,7 @@ that you can't portably construct a complete program without using them."
(:file "common-lisp" :depends-on ("package")) (:file "common-lisp" :depends-on ("package"))
(:file "utility" :depends-on ("common-lisp")) (:file "utility" :depends-on ("common-lisp"))
(:file "os" :depends-on ("utility")) (:file "os" :depends-on ("utility"))
(:file "pathname" :depends-on ("utility")) (:file "pathname" :depends-on ("utility" "os"))
(:file "filesystem" :depends-on ("os" "pathname")) (:file "filesystem" :depends-on ("os" "pathname"))
(:file "stream" :depends-on ("filesystem")) (:file "stream" :depends-on ("filesystem"))
(:file "image" :depends-on ("stream")) (:file "image" :depends-on ("stream"))
......
...@@ -66,7 +66,7 @@ ...@@ -66,7 +66,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.163" ;; to be automatically updated by make bump-version :version "2.26.164" ;; to be automatically updated by make bump-version
:depends-on () :depends-on ()
#+asdf3 :encoding #+asdf3 :utf-8 #+asdf3 :encoding #+asdf3 :utf-8
;; For most purposes, asdf itself specially counts as a builtin system. ;; For most purposes, asdf itself specially counts as a builtin system.
......
...@@ -182,7 +182,7 @@ another pathname in a degenerate way.")) ...@@ -182,7 +182,7 @@ another pathname in a degenerate way."))
(compute-children-by-name m)))) (compute-children-by-name m))))
(defclass module (child-component parent-component) (defclass module (child-component parent-component)
()) (#+clisp (components))) ;; backward compatibility during upgrade only
;;;; component pathnames ;;;; component pathnames
......
...@@ -19,7 +19,11 @@ ...@@ -19,7 +19,11 @@
#:inter-directory-separator #:split-native-pathnames-string #:inter-directory-separator #:split-native-pathnames-string
#:getenv-pathname #:getenv-pathnames #:getenv-pathname #:getenv-pathnames
#:getenv-absolute-directory #:getenv-absolute-directories #: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) (in-package :asdf/filesystem)
;;; Native namestrings, as seen by the operating system calls rather than Lisp ;;; 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." ...@@ -446,3 +450,19 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
t)) 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)))
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.26.163: Another System Definition Facility. ;;; This is ASDF 2.26.164: Another System Definition Facility.
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
...@@ -54,7 +54,7 @@ ...@@ -54,7 +54,7 @@
(declaim (optimize (speed 1) (safety 3) (debug 3))) (declaim (optimize (speed 1) (safety 3) (debug 3)))
(setf ext:*gc-verbose* nil)) (setf ext:*gc-verbose* nil))
#+(or abcl clisp) ;; cmu #+clisp
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
(unless (member :asdf3 *features*) (unless (member :asdf3 *features*)
(let* ((existing-version (let* ((existing-version
......
...@@ -89,6 +89,8 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -89,6 +89,8 @@ This is designed to abstract away the implementation specific quit forms."
(defun* raw-print-backtrace (&key (stream *debug-io*) count) (defun* raw-print-backtrace (&key (stream *debug-io*) count)
"Print a backtrace, directly accessing the implementation" "Print a backtrace, directly accessing the implementation"
(declare (ignorable stream count)) (declare (ignorable stream count))
#+abcl
(let ((*debug-io* stream)) (top-level::backtrace-command count))
#+allegro #+allegro
(let ((*terminal-io* stream) (let ((*terminal-io* stream)
(*standard-output* stream) (*standard-output* stream)
......
...@@ -12,7 +12,7 @@ ...@@ -12,7 +12,7 @@
#:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations #: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 #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
#:call-with-around-compile-hook #: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) (in-package :asdf/lisp-action)
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
(asdf/package:define-package :asdf/lisp-build (asdf/package:define-package :asdf/lisp-build
(:recycle :asdf/interface :asdf :asdf/lisp-build) (:recycle :asdf/interface :asdf :asdf/lisp-build)
(:use :asdf/common-lisp :asdf/package :asdf/utility (: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 (:export
;; Variables ;; Variables
#:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
(asdf/package:define-package :asdf/pathname (asdf/package:define-package :asdf/pathname
(:recycle :asdf/pathname :asdf) (:recycle :asdf/pathname :asdf)
(:use :asdf/common-lisp :asdf/package :asdf/utility) (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os)
(:export (:export
;; Making and merging pathnames, portably ;; Making and merging pathnames, portably
#:normalize-pathname-directory-component #:denormalize-pathname-directory-component #:normalize-pathname-directory-component #:denormalize-pathname-directory-component
......
...@@ -19,9 +19,7 @@ ...@@ -19,9 +19,7 @@
#:detect-encoding #:*encoding-detection-hook* #:always-default-encoding #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
#:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
#:*default-encoding* #:*utf-8-external-format* #:*default-encoding* #:*utf-8-external-format*
#:ensure-all-directories-exist ;; Temporary files
#:rename-file-overwriting-target
#:delete-file-if-exists
#:*temporary-directory* #:temporary-directory #:default-temporary-directory #:*temporary-directory* #:temporary-directory #:default-temporary-directory
#:setup-temporary-directory #:setup-temporary-directory
#:call-with-temporary-file #:with-temporary-file #:call-with-temporary-file #:with-temporary-file
...@@ -339,7 +337,7 @@ hopefully, if done consistently, that won't affect program behavior too much.") ...@@ -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") "Hook for an extension to define a function to automatically detect a file's encoding")
(defun* detect-encoding (pathname) (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) (funcall *encoding-detection-hook* pathname)
*default-encoding*)) *default-encoding*))
...@@ -360,22 +358,6 @@ and implementation-defined external-format's") ...@@ -360,22 +358,6 @@ and implementation-defined external-format's")
(funcall *encoding-external-format-hook* encoding)) (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 ;;; Using temporary files
(defun* default-temporary-directory () (defun* default-temporary-directory ()
(or (or
...@@ -409,7 +391,7 @@ and implementation-defined external-format's") ...@@ -409,7 +391,7 @@ and implementation-defined external-format's")
:for pathname = (pathname (format nil "~A~36R" prefix counter)) :do :for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
;; TODO: on Unix, do something about umask ;; 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, 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 (with-open-file (stream pathname
:direction direction :direction direction
:element-type element-type :element-type element-type
......
...@@ -282,8 +282,8 @@ extract_tagged_asdf () { ...@@ -282,8 +282,8 @@ extract_tagged_asdf () {
} }
valid_upgrade_test_p () { valid_upgrade_test_p () {
case "${1}:${2}:${3}" in case "${1}:${2}:${3}" in
abcl:2.0[01][1-9]:*|abcl:2.2[1-2]:*) abcl:1.*|abcl:2.00[0-9]:*|abcl:201[0-7]:*)
: Skip, because it is so damn slow ;; : "Skip, because it is so slow." ;;
ccl:1.*|ccl:2.0[01]*) ccl:1.*|ccl:2.0[01]*)
: Skip, because ccl broke old asdf ;; : Skip, because ccl broke old asdf ;;
clisp:1.??*|clisp:2.00[0-7]:*) clisp:1.??*|clisp:2.00[0-7]:*)
......
...@@ -430,9 +430,9 @@ is bound, write a message and exit on an error. If ...@@ -430,9 +430,9 @@ is bound, write a message and exit on an error. If
(cons (format nil "~{~D~^.~}" ver)) (cons (format nil "~{~D~^.~}" ver))
(null "1.0")))))) (null "1.0"))))))
(defun test-upgrade (old-method new-method tag) ;; called by run-test (defun test-upgrade (old-method new-method tag) ;; called by run-test
(with-test () (with-test ()
(verbose t nil)
(when old-method (when old-method
(cond (cond
((string-equal tag "REQUIRE") ((string-equal tag "REQUIRE")
...@@ -444,6 +444,8 @@ is bound, write a message and exit on an error. If ...@@ -444,6 +444,8 @@ is bound, write a message and exit on an error. If
(t (t
(format t "Loading old asdf ~A via ~A~%" tag old-method) (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) (format t "Now loading new asdf via method ~A~%" new-method)
(funcall new-method) (funcall new-method)
(format t "Testing it~%") (format t "Testing it~%")
......
...@@ -54,15 +54,22 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ...@@ -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.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.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 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
(asdf-version "2.26.163") (asdf-version "2.26.164")
(existing-version (asdf-version))) (existing-version (asdf-version)))
(setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version))) (when (and existing-version (not (equal asdf-version existing-version)))
(push existing-version *previous-asdf-versions*) (push existing-version *previous-asdf-versions*)
(when *asdf-verbose* (when *asdf-verbose*
(format *trace-output* (format *trace-output*
(compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
existing-version asdf-version))) existing-version asdf-version))
(setf *asdf-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 () (when-upgrading ()
(let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops. (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 ...@@ -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 #:resolve-relative-location-component #:resolve-absolute-location-component
#:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function #:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function
(declare (ignorable redefined-functions uninterned-symbols)) (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 :for sym = (find-symbol* name :asdf nil) :do
(when sym (when sym
(fmakunbound sym))) (fmakunbound sym)))
(loop :with asdf = (find-package :asdf) (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 sym = (find-symbol* name :asdf nil)
:for base-pkg = (and sym (symbol-package sym)) :do :for base-pkg = (and sym (symbol-package sym)) :do
(when sym (when sym
......
...@@ -28,7 +28,8 @@ ...@@ -28,7 +28,8 @@
#:match-condition-p #:match-any-condition-p ;; conditions #:match-condition-p #:match-any-condition-p ;; conditions
#:call-with-muffled-conditions #:with-muffled-conditions #:call-with-muffled-conditions #:with-muffled-conditions
#:load-string #:load-stream #: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) (in-package :asdf/utility)
;;;; Defining functions in a way compatible with hot-upgrade: ;;;; Defining functions in a way compatible with hot-upgrade:
...@@ -314,6 +315,7 @@ instead of a list." ...@@ -314,6 +315,7 @@ instead of a list."
;;; Version handling ;;; Version handling
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun* unparse-version (version-list) (defun* unparse-version (version-list)
(format nil "~{~D~^.~}" version-list)) (format nil "~{~D~^.~}" version-list))
...@@ -344,6 +346,23 @@ in that it doesn't print back to itself, but the list is returned anyway." ...@@ -344,6 +346,23 @@ 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)) (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string))
version-list))) 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) (defun* version-compatible-p (provided-version required-version)
"Is the provided version a compatible substitution for the required-version? "Is the provided version a compatible substitution for the required-version?
...@@ -352,14 +371,8 @@ If they are equal, then any later version is compatible, ...@@ -352,14 +371,8 @@ If they are equal, then any later version is compatible,
with later being determined by a lexicographical comparison of minor numbers." with later being determined by a lexicographical comparison of minor numbers."
(let ((x (parse-version provided-version nil)) (let ((x (parse-version provided-version nil))
(y (parse-version required-version nil))) (y (parse-version required-version nil)))
(labels ((bigger (x y) (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x)))))
(cond ((not y) t) ); eval-when for version support
((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)))))))
;;; Condition control ;;; Condition control
......
"2.26.163" "2.26.164"
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment