Commit fb3d1204 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.120: vanquishing the dragon of CL pathnames so you don't have to.

(equal #p"ccl:" #p"/") ==> T. Yikes.
parent 072692f1
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.119" ;; to be automatically updated by bin/bump-revision :version "2.26.120" ;; to be automatically updated by bin/bump-revision
:depends-on () :depends-on ()
:components ((:module "build" :components ((:file "asdf")))) :components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf)))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......
...@@ -16,7 +16,7 @@ ...@@ -16,7 +16,7 @@
#:operation-monolithic-p #:operation-monolithic-p
#:user-system-p #:user-system #:trivial-system-p #:user-system-p #:user-system #:trivial-system-p
#:gather-actions #:operated-components #:gather-actions #:operated-components
#+ecl #:make-build #+mkcl #:bundle-system #+ecl #:make-build
#:register-pre-built-system #:register-pre-built-system
#:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library
#:component-translate-output-p #:translate-output-p #:component-translate-output-p #:translate-output-p
......
...@@ -32,16 +32,9 @@ ...@@ -32,16 +32,9 @@
;; and may be from within the EVAL-WHEN of a file compilation. ;; and may be from within the EVAL-WHEN of a file compilation.
;; If no absolute pathname was found, we return NIL. ;; If no absolute pathname was found, we return NIL.
(check-type pathname (or null string pathname)) (check-type pathname (or null string pathname))
(or (and (absolute-pathname-p pathname) (resolve-symlinks* pathname)) (absolutize-pathnames
(let* ((load-pathname (load-pathname)) (list pathname (load-pathname) *default-pathname-defaults* (getcwd))
(load-absolute :resolve-symlinks *resolve-symlinks*))
(or (absolute-pathname-p load-pathname)
(let ((defaults (resolve-symlinks* *default-pathname-defaults*)))
(and (absolute-pathname-p defaults)
(merge-pathnames* load-pathname defaults))))))
(when (absolute-pathname-p load-absolute)
(resolve-symlinks*
(subpathname load-absolute pathname :type :directory))))))
;;; Component class ;;; Component class
......
...@@ -155,7 +155,12 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -155,7 +155,12 @@ Going forward, we recommend new users should be using the source-registry.
(defun* probe-asd (name defaults &key truename) (defun* probe-asd (name defaults &key truename)
(block nil (block nil
(when (directory-pathname-p defaults) (when (directory-pathname-p defaults)
(let* ((file (probe-file* (subpathname defaults name :type "asd") :truename truename))) (let* ((file (probe-file*
(absolutize-pathnames
(list (make-pathname :name name :type "asd")
defaults *default-pathname-defaults* (getcwd))
:resolve-symlinks truename)
:truename truename)))
(when file (when file
(return file))) (return file)))
#-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
...@@ -177,11 +182,10 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -177,11 +182,10 @@ Going forward, we recommend new users should be using the source-registry.
(block nil (block nil
(unwind-protect (unwind-protect
(dolist (dir *central-registry*) (dolist (dir *central-registry*)
(let ((defaults (resolve-symlinks* (eval dir))) (let ((defaults (eval dir))
directorized truenamized) directorized)
(when defaults (when defaults
(cond ((and (directory-pathname-p defaults) (cond ((directory-pathname-p defaults)
(absolute-pathname-p defaults))
(let* ((file (probe-asd name defaults :truename *resolve-symlinks*))) (let* ((file (probe-asd name defaults :truename *resolve-symlinks*)))
(when file (when file
(return file)))) (return file))))
...@@ -196,13 +200,6 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -196,13 +200,6 @@ Going forward, we recommend new users should be using the source-registry.
(remove-entry-from-registry () (remove-entry-from-registry ()
:report "Remove entry from *central-registry* and continue" :report "Remove entry from *central-registry* and continue"
(push dir to-remove)) (push dir to-remove))
(coerce-to-truename ()
:test (lambda (c) (declare (ignore c))
(setf truenamized (truename* defaults)))
:report (lambda (s)
(format s (compatfmt "~@<Coerce entry to truename ~S and continue.~@:>")
truenamized))
(push dir to-remove))
(coerce-entry-to-directory () (coerce-entry-to-directory ()
:test (lambda (c) (declare (ignore c)) :test (lambda (c) (declare (ignore c))
(and (not (directory-pathname-p defaults)) (and (not (directory-pathname-p defaults))
...@@ -305,14 +302,18 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -305,14 +302,18 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(multiple-value-bind (foundp found-system pathname previous previous-time) (multiple-value-bind (foundp found-system pathname previous previous-time)
(locate-system name) (locate-system name)
(assert (eq foundp (and (or found-system pathname previous) t))) (assert (eq foundp (and (or found-system pathname previous) t)))
(when (and found-system (not previous)) (let ((previous-pathname (and previous (system-source-file previous)))
(register-system found-system)) (system (or previous found-system)))
(when (and pathname (when (and found-system (not previous))
(not (and previous (register-system found-system))
(pathname-equal pathname (system-source-file previous)) (when (and system pathname)
(stamp<= (safe-file-write-date pathname) previous-time)))) (setf (system-source-file system) pathname))
;; only load when it's a pathname that is different or has newer content (when (and pathname
(load-sysdef name pathname)) (not (and previous
(pathname-equal pathname previous-pathname)
(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 (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
(return (return
(cond (cond
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.119: Another System Definition Facility. ;;; This is ASDF 2.26.120: Another System Definition Facility.
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
......
This diff is collapsed.
...@@ -65,7 +65,6 @@ in which the system specification (.asd file) is located." ...@@ -65,7 +65,6 @@ in which the system specification (.asd file) is located."
(defun* system-relative-pathname (system name &key type) (defun* system-relative-pathname (system name &key type)
(subpathname (system-source-directory system) name :type type)) (subpathname (system-source-directory system) name :type type))
;;;; Beware of builtin systems ;;;; Beware of builtin systems
(defgeneric* builtin-system-p (system)) (defgeneric* builtin-system-p (system))
(defmethod builtin-system-p ((s system)) (defmethod builtin-system-p ((s system))
......
...@@ -36,6 +36,7 @@ Some constraints: ...@@ -36,6 +36,7 @@ Some constraints:
`(;; If you want to trace some stuff while debugging ASDF, `(;; If you want to trace some stuff while debugging ASDF,
;; here's a nice place to say what. ;; here's a nice place to say what.
;; These string designators will be interned in ASDF after it is loaded. ;; These string designators will be interned in ASDF after it is loaded.
:absolutize-pathnames
)) ))
(defvar *debug-asdf* nil) (defvar *debug-asdf* nil)
......
...@@ -22,12 +22,14 @@ ...@@ -22,12 +22,14 @@
(bundle-1 (asdf:output-file op (find-system :test-bundle-1))) (bundle-1 (asdf:output-file op (find-system :test-bundle-1)))
(bundle-2 (asdf:output-file op (find-system :test-bundle-2)))) (bundle-2 (asdf:output-file op (find-system :test-bundle-2))))
(DBG :test-bundle bundle-1 bundle-2) (DBG :test-bundle bundle-1 bundle-2)
(assert-equal (list bundle-2)
(input-files (make-operation 'load-fasl-op) (find-system :test-bundle-2)))
(delete-file-if-exists bundle-1) (delete-file-if-exists bundle-1)
(delete-file-if-exists bundle-2) (delete-file-if-exists bundle-2)
(operate 'load-fasl-op :test-bundle-2) (operate 'load-fasl-op :test-bundle-2)
;; Check that the bundles were indeed created. ;; Check that the bundles were indeed created.
(assert (probe-file bundle-1))
(assert (probe-file bundle-2)) (assert (probe-file bundle-2))
(assert (probe-file bundle-1))
;; Check that the files were indeed loaded. ;; Check that the files were indeed loaded.
(assert (symbol-value (find-symbol* :*file1* :test-package))) (assert (symbol-value (find-symbol* :*file1* :test-package)))
(assert (symbol-value (find-symbol* :*file3* :test-package))))) (assert (symbol-value (find-symbol* :*file3* :test-package)))))
...@@ -45,7 +45,7 @@ ...@@ -45,7 +45,7 @@
;; "2.345.6" would be a development version in the official upstream ;; "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.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 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(asdf-version "2.26.119") (asdf-version "2.26.120")
(existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) (existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*) (existing-version *asdf-version*)
(already-there (equal asdf-version existing-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