Commit 98127ec8 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.107: make logical pathnames work. Gah.

parent 139af5a4
......@@ -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.106" ;; to be automatically updated by bin/bump-revision
:version "2.26.107" ;; 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))))
......@@ -30,7 +30,7 @@
;; and merged into that DIRECTORY as per SUBPATHNAME.
;; If no absolute pathname was found, we return NIL.
(check-type pathname (or null string pathname))
(or (and (pathnamep pathname) (absolute-pathname-p pathname))
(or (and (pathnamep pathname) (absolute-pathname-p pathname) (resolve-symlinks* pathname))
(let* ((lisp-file-pathname (resolve-symlinks* (current-lisp-file-pathname))))
(when (absolute-pathname-p lisp-file-pathname)
(subpathname lisp-file-pathname pathname :type :directory)))))
......@@ -169,7 +169,7 @@
;; we also need to remember it in a special variable *systems-being-defined*.
(with-system-definitions ()
(let* ((name (coerce-name name))
(source-file (if sfp source-file (current-lisp-file-pathname)))
(source-file (if sfp source-file (resolve-symlinks* (current-lisp-file-pathname))))
(registered (system-registered-p name))
(registered! (if registered
(rplaca registered (safe-file-write-date source-file))
......@@ -133,9 +133,10 @@ called with an object of type asdf:system."
(defun* search-for-system-definition (system)
(some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
(cons 'find-system-if-being-defined
(with-pathname-defaults ()
(some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
(cons 'find-system-if-being-defined
(defvar *central-registry* nil
"A list of 'system directory designators' ASDF uses to find systems.
......@@ -155,14 +156,14 @@ Going forward, we recommend new users should be using the source-registry.
(defun* probe-asd (name defaults)
(block nil
(when (directory-pathname-p defaults)
(let* ((file (probe-file* (subpathname defaults (strcat name ".asd")))))
(let* ((file (probe-file* (subpathname defaults name :type "asd"))))
(when file
(return file)))
#-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
(when (os-windows-p)
(let ((shortcut
:defaults defaults :version :newest :case :local
:defaults defaults :case :local
:name (strcat name ".asd")
:type "lnk")))
(when (probe-file* shortcut)
......@@ -279,16 +280,13 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(pathname (or (and (typep found '(or pathname string)) (pathname found))
(and found-system (system-source-file found-system))
(and previous (system-source-file previous))))
(pathname (ensure-pathname (resolve-symlinks* pathname) :want-absolute t))
(foundp (and (or found-system pathname previous) t)))
(check-type found (or null pathname system))
(when foundp
(setf pathname (resolve-symlinks* pathname))
(when (and pathname (not (absolute-pathname-p pathname)))
(setf pathname (ensure-pathname-absolute pathname))
(when found-system
(setf (system-source-file found-system) pathname)))
(when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
(system-source-file previous) pathname)))
(when (and pathname found-system)
(setf (system-source-file found-system) pathname))
(when (and previous (not (pathname-equal (system-source-file previous) pathname)))
(setf (system-source-file previous) pathname)
(setf previous-time nil))
(values foundp found-system pathname previous previous-time))))
......@@ -302,9 +300,11 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(declare (ignore foundp))
(when (and found-system (not previous))
(register-system found-system))
(unless (and (equal pathname (and previous (system-source-file previous)))
(stamp<= (safe-file-write-date pathname) previous-time))
;; only load when it's a different pathname, or newer file content
(when (and pathname
(not (and previous
(pathname-equal pathname (system-source-file previous))
(stamp<= (safe-file-write-date pathname) previous-time))))
;; only load when it's a pathname that is different or has newer content
(load-sysdef name pathname))
(let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.106: Another System Definition Facility.
;;; This is ASDF 2.26.107: Another System Definition Facility.
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <>.
......@@ -9,6 +9,7 @@
;; Making and merging pathnames, portably
#:normalize-pathname-directory-component #:denormalize-pathname-directory-component
#:merge-pathname-directory-components #:make-pathname* #:*unspecific-pathname-type*
#:make-pathname-component-logical #:make-pathname-logical
......@@ -200,6 +201,27 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
;;; Some pathname predicates
(defun* pathname-equal (p1 p2)
(when (stringp p1) (setf p1 (pathname p1)))
(when (stringp p2) (setf p2 (pathname p2)))
(flet ((normalize-component (x)
(and (not (member x '(nil :unspecific :newest (:relative)) :test 'equal)) x)))
(macrolet ((=? (&rest accessors)
(flet ((frob (x)
(reduce 'list (cons 'normalize-component accessors)
:initial-value x :from-end t)))
`(equal ,(frob 'p1) ,(frob 'p2)))))
(or (and (null p1) (null 2))
(and (pathnamep p1) (pathnamep p2)
(or (equal p1 p2)
(=? pathname-host)
(=? pathname-device)
(=? normalize-pathname-directory-component pathname-directory)
(=? pathname-name)
(=? pathname-type)
(=? pathname-version)))))))
(defun* absolute-pathname-p (pathspec)
"If PATHSPEC is a pathname or namestring object that parses as a pathname
possessing an :ABSOLUTE directory component, return the (parsed) pathname.
......@@ -853,8 +875,11 @@ For the latter case, we ought pick random suffix and atomically open it."
`(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))
;;; Basic pathnames
(defun* logical-pathname-p (x)
(typep x 'logical-pathname))
(defun* physical-pathname-p (x)
(and (pathnamep x) (not (typep x 'logical-pathname))))
(and (pathnamep x) (not (logical-pathname-p x))))
(defun* sane-physical-pathname (&key defaults (keep t) fallback want-existing)
(flet ((sanitize (x)
......@@ -1049,7 +1074,7 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
:ensure-directory ensure-directory :want-relative want-relative))))
(check want-pathname (pathnamep p) "Expected a pathname, not NIL")
(unless pathname (return NIL))
(check want-logical (typep p 'logical-pathname) "Expected a logical pathname")
(check want-logical (logical-pathname-p p) "Expected a logical pathname")
(check want-physical (physical-pathname-p p) "Expected a physical pathname")
(transform ensure-physical () (translate-logical-pathname p))
(check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
......@@ -51,7 +51,7 @@ system names to pathnames of .asd files")
(register-clear-configuration-hook 'clear-source-registry)
(defparameter *wild-asd*
(make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
(make-pathname* :directory nil :name *wild* :type "asd"))
(defun* directory-asd-files (directory)
(directory-files directory *wild-asd*))
......@@ -50,6 +50,9 @@
;; and it tries to load ASDF from a logical-pathname.
'(:source-registry (:tree #p"ASDF:test;")
(load-system :test-logical-pathname :force t))
(load-system :test-logical-pathname :force t)
(let ((sys (find-system :test-logical-pathname)))
(assert (logical-pathname-p (component-pathname sys)))
(assert (logical-pathname-p (system-source-file sys)))))
(DBG "Done"))
......@@ -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.106")
(asdf-version "2.26.107")
(existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
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