From 4b1cea29891e45ee50c4114dd7b7c17b78cfc7fc Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Wed, 9 Jan 2013 00:32:11 -0500 Subject: [PATCH] 2.26.63: more pathname hell. New pathname functions to work around more logical-pathname issues. See discussion with rpgoldman on asdf-devel, and see CCL ticket:953. Also, tweak build to reflect recent refactoring of asdf. WIP of define-package work needed for clean upgrade (still broken). --- Makefile | 20 ++++----- asdf.asd | 2 +- bin/bump-version | 2 +- bundle.lisp | 2 +- component.lisp | 2 +- generate-asdf.asd | 2 +- header.lisp | 2 +- os.lisp | 4 +- package.lisp | 33 +++++++++++---- pathname.lisp | 90 ++++++++++++++++++++++++++++++---------- plan.lisp | 19 ++++----- source-registry.lisp | 2 +- test/script-support.lisp | 4 +- upgrade.lisp | 2 +- utility.lisp | 6 +-- 15 files changed, 129 insertions(+), 63 deletions(-) diff --git a/Makefile b/Makefile index 426e7468..ba13d157 100644 --- a/Makefile +++ b/Makefile @@ -18,19 +18,19 @@ export CL_SOURCE_REGISTRY := (:source-registry (:tree "${sourceDirectory}") :ign lisp ?= sbcl +ABCL ?= abcl +ALLEGRO ?= alisp +ALLEGROMODERN ?= mlisp CCL ?= ccl CLISP ?= clisp -SBCL ?= sbcl +CMUCL ?= cmucl ECL ?= ecl +GCL ?= gcl +LISPWORKS ?= lispworks MKCL ?= mkcl -CMUCL ?= cmucl -ABCL ?= abcl -XCL ?= xcl +SBCL ?= sbcl SCL ?= scl -ALLEGRO ?= alisp -ALLEGROMODERN ?= mlisp -LISPWORKS ?= lispworks -GCL ?= gcl +XCL ?= xcl # website, tag, install @@ -53,7 +53,7 @@ archive-copy: archive tmp/asdf.lisp tmp/asdf.lisp: $(wildcard *.lisp) mkdir -p tmp - cat header.lisp package.lisp implementation.lisp utility.lisp upgrade.lisp pathname.lisp os.lisp component.lisp system.lisp find-system.lisp find-component.lisp lisp-build.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp configuration.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp user.lisp footer.lisp > $@ + cat header.lisp package.lisp implementation.lisp utility.lisp upgrade.lisp pathname.lisp os.lisp component.lisp system.lisp find-system.lisp find-component.lisp lisp-build.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp configuration.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp > $@ push: git status @@ -146,7 +146,7 @@ test-upgrade: test-forward-references: tmp/asdf.lisp ${SBCL} --noinform --no-userinit --no-sysinit --load tmp/asdf.lisp --load test/script-support.lisp --eval '(asdf-test::exit-lisp 0)' 2>&1 | cmp - /dev/null -test-lisp: +test-lisp: tmp/asdf.lisp @cd test; ${MAKE} clean;./run-tests.sh ${lisp} ${test-glob} test: test-lisp test-forward-references doc diff --git a/asdf.asd b/asdf.asd index 9f246d45..c49b9132 100644 --- a/asdf.asd +++ b/asdf.asd @@ -14,7 +14,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.26.62" ;; to be automatically updated by bin/bump-revision + :version "2.26.63" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:file "asdf"))) diff --git a/bin/bump-version b/bin/bump-version index 9ac83866..cc1a578d 100755 --- a/bin/bump-version +++ b/bin/bump-version @@ -7,7 +7,7 @@ PROG="$0" ASDFDIR="$(cd $(dirname $PROG)/.. ; /bin/pwd)" ## readlink -f doesn't work on BSD if [ -z "$NEWVER" ] ; then - OLDVER="$(grep ' (asdf-version "' ${ASDFDIR}/header.lisp | cut -d\" -f2)" + 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" diff --git a/bundle.lisp b/bundle.lisp index ed61f780..623a3f54 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -244,7 +244,7 @@ (files (and system (output-files operation system)))) (if (or move-here (and (null move-here-p) (member operation-name '(:program :binary)))) - (loop :with dest-path = (truename (ensure-directories-exist move-here-path)) + (loop :with dest-path = (truename* (ensure-directories-exist move-here-path)) :for f :in files :for new-f = (make-pathname :name (pathname-name f) :type (pathname-type f) diff --git a/component.lisp b/component.lisp index bc1a90db..2f9e062b 100644 --- a/component.lisp +++ b/component.lisp @@ -184,7 +184,7 @@ hopefully, if done consistently, that won't affect program behavior too much.") "Hook for an extension to define a function to automatically detect a file's encoding") (defun* detect-encoding (pathname) - (if (and pathname (probe-file pathname)) + (if (and pathname (not (directory-pathname-p pathname)) (probe-file pathname)) (funcall *encoding-detection-hook* pathname) *default-encoding*)) diff --git a/generate-asdf.asd b/generate-asdf.asd index c165825c..87b78efe 100644 --- a/generate-asdf.asd +++ b/generate-asdf.asd @@ -7,7 +7,7 @@ :class :concatenated-source-system ;; :include-dependencies t :translate-output-p nil - :output-file "tmp/asdf.lisp" + :concatenated-source-file "tmp/generated-asdf.lisp" #| :depends-on (:asdf-header :asdf-package diff --git a/header.lisp b/header.lisp index ccd50ff8..4c46d105 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.62: Another System Definition Facility. +;;; This is ASDF 2.26.63: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. diff --git a/os.lisp b/os.lisp index a9664f64..ae621ca8 100644 --- a/os.lisp +++ b/os.lisp @@ -222,12 +222,12 @@ using WRITE-SEQUENCE and a sensibly sized buffer." ; copied from xcvb-driver (defun* lisp-implementation-directory (&key truename) (let ((dir (ignore-errors - #+clozure (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:")) + #+clozure #p"ccl:" #+(or ecl mkcl) #p"SYS:" #+sbcl (aif (find-symbol* :sbcl-homedir-pathname :sb-int) (funcall it) (getenv-pathname "SBCL_HOME" :want-directory t))))) (if (and dir truename) - (let ((*default-pathname-defaults* #p"")) (truename dir)) + (truename* dir) dir))) diff --git a/package.lisp b/package.lisp index 06f7a2ae..40614aaa 100644 --- a/package.lisp +++ b/package.lisp @@ -124,9 +124,10 @@ when the symbol is not found." (loop :for x :in newly-exported-symbols :do (export (intern* x package))))) (defun ensure-package (name &key - nicknames use reuse unintern - shadow export fmakunbound fmakunbound-setf) - reuse + nicknames use intern unintern shadow export + import-from shadowing-import-from + recycle mix fmakunbound fmakunbound-setf) + recycle mix intern import-from shadowing-import-from (let* ((p (ensure-package-exists name nicknames use))) #-ecl (ensure-package-fmakunbound p fmakunbound) #+ecl fmakunbound ;; do it later on ECL #-ecl (ensure-package-fmakunbound-setf p fmakunbound-setf) #+ecl fmakunbound-setf @@ -134,8 +135,6 @@ when the symbol is not found." (ensure-package-shadow p shadow) (ensure-package-export p export) p)) - (defun do-define-package (package clauses) - package clauses #| (let ((h (make-hash-table :test 'equal))) (labels ((ensure-imported (n) @@ -163,8 +162,28 @@ when the symbol is not found." ,@clauses (:export ,@(loop :for s :being :the :hash-keys :of h :collect s))))))) |# - )) + (defun parse-define-package-clauses (clauses) + (loop :for (kw . args) :in clauses + :when (eq kw :nicknames) :append args :into nicknames :else + :when (eq kw :use) :append args :into use :else + :when (eq kw :shadow) :append args :into shadow :else + :when (eq kw :export) :append args :into export :else + :when (eq kw :intern) :append args :into intern :else + :when (eq kw :import-from) :collect args :into import-from :else + :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else + :when (eq kw :recycle) :append args :into recycle :else + :when (eq kw :mix) :append args :into mix :else + :when (eq kw :unintern) :append args :into unintern :else + :when (eq kw :fmakunbound) :append args :into fmakunbound :else + :when (eq kw :fmakunbound-setf) :append args :into fmakunbound-setf :else + :do (error "unrecognized define-package keyword ~S" kw) + :finally (return `(:nicknames ,nicknames :use ,use + :shadow ,shadow :export ,export :intern ,intern + :import-from ,import-from :shadowing-import-from ,shadowing-import-from + :recycle ,recycle :mix ,mix :unintern ,unintern + :fmakunbound ,fmakunbound :fmakunbound-setf ,fmakunbound-setf)))) +);eval-when (defmacro define-package (package &rest clauses) `(eval-when (:compile-toplevel :load-toplevel :execute) - (do-define-package ',package ',clauses))) + (apply 'ensure-package ',package ',(parse-define-package-clauses clauses)))) diff --git a/pathname.lisp b/pathname.lisp index 72acca94..01bdf0d5 100644 --- a/pathname.lisp +++ b/pathname.lisp @@ -23,10 +23,12 @@ ;; Wildcard pathnames #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden ;; Pathname host and its root - #:pathname-root #:directory-sperator-for-host + #:pathname-root #:directory-separator-for-host #:directorize-pathname-host-device + ;; defaults + #:nil-pathname #:with-pathname-defaults ;; probe filesystem - #:probe-file* #:safe-file-write-date + #:truename* #:probe-file* #:safe-file-write-date #:subdirectories #:directory-files #:directory* #:filter-logical-directory-results #:collect-sub*directories ;; Simple filesystem operations @@ -39,7 +41,9 @@ #:add-pathname-suffix #:tmpize-pathname #:call-with-staging-pathname #:with-staging-pathname ;; basic pathnames - #:load-pathname #:default-directory + #:load-pathname #:default-directory #:nil-pathname + ;; physical pathnames + #:physical-pathname-p #:sane-physical-pathname ;; Windows shortcut support #:read-null-terminated-string #:read-little-endian #:parse-file-location-info #:parse-windows-shortcut)) @@ -106,7 +110,7 @@ Defaults to T.") :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) (defun* make-pathname* (&rest keys &key (directory nil directoryp) - host device name type version defaults) + host device name type version defaults #+scl &allow-other-keys) (declare (ignore host device name type version defaults)) (apply 'make-pathname (append (when directoryp @@ -241,24 +245,36 @@ actually-existing directory." ;;; Probing the filesystem +(defun* nil-pathname (&optional (defaults *default-pathname-defaults*)) + (make-pathname :directory nil :name nil :type nil :version nil :device nil :host nil + :defaults defaults)) ;; shouldn't matter + +(defmacro with-pathname-defaults ((&optional defaults) &body body) + `(let ((*default-pathname-defaults* ,(or defaults (nil-pathname)))) ,@body)) + +(defun truename* (p) + ;; avoids both logical-pathname merging and physical resolution issues + (ignore-errors (with-pathname-defaults () (truename p)))) + (defun* probe-file* (p) "when given a pathname P, probes the filesystem for a file or directory with given pathname and if it exists return its truename." - (etypecase p - (null nil) - (string (probe-file* (parse-namestring p))) - (pathname (unless (wild-pathname-p p) - #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl) - '(probe-file p) - #+clisp (aif (find-symbol* '#:probe-pathname :ext) - `(ignore-errors (,it p))) - #+gcl<2.7 - '(or (probe-file p) - (and (directory-pathname-p p) - (ignore-errors - (ensure-directory-pathname - (truename (subpathname (ensure-directory-pathname p) ".")))))) - '(ignore-errors (truename p))))))) + (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations + (etypecase p + (null nil) + (string (probe-file* (parse-namestring p))) + (pathname (unless (wild-pathname-p p) + #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl) + '(probe-file p) + #+clisp (aif (find-symbol* '#:probe-pathname :ext) + `(ignore-errors (,it p))) + #+gcl<2.7 + '(or (probe-file p) + (and (directory-pathname-p p) + (ignore-errors + (ensure-directory-pathname + (truename* (subpathname (ensure-directory-pathname p) ".")))))) + '(truename* p))))))) (defun* safe-file-write-date (pathname) ;; If FILE-WRITE-DATE returns NIL, it's possible that @@ -293,8 +309,8 @@ with given pathname and if it exists return its truename." (let* ((u (ignore-errors (funcall merger f)))) ;; The first u avoids a cumbersome (truename u) error. ;; At this point f should already be a truename, - ;; but isn't quite in CLISP, for doesn't have :version :newest - (and u (equal (ignore-errors (truename u)) (truename f)) u))) + ;; but isn't quite in CLISP, for it doesn't have :version :newest + (and u (equal (truename* u) (truename* f)) u))) :when p :collect p) entries)) @@ -489,6 +505,13 @@ Host, device and version components are taken from DEFAULTS." ;; scheme-specific parts: port username password, not others: . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) +(defun* pathname-host-pathname (pathname) + (make-pathname :directory nil + :name nil :type nil :version nil :device nil + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) + #-scl (defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname))) @@ -547,7 +570,7 @@ Host, device and version components are taken from DEFAULTS." (let ((found (probe-file* p))) (when found (return found))) (unless (absolute-pathname-p p) - (let ((true-defaults (ignore-errors (truename defaults)))) + (let ((true-defaults (truename* defaults))) (when true-defaults (setf p (merge-pathnames pathname true-defaults))))) (unless (absolute-pathname-p p) (return p)) @@ -680,6 +703,29 @@ For the latter case, we ought pick random suffix and atomically open it." (defun* default-directory () (truenamize (pathname-directory-pathname *default-pathname-defaults*))) +(defun* physical-pathname-p (x) + (and (pathnamep x) (not (typep x 'logical-pathname)))) + +(defun* sane-physical-pathname (&key (defaults *default-pathname-defaults*) + fallback (keep t) must-exist) + (flet ((sanitize (x) + (setf x (and x (ignore-errors (translate-logical-pathname x)))) + (when (pathnamep x) + (setf x + (ecase keep + ((t) x) + ((:directory) (pathname-directory-pathname x)) + ((:root) (pathname-root x)) + ((:host) (pathname-host-pathname x)) + ((nil) (nil-pathname x)))) + (when must-exist ;; CCL's probe-file will choke if d-p-d is logical + (setf x (and (probe-file* x) x))) + (and (physical-pathname-p x) x)))) + (or (sanitize defaults) + (when fallback (sanitize (ignore-errors (user-homedir-pathname)))) + (error "Could not find a sanitize ~S ~:[~;or a fallback ~] into a physical pathname" + defaults fallback)))) + ;;;; ----------------------------------------------------------------- ;;;; Windows shortcut support. Based on: ;;;; diff --git a/plan.lisp b/plan.lisp index c5bd9cce..11581ba7 100644 --- a/plan.lisp +++ b/plan.lisp @@ -219,16 +219,15 @@ the action of OPERATION on COMPONENT in the PLAN")) (with-accessors ((action-set plan-visiting-action-set) (action-list plan-visiting-action-list)) plan (let ((action (cons operation component))) - (aif (gethash action action-set) - (error 'circular-dependency :actions - (member action (reverse action-list) :test 'equal)) - (progn - (setf (gethash action action-set) t) - (push action action-list) - (unwind-protect - (funcall fun) - (pop action-list) - (setf (gethash action action-set) nil))))))) + (when (gethash action action-set) + (error 'circular-dependency :actions + (member action (reverse action-list) :test 'equal))) + (setf (gethash action action-set) t) + (push action action-list) + (unwind-protect + (funcall fun) + (pop action-list) + (setf (gethash action action-set) nil))))) ;;;; Actual traversal: traverse-action diff --git a/source-registry.lisp b/source-registry.lisp index 928384b8..6b7a4f7b 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -247,7 +247,7 @@ with a different configuration, so the configuration would be re-read then." (defun* flatten-source-registry (&optional parameter) (remove-duplicates (while-collecting (collect) - (let ((*default-pathname-defaults* (default-directory))) + (with-pathname-defaults () ;; be location-independent (inherit-source-registry `(wrapping-source-registry ,parameter diff --git a/test/script-support.lisp b/test/script-support.lisp index 42b01326..f3d04415 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -31,7 +31,9 @@ (make-pathname :directory '(#-gcl :relative #-gcl :back #+gcl :parent) :defaults *test-directory*) *test-directory*))) (defparameter *asdf-lisp* - (make-pathname :name "asdf" :type "lisp" :defaults *asdf-directory*)) + (merge-pathnames + (make-pathname :directory '(#-gcl :relative "tmp") :name "asdf" :type "lisp" :defaults *asdf-directory*) + *asdf-directory*)) (defparameter *asdf-fasl* (compile-file-pathname (let ((impl (string-downcase diff --git a/upgrade.lisp b/upgrade.lisp index 22feaa7b..a8fcec8c 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -23,7 +23,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.62") + (asdf-version "2.26.63") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) diff --git a/utility.lisp b/utility.lisp index 1a390252..fdce626d 100644 --- a/utility.lisp +++ b/utility.lisp @@ -152,7 +152,7 @@ starting the separation from the end, e.g. when called with arguments ;;; Functions (defun* ensure-function (fun &key (package :asdf)) (etypecase fun - ((or boolean keyword character number) (constantly fun)) + ((or boolean keyword character number pathname) (constantly fun)) ((or function symbol) fun) (cons (eval `(function ,fun))) (string (eval `(function ,(with-standard-io-syntax @@ -186,8 +186,8 @@ NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3" If major versions differ, it's not compatible. If they are equal, then any later version is compatible, with later being determined by a lexicographical comparison of minor numbers." - (let ((x (parse-version version 'warn)) - (y (parse-version base-version 'warn))) + (let ((x (parse-version provided-version 'warn)) + (y (parse-version required-version 'warn))) (labels ((bigger (x y) (cond ((not y) t) ((not x) nil) -- GitLab