diff --git a/asdf.asd b/asdf.asd index 214fa899e64f832ea109d8239ab5e6ff7a744cb7..a703a51f0aa98ca6a20d1ab42cfb7b52fdd8e8ac 100644 --- a/asdf.asd +++ b/asdf.asd @@ -15,7 +15,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.26.104" ;; to be automatically updated by bin/bump-revision + :version "2.26.105" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:module "build" :components ((:file "asdf")))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf)))) diff --git a/bin/make-tarball b/bin/make-tarball index 1b17aaa75f08462c8cf8a856af994d47ebe65306..283363d5750e061623640f2bfee6d7dccb9a33c3 100755 --- a/bin/make-tarball +++ b/bin/make-tarball @@ -13,33 +13,37 @@ (describe (find-system :asdf)) (defparameter *ad* (find-system :asdf-driver)) -(defparameter *asdf-directory* (system-source-directory *ad*)) -(defparameter *version* - (safe-read-first-file-form (subpathname *asdf-directory* "version.lisp-expr"))) - -(DBG :foo *ad* *version* (asdf-version)) - +(defparameter *asdf-dir* + (ensure-pathname (system-source-directory *ad*) + :want-existing t :want-absolute t)) +(defun apath (x) (subpathname *asdf-dir* x)) +(defun ann (x) (native-namestring (apath x))) +(defparameter *build-dir* (apath "build/")) +(defparameter /build-dir/ (ann "build/")) +(defun bpath (x) (subpathname *build-dir* x)) +(defun bnn (x) (native-namestring (bpath x))) (defparameter *files* - (append - (loop :for c :in (operated-components *ad* - :goal-operation 'load-op - :keep-operation 'load-op) - :for n = (enough-namestring (component-pathname c) *asdf-directory*) - :when (typep c 'cl-source-file) - :collect n) - (list "version.lisp-expr" "asdf-driver.asd"))) - -;; make asdf: -;;;(run-program/ (list "make" "-C" (native-namestring *asdf-directory*) "build/asdf.lisp")) - -#| -if [ -d "tmp" ]; then - rm -r tmp -fi -mkdir tmp - -archive_file="tmp/asdf-$tag.tar.gz" -echo "Create tmp/asdf.tar.gz with tag $tag" -git archive $tag --prefix="asdf/" --format=tar | \ - gzip > $archive_file -|# \ No newline at end of file + (list* "asdf-driver.asd" "version.lisp-expr" + (loop :for c :in (operated-components + *ad* :goal-operation 'load-op + :keep-operation 'load-op) + :for n = (enough-namestring (component-pathname c) + *asdf-directory*) + :when (typep c 'cl-source-file) + :collect n))) +(defparameter *version* + (safe-read-first-file-form (apath "version.lisp-expr"))) +(defparameter *name* (format nil "asdf-driver-~A" *version*)) +(defparameter *tarname* (strcat *name* ".tar.gz")) +(defparameter dirname/ (strcat *name* "/")) +(defparameter *destination* + (ensure-pathname (bpath dirname/) + :want-directory t :want-absolute t)) +(assert (< 6 (length (pathname-directory *destination*)))) +(defparameter /destination/ (native-namestring *destination*)) +(run-program/ `("rm" "-rf" ,/destination/)) +(ensure-directory-exists *destination*) +(run-program/ `("ln" ,@(mapcar 'ann *files*) ,/destination/)) +(run-program/ (format nil "cd ~S && tar zcf ~S ~S" + ,/build-dir/, ,*tarname* ,dirname/)) +(run-program/ `("rm" "-rf" ,/destination/)) diff --git a/configuration.lisp b/configuration.lisp index 7d2a3bd2a233ee3db0a883e771688d5c518693bf..9eef435e2e39bc8b6a735965a70a07221b99149b 100644 --- a/configuration.lisp +++ b/configuration.lisp @@ -152,35 +152,34 @@ values of TAG include :source-registry and :output-translations." :inherit-configuration))) (defun* resolve-relative-location-component (x &key want-directory wilden) - (let* ((r (etypecase x - (pathname x) - (string (parse-unix-namestring - x :want-directory want-directory)) - (cons - (if (null (cdr x)) - (resolve-relative-location-component - (car x) :want-directory want-directory :wilden wilden) - (let* ((car (resolve-relative-location-component - (car x) :want-directory t :wilden nil))) - (merge-pathnames* - (resolve-relative-location-component - (cdr x) :want-directory want-directory :wilden wilden) - car)))) - ((eql :*/) *wild-directory*) - ((eql :**/) *wild-inferiors*) - ((eql :*.*.*) *wild-file*) - ((eql :implementation) - (parse-unix-namestring - (implementation-identifier) :want-directory t)) - ((eql :implementation-type) - (parse-unix-namestring - (string-downcase (implementation-type)) :want-directory t)) - ((eql :hostname) - (parse-unix-namestring (hostname) :want-directory t)))) - (w (if (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*)))) - (wilden r) - r))) - (ensure-pathname w :want-relative t))) + (ensure-pathname + (etypecase x + (pathname x) + (string (parse-unix-namestring + x :want-directory want-directory)) + (cons + (if (null (cdr x)) + (resolve-relative-location-component + (car x) :want-directory want-directory :wilden wilden) + (let* ((car (resolve-relative-location-component + (car x) :want-directory t :wilden nil))) + (merge-pathnames* + (resolve-relative-location-component + (cdr x) :want-directory want-directory :wilden wilden) + car)))) + ((eql :*/) *wild-directory*) + ((eql :**/) *wild-inferiors*) + ((eql :*.*.*) *wild-file*) + ((eql :implementation) + (parse-unix-namestring + (implementation-identifier) :want-directory t)) + ((eql :implementation-type) + (parse-unix-namestring + (string-downcase (implementation-type)) :want-directory t)) + ((eql :hostname) + (parse-unix-namestring (hostname) :want-directory t))) + :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*)))) + :want-relative t)) (defvar *here-directory* nil "This special variable is bound to the currect directory during calls to @@ -203,39 +202,38 @@ directive.") (register-image-restore-hook 'compute-user-cache) (defun* resolve-absolute-location-component (x &key want-directory wilden) - (let* ((r (etypecase x - (pathname x) - (string - (let ((p #-mcl (parse-namestring x) - #+mcl (probe-posix x))) - #+mcl (unless p (error "POSIX pathname ~S does not exist" x)) - (if want-directory (ensure-directory-pathname p) p))) - (cons - (return-from resolve-absolute-location-component - (if (null (cdr x)) - (resolve-absolute-location-component - (car x) :want-directory want-directory :wilden wilden) - (merge-pathnames* - (resolve-relative-location-component - (cdr x) :want-directory want-directory :wilden wilden) - (resolve-absolute-location-component - (car x) :want-directory t :wilden nil))))) - ((eql :root) - ;; special magic! we return a relative pathname, - ;; but what it means to the output-translations is - ;; "relative to the root of the source pathname's host and device". - (return-from resolve-absolute-location-component - (let ((p (make-pathname* :directory '(:relative)))) - (if wilden (wilden p) p)))) - ((eql :home) (user-homedir)) - ((eql :here) (resolve-absolute-location-component - *here-directory* :want-directory t :wilden nil)) - ((eql :user-cache) (resolve-absolute-location-component - *user-cache* :want-directory t :wilden nil)))) - (w (if (and wilden (not (pathnamep x))) - (wilden r) - r))) - (ensure-pathname w :want-absolute t))) + (ensure-pathname + (etypecase x + (pathname x) + (string + (let ((p #-mcl (parse-namestring x) + #+mcl (probe-posix x))) + #+mcl (unless p (error "POSIX pathname ~S does not exist" x)) + (if want-directory (ensure-directory-pathname p) p))) + (cons + (return-from resolve-absolute-location-component + (if (null (cdr x)) + (resolve-absolute-location-component + (car x) :want-directory want-directory :wilden wilden) + (merge-pathnames* + (resolve-relative-location-component + (cdr x) :want-directory want-directory :wilden wilden) + (resolve-absolute-location-component + (car x) :want-directory t :wilden nil))))) + ((eql :root) + ;; special magic! we return a relative pathname, + ;; but what it means to the output-translations is + ;; "relative to the root of the source pathname's host and device". + (return-from resolve-absolute-location-component + (let ((p (make-pathname* :directory '(:relative)))) + (if wilden (wilden p) p)))) + ((eql :home) (user-homedir)) + ((eql :here) (resolve-absolute-location-component + *here-directory* :want-directory t :wilden nil)) + ((eql :user-cache) (resolve-absolute-location-component + *user-cache* :want-directory t :wilden nil))) + :wilden (and wilden (not (pathnamep x))) + :want-absolute t)) (defun* resolve-location (x &key want-directory wilden directory) (when directory (setf want-directory t)) ;; :directory backward compatibility, until 2014-01-16. diff --git a/header.lisp b/header.lisp index 8c3d680beb1ddd93c9c796d59f32cb4db9eb8668..434106788032c3b4a6c59a44ee7d34fe0cd68369 100644 --- a/header.lisp +++ b/header.lisp @@ -1,5 +1,5 @@ ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.26.104: Another System Definition Facility. +;;; This is ASDF 2.26.105: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . diff --git a/pathname.lisp b/pathname.lisp index 89a5e1b2d3b4e2de3ddf867dee3f8c57b9fa3bc2..f7526a190c6cb79dfce16a52d78bfb40d0f4abda 100644 --- a/pathname.lisp +++ b/pathname.lisp @@ -931,9 +931,11 @@ Otherwise, this will be the root of some implementation-dependent filesystem hos (defun* ensure-pathname (pathname &key want-pathname want-existing - want-absolute want-relative want-directory want-file - want-wild want-non-wild want-truename truenamize - error-arguments) + want-absolute want-relative + want-logical want-physical ensure-physical + want-wild want-non-wild wilden + ensure-directory want-directory want-file + want-truename truenamize error-arguments) "Coerces its argument into a PATHNAME, and checks specified constraints. If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified. If the argument is a STRING, it is first converted to a pathname via PARSE-NAMESTRING. @@ -968,30 +970,42 @@ in case you use the long variant." (string (setf pathname (parse-namestring pathname))) (pathname)) + (when want-logical + (unless (typep pathname 'logical-pathname) + (err want-logical "Expected a logical pathname, got"))) + (when want-physical + (unless (physical-pathname-p pathname) + (err want-physical "Expected a physical pathname, got"))) + (when ensure-physical + (setf pathname (translate-logical-pathname pathname))) (when want-absolute (unless (absolute-pathname-p pathname) (err want-absolute "Expected an absolute pathname, got"))) (when want-relative (when (absolute-pathname-p pathname) (err want-relative "Expected a relative pathname, got"))) - (when want-directory - (unless (directory-pathname-p pathname) - (err want-directory "Expected a directory pathname, got"))) - (when want-file - (unless (pathname-name pathname) - (err want-file "Expected a file pathname, got"))) (when want-wild (unless (wild-pathname-p pathname) (err want-wild "Expected a wildcard pathname, got"))) (when (or want-non-wild want-existing) (when (wild-pathname-p pathname) (err want-non-wild "Expected a non-wildcard pathname, got"))) + (when (and wilden (not (wild-pathname-p pathname))) + (setf pathname (wilden pathname))) + (when ensure-directory + (setf pathname (ensure-directory-pathname pathname))) + (when want-directory + (unless (directory-pathname-p pathname) + (err want-directory "Expected a directory pathname, got"))) + (when want-file + (unless (pathname-name pathname) + (err want-file "Expected a file pathname, got"))) (when want-existing (let ((existing (probe-file* pathname))) (if existing - (err want-existing "Expected an existing pathname, got") (when (or want-truename truenamize) - (return existing))))) + (return existing)) + (err want-existing "Expected an existing pathname, got")))) (when want-truename (let ((truename (truename* pathname))) (if truename diff --git a/upgrade.lisp b/upgrade.lisp index 291ad4720c5cf055672b6794ca3dafcffcbc97b0..60b35c50f8c175fe84a1d8cd6d95e9651e770efa 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -45,7 +45,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.26.104") + (asdf-version "2.26.105") (existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) diff --git a/version.lisp-expr b/version.lisp-expr index 6c4ed9efaf32e6f8cfccdc531cdfd6f744248d74..e1a03a91b0fab0970c8f6724d38c556f1cc44bfb 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -1 +1 @@ -"2.26.104" +"2.26.105"