Commit 9ddaac9c authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.20.10: improve logical-pathname treatment in CLISP and Allegro

parent 0c281b99
Loading
Loading
Loading
Loading
+1 −1
Original line number Original line Diff line number Diff line
@@ -14,7 +14,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.20.9" ;; to be automatically updated by bin/bump-revision
  :version "2.20.10" ;; to be automatically updated by bin/bump-revision
  :depends-on ()
  :depends-on ()
  :components
  :components
  ((:file "asdf")
  ((:file "asdf")
+33 −18
Original line number Original line Diff line number Diff line
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.20.9: Another System Definition Facility.
;;; This is ASDF 2.20.10: 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>.
@@ -115,7 +115,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.20.9")
         (asdf-version "2.20.10")
         (existing-asdf (find-class 'component nil))
         (existing-asdf (find-class 'component nil))
         (existing-version *asdf-version*)
         (existing-version *asdf-version*)
         (already-there (equal asdf-version existing-version)))
         (already-there (equal asdf-version existing-version)))
@@ -541,6 +541,20 @@ and NIL NAME, TYPE and VERSION components"
(defun* ununspecific (x)
(defun* ununspecific (x)
  (if (eq x :unspecific) nil x))
  (if (eq x :unspecific) nil x))


(defun* make-pathname-component-logical (x)
  (typecase x
    ((eql :unspecific) nil)
    #+clisp (string (string-upcase x))
    #+clisp (cons (mapcar 'make-pathname-component-logical x))
    (t x)))

(defun* make-pathname-logical (x)
  (make-pathname
   :directory (make-pathname-component-logical (pathname-directory x))
   :name (make-pathname-component-logical (pathname-name x))
   :type (make-pathname-component-logical (pathname-type x))
   :defaults x))

(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
if the SPECIFIED pathname does not have an absolute directory,
if the SPECIFIED pathname does not have an absolute directory,
@@ -560,7 +574,7 @@ Also, if either argument is NIL, then the other argument is returned unmodified.
         (type (or (pathname-type specified) (pathname-type defaults)))
         (type (or (pathname-type specified) (pathname-type defaults)))
         (version (or (pathname-version specified) (pathname-version defaults))))
         (version (or (pathname-version specified) (pathname-version defaults))))
    (labels ((unspecific-handler (p)
    (labels ((unspecific-handler (p)
               (if (typep p 'logical-pathname) #'ununspecific #'identity)))
               (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
      (multiple-value-bind (host device directory unspecific-handler)
      (multiple-value-bind (host device directory unspecific-handler)
          (ecase (first directory)
          (ecase (first directory)
            ((:absolute)
            ((:absolute)
@@ -1588,9 +1602,7 @@ Going forward, we recommend new users should be using the source-registry.
(defun* probe-asd (name defaults)
(defun* probe-asd (name defaults)
  (block nil
  (block nil
    (when (directory-pathname-p defaults)
    (when (directory-pathname-p defaults)
      (let ((file (make-pathname
      (let ((file (subpathname defaults (strcat name ".asd"))))
                   :defaults defaults :name name
                   :version :newest :case :local :type "asd")))
        (when (probe-file* file)
        (when (probe-file* 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(!)
@@ -2359,9 +2371,7 @@ recursive calls to traverse.")


(defun* ensure-all-directories-exist (pathnames)
(defun* ensure-all-directories-exist (pathnames)
   (loop :for pn :in pathnames
   (loop :for pn :in pathnames
     :for pathname = (if (typep pn 'logical-pathname)
     :for pathname = (translate-logical-pathname pn)
                         (translate-logical-pathname pn)
                         pn)
     :do (ensure-directories-exist pathname)))
     :do (ensure-directories-exist pathname)))


(defmethod perform :before ((operation compile-op) (c source-file))
(defmethod perform :before ((operation compile-op) (c source-file))
@@ -3925,23 +3935,29 @@ with a different configuration, so the configuration would be re-read then."
      (loop :for f :in entries
      (loop :for f :in entries
        :for p = (or (and (typep f 'logical-pathname) f)
        :for p = (or (and (typep f 'logical-pathname) f)
                     (let* ((u (ignore-errors (funcall merger f))))
                     (let* ((u (ignore-errors (funcall merger f))))
                       ;; The first u avoids a cumbersome (truename u) error
                       ;; The first u avoids a cumbersome (truename u) error.
                       (and u (equal (ignore-errors (truename u)) f) u)))
                       ;; 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)))
        :when p :collect p)
        :when p :collect p)
      entries))
      entries))


(defun* directory-files (directory &optional (pattern *wild-file*))
(defun* directory-files (directory &optional (pattern *wild-file*))
  (setf directory (pathname directory))
  (when (wild-pathname-p directory)
  (when (wild-pathname-p directory)
    (error "Invalid wild in ~S" directory))
    (error "Invalid wild in ~S" directory))
  (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
  (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
    (error "Invalid file pattern ~S" pattern))
    (error "Invalid file pattern ~S" pattern))
  (when (typep directory 'logical-pathname)
    (setf pattern (make-pathname-logical pattern)))
  (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory)))))
  (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory)))))
    (filter-logical-directory-results
    (filter-logical-directory-results
     directory entries
     directory entries
     #'(lambda (f)
     #'(lambda (f)
         (make-pathname :defaults directory
         (make-pathname :defaults directory
                        :name (pathname-name f) :type (ununspecific (pathname-type f))
                        :name (pathname-name f)
                        :version (ununspecific (pathname-version f)))))))
                        :type (make-pathname-component-logical (pathname-type f))
                        :version (make-pathname-component-logical (pathname-version f)))))))


(defun* directory-asd-files (directory)
(defun* directory-asd-files (directory)
  (directory-files directory *wild-asd*))
  (directory-files directory *wild-asd*))
@@ -3974,15 +3990,14 @@ with a different configuration, so the configuration would be re-read then."
                                  #+(or cmu lispworks sbcl scl) x)))
                                  #+(or cmu lispworks sbcl scl) x)))
    (filter-logical-directory-results
    (filter-logical-directory-results
     directory dirs
     directory dirs
     (let ((prefix (normalize-pathname-directory-component
     (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
                    (pathname-directory directory))))
                       '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
       #'(lambda (d)
       #'(lambda (d)
           (let ((dir (normalize-pathname-directory-component
           (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
                       (pathname-directory d))))
             (and (consp dir) (consp (cdr dir))
             (and (consp dir) (consp (cdr dir))
                  (make-pathname
                  (make-pathname
                   :defaults directory :name nil :type nil :version nil
                   :defaults directory :name nil :type nil :version nil
                   :directory (append prefix (last dir))))))))))
                   :directory (append prefix (make-pathname-component-logical (last dir)))))))))))


(defun* collect-asds-in-directory (directory collect)
(defun* collect-asds-in-directory (directory collect)
  (map () collect (directory-asd-files directory)))
  (map () collect (directory-asd-files directory)))
+29 −21
Original line number Original line Diff line number Diff line
@@ -3,34 +3,42 @@
(load-asdf)
(load-asdf)


(setf (logical-pathname-translations "ASDF")
(setf (logical-pathname-translations "ASDF")
      `(("**;*.asd.*" ,(make-pathname :type "asd" :defaults (resolve-location `(,*asdf-directory* :**/ :*.*.*))))
      #+(or allegro clisp)
        ("**;*.asd" ,(resolve-location `(,*asdf-directory* :**/ #p"*.asd")))
      `(("**;*.*.*" ,(asdf::wilden *asdf-directory*)))
        ("**;*.lisp.*" ,(make-pathname :type "lisp" :defaults (resolve-location `(,*asdf-directory* :**/ :*.*.*))))
      #-(or allegro clisp)
        ("**;*.lisp" ,(resolve-location `(,*asdf-directory* :**/ #p"*.lisp")))
      `(("**;*.asd.*" ,(make-pathname :type "asd" :defaults (asdf::wilden *asdf-directory*)))
        ("**;*.lisp.*" ,(make-pathname :type "lisp" :defaults (asdf::wilden *asdf-directory*)))
        ("**;*.*.*" ,(resolve-location
        ("**;*.*.*" ,(resolve-location
                      `(,*asdf-directory* "tmp/fasls" :implementation "logical-host-asdf" :**/ :*.*.*)))))
                      `(,*asdf-directory* "tmp/fasls" :implementation "logical-host-asdf")
                      :wilden t))))


(quit-on-error
(quit-on-error
 (format t "~S~%" (translate-logical-pathname "ASDF:test;test-force.asd"))
 (format t "~S~%" (translate-logical-pathname "ASDF:test;test-force.asd"))
 (format t "~S~%" (truename "ASDF:test;test-force.asd"))
 (format t "~S~%" (truename "ASDF:test;test-force.asd"))


 (progn
   (format t "Test logical pathnames in central registry~%")
   (format t "Test logical pathnames in central registry~%")
 (setf *central-registry* '("ASDF:test;"))
   (setf *central-registry* '(#p"ASDF:test;"))
   (initialize-source-registry '(:source-registry :ignore-inherited-configuration))
   (initialize-source-registry '(:source-registry :ignore-inherited-configuration))
 (load-system :test-force :force t)
   (load-system :test-force :force t))


 (progn
   (format t "Test logical pathnames in source-registry, non-recursive~%")
   (format t "Test logical pathnames in source-registry, non-recursive~%")
   (clear-system :test-force)
   (clear-system :test-force)
   (setf *central-registry* '())
   (setf *central-registry* '())
   (initialize-source-registry
   (initialize-source-registry
  '(:source-registry (:directory "ASDF:test;") :ignore-inherited-configuration))
    '(:source-registry (:directory #p"ASDF:test;") :ignore-inherited-configuration))
 (load-system :test-force :force t)
   (load-system :test-force :force t))


 #-allegro ;; Allegro 8.2 seems to have trouble with logical-pathnames. disable for now.
 (progn
   (format t "Test logical pathnames in source-registry, recursive~%")
   (format t "Test logical pathnames in source-registry, recursive~%")
   (clear-system :test-force)
   (clear-system :test-force)
   (setf *central-registry* '())
   (setf *central-registry* '())
   (initialize-source-registry
   (initialize-source-registry
  '(:source-registry (:tree "ASDF:") :ignore-inherited-configuration))
    ;; Bug: Allegro Express 8.2 incorrectly reads #p"ASDF:" as relative.
 (load-system :test-force :force t)
    '(:source-registry (:tree #-allegro #p"ASDF:" #+allegro #.(asdf::pathname-root #p"ASDF"))
      :ignore-inherited-configuration))
   (load-system :test-force :force t))


 (format t "Done~%"))
 (format t "Done~%"))