Commit f3e6b7d1 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.86: bin/bump-version is now written in Lisp using ASDF support functions

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.
parent 5270de20
...@@ -115,7 +115,7 @@ You can put together sentences using this phrase.")) ...@@ -115,7 +115,7 @@ You can put together sentences using this phrase."))
(multiple-value-bind (files fixedp) (call-next-method) (multiple-value-bind (files fixedp) (call-next-method)
(if fixedp (if fixedp
files files
(mapcar *output-translation-hook* files))) (mapcar *output-translation-function* files)))
t)) t))
(defmethod output-files ((o operation) (c component)) (defmethod output-files ((o operation) (c component))
(declare (ignorable o c)) (declare (ignorable o c))
......
...@@ -5,6 +5,7 @@ ...@@ -5,6 +5,7 @@
:description "Basic general-purpose utilities used by ASDF" :description "Basic general-purpose utilities used by ASDF"
:long-description "Basic general-purpose utilities that is in such a need :long-description "Basic general-purpose utilities that is in such a need
that you can't portably construct a complete program without using them." that you can't portably construct a complete program without using them."
#+asdf2.27 :version #+asdf2.27 (:read-file-form "version.lisp-expr")
:components :components
((:file "header") ((:file "header")
(:file "package") (:file "package")
...@@ -12,9 +13,9 @@ that you can't portably construct a complete program without using them." ...@@ -12,9 +13,9 @@ that you can't portably construct a complete program without using them."
(:file "utility" :depends-on ("compatibility")) (:file "utility" :depends-on ("compatibility"))
(:file "pathname" :depends-on ("utility")) (:file "pathname" :depends-on ("utility"))
(:file "stream" :depends-on ("pathname")) (:file "stream" :depends-on ("pathname"))
(:file "os" :depends-on ("pathname" "stream")) (:file "os" :depends-on ("stream"))
(:file "image" :depends-on ("os")) (:file "image" :depends-on ("os"))
(:file "run-program" :depends-on ("os")) (:file "run-program" :depends-on ("os"))
(:file "lisp-build" :depends-on ("image")) (: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")))) (:file "driver" :depends-on ("lisp-build" "run-program" "configuration"))))
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.85" ;; to be automatically updated by bin/bump-revision :version "2.26.86" ;; to be automatically updated by bin/bump-revision
:depends-on () :depends-on ()
:components ((:module "build" :components ((:file "asdf")))) :components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf)))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......
#!/bin/sh #!/bin/sh
# Takes one optional argument: the new version number. ":" ; exec sbcl --script "$0" "$@" ; exit # -*- Lisp -*-
# If not provided, increment previous patch number, ;;; Really runs on any decent Common Lisp implementation
# e.g. 3.45.6 ==> 3.45.7, or 3.56 ==> 3.56.1
NEWVER="${1}" (require :asdf)
PROG="$0" (in-package :asdf)
ASDFDIR="$(cd $(dirname $PROG)/.. ; /bin/pwd)" ## readlink -f doesn't work on BSD
(upgrade-asdf)
if [ -z "$NEWVER" ] ; then
OLDVER="$(grep ' (asdf-version "' ${ASDFDIR}/upgrade.lisp | cut -d\" -f2)" (load-systems :cl-ppcre :xcvb-utils)
NEWVER="$(echo $OLDVER | perl -npe 's/([0-9].[0-9]+)(\.([0-9]+))?/"${1}.".($3+1)/e')"
fi (in-package :xcvb-utils)
echo "Setting ASDF version to $NEWVER"
for i in ${ASDFDIR}/header.lisp ${ASDFDIR}/upgrade.lisp ; do (asdf-debug)
perl -i.bak -npe 's/^( \(asdf-version "|;;; This is ASDF )[0-9.]+("\)|:)/${1}'"$NEWVER"'${2}/' $i
done (defun afile (x)
for i in ${ASDFDIR}/asdf.asd ; do # ${ASDFDIR}/generate-asdf.asd (asdf:system-relative-pathname :asdf x))
perl -i.bak -npe 's/^( :version ")[0-9.]+(")/${1}'"$NEWVER"'${2}/' $i
done (defparameter *version-file*
(afile "version.lisp-expr"))
cat<<EOF
To complete the version change, you may: (defparameter *old-version*
git commit -a (safe-read-first-file-form *version-file*))
git tag $NEWVER
EOF (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*)
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
(asdf/package:define-package :asdf/configuration (asdf/package:define-package :asdf/configuration
(:recycle :asdf/configuration :asdf) (: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 (:export
#:get-folder-path #:get-folder-path
#:user-configuration-directories #:system-configuration-directories #:user-configuration-directories #:system-configuration-directories
...@@ -280,3 +280,4 @@ Please remove it from your ASDF configuration")) ...@@ -280,3 +280,4 @@ Please remove it from your ASDF configuration"))
(defun* clear-configuration () (defun* clear-configuration ()
(call-functions *clear-configuration-hook*)) (call-functions *clear-configuration-hook*))
(register-image-dump-hook 'clear-configuration)
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
(asdf/package:define-package :asdf/defsystem (asdf/package:define-package :asdf/defsystem
(:recycle :asdf/defsystem :asdf) (: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/component :asdf/system :asdf/find-system :asdf/find-component
:asdf/lisp-action :asdf/operate :asdf/lisp-action :asdf/operate
:asdf/backward-internals) :asdf/backward-internals)
...@@ -76,6 +76,14 @@ ...@@ -76,6 +76,14 @@
(sysdef-error-component ":in-order-to must be NIL or a list of components." (sysdef-error-component ":in-order-to must be NIL or a list of components."
type name in-order-to))) 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 ;;; Main parsing function
(defun* parse-component-form (parent options &key previous-serial-component) (defun* parse-component-form (parent options &key previous-serial-component)
...@@ -98,10 +106,6 @@ ...@@ -98,10 +106,6 @@
(typep (find-component parent name) (typep (find-component parent name)
(class-for-type parent type)))) (class-for-type parent type))))
(error 'duplicate-names :name name)) (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")) (when do-first (error "DO-FIRST is not supported anymore since ASDF 2.27"))
(let* ((args `(:name ,(coerce-name name) (let* ((args `(:name ,(coerce-name name)
:pathname ,pathname :pathname ,pathname
...@@ -120,6 +124,10 @@ ...@@ -120,6 +124,10 @@
(apply 'reinitialize-instance ret args) (apply 'reinitialize-instance ret args)
(setf ret (apply 'make-instance (class-for-type parent type) args))) (setf ret (apply 'make-instance (class-for-type parent type) args)))
(component-pathname ret) ; eagerly compute the absolute pathname (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) (when (typep ret 'parent-component)
(setf (component-children ret) (setf (component-children ret)
(loop (loop
......
...@@ -847,7 +847,13 @@ are parsed as period-separated lists of integers. I.e., in the example, ...@@ -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 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}, @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. 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 @cindex :version
@end itemize @end itemize
......
...@@ -2,6 +2,7 @@ ...@@ -2,6 +2,7 @@
;;;; Re-export all the functionality in asdf/driver ;;;; Re-export all the functionality in asdf/driver
(asdf/package:define-package :asdf/driver (asdf/package:define-package :asdf/driver
(:nicknames :d)
(:use :common-lisp (:use :common-lisp
:asdf/package :asdf/compatibility :asdf/utility :asdf/package :asdf/compatibility :asdf/utility
:asdf/pathname :asdf/stream :asdf/os :asdf/image :asdf/pathname :asdf/stream :asdf/os :asdf/image
......
...@@ -9,6 +9,7 @@ ...@@ -9,6 +9,7 @@
;; :include-dependencies t ;; :include-dependencies t
:translate-output-p nil :translate-output-p nil
:concatenated-source-file "build/asdf.lisp" :concatenated-source-file "build/asdf.lisp"
:version (:read-file-form "version.lisp-expr")
:serial t :serial t
:depends-on (:asdf-driver) :depends-on (:asdf-driver)
:components :components
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- ;; -*- 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: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
......
...@@ -5,7 +5,8 @@ ...@@ -5,7 +5,8 @@
(:recycle :asdf/image :xcvb-driver) (:recycle :asdf/image :xcvb-driver)
(:use :common-lisp :asdf/utility :asdf/pathname :asdf/stream :asdf/os) (:use :common-lisp :asdf/utility :asdf/pathname :asdf/stream :asdf/os)
(:export (: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* #:*debugging* #:*post-image-restart* #:*entry-point*
#:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace
#:bork #:with-coded-exit #:shell-boolean #:bork #:with-coded-exit #:shell-boolean
...@@ -19,7 +20,7 @@ ...@@ -19,7 +20,7 @@
(defvar *debugging* nil (defvar *debugging* nil
"Shall we print extra debugging information?") "Shall we print extra debugging information?")
(defvar *arguments* nil (defvar *command-line-arguments* nil
"Command-line arguments") "Command-line arguments")
(defvar *dumped* nil (defvar *dumped* nil
...@@ -158,11 +159,11 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -158,11 +159,11 @@ This is designed to abstract away the implementation specific quit forms."
;;; Using hooks ;;; Using hooks
(defun* register-image-resume-hook (hook) (defun* register-image-resume-hook (hook &optional (now t))
(pushnew hook *image-resume-hook*)) (register-hook-function '*image-resume-hook* hook now))
(defun* register-image-dump-hook (hook) (defun* register-image-dump-hook (hook &optional (now nil))
(pushnew hook *image-dump-hook*)) (register-hook-function '*image-dump-hook* hook now))
(defun* call-image-resume-hook () (defun* call-image-resume-hook ()
(call-functions (reverse *image-resume-hook*))) (call-functions (reverse *image-resume-hook*)))
...@@ -171,15 +172,6 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -171,15 +172,6 @@ This is designed to abstract away the implementation specific quit forms."
(call-functions *image-dump-hook*)) (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 ;;; Proper command-line arguments
(defun* raw-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." ...@@ -210,20 +202,24 @@ if we are not called from a directly executable image dumped by XCVB."
(member "--" arguments :test 'string-equal)))) (member "--" arguments :test 'string-equal))))
(rest arguments))) (rest arguments)))
(defun* do-resume (&key (post-image-restart *post-image-restart*) (entry-point *entry-point*)) (defun setup-command-line-arguments ()
(with-safe-io-syntax (:package :asdf) (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)) (let ((*read-eval* t))
(when post-image-restart (eval-input post-image-restart)))) (when post-image-restart (eval-input post-image-restart))))
(with-coded-exit () (when entry-point
(when entry-point (apply entry-point *command-line-arguments*)))
(let ((ret (apply entry-point *arguments*)))
(if (typep ret 'integer)
(quit ret)
(quit 99))))))
(defun* resume () (defun* resume ()
(setf *arguments* (command-line-arguments)) (with-coded-exit ()
(do-resume)) (let ((ret (resume-program)))
(if (typep ret 'integer)
(quit ret)
(quit 99)))))
;;; Dumping an image ;;; Dumping an image
...@@ -284,3 +280,9 @@ if we are not called from a directly executable image dumped by XCVB." ...@@ -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 (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) #-(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)) (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*)
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
(:export (:export
;; Variables ;; Variables
#:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*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* #:*optimization-settings* #:*previous-optimization-settings*
#:*uninteresting-conditions* #:*uninteresting-conditions*
#:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions* #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
...@@ -259,7 +259,7 @@ for processing later (possibly in a different process)." ...@@ -259,7 +259,7 @@ for processing later (possibly in a different process)."
(defaults (make-pathname (defaults (make-pathname
:type type :defaults (merge-pathnames* input-file)))) :type type :defaults (merge-pathnames* input-file))))
(merge-pathnames* output-file defaults)) (merge-pathnames* output-file defaults))
(funcall *output-translation-hook* (funcall *output-translation-function*
(apply 'compile-file-pathname input-file keys))))) (apply 'compile-file-pathname input-file keys)))))
(defun* load* (x &rest keys &key &allow-other-keys) (defun* load* (x &rest keys &key &allow-other-keys)
......
...@@ -15,24 +15,19 @@ ...@@ -15,24 +15,19 @@
#:hostname #:user-homedir #:lisp-implementation-directory #:hostname #:user-homedir #:lisp-implementation-directory
#:getcwd #:chdir #:call-with-current-directory #:with-current-directory #:getcwd #:chdir #:call-with-current-directory #:with-current-directory
#:*temporary-directory* #:temporary-directory #:default-temporary-directory #:*temporary-directory* #:temporary-directory #:default-temporary-directory
#:setup-temporary-directory
#:call-with-temporary-file #:with-temporary-file)) #:call-with-temporary-file #:with-temporary-file))
(in-package :asdf/os) (in-package :asdf/os)
;;; Features ;;; Features
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
(defun* featurep (x &optional (features *features*)) (defun* featurep (x &optional (*features* *features*))
(cond (cond
((atom x) ((atom x) (and (member x *features*) t))
(and (member x features) t)) ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
((eq :not (car x)) ((eq :or (car x)) (some #'featurep (cdr x)))
(assert (null (cddr x))) ((eq :and (car x)) (every #'featurep (cdr x)))
(not (featurep (cadr x) features))) (t (error "Malformed feature specification ~S" x))))
((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))))
(defun* os-unix-p () (defun* os-unix-p ()
(featurep '(:or :unix :cygwin :darwin))) (featurep '(:or :unix :cygwin :darwin)))
...@@ -109,16 +104,21 @@ then returning the non-empty string value of the variable" ...@@ -109,16 +104,21 @@ then returning the non-empty string value of the variable"
;; Initially stolen from SLIME's SWANK, completely rewritten since. ;; Initially stolen from SLIME's SWANK, completely rewritten since.
;; We're back to runtime checking, for the sake of e.g. ABCL. ;; We're back to runtime checking, for the sake of e.g. ABCL.
(defun* first-feature (features) (defun* first-feature (feature-sets)
(dolist (x features) (dolist (x feature-sets)
(multiple-value-bind (val feature) (multiple-value-bind (short long feature-expr)
(if (consp x) (values (first x) (cons :or (rest x))) (values x x)) (if (consp x)
(when (featurep feature) (return val))))) (values (first x) (second x) (cons :or (rest x)))
(values x x x))
(when (featurep feature-expr)
(return (values short long))))))
(defun* implementation-type () (defun* implementation-type ()
(first-feature (first-feature
'(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
:ecl :gcl (:lw :lispworks) :mcl :mkcl :sbcl :scl :symbolics :xcl))) (:cmu :cmucl :cmu) :ecl :gcl
(:lwpe :lispworks-personal-edition) (:lw :lispworks)
:mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
(defun* operating-system () (defun* operating-system ()
(first-feature (first-feature
...@@ -130,7 +130,7 @@ then returning the non-empty string value of the variable" ...@@ -130,7 +130,7 @@ then returning the non-empty string value of the variable"
(defun* architecture () (defun* architecture ()
(first-feature (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) (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
(:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc) (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
:hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc) :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
...@@ -278,6 +278,9 @@ then returning the non-empty string value of the variable" ...@@ -278,6 +278,9 @@ then returning the non-empty string value of the variable"
(defun* temporary-directory () (defun* temporary-directory ()
(or *temporary-directory* (default-temporary-directory))) (or *temporary-directory* (default-temporary-directory)))
(defun setup-temporary-directory ()
(setf *temporary-directory* (default-temporary-directory)))
(defun* call-with-temporary-file (defun* call-with-temporary-file
(thunk &key (thunk &key
prefix keep (direction :io) prefix keep (direction :io)
......
...@@ -20,6 +20,8 @@ ...@@ -20,6 +20,8 @@
)) ))
(in-package :asdf/output-translations) (in-package :asdf/output-translations)
(when-upgrade () (undefine-function '(setf output-translations)))
(define-condition invalid-output-translation (invalid-configuration warning) (define-condition invalid-output-translation (invalid-configuration warning)
((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
...@@ -305,5 +307,5 @@ effectively disabling the output translation facility." ...@@ -305,5 +307,5 @@ effectively disabling the output translation facility."
(merge-pathnames* relative-source target-root))) (merge-pathnames* relative-source target-root)))
(normalize-device (apply-output-translations target))))) (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*) (pushnew 'clear-output-translations *clear-configuration-hook*)
...@@ -73,7 +73,9 @@ or when loading the package is optional." ...@@ -73,7 +73,9 @@ or when loading the package is optional."
(let* ((symbol-name (aref vector 0)) (let* ((symbol-name (aref vector 0))
(package-name (aref vector 1))) (package-name (aref vector 1)))
(if package-name (intern symbol-name package-name) (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) (eval-when (:load-toplevel :compile-toplevel :execute)
#+(or clisp clozure) #+(or clisp clozure)
...@@ -225,7 +227,7 @@ or when loading the package is optional." ...@@ -225,7 +227,7 @@ or when loading the package is optional."
(imported (not (eq home package))) (imported (not (eq home package)))
(shadowing (symbol-shadowing-p sym package))) (shadowing (symbol-shadowing-p sym package)))
(cond (cond
((and shadowing import) ((and shadowing imported)
(push name (gethash home-name shadowing-import))) (push name (gethash home-name shadowing-import)))
(shadowing (shadowing
(push name shadow)) (push name shadow))
...@@ -290,9 +292,8 @@ or when loading the package is optional." ...@@ -290,9 +292,8 @@ or when loading the package is optional."
(macrolet ((fishy (&rest info) (macrolet ((fishy (&rest info)
`(when fishyp (push (list ,@info) fishy)))) `(when fishyp (push (list ,@info) fishy))))
(labels (labels
((ensure-shadowing-import (sym p) ((ensure-shadowing-import (name p)
(let ((name (string sym)) (let ((import (find-symbol* name p)))
(import (find-symbol* name p)))
(multiple-value-bind (existing status) (find-symbol name package) (multiple-value-bind (existing status) (find-symbol name package)
(cond (cond
((gethash name shadowed) ((gethash name shadowed)
...@@ -303,10 +304,10 @@ or when loading the package is optional." ...@@ -303,10 +304,10 @@ or when loading the package is optional."
(setf (gethash name imported) t) (setf (gethash name imported) t)
(unless (or (null status) (unless (or (null status)
(and (member status '(:internal :external)) (and (member status '(:internal :external))
(eq existing sym) (eq existing import)
(symbol-shadowing-p existing package))) (symbol-shadowing-p existing package)))
(fishy :shadowing-import (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)) (and status (symbol-package-name existing)) status))
(shadowing-import import package)))))) (shadowing-import import package))))))
(ensure-import (sym p) (ensure-import (sym p)
...@@ -328,29 +329,38 @@ or when loading the package is optional." ...@@ -328,29 +329,38 @@ or when loading the package is optional."
(fishy :import name (package-name p) (symbol-package-name import) (fishy :import name (package-name p) (symbol-package-name import)
(and status (symbol-package-name existing)) status)) (and status (symbol-package-name existing)) status))
(import import package))))))) (import import package)))))))
(ensure-mix (sym p) (ensure-mix (name symbol p)
(let* ((name (symbol-name sym)) (unless (gethash name shadowed)
(sp (symbol-package sym))) (multiple-value-bind (existing status) (find-symbol name package)
(unless (or (gethash name shadowed) (gethash name imported)) (let* ((sp (symbol-package symbol))
(let ((ip (gethash name inherited))) (im (gethash name imported))
(in (gethash name inherited)))
(cond (cond
((and ip (eq sp (first ip)))) ((or (null status)
(ip (and status (eq symbol existing))
(and in (eq sp (first in))))
(ensure-inherited name symbol p t))
(in
(remhash name inherited) (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 (t
(ensure-inherited name sym p))))))) (ensure-inherited name symbol p t)))))))
(ensure-inherited (name symbol p) (ensure-inherited (name symbol p mix)
(multiple-value-bind (existing status) (find-symbol name package) (multiple-value-bind (existing status) (find-symbol name package)
(let* ((sp (symbol-package symbol)) (let* ((sp (symbol-package symbol))
(ip (gethash name inherited)) (in (gethash name inherited))
(xp (and status (symbol-package existing)))) (xp (and status (symbol-package existing))))
(cond (cond
((gethash name shadowed)) ((gethash name shadowed))
(ip (in
(unless (equal sp (first ip)) (unless (equal sp (first in))
(error "Can't inherit ~S from ~S, it is inherited from ~S" (if mix
name (package-name sp) (package-name (first ip))))) (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) ((gethash name imported)
(unless (eq symbol existing) (unless (eq symbol existing)
(error "Can't inherit ~S from ~S, it is imported from ~S" (error "Can't inherit ~S from ~S, it is imported from ~S"
...@@ -358,11 +368,11 @@ or when loading the package is optional." ...@@ -358,11 +368,11 @@ or when loading the package is optional."
(t (t
(setf (gethash name inherited) (list sp p)) (setf (gethash name inherited) (list sp p))
(when status (when status
(unintern* existing package) (let ((shadowing (symbol-shadowing-p existing package)))
(fishy :inherited name (package-name p) (package-name sp) (fishy :inherited name (package-name p) (package-name sp)
(package-name xp)))))))) (package-name xp))
(home-package-p (symbol package) (if shadowing (ensure-shadowing-import name p)
(eq (symbol-package symbol) (find-package* package))) (unintern* existing package)))))))))
(recycle-symbol (name) (recycle-symbol (name)
(let (recycled foundp) (let (recycled foundp)
(dolist (r recycle (values recycled foundp)) (dolist (r recycle (values recycled foundp))
...@@ -466,14 +476,15 @@ or when loading the package is optional." ...@@ -466,14 +476,15 @@ or when loading the package is optional."
(shadowing-import dummy package) (shadowing-import dummy package)
(import dummy package))))))) (import dummy package)))))))
(shadow name package)) (shadow name package))
(loop :for (p . syms) :in shadowing-import-from :do (loop :for (p . syms) :in shadowing-import-from
(dolist (sym syms) (ensure-shadowing-import sym p))) :for pp = (find-package* p) :do
(dolist (sym syms) (ensure-shadowing-import (string sym) pp)))
(dolist (p mix) (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 (loop :for (p . syms) :in import-from :do
(dolist (sym syms) (ensure-import sym p))) (dolist (sym syms) (ensure-import sym p)))