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."))
(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))
......
......@@ -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"))))
......@@ -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))))
......
#!/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*)
......@@ -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)
......@@ -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)
......@@ -76,6 +76,14 @@
(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)
......@@ -98,10 +106,6 @@
(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
......@@ -120,6 +124,10 @@
(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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
;; -*- 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>.
......
......@@ -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*)
......@@ -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)
......
......@@ -15,24 +15,19 @@
#: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)
......
......@@ -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*)
......@@ -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)
......
......@@ -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)
......@@ -10,10 +10,12 @@
#: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)
......
......@@ -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*))
......@@ -27,9 +28,14 @@
(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)))
......
......@@ -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
......
......@@ -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)))
......
......@@ -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.
......
Markdown is supported
0%