Commit 6782f5eb authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.102: fix issues on ECL, maybe CLISP too, improve version bumper.

Move things around and rename functions to improve backward compatibility.
The driver now has its own backward-compatibility file.
parent 639faf17
......@@ -41,7 +41,7 @@ XCL ?= xcl
# website, tag, install
driver_lisp := header.lisp package.lisp compatibility.lisp utility.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp driver.lisp
driver_lisp := header.lisp package.lisp compatibility.lisp utility.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp backward-driver.lisp driver.lisp
asdf_lisp := upgrade.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp
# Making ASDF itself should be our first, default, target:
......
......@@ -25,4 +25,5 @@ that you can't portably construct a complete program without using them."
(:file "run-program" :depends-on ("os"))
(:file "lisp-build" :depends-on ("image"))
(:file "configuration" :depends-on ("image"))
(:file "driver" :depends-on ("lisp-build" "run-program" "configuration"))))
(:file "backward-driver" :depends-on ("lisp-build" "run-program" "configuration"))
(:file "driver" :depends-on ("backward-driver"))))
......@@ -15,7 +15,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.100" ;; to be automatically updated by bin/bump-revision
:version "2.26.102" ;; to be automatically updated by bin/bump-revision
:depends-on ()
:components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......
;;;; -------------------------------------------------------------------------
;;; Hacks for backward-compatibility of the driver
(asdf/package:define-package :asdf/backward-driver
(:recycle :asdf/backward-driver :asdf)
(:use :common-lisp
:asdf/package :asdf/compatibility :asdf/utility
:asdf/pathname :asdf/stream :asdf/os :asdf/image
:asdf/run-program :asdf/lisp-build
:asdf/configuration)
(:export
#:coerce-pathname #:component-name-to-pathname-components))
(in-package :asdf/backward-driver)
;;;; Backward compatibility with various pathname functions.
(defun* coerce-pathname (name &key type defaults)
;; For backward-compatibility only, for people using internals
;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb
;; Will be removed after 2014-01-16.
;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.")
(parse-unix-namestring name :type type :defaults defaults))
(defun* component-name-to-pathname-components (unix-style-namestring
&key force-directory force-relative)
;; Will be removed after 2014-01-16.
;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS")
(multiple-value-bind (relabs path filename file-only)
(split-unix-namestring-directory-components
unix-style-namestring :want-directory force-directory)
(declare (ignore file-only))
(when (and force-relative (not (eq relabs :relative)))
(error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>")
unix-style-namestring))
(values relabs path filename)))
......@@ -21,13 +21,6 @@
;; Old deprecated name for the same thing. Please update your software.
(component-sibling-dependencies component))
(defun* coerce-pathname (name &key type defaults)
;; For backward-compatibility only, for people using internals
;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb
;; Will be removed in a future release, e.g. 2.30.
(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.")
(parse-unix-namestring name :type type :defaults defaults))
(defgeneric* operation-forced (operation)) ;; Used by swank.asd for swank-loader.
(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
......
......@@ -2,30 +2,14 @@
":" ; exec sbcl --script "$0" "$@" ; exit # -*- Lisp -*-
;;; Really runs on any decent Common Lisp implementation
(setf *load-verbose* nil *load-print* nil
*compile-verbose* nil *compile-print* nil)
(format t "Loading your implementation's ASDF... ~%")
(require :asdf)
(in-package :asdf)
#-asdf2 (error "Not ASDF2, you lose!")
(format t "Initializing the source registry... ~%")
(initialize-source-registry)
(format t "Upgrading to the latest ASDF... ~%")
(upgrade-asdf)
(format t "Now loading some dependencies... ~%")
(load-systems :cl-ppcre :fare-utils)
(load (make-pathname :name "prelude" :type "lisp" :defaults *load-pathname*)
:verbose nil :print nil)
(in-package :fare-utils)
(format t "And the debug utilities... ~%")
(asdf-debug)
(defvar *adir* (asdf:system-relative-pathname :asdf nil))
(DBG "There we are!")
(restore-image)
(defun afile (x)
(asdf:system-relative-pathname :asdf x))
(defun afile (x) (subpathname *adir* x))
(defparameter *version-file*
(afile "version.lisp-expr"))
......@@ -73,18 +57,41 @@
(clobber-file-with-vector file written-contents :external-format external-format)
(format t "done.~%")))))
(defun version-transform (text)
(flet ((v1 (ver) (format nil "~S" ver))
(v2 (ver) (format nil "This is ASDF ~A:" ver))
(f (fun text)
(cl-ppcre:regex-replace-all
(funcall fun *old-version*) text (funcall fun *new-version*))))
(f #'v2 (f #'v1 text))))
(defun version-transformer (new-version file prefix suffix)
(let* ((qprefix (cl-ppcre:quote-meta-chars prefix))
(versionrx "([0-9]+(\\.[0-9]+)+)")
(qsuffix (cl-ppcre:quote-meta-chars suffix))
(regex (strcat "(" qprefix ")(" versionrx ")(" qsuffix ")"))
(replacement
(constantly (strcat prefix new-version suffix))))
(lambda (text)
(multiple-value-bind (new-text foundp)
(cl-ppcre:regex-replace regex text replacement)
(unless (or foundp t)
(warn "Missing version in ~A" (file-namestring file)))
(values new-text foundp)))))
(defparameter *versioned-files*
'("version.lisp-expr" "asdf.asd" "header.lisp" "build/asdf.lisp" "upgrade.lisp"))
(defun transform-file (x)
(maybe-replace-file (afile x) #'version-transform))
(map () 'transform-file *versioned-files*)
'(("version.lisp-expr" "\"" "\"")
("asdf.asd" " :version \"" "\" ;; to be automatically updated by bin/bump-revision")
("header.lisp" "This is ASDF " ": Another System Definition Facility.")
("upgrade.lisp" " (asdf-version \"" "\")")))
(defun transform-file (new-version file prefix suffix)
(maybe-replace-file (afile file) (version-transformer new-version file prefix suffix)))
(defun transform-files ()
(loop :for f :in *versioned-files* :do (apply 'transform-file *new-version* f)))
(defun test-transform-file (new-version file prefix suffix)
(let ((lines (read-file-lines (afile file))))
(dolist (l lines (progn (warn "Couldn't find a match in ~A" file) nil))
(multiple-value-bind (new-text foundp)
(funcall (version-transformer new-version file prefix suffix) l)
(when foundp
(format t "Found a match:~% ==> ~A~%Replacing with~% ==> ~A~%~%"
l new-text)
(return t))))))
(defun z () (apply 'test-transform-file *new-version* (first *versioned-files*)))
(transform-files)
#!/bin/sh
":" ; exec sbcl --script "$0" "$@" ; exit # -*- Lisp -*-
;;;;; Really runs on any decent Common Lisp implementation
# create tarball and tagged asdf.lisp file in tmp/ using the most recent
# annotated tag
(load (make-pathname :name "prelude" :type "lisp" :defaults *load-pathname*)
:verbose nil :print nil)
;;;;; create tarball for the current version.
tag=`git describe --tags --match '[0-9].[0-9][0-9]'`
if [ "$tag" == "" ]; then
echo "Unable to find most recent tag, exiting"
exit 1
fi
(in-package :asdf)
(asdf-debug)
(describe (find-system :asdf))
(defparameter *ad* (find-system :asdf-driver))
(defparameter *asdf-directory* (system-source-directory *ad*))
(defparameter *version*
(safe-read-first-file-form (subpathname *asdf-directory* "version.lisp-expr")))
(DBG :foo *ad* *version* (asdf-version))
(defparameter *files*
(append
(loop :for c :in (operated-components *ad*
:goal-operation 'load-op
:keep-operation 'load-op)
:for n = (enough-namestring (component-pathname c) *asdf-directory*)
:when (typep c 'cl-source-file)
:collect n)
(list "version.lisp-expr" "asdf-driver.asd")))
;; make asdf:
;;;(run-program/ (list "make" "-C" (native-namestring *asdf-directory*) "build/asdf.lisp"))
#|
if [ -d "tmp" ]; then
rm -r tmp
fi
......@@ -19,3 +42,4 @@ archive_file="tmp/asdf-$tag.tar.gz"
echo "Create tmp/asdf.tar.gz with tag $tag"
git archive $tag --prefix="asdf/" --format=tar | \
gzip > $archive_file
|#
\ No newline at end of file
......@@ -9,13 +9,13 @@
(:export
#:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system
#:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op
#:monolithic-op #:monolithic-bundle-op
#:monolithic-op #:monolithic-bundle-op #:dependency-files
#:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op
#:program-op #:program-system
#:compiled-file #:precompiled-system #:prebuilt-system
#:operation-monolithic-p
#:user-system-p #:user-system #:trivial-system-p
#:gather-actions #:gather-components
#:gather-actions #:operated-components
#+ecl #:make-build #+mkcl #:bundle-system
#:register-pre-built-system
#:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library
......@@ -215,12 +215,13 @@
(defun* bundlable-file-p (pathname)
(let ((type (pathname-type pathname)))
(declare (ignorable type))
(or #+ecl (or (equal type (compile-file-type :object))
(equal type (compile-file-type :static-library)))
#+mkcl (equal type (compile-file-type :fasl-p nil))
#+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal type (compile-file-type)))))
(defun* gather-components (system &key (goal-operation 'load-op) (keep-operation goal-operation)
(defun* operated-components (system &key (goal-operation 'load-op) (keep-operation goal-operation)
(component-type t) other-systems)
(let ((goal-op (make-operation goal-operation)))
(flet ((filter (o c)
......@@ -253,13 +254,13 @@
(defmethod component-depends-on ((o monolithic-lib-op) (c system))
(declare (ignorable o))
`((lib-op ,@(gather-components c :other-systems t :component-type 'system
`((lib-op ,@(operated-components c :other-systems t :component-type 'system
:goal-operation 'load-op
:keep-operation 'load-op))))
(defmethod component-depends-on ((o monolithic-fasl-op) (c system))
(declare (ignorable o))
`((fasl-op ,@(gather-components c :other-systems t :component-type 'system
`((fasl-op ,@(operated-components c :other-systems t :component-type 'system
:goal-operation 'load-fasl-op
:keep-operation 'load-fasl-op))))
......@@ -278,7 +279,7 @@
(defmethod component-depends-on ((o lib-op) (c system))
(declare (ignorable o))
`((compile-op ,@(gather-components c :other-systems nil :component-type '(not system)
`((compile-op ,@(operated-components c :other-systems nil :component-type '(not system)
:goal-operation 'load-op
:keep-operation 'load-op))))
......@@ -295,12 +296,15 @@
(declare (ignorable o c))
nil)
(defmethod input-files ((o bundle-op) (c system))
(defun* dependency-files (o c &key (test 'identity) (key 'output-files))
(while-collecting (collect)
(visit-dependencies
() o c #'(lambda (sub-o sub-c)
(loop :for f :in (output-files sub-o sub-c)
:when (bundlable-file-p f) :do (collect f))))))
(loop :for f :in (funcall key sub-o sub-c)
:when (funcall test f) :do (collect f))))))
(defmethod input-files ((o bundle-op) (c system))
(dependency-files o c :test 'bundlable-file-p :key 'output-files))
(defun* select-bundle-operation (type &optional monolithic)
(ecase type
......
......@@ -47,10 +47,9 @@
:with other-encodings = '()
:with around-compile = (around-compile-hook s)
:with other-around-compile = '()
:for c :in (gather-components s
:goal-operation 'compile-op
:for c :in (operated-components
s :goal-operation 'compile-op
:keep-operation 'compile-op
:component-type 'component
:other-systems (operation-monolithic-p operation))
:append
(when (typep c 'cl-source-file)
......@@ -71,24 +70,14 @@
(return inputs)))
(defmethod input-files ((o load-concatenated-source-op) (s system))
(output-files (find-operation o 'concatenate-source-op) s))
(dependency-files o s))
(defmethod input-files ((o compile-concatenated-source-op) (s system))
(output-files (find-operation o 'concatenate-source-op) s))
(dependency-files o s))
(defmethod output-files ((o compile-concatenated-source-op) (s system))
(let ((input (first (input-files o s))))
(list (compile-file-pathname input))))
(defmethod input-files ((o load-compiled-concatenated-source-op) (s system))
(output-files (find-operation o 'compile-concatenated-source-op) s))
(defmethod input-files ((o monolithic-load-concatenated-source-op) (s system))
(output-files (find-operation o 'monolithic-concatenate-source-op) s))
(defmethod input-files ((o monolithic-compile-concatenated-source-op) (s system))
(output-files (find-operation o 'monolithic-concatenate-source-op) s))
(defmethod output-files ((o monolithic-compile-concatenated-source-op) (s system))
(let ((input (first (input-files o s))))
(list (compile-file-pathname input))))
(defmethod input-files ((o monolithic-load-compiled-concatenated-source-op) (s system))
(output-files (find-operation o 'monolithic-compile-concatenated-source-op) s))
(dependency-files o s))
(defmethod perform ((o concatenate-source-op) (s system))
(let ((inputs (input-files o s))
......
......@@ -237,7 +237,8 @@ directive.")
r)))
(ensure-pathname w :want-absolute t)))
(defun* resolve-location (x &key want-directory wilden)
(defun* resolve-location (x &key want-directory wilden directory)
(when directory (setf want-directory t)) ;; :directory backward compatibility, until 2014-01-16.
(if (atom x)
(resolve-absolute-location-component x :want-directory want-directory :wilden wilden)
(loop :with path = (resolve-absolute-location-component
......
......@@ -2,12 +2,12 @@
;;;; Re-export all the functionality in asdf/driver
(asdf/package:define-package :asdf/driver
(:nicknames :d :asdf-driver)
(:nicknames :d :asdf-driver :asdf-utils)
(:use :common-lisp
:asdf/package :asdf/compatibility :asdf/utility
:asdf/pathname :asdf/stream :asdf/os :asdf/image
:asdf/run-program :asdf/lisp-build
:asdf/configuration)
:asdf/configuration :asdf/backward-driver)
(:reexport
:asdf/package :asdf/compatibility :asdf/utility
:asdf/pathname :asdf/stream :asdf/os :asdf/image
......
......@@ -12,7 +12,7 @@
;;;; Configure
(setf asdf/utility:*asdf-debug-utility*
'(asdf:system-relative-pathname :asdf "contrib/debug.lisp"))
'(asdf/interface:system-relative-pathname :asdf "contrib/debug.lisp"))
;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.102: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
;;; Note first that the canonical source for ASDF is presently
;;; <URL:http://common-lisp.net/project/asdf/>.
;;;
;;; If you obtained this copy from anywhere else, and you experience
;;; trouble using it, or find bugs, you may want to check at the
;;; location above for a more recent version (and for documentation
;;; and test files, if your copy came without them) before reporting
;;; bugs. There are usually two "supported" revisions - the git master
;;; branch is the latest development version, whereas the git release
;;; branch may be slightly older but is considered `stable'
;;; -- LICENSE START
;;; (This is the MIT / X Consortium license as taken from
;;; http://www.opensource.org/licenses/mit-license.html on or about
;;; Monday; July 13, 2009)
;;;
;;; Copyright (c) 2001-2012 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
;;; "Software"), to deal in the Software without restriction, including
;;; without limitation the rights to use, copy, modify, merge, publish,
;;; distribute, sublicense, and/or sell copies of the Software, and to
;;; permit persons to whom the Software is furnished to do so, subject to
;;; the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
;;;
;;; -- LICENSE END
;;; The problem with writing a defsystem replacement is bootstrapping:
;;; we can't use defsystem to compile it. Hence, all in one file.
#+xcvb (module ())
......@@ -19,8 +19,8 @@
#:call-with-asdf-compilation-unit #:with-asdf-compilation-unit
#:current-lisp-file-pathname #:lispize-pathname #:compile-file-type #:call-around-hook
#:compile-file* #:compile-file-pathname*
#:load* #:load-from-string
#:combine-fasls))
#:load* #:load-from-string #:combine-fasls)
(:intern #:defaults #:failure-p #:warnings-p))
(in-package :asdf/lisp-build)
(defvar *compile-file-warnings-behaviour*
......@@ -202,20 +202,20 @@ it will filter them appropriately."
(output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))
#+ecl
(object-file
(when (use-ecl-byte-compiler-p)
(unless (use-ecl-byte-compiler-p)
(or object-file
(compile-file-pathname output-file :type :object))))
#+mkcl
(object-file
(or object-file
(compile-file-pathname output-file #+mkcl :fasl-p #+mkcl nil)))
(tmp-file (make-pathname :type "fasl-tmp" :defaults output-file)))
(compile-file-pathname output-file :fasl-p nil)))
(tmp-file (tmpize-pathname output-file)))
(multiple-value-bind (output-truename warnings-p failure-p)
(or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords)
#+ecl (apply 'compile-file input-file
#+ecl (apply 'compile-file input-file :output-file
(if object-file
(list* :output-file object-file :type :object keywords)
keywords))
(list* object-file :system-p t keywords)
(list* output-file keywords)))
#+mkcl (apply 'compile-file input-file :output-file object-file :fasl-p nil keywords))
(cond
((and output-truename
......@@ -225,7 +225,7 @@ it will filter them appropriately."
(check-flag warnings-p *compile-file-warnings-behaviour*)))
(progn
#+(or ecl mkcl)
(when (and (eq status :success) #+ecl object-file)
(when (and #+ecl object-file)
(setf output-truename
(compiler::build-fasl
tmp-file #+ecl :lisp-files #+mkcl :lisp-object-files
......
......@@ -74,7 +74,10 @@ or when loading the package is optional."
(defun symbol-shadowing-p (symbol package)
(and (member symbol (package-shadowing-symbols package)) t))
(defun home-package-p (symbol package)
(eq (symbol-package symbol) (find-package* package))))
(and package (let ((sp (symbol-package symbol)))
(and sp (let ((pp (find-package* package)))
(and pp (eq sp pp))))))))
(eval-when (:load-toplevel :compile-toplevel :execute)
(defun symbol-package-name (symbol)
......@@ -213,10 +216,10 @@ or when loading the package is optional."
(defun ensure-package-unused (package)
(loop :for p :in (package-used-by-list package) :do
(unuse-package package p)))
(defun delete-package* (package &optional nuke)
(defun delete-package* (package &key nuke)
(let ((p (find-package package)))
(when p
(when nuke (do-symbols (s p) (when (eq p (symbol-package s)) (nuke-symbol s))))
(when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))
(ensure-package-unused p)
(delete-package package))))
(defun fresh-package-name (&optional (prefix :%TO-BE-DELETED)
......@@ -236,8 +239,12 @@ or when loading the package is optional."
;;; Communicable representation of symbol and package information
(eval-when (:load-toplevel :compile-toplevel :execute)
(defun package-definition-form (package-designator &key internp (nicknamesp t) (error t))
(let* ((package (find-package* package-designator error))
(defun package-definition-form (package-designator
&key (nicknamesp t) (usep t)
(shadowp t) (shadowing-import-p t)
(exportp t) (importp t) internp (error t))
(let* ((package (or (find-package* package-designator error)
(return-from package-definition-form nil)))
(name (package-name package))
(nicknames (package-nicknames package))
(use (mapcar #'package-name (package-use-list package)))
......@@ -281,11 +288,11 @@ or when loading the package is optional."
:collect `(,key ,i ,@(sort-names (gethash i table))))))
`(defpackage ,name
,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames)))
(:use ,@(sort-names use))
,@(when-relevant :shadow (sort-names shadow))
,@(import-options :shadowing-import-from shadowing-import)
,@(import-options :import-from import)
,@(when-relevant :export (sort-names export))
(:use ,@(and usep (sort-names use)))
,@(when-relevant :shadow (and shadowp (sort-names shadow)))
,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import))
,@(import-options :import-from (and importp import))
,@(when-relevant :export (and exportp (sort-names export)))
,@(when-relevant :intern (and internp (sort-names intern)))))))))
......@@ -573,15 +580,17 @@ or when loading the package is optional."
:mix ,mix :reexport ,reexport :unintern ,unintern)))))
(defmacro define-package (package &rest clauses)
`(eval-when (:compile-toplevel :load-toplevel :execute)
#+(or ecl gcl) (defpackage ,package (:use))
(let ((ensure-form
`(apply 'ensure-package ',(parse-define-package-form package clauses))))
(eval ensure-form)
`(progn
#+clisp
(macrolet ((foo ()
(apply 'ensure-package ',(parse-define-package-form package clauses))
(package-definition-form ',package :nicknamesp nil)))
(foo))
(apply 'ensure-package ',(parse-define-package-form package clauses))))
(eval-when (:compile-toplevel :load-toplevel :execute)
,ensure-form)
#+(or ecl gcl) (defpackage ,package (:use))
#+clisp ,(package-definition-form package :error nil)
(eval-when (:compile-toplevel :load-toplevel :execute)
,ensure-form))))
;;;; Final tricks to keep various implementations happy.
(eval-when (:load-toplevel :compile-toplevel :execute)
......@@ -590,14 +599,3 @@ or when loading the package is optional."
(remove "asdf" excl::*autoload-package-name-alist*
:test 'equalp :key 'car)))
;; Note that this massive package destruction makes it impossible
;; to use asdf/driver on top of an old ASDF on these implementations
#+(or clisp xcl)
(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (let ((vs (find-symbol* 'version-satisfies :asdf nil))
(av (find-symbol* 'asdf-version :asdf nil)))
(and vs av (funcall vs (funcall av) "2.26.59")))
(when (find-package :asdf)
(delete-package* :asdf t))
(make-package :asdf :use ())))
......@@ -21,6 +21,7 @@
;; Parsing filenames and lists thereof
#:component-name-to-pathname-components
#:split-name-type #:parse-unix-namestring #:unix-namestring
#:split-unix-namestring-directory-components
#:subpathname #:subpathname*
;; Resolving symlinks somewhat
#:truenamize #:resolve-symlinks #:resolve-symlinks*
......@@ -429,11 +430,12 @@ with given pathname and if it exists return its truename."
;;; Parsing filenames and lists thereof
(defun* component-name-to-pathname-components (unix-style-namestring &key want-directory dot-dot)
(defun* split-unix-namestring-directory-components
(unix-style-namestring &key want-directory dot-dot)
"Splits the path string UNIX-STYLE-NAMESTRING, returning four values:
A flag that is either :absolute or :relative, indicating
how the rest of the values are to be interpreted.
A directory path --- a list of strings, suitable for
A directory path --- a list of strings and keywords, suitable for
use with MAKE-PATHNAME when prepended with the flag value.
Directory components with an empty name or the name . are removed.
Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP).
......@@ -541,7 +543,7 @@ when you're running portable code and the OS may not be Unixish."
(setf name (string-downcase name)))
(string))
(multiple-value-bind (relative path filename file-only)
(component-name-to-pathname-components
(split-unix-namestring-directory-components
name :dot-dot dot-dot :want-directory want-directory)
(multiple-value-bind (name type)
(cond
......@@ -649,7 +651,7 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
(eql x separator)))
root-namestring)))
(multiple-value-bind (relative path filename)
(component-name-to-pathname-components root-string :want-directory t)
(split-unix-namestring-directory-components root-string :want-directory t)
(declare (ignore relative filename))
(let ((new-base
(make-pathname* :defaults root :directory `(:absolute ,@path))))
......
......@@ -26,17 +26,17 @@
;; These are funky and non portable, omit from tests:
;; (make-pathname* :name "." :type nil :directory '(:absolute "tmp"))
;; (make-pathname* :name "." :type "" :directory '(:absolute "tmp"))
(assert (equal (multiple-value-list (component-name-to-pathname-components "" :want-directory t))
(assert (equal (multiple-value-list (split-unix-namestring-directory-components "" :want-directory t))
'(:relative nil nil nil)))
(assert (equal (multiple-value-list (component-name-to-pathname-components "" :want-directory nil))
(assert (equal (multiple-value-list (split-unix-namestring-directory-components "" :want-directory nil))
'(:relative nil nil nil)))
(assert (equal (multiple-value-list (component-name-to-pathname-components "/" :want-directory t))
(assert (equal (multiple-value-list (split-unix-namestring-directory-components "/" :want-directory t))
'(:absolute nil nil nil)))
(assert (equal (multiple-value-list (component-name-to-pathname-components "/" :want-directory nil))
(assert (equal (multiple-value-list (split-unix-namestring-directory-components "/" :want-directory nil))
'(:absolute nil nil nil)))
(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" :want-directory t))
(assert (equal (multiple-value-list (split-unix-namestring-directory-components "/aa/ba" :want-directory t))
'(:absolute ("aa" "ba") nil nil)))
(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" :want-directory nil))
(assert (equal (multiple-value-list (split-unix-namestring-directory-components "/aa/ba" :want-directory nil))
'(:absolute ("aa") "ba" nil)))
(assert
(version-satisfies (asdf-version) (asdf-version)))
......
......@@ -16,6 +16,16 @@
(:import-from :asdf/package #:intern* #:find-symbol*))
(in-package :asdf/upgrade)
;; Note that this massive package destruction makes it impossible
;; to use asdf/driver on top of an old ASDF on these implementations
#+(or clisp xcl)
(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (let ((vs (find-symbol* 'version-satisfies :asdf nil))
(av (find-symbol* 'asdf-version :asdf nil)))
(and vs av (funcall vs (funcall av) "2.26.59")))
(if-bind (p (find-package :asdf))
(do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))))
;;; Special magic to detect if this is an upgrade
(eval-when (:load-toplevel :compile-toplevel :execute)
......@@ -35,7 +45,7 @@
;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(asdf-version "2.26.99")
(asdf-version "2.26.102")
(existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*)
(already-there (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