2.26.86: bin/bump-version is now written in Lisp using ASDF support functions
authorFrancois-Rene Rideau <tunes@google.com>
Sun, 13 Jan 2013 21:23:00 +0000 (16:23 -0500)
committerFrancois-Rene Rideau <tunes@google.com>
Sun, 13 Jan 2013 21:23:00 +0000 (16:23 -0500)
Much cleanup in image support and hooks.
More package hacking.
New feature for :version: `(:read-file-from ,path) - thanks to Stelian Ionescu.
The driver now homesteads the package nickname d.
Rename-package it away if you don't like it.

22 files changed:
action.lisp
asdf-driver.asd
asdf.asd
bin/bump-version
configuration.lisp
defsystem.lisp
doc/asdf.texinfo
driver.lisp
generate-asdf.asd
header.lisp
image.lisp
lisp-build.lisp
os.lisp
output-translations.lisp
package.lisp
pathname.lisp
run-program.lisp
stream.lisp
system.lisp
upgrade.lisp
utility.lisp
version.lisp-expr [new file with mode: 0644]

index 485979a..2475697 100644 (file)
@@ -115,7 +115,7 @@ You can put together sentences using this phrase."))
    (multiple-value-bind (files fixedp) (call-next-method)
      (if fixedp
          files
-         (mapcar *output-translation-hook* files)))
+         (mapcar *output-translation-function* files)))
    t))
 (defmethod output-files ((o operation) (c component))
   (declare (ignorable o c))
index 29ed2a5..425dfe0 100644 (file)
@@ -5,6 +5,7 @@
   :description "Basic general-purpose utilities used by ASDF"
   :long-description "Basic general-purpose utilities that is in such a need
 that you can't portably construct a complete program without using them."
+  #+asdf2.27 :version #+asdf2.27 (:read-file-form "version.lisp-expr")
   :components
   ((:file "header")
    (:file "package")
@@ -12,9 +13,9 @@ that you can't portably construct a complete program without using them."
    (:file "utility" :depends-on ("compatibility"))
    (:file "pathname" :depends-on ("utility"))
    (:file "stream" :depends-on ("pathname"))
-   (:file "os" :depends-on ("pathname" "stream"))
+   (:file "os" :depends-on ("stream"))
    (:file "image" :depends-on ("os"))
    (:file "run-program" :depends-on ("os"))
    (:file "lisp-build" :depends-on ("image"))
-   (:file "configuration" :depends-on ("os"))
+   (:file "configuration" :depends-on ("image"))
    (:file "driver" :depends-on ("lisp-build" "run-program" "configuration"))))
index 750d258..3de1d4a 100644 (file)
--- 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.85" ;; to be automatically updated by bin/bump-revision
+  :version "2.26.86" ;; 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))))
index cc1a578..d03238d 100755 (executable)
@@ -1,25 +1,68 @@
 #!/bin/sh
-# Takes one optional argument: the new version number.
-# If not provided, increment previous patch number,
-# e.g. 3.45.6 ==> 3.45.7, or 3.56 ==> 3.56.1
-NEWVER="${1}"
-PROG="$0"
-ASDFDIR="$(cd $(dirname $PROG)/.. ; /bin/pwd)" ## readlink -f doesn't work on BSD
-
-if [ -z "$NEWVER" ] ; then
-  OLDVER="$(grep '         (asdf-version "' ${ASDFDIR}/upgrade.lisp | cut -d\" -f2)"
-  NEWVER="$(echo $OLDVER | perl -npe 's/([0-9].[0-9]+)(\.([0-9]+))?/"${1}.".($3+1)/e')"
-fi
-echo "Setting ASDF version to $NEWVER"
-for i in ${ASDFDIR}/header.lisp ${ASDFDIR}/upgrade.lisp ; do
-  perl -i.bak -npe 's/^(         \(asdf-version "|;;; This is ASDF )[0-9.]+("\)|:)/${1}'"$NEWVER"'${2}/' $i
-done
-for i in ${ASDFDIR}/asdf.asd ; do # ${ASDFDIR}/generate-asdf.asd
-  perl -i.bak -npe 's/^(  :version ")[0-9.]+(")/${1}'"$NEWVER"'${2}/' $i
-done
-
-cat<<EOF
-To complete the version change, you may:
-       git commit -a
-       git tag $NEWVER
-EOF
+":" ; exec sbcl --script "$0" "$@" ; exit # -*- Lisp -*-
+;;; Really runs on any decent Common Lisp implementation
+
+(require :asdf)
+(in-package :asdf)
+
+(upgrade-asdf)
+
+(load-systems :cl-ppcre :xcvb-utils)
+
+(in-package :xcvb-utils)
+
+(asdf-debug)
+
+(defun afile (x)
+  (asdf:system-relative-pathname :asdf x))
+
+(defparameter *version-file*
+  (afile "version.lisp-expr"))
+
+(defparameter *old-version*
+  (safe-read-first-file-form *version-file*))
+
+(defparameter *argv* (command-line-arguments))
+
+(defun next-version (v)
+  (let ((pv (parse-version v)))
+    (incf (third pv))
+    (unparse-version pv)))
+
+(defparameter *new-version* (or (first *argv*) (next-version *old-version*)))
+
+(format t "Bumping ASDF version from ~A to ~A~%" *old-version* *new-version*)
+
+(deftype byte-vector () '(array (unsigned-byte 8) (*)))
+
+(defun maybe-replace-file (file transformer
+                           &key (reader 'read-file-string)
+                             (writer nil) (comparator 'equal)
+                             (external-format *utf-8-external-format*))
+  (let* ((old-contents (funcall reader file))
+         (new-contents (funcall transformer old-contents)))
+    (unless (funcall comparator old-contents new-contents)
+      (let ((written-contents
+              (if writer
+                  (with-output (s ())
+                    (funcall writer s new-contents))
+                  new-contents)))
+        (check-type written-contents (or string (byte-vector)))
+        (clobber-file-with-vector file written-contents :external-format external-format)))))
+
+(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 #'v1 (f #'v2 text))))
+
+(defparameter *versioned-files*
+  '("version.lisp-expr" "asdf.asd" "build/asdf.lisp" "upgrade.lisp"))
+
+(defun transform-file (x)
+  (format t "Transforming file ~A~%" x)
+  (maybe-replace-file (afile x) #'version-transform))
+
+(map () 'transform-file *versioned-files*)
index c85e14b..5da2e79 100644 (file)
@@ -3,7 +3,7 @@
 
 (asdf/package:define-package :asdf/configuration
   (:recycle :asdf/configuration :asdf)
-  (:use :common-lisp :asdf/utility :asdf/pathname :asdf/stream :asdf/os)
+  (:use :common-lisp :asdf/utility :asdf/pathname :asdf/stream :asdf/os :asdf/image)
   (:export
    #:get-folder-path
    #:user-configuration-directories #:system-configuration-directories
@@ -280,3 +280,4 @@ Please remove it from your ASDF configuration"))
 (defun* clear-configuration ()
   (call-functions *clear-configuration-hook*))
 
+(register-image-dump-hook 'clear-configuration)
index f9896cd..2bdf4c4 100644 (file)
@@ -3,7 +3,7 @@
 
 (asdf/package:define-package :asdf/defsystem
   (:recycle :asdf/defsystem :asdf)
-  (:use :common-lisp :asdf/utility :asdf/pathname
+  (:use :common-lisp :asdf/utility :asdf/pathname :asdf/stream
    :asdf/component :asdf/system :asdf/find-system :asdf/find-component
    :asdf/lisp-action :asdf/operate
    :asdf/backward-internals)
     (sysdef-error-component ":in-order-to must be NIL or a list of components."
                             type name in-order-to)))
 
+(defun* normalize-version (form pathname)
+  (cond
+    ((typep form '(or string null)) form)
+    ((length=n-p form 2)
+     (ecase (first form)
+       ((:read-file-form)
+        (safe-read-first-file-form (subpathname pathname (second form))))))))
+
 ;;; Main parsing function
 
 (defun* parse-component-form (parent options &key previous-serial-component)
                 (typep (find-component parent name)
                        (class-for-type parent type))))
       (error 'duplicate-names :name name))
-    (when versionp
-      (unless (parse-version version nil)
-        (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
-              version name parent)))
     (when do-first (error "DO-FIRST is not supported anymore since ASDF 2.27"))
     (let* ((args `(:name ,(coerce-name name)
                    :pathname ,pathname
           (apply 'reinitialize-instance ret args)
           (setf ret (apply 'make-instance (class-for-type parent type) args)))
       (component-pathname ret) ; eagerly compute the absolute pathname
+      (when versionp
+        (unless (parse-version (normalize-version version (component-pathname ret)) nil)
+          (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
+                version name parent)))
       (when (typep ret 'parent-component)
         (setf (component-children ret)
               (loop
index 6460ece..ab74bed 100644 (file)
@@ -847,7 +847,13 @@ are parsed as period-separated lists of integers.  I.e., in the example,
 In particular, version @code{0.2.1} is interpreted the same as
 @code{0.0002.1} and is strictly version-less-than version @code{0.20.1},
 even though the two are the same when interpreted as decimal fractions.
-@cindex version specifiers
+Instead of a string representing the version,
+the @code{:version} argument can be an expression that is resolved to
+such a string using the following trivial domain-specific language:
+in addition to being a literal string, it can be an expression of the form
+@code{(:read-file-form <pathname-or-string>)}, which will be resolved
+by reading the first form in the specified pathname or string
+(merged against the pathname of the current component if relative).
 @cindex :version
 
 @end itemize
index eb0fdfe..c4f6e7b 100644 (file)
@@ -2,6 +2,7 @@
 ;;;; Re-export all the functionality in asdf/driver
 
 (asdf/package:define-package :asdf/driver
+  (:nicknames :d)
   (:use :common-lisp
    :asdf/package :asdf/compatibility :asdf/utility
    :asdf/pathname :asdf/stream :asdf/os :asdf/image
index 8654adc..48d47fa 100644 (file)
@@ -9,6 +9,7 @@
   ;; :include-dependencies t
   :translate-output-p nil
   :concatenated-source-file "build/asdf.lisp"
+  :version (:read-file-form "version.lisp-expr")
   :serial t
   :depends-on (:asdf-driver)
   :components
index 8dfb510..0a62a80 100644 (file)
@@ -1,5 +1,5 @@
 ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
-;;; This is ASDF 2.26.85: Another System Definition Facility.
+;;; This is ASDF 2.26.86: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
index 0326e48..cd51a6f 100644 (file)
@@ -5,7 +5,8 @@
   (:recycle :asdf/image :xcvb-driver)
   (:use :common-lisp :asdf/utility :asdf/pathname :asdf/stream :asdf/os)
   (:export
-   #:*arguments* #:*dumped* #:raw-command-line-arguments #:*command-line-arguments*
+   #:*dumped* #:raw-command-line-arguments #:*command-line-arguments*
+   #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments
    #:*debugging* #:*post-image-restart* #:*entry-point*
    #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace
    #:bork #:with-coded-exit #:shell-boolean
@@ -19,7 +20,7 @@
 (defvar *debugging* nil
   "Shall we print extra debugging information?")
 
-(defvar *arguments* nil
+(defvar *command-line-arguments* nil
   "Command-line arguments")
 
 (defvar *dumped* nil
@@ -158,11 +159,11 @@ This is designed to abstract away the implementation specific quit forms."
 
 ;;; Using hooks
 
-(defun* register-image-resume-hook (hook)
-  (pushnew hook *image-resume-hook*))
+(defun* register-image-resume-hook (hook &optional (now t))
+  (register-hook-function '*image-resume-hook* hook now))
 
-(defun* register-image-dump-hook (hook)
-  (pushnew hook *image-dump-hook*))
+(defun* register-image-dump-hook (hook &optional (now nil))
+  (register-hook-function '*image-dump-hook* hook now))
 
 (defun* call-image-resume-hook ()
   (call-functions (reverse *image-resume-hook*)))
@@ -171,15 +172,6 @@ This is designed to abstract away the implementation specific quit forms."
   (call-functions *image-dump-hook*))
 
 
-;;; Build initialization
-
-(defun* initialize-asdf-utilities ()
-  "Setup the XCVB environment with respect to debugging, profiling, performance"
-  (setf *temporary-directory* (default-temporary-directory)
-       *stderr* #-clozure *error-output* #+clozure ccl::*stderr*)
-  (values))
-
-
 ;;; Proper command-line arguments
 
 (defun* raw-command-line-arguments ()
@@ -210,20 +202,24 @@ if we are not called from a directly executable image dumped by XCVB."
              (member "--" arguments :test 'string-equal))))
     (rest arguments)))
 
-(defun* do-resume (&key (post-image-restart *post-image-restart*) (entry-point *entry-point*))
-  (with-safe-io-syntax (:package :asdf)
+(defun setup-command-line-arguments ()
+  (setf *command-line-arguments* (command-line-arguments)))
+
+(defun* resume-program (&key (post-image-restart *post-image-restart*) (entry-point *entry-point*))
+  (call-image-resume-hook)
+  (with-safe-io-syntax ()
     (let ((*read-eval* t))
       (when post-image-restart (eval-input post-image-restart))))
-  (with-coded-exit ()
-    (when entry-point
-      (let ((ret (apply entry-point *arguments*)))
-       (if (typep ret 'integer)
-           (quit ret)
-           (quit 99))))))
+  (when entry-point
+    (apply entry-point *command-line-arguments*)))
 
 (defun* resume ()
-  (setf *arguments* (command-line-arguments))
-  (do-resume))
+  (with-coded-exit ()
+    (let ((ret (resume-program)))
+      (if (typep ret 'integer)
+          (quit ret)
+          (quit 99)))))
+
 
 ;;; Dumping an image
 
@@ -284,3 +280,9 @@ if we are not called from a directly executable image dumped by XCVB."
     (when executable (list :toplevel #'resume :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
   #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
   (die 98 "Can't dump ~S: asdf doesn't support image dumping with this Lisp implementation.~%" filename))
+
+
+;;; Initial environmental hooks
+(pushnew 'setup-temporary-directory *image-resume-hook*)
+(pushnew 'setup-stderr *image-resume-hook*)
+(pushnew 'setup-command-line-arguments *image-resume-hook*)
index 667eb02..e5aaf3f 100644 (file)
@@ -7,7 +7,7 @@
   (:export
    ;; Variables
    #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
-   #:*compile-file-function* #:*output-translation-hook*
+   #:*compile-file-function* #:*output-translation-function*
    #:*optimization-settings* #:*previous-optimization-settings*
    #:*uninteresting-conditions*
    #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
@@ -259,7 +259,7 @@ for processing later (possibly in a different process)."
                (defaults (make-pathname
                           :type type :defaults (merge-pathnames* input-file))))
           (merge-pathnames* output-file defaults))
-        (funcall *output-translation-hook*
+        (funcall *output-translation-function*
                  (apply 'compile-file-pathname input-file keys)))))
 
 (defun* load* (x &rest keys &key &allow-other-keys)
diff --git a/os.lisp b/os.lisp
index 8f6abe1..253e17d 100644 (file)
--- a/os.lisp
+++ b/os.lisp
    #:hostname #:user-homedir #:lisp-implementation-directory
    #:getcwd #:chdir #:call-with-current-directory #:with-current-directory
    #:*temporary-directory* #:temporary-directory #:default-temporary-directory
+   #:setup-temporary-directory
    #:call-with-temporary-file #:with-temporary-file))
 (in-package :asdf/os)
 
 ;;; Features
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defun* featurep (x &optional (features *features*))
+  (defun* featurep (x &optional (*features* *features*))
     (cond
-      ((atom x)
-       (and (member x features) t))
-      ((eq :not (car x))
-       (assert (null (cddr x)))
-       (not (featurep (cadr x) features)))
-      ((eq :or (car x))
-       (some #'(lambda (x) (featurep x features)) (cdr x)))
-      ((eq :and (car x))
-       (every #'(lambda (x) (featurep x features)) (cdr x)))
-      (t
-       (error "Malformed feature specification ~S" x))))
+      ((atom x) (and (member x *features*) t))
+      ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
+      ((eq :or (car x)) (some #'featurep (cdr x)))
+      ((eq :and (car x)) (every #'featurep (cdr x)))
+      (t (error "Malformed feature specification ~S" x))))
 
   (defun* os-unix-p ()
     (featurep '(:or :unix :cygwin :darwin)))
@@ -109,16 +104,21 @@ then returning the non-empty string value of the variable"
 ;; Initially stolen from SLIME's SWANK, completely rewritten since.
 ;; We're back to runtime checking, for the sake of e.g. ABCL.
 
-(defun* first-feature (features)
-  (dolist (x features)
-    (multiple-value-bind (val feature)
-        (if (consp x) (values (first x) (cons :or (rest x))) (values x x))
-      (when (featurep feature) (return val)))))
+(defun* first-feature (feature-sets)
+  (dolist (x feature-sets)
+    (multiple-value-bind (short long feature-expr)
+        (if (consp x)
+            (values (first x) (second x) (cons :or (rest x)))
+            (values x x x))
+      (when (featurep feature-expr)
+        (return (values short long))))))
 
 (defun* implementation-type ()
   (first-feature
-   '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu
-     :ecl :gcl (:lw :lispworks) :mcl :mkcl :sbcl :scl :symbolics :xcl)))
+   '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
+     (:cmu :cmucl :cmu) :ecl :gcl
+     (:lwpe :lispworks-personal-edition) (:lw :lispworks)
+     :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
 
 (defun* operating-system ()
   (first-feature
@@ -130,7 +130,7 @@ then returning the non-empty string value of the variable"
 
 (defun* architecture ()
   (first-feature
-   '((:x64 :amd64 :x86-64 :x86_64 :x8664-target (:and :word-size=64 :pc386))
+   '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386))
      (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
      (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
      :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
@@ -278,6 +278,9 @@ then returning the non-empty string value of the variable"
 (defun* temporary-directory ()
   (or *temporary-directory* (default-temporary-directory)))
 
+(defun setup-temporary-directory ()
+  (setf *temporary-directory* (default-temporary-directory)))
+
 (defun* call-with-temporary-file
     (thunk &key
      prefix keep (direction :io)
index 49478e6..89dd41f 100644 (file)
@@ -20,6 +20,8 @@
    ))
 (in-package :asdf/output-translations)
 
+(when-upgrade () (undefine-function '(setf output-translations)))
+
 (define-condition invalid-output-translation (invalid-configuration warning)
   ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
 
@@ -305,5 +307,5 @@ effectively disabling the output translation facility."
              (merge-pathnames* relative-source target-root)))
       (normalize-device (apply-output-translations target)))))
 
-(setf *output-translation-hook* 'apply-output-translations)
+(setf *output-translation-function* 'apply-output-translations)
 (pushnew 'clear-output-translations *clear-configuration-hook*)
index 3653c44..aeef011 100644 (file)
@@ -73,7 +73,9 @@ or when loading the package is optional."
     (let* ((symbol-name (aref vector 0))
            (package-name (aref vector 1)))
       (if package-name (intern symbol-name package-name)
-          (make-symbol symbol-name)))))
+          (make-symbol symbol-name))))
+  (defun home-package-p (symbol package)
+    (eq (symbol-package symbol) (find-package* package))))
 
 (eval-when (:load-toplevel :compile-toplevel :execute)
   #+(or clisp clozure)
@@ -225,7 +227,7 @@ or when loading the package is optional."
                           (imported (not (eq home package)))
                           (shadowing (symbol-shadowing-p sym package)))
                      (cond
-                       ((and shadowing import)
+                       ((and shadowing imported)
                         (push name (gethash home-name shadowing-import)))
                        (shadowing
                         (push name shadow))
@@ -290,9 +292,8 @@ or when loading the package is optional."
       (macrolet ((fishy (&rest info)
                    `(when fishyp (push (list ,@info) fishy))))
         (labels
-            ((ensure-shadowing-import (sym p)
-               (let ((name (string sym))
-                     (import (find-symbol* name p)))
+            ((ensure-shadowing-import (name p)
+               (let ((import (find-symbol* name p)))
                  (multiple-value-bind (existing status) (find-symbol name package)
                    (cond
                      ((gethash name shadowed)
@@ -303,10 +304,10 @@ or when loading the package is optional."
                       (setf (gethash name imported) t)
                       (unless (or (null status)
                                   (and (member status '(:internal :external))
-                                       (eq existing sym)
+                                       (eq existing import)
                                        (symbol-shadowing-p existing package)))
                         (fishy :shadowing-import
-                               name (package-name p) (symbol-package-name sym)
+                               name (package-name p) (symbol-package-name import)
                                (and status (symbol-package-name existing)) status))
                       (shadowing-import import package))))))
              (ensure-import (sym p)
@@ -328,29 +329,38 @@ or when loading the package is optional."
                           (fishy :import name (package-name p) (symbol-package-name import)
                                  (and status (symbol-package-name existing)) status))
                         (import import package)))))))
-             (ensure-mix (sym p)
-               (let* ((name (symbol-name sym))
-                      (sp (symbol-package sym)))
-                 (unless (or (gethash name shadowed) (gethash name imported))
-                   (let ((ip (gethash name inherited)))
+             (ensure-mix (name symbol p)
+               (unless (gethash name shadowed)
+                 (multiple-value-bind (existing status) (find-symbol name package)
+                   (let* ((sp (symbol-package symbol))
+                          (im (gethash name imported))
+                          (in (gethash name inherited)))
                      (cond
-                       ((and ip (eq sp (first ip))))
-                       (ip
+                       ((or (null status)
+                            (and status (eq symbol existing))
+                            (and in (eq sp (first in))))
+                        (ensure-inherited name symbol p t))
+                       (in
                         (remhash name inherited)
-                        (ensure-shadowing-import name (second ip)))
+                        (ensure-shadowing-import name (second in)))
+                       (im
+                         (error "Imported symbol ~S conflicts with inherited symbol ~S in ~S"
+                                existing symbol (package-name package)))
                        (t
-                        (ensure-inherited name sym p)))))))
-             (ensure-inherited (name symbol p)
+                        (ensure-inherited name symbol p t)))))))
+             (ensure-inherited (name symbol p mix)
                (multiple-value-bind (existing status) (find-symbol name package)
                  (let* ((sp (symbol-package symbol))
-                        (ip (gethash name inherited))
+                        (in (gethash name inherited))
                         (xp (and status (symbol-package existing))))
                    (cond
                      ((gethash name shadowed))
-                     (ip
-                      (unless (equal sp (first ip))
-                        (error "Can't inherit ~S from ~S, it is inherited from ~S"
-                               name (package-name sp) (package-name (first ip)))))
+                     (in
+                      (unless (equal sp (first in))
+                        (if mix
+                            (ensure-shadowing-import name (second in))
+                            (error "Can't inherit ~S from ~S, it is inherited from ~S"
+                                   name (package-name sp) (package-name (first in))))))
                      ((gethash name imported)
                       (unless (eq symbol existing)
                         (error "Can't inherit ~S from ~S, it is imported from ~S"
@@ -358,11 +368,11 @@ or when loading the package is optional."
                      (t
                       (setf (gethash name inherited) (list sp p))
                       (when status
-                        (unintern* existing package)
-                        (fishy :inherited name (package-name p) (package-name sp)
-                               (package-name xp))))))))
-             (home-package-p (symbol package)
-               (eq (symbol-package symbol) (find-package* package)))
+                        (let ((shadowing (symbol-shadowing-p existing package)))
+                          (fishy :inherited name (package-name p) (package-name sp)
+                                 (package-name xp))
+                          (if shadowing (ensure-shadowing-import name p)
+                              (unintern* existing package)))))))))
              (recycle-symbol (name)
                (let (recycled foundp)
                  (dolist (r recycle (values recycled foundp))
@@ -466,14 +476,15 @@ or when loading the package is optional."
                        (shadowing-import dummy package)
                        (import dummy package)))))))
             (shadow name package))
-          (loop :for (p . syms) :in shadowing-import-from :do
-            (dolist (sym syms) (ensure-shadowing-import sym p)))
+          (loop :for (p . syms) :in shadowing-import-from
+                :for pp = (find-package* p) :do
+                  (dolist (sym syms) (ensure-shadowing-import (string sym) pp)))
           (dolist (p mix)
-            (do-external-symbols (sym p) (ensure-mix sym p)))
+            (do-external-symbols (sym p) (ensure-mix (symbol-name sym) sym p)))
           (loop :for (p . syms) :in import-from :do
             (dolist (sym syms) (ensure-import sym p)))
           (dolist (p (append use mix))
-            (do-external-symbols (sym p) (ensure-inherited (string sym) sym p))
+            (do-external-symbols (sym p) (ensure-inherited (string sym) sym p nil))
             (use-package p package))
           (loop :for name :being :the :hash-keys :of exported :do
             (ensure-symbol (string name) t)
index 5a7d225..98535a0 100644 (file)
@@ -53,7 +53,7 @@
    #:read-null-terminated-string #:read-little-endian
    #:parse-file-location-info #:parse-windows-shortcut
    ;; Output translations
-   #:*output-translation-hook*))
+   #:*output-translation-function*))
 
 (in-package :asdf/pathname)
 
@@ -835,4 +835,4 @@ For the latter case, we ought pick random suffix and atomically open it."
         nil)))))
 
 ;;; Hook for output translations
-(defvar *output-translation-hook* 'identity)
+(defvar *output-translation-function* 'identity)
index f262cf2..4f8d7d1 100644 (file)
    #:escape-windows-token #:escape-windows-command
    #:escape-token #:escape-command
 
-   ;;; run-program/foo
+   ;;; run-program/
+   #:slurp-input-stream
    #:run-program/
    #:subprocess-error
-   #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process))
+   #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
+   ))
 (in-package :asdf/run-program)
 
 ;;;; ----- Escaping strings for the shell -----
@@ -339,6 +341,7 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
              (format nil (if (os-unix-p) "exec > ~*~A ; ~2:*~A" "~A > ~A")
                      (system-command command) (native-namestring out)))
            (system (command &key interactive)
+             (declare (ignorable interactive))
              #+(or abcl xcl) (ext:run-shell-command command)
              #+allegro
              (excl:run-shell-command command :input interactive :output interactive :wait t)
index 675d6cc..41e43f5 100644 (file)
@@ -5,7 +5,7 @@
   (:recycle :asdf/stream)
   (:use :cl :asdf/package :asdf/compatibility :asdf/utility :asdf/pathname)
   (:export
-   #:*default-stream-element-type* #:*stderr*
+   #:*default-stream-element-type* #:*stderr* #:setup-stderr
    #:with-safe-io-syntax #:call-with-safe-io-syntax
    #:with-output #:output-string #:with-input
    #:with-input-file #:call-with-input-file
@@ -14,8 +14,9 @@
    #:copy-stream-to-stream #:concatenate-files
    #:copy-stream-to-stream-line-by-line
    #:slurp-stream-string #:slurp-stream-lines
-   #:slurp-stream-forms #:slurp-file-string
-   #:read-file-lines #:read-file-forms #:eval-input
+   #:slurp-stream-forms #:read-file-string
+   #:read-file-lines #:read-file-forms
+   #:safe-read-first-file-form #:eval-input
    #: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*))
 (defvar *stderr* #-clozure *error-output* #+clozure ccl::*stderr*
   "the original error output stream at startup")
 
+(defun setup-stderr ()
+  (setf *stderr* #-clozure *error-output* #+clozure ccl::*stderr*))
+
 
 ;;; Safe syntax
 
+(defvar *standard-readtable* (copy-readtable nil))
+
 (defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
   "Establish safe CL reader options around the evaluation of BODY"
   `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body))))
@@ -37,6 +43,8 @@
 (defun* call-with-safe-io-syntax (thunk &key (package :cl))
   (with-standard-io-syntax ()
     (let ((*package* (find-package package))
+          (*readtable* *standard-readtable*)
+          (*read-default-float-format* 'double-float)
           (*print-readably* nil)
          (*read-eval* nil))
       (funcall thunk))))
@@ -207,9 +215,11 @@ BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
   "Reads the first form from the top of a file.
 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
   (with-input-file (in pathname)
-    (read in eof-error-p eof-value)))
+    (read-preserving-whitespace in eof-error-p eof-value)))
 
-(defun* safe-read-first-file-form (pathname &key (package :cl) eof-error-p eof-value)
+(defun* safe-read-first-file-form (pathname &key
+                                            (package :cl)
+                                            eof-error-p eof-value)
   "Reads the first form from the top of a file using a safe standardized syntax"
   (with-safe-io-syntax (:package package)
     (read-first-file-form pathname :eof-error-p eof-error-p :eof-value eof-value)))
index f3d9560..c8d15b2 100644 (file)
@@ -2,7 +2,7 @@
 ;;;; Systems
 
 (asdf/package:define-package :asdf/system
-  (:recycle :asdf/system :asdf)
+  (:recycle :asdf :asdf/system)
   (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/upgrade
    :asdf/component)
   (:intern #:children #:children-by-name #:default-component-class
index 1650ccd..738f71b 100644 (file)
@@ -32,7 +32,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.85")
+         (asdf-version "2.26.86")
          (existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
@@ -94,7 +94,7 @@ You can compare this string with e.g.:
 
 (defun* upgrade-asdf ()
   "Try to upgrade of ASDF. If a different version was used, return T.
-   We need do that before we operate on anything that depends on ASDF."
+   We need do that before we operate on anything that may possibly depend on ASDF."
   (unless *asdf-upgrade-already-attempted*
     (setf *asdf-upgrade-already-attempted* t)
     (let ((version (asdf-version)))
index 71058f8..d88eaca 100644 (file)
@@ -20,9 +20,9 @@
    #:stamp< #:stamp<= #:earlier-stamp #:stamps-earliest #:earliest-stamp ;; stamps
    #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
    #:list-to-hash-set ;; hash-table
-   #:ensure-function #:call-function #:call-functions ;; functions
+   #:ensure-function #:call-function #:call-functions #:register-hook-function ;; functions
    #:eval-string #:load-string #:load-stream
-   #:parse-version #:version-compatible-p)) ;; version
+   #:parse-version #:unparse-version #:version-compatible-p)) ;; version
 (in-package :asdf/utility)
 
 ;;;; Defining functions in a way compatible with hot-upgrade:
@@ -238,6 +238,10 @@ starting the separation from the end, e.g. when called with arguments
 (defun* call-functions (function-specs)
   (map () 'call-function function-specs))
 
+(defun* register-hook-function (variable hook &optional (now t))
+  (pushnew hook (symbol-value variable))
+  (when now (call-function hook)))
+
 
 ;;; Version handling
 (defun* parse-version (string &optional on-error)
@@ -260,6 +264,9 @@ NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3"
                   'parse-version string)) nil)
    (mapcar #'parse-integer (split-string string :separator "."))))
 
+(defun* unparse-version (version-list)
+  (format nil "~{~D~^.~}" version-list))
+
 (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.
diff --git a/version.lisp-expr b/version.lisp-expr
new file mode 100644 (file)
index 0000000..aa65cbb
--- /dev/null
@@ -0,0 +1 @@
+"2.26.86"