Commit 4b1cea29 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

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).
parent 7c151aab
......@@ -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
......
......@@ -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")))
......
......@@ -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"
......
......@@ -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)
......
......@@ -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*))
......
......@@ -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
......
;; -*- 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>.
......
......@@ -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)))
......@@ -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))))
......@@ -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:
;;;;
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)))
......
......@@ -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)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment