diff --git a/Makefile b/Makefile index 7283ab1f62129a30d68c8097c53f7a5a20762096..f6551fc2d987d9bd444b8857ca9a6007264f8188 100644 --- a/Makefile +++ b/Makefile @@ -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: diff --git a/asdf-driver.asd b/asdf-driver.asd index 183f35ca90d15ffd0fe4f31fd71e0b4c66a83843..a6fff086402e91a9ec9e97e30a9057cd03cd7876 100644 --- a/asdf-driver.asd +++ b/asdf-driver.asd @@ -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")))) diff --git a/asdf.asd b/asdf.asd index 10fff7e75e9fa24ca5e0a9b4a6aa9d1ba647f9dd..ceef5c1c9beea6837cfd21b93956d0c362448498 100644 --- a/asdf.asd +++ b/asdf.asd @@ -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)))) diff --git a/backward-driver.lisp b/backward-driver.lisp new file mode 100644 index 0000000000000000000000000000000000000000..040675e91abef46a3024f98bedb190061d943ac3 --- /dev/null +++ b/backward-driver.lisp @@ -0,0 +1,36 @@ +;;;; ------------------------------------------------------------------------- +;;; 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))) + diff --git a/backward-interface.lisp b/backward-interface.lisp index 55945008c8e4a314d5338fd88e8fe738f42465a7..2b06664007f4e55373a1b5e1867d4ca48ca1b512 100644 --- a/backward-interface.lisp +++ b/backward-interface.lisp @@ -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)) diff --git a/bin/bump-version b/bin/bump-version index f79f21c0491016c9f647f6a5bf214c499a586a96..943712e3e560331637b08376063db64be4c00454 100755 --- a/bin/bump-version +++ b/bin/bump-version @@ -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) diff --git a/bin/make-tarball b/bin/make-tarball index c117150e267217577d65437d7de53cc9437a996e..1b17aaa75f08462c8cf8a856af994d47ebe65306 100755 --- a/bin/make-tarball +++ b/bin/make-tarball @@ -1,15 +1,38 @@ -#!/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 diff --git a/bundle.lisp b/bundle.lisp index 49e929aa9ee20cc9d354887a0069e90f3b50ae40..353fd6ab2613a8bd57dfcef29bdeccf2cfc41fd2 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -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,13 +215,14 @@ (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) - (component-type t) other-systems) +(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) (declare (ignore o)) @@ -253,15 +254,15 @@ (defmethod component-depends-on ((o monolithic-lib-op) (c system)) (declare (ignorable o)) - `((lib-op ,@(gather-components c :other-systems t :component-type 'system - :goal-operation 'load-op - :keep-operation 'load-op)))) + `((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 - :goal-operation 'load-fasl-op - :keep-operation 'load-fasl-op)))) + `((fasl-op ,@(operated-components c :other-systems t :component-type 'system + :goal-operation 'load-fasl-op + :keep-operation 'load-fasl-op)))) (defmethod component-depends-on ((o program-op) (c system)) (declare (ignorable o)) @@ -278,9 +279,9 @@ (defmethod component-depends-on ((o lib-op) (c system)) (declare (ignorable o)) - `((compile-op ,@(gather-components c :other-systems nil :component-type '(not system) - :goal-operation 'load-op - :keep-operation 'load-op)))) + `((compile-op ,@(operated-components c :other-systems nil :component-type '(not system) + :goal-operation 'load-op + :keep-operation 'load-op)))) (defmethod component-depends-on ((o fasl-op) (c system)) (declare (ignorable o)) @@ -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 diff --git a/concatenate-source.lisp b/concatenate-source.lisp index 8aa596b420aa4a48683c2b4842e94009be20d8e9..8b1e9add7c63cb79819b59913ccafdb58f3401c2 100644 --- a/concatenate-source.lisp +++ b/concatenate-source.lisp @@ -47,11 +47,10 @@ :with other-encodings = '() :with around-compile = (around-compile-hook s) :with other-around-compile = '() - :for c :in (gather-components s - :goal-operation 'compile-op - :keep-operation 'compile-op - :component-type 'component - :other-systems (operation-monolithic-p operation)) + :for c :in (operated-components + s :goal-operation 'compile-op + :keep-operation 'compile-op + :other-systems (operation-monolithic-p operation)) :append (when (typep c 'cl-source-file) (let ((e (component-encoding c))) @@ -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)) diff --git a/configuration.lisp b/configuration.lisp index a44b5211ad48c0de45a21c96c823d578570f8632..7d2a3bd2a233ee3db0a883e771688d5c518693bf 100644 --- a/configuration.lisp +++ b/configuration.lisp @@ -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 diff --git a/driver.lisp b/driver.lisp index e8dd0e4111f75d453388cf8cb29145ad01d27ea0..e53bf87b236681dd581ba1087ede74b97c05278c 100644 --- a/driver.lisp +++ b/driver.lisp @@ -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 diff --git a/footer.lisp b/footer.lisp index af8ba23324799b13b2c651ae4826977b8c218b62..7c8cb3b0d343f15c4846907807a68000eeb4f3aa 100644 --- a/footer.lisp +++ b/footer.lisp @@ -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. diff --git a/header.lisp b/header.lisp index e69de29bb2d1d6434b8b29ae775ad8c2e48c5391..d99328093e8444d05a1c5e8d289ef4f6e213c81f 100644 --- a/header.lisp +++ b/header.lisp @@ -0,0 +1,48 @@ +;; -*- 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 ()) diff --git a/lisp-build.lisp b/lisp-build.lisp index 5f1f325af021cc3f60b816c836514599031c2fe0..f8454b82789d26b2bc54c2553ae66c4f10ce3b24 100644 --- a/lisp-build.lisp +++ b/lisp-build.lisp @@ -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 diff --git a/package.lisp b/package.lisp index c455ea04bc4847d67b0e3669c6947a828bb09536..69a4aa4b77d9900cb7b231edb3c07cecb7c8e840 100644 --- a/package.lisp +++ b/package.lisp @@ -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)) - #+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)))) - + (let ((ensure-form + `(apply 'ensure-package ',(parse-define-package-form package clauses)))) + (eval ensure-form) + `(progn + #+clisp + (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 ()))) - diff --git a/pathname.lisp b/pathname.lisp index 1ae22f7573c01b89783bc5d57ea679f03d018c9c..22b4c470ee15fb2e042c7d3bead0cdbd5858d591 100644 --- a/pathname.lisp +++ b/pathname.lisp @@ -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)))) diff --git a/test/test-utilities.script b/test/test-utilities.script index 167439f341d2897e0de353044ebe1a62b7008472..47a070832f3ef63f919f291677b4061ec6cd7fac 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -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))) diff --git a/upgrade.lisp b/upgrade.lisp index e8f6088cd0fe6a469d9e9d7153a1cb92f514707b..cd1f2e164d759ac1e981e94c41a578c3dda97fcf 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -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))) diff --git a/version.lisp-expr b/version.lisp-expr index 8f3b63babc9a10c86d11ae5210888faf83c0c3b7..44b7b54ab54c8ba837eb865a80358eeb5b1378e5 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -1 +1 @@ -"2.26.100" +"2.26.102"