Ignore:
Timestamp:
07/27/11 06:44:50 (10 years ago)
Author:
Mark Evenson
Message:

Upgrade to asdf-2.017.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r13319 r13417  
    11;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.016.1: Another System Definition Facility.
     2;;; This is ASDF 2.017: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    5151
    5252#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
    53 (error "ASDF is not supported on your implementation. Please help us with it.")
     53(error "ASDF is not supported on your implementation. Please help us port it.")
    5454
    5555#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
     
    6363                :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
    6464  #+(and ecl (not ecl-bytecmp)) (require :cmp)
    65   #+gcl
    66   (when (or (< system::*gcl-major-version* 2)
     65  #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
     66  (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
    6767            (and (= system::*gcl-major-version* 2)
    6868                 (< system::*gcl-minor-version* 7)))
     
    113113         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    114114         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    115          (asdf-version "2.016.1")
     115         (asdf-version "2.017")
    116116         (existing-asdf (find-class 'component nil))
    117117         (existing-version *asdf-version*)
     
    201201               (loop :for x :in newly-exported-symbols :do
    202202                 (export (intern* x package)))))
    203            (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
     203           (ensure-package (name &key nicknames use unintern fmakunbound
     204         shadow export redefined-functions)
    204205             (let* ((p (ensure-exists name nicknames use)))
    205206               (ensure-unintern p unintern)
    206207               (ensure-shadow p shadow)
    207208               (ensure-export p export)
    208                (ensure-fmakunbound p fmakunbound)
     209               (ensure-fmakunbound p (append fmakunbound redefined-functions))
    209210               p)))
    210211        (macrolet
     
    214215                   ',name :nicknames ',nicknames :use ',use :export ',export
    215216                   :shadow ',shadow
    216                    :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
    217                    :fmakunbound ',(append fmakunbound))))
     217                   :unintern ',unintern
     218       :redefined-functions ',redefined-functions
     219                   :fmakunbound ',fmakunbound)))
    218220          (pkgdcl
    219221           :asdf
     
    349351            #:ensure-directory-pathname
    350352            #:getenv
    351             ;; #:get-uid
    352353            ;; #:length=n-p
    353354            ;; #:find-symbol*
     
    420421
    421422;;;; -------------------------------------------------------------------------
    422 ;;;; Compatibility with Corman Lisp
     423;;;; Compatibility various implementations
    423424#+cormanlisp
    424425(progn
     
    428429    (setf p (pathname p))
    429430    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
     431
     432#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
     433      (read-from-string
     434       "(eval-when (:compile-toplevel :load-toplevel :execute)
     435          (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
     436          (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
     437          ;; Note: ASDF may expect user-homedir-pathname to provide
     438          ;; the pathname of the current user's home directory, whereas
     439          ;; MCL by default provides the directory from which MCL was started.
     440          ;; See http://code.google.com/p/mcl/wiki/Portability
     441          (defun current-user-homedir-pathname ()
     442            (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
     443          (defun probe-posix (posix-namestring)
     444            \"If a file exists for the posix namestring, return the pathname\"
     445            (ccl::with-cstrs ((cpath posix-namestring))
     446              (ccl::rlet ((is-dir :boolean)
     447                          (fsref :fsref))
     448                (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
     449                  (ccl::%path-from-fsref fsref is-dir))))))"))
    430450
    431451;;;; -------------------------------------------------------------------------
     
    554574                   :defaults pathname)))
    555575
    556 
    557576(define-modify-macro appendf (&rest args)
    558577  append "Append onto list") ;; only to be used on short lists.
     
    654673    :unless (eq k key)
    655674    :append (list k v)))
    656 
    657 #+mcl
    658 (eval-when (:compile-toplevel :load-toplevel :execute)
    659   (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string))
    660675
    661676(defun* getenv (x)
     
    754769     :until (eq form eof)
    755770     :collect form)))
    756 
    757 #+asdf-unix
    758 (progn
    759   #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
    760                   '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
    761   (defun* get-uid ()
    762     #+allegro (excl.osi:getuid)
    763     #+ccl (ccl::getuid)
    764     #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
    765                   :for f = (ignore-errors (read-from-string s))
    766                   :when f :return (funcall f))
    767     #+(or cmu scl) (unix:unix-getuid)
    768     #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
    769                    '(ffi:c-inline () () :int "getuid()" :one-liner t)
    770                    '(ext::getuid))
    771     #+sbcl (sb-unix:unix-getuid)
    772     #-(or allegro ccl clisp cmu ecl sbcl scl)
    773     (let ((uid-string
    774            (with-output-to-string (*verbose-out*)
    775              (run-shell-command "id -ur"))))
    776       (with-input-from-string (stream uid-string)
    777         (read-line stream)
    778         (handler-case (parse-integer (read-line stream))
    779           (error () (error "Unable to find out user ID")))))))
    780771
    781772(defun* pathname-root (pathname)
     
    14331424  (block nil
    14341425    (when (directory-pathname-p defaults)
    1435       (let ((file
    1436              (make-pathname
    1437               :defaults defaults :version :newest :case :local
    1438               :name name
    1439               :type "asd")))
     1426      (let ((file (make-pathname
     1427                   :defaults defaults :name name
     1428                   :version :newest :case :local :type "asd")))
    14401429        (when (probe-file* file)
    14411430          (return file)))
     
    15371526        (funcall thunk))))
    15381527
    1539 (defmacro with-system-definitions ((&optional) &body body)
     1528(defmacro with-system-definitions (() &body body)
    15401529  `(call-with-system-definitions #'(lambda () ,@body)))
    15411530
     
    23722361           (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
    23732362                         version new-version)))
    2374         (let ((asdf (find-system :asdf)))
     2363        (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
    23752364          ;; invalidate all systems but ASDF itself
    23762365          (setf *defined-systems* (make-defined-systems-table))
     
    26082597              perform explain output-files operation-done-p
    26092598              weakly-depends-on
    2610               depends-on serial in-order-to
     2599              depends-on serial in-order-to do-first
    26112600              (version nil versionp)
    26122601              ;; list ends
     
    26692658             `((compile-op (compile-op ,@depends-on))
    26702659               (load-op (load-op ,@depends-on)))))
    2671       (setf (component-do-first ret) `((compile-op (load-op ,@depends-on))))
     2660      (setf (component-do-first ret)
     2661            (union-of-dependencies
     2662             do-first
     2663       `((compile-op (load-op ,@depends-on)))))
    26722664
    26732665      (%refresh-component-inline-methods ret rest)
     
    27532745                                 :wait t)))
    27542746
     2747    #+(or cmu scl)
     2748    (ext:process-exit-code
     2749     (ext:run-program
     2750      "/bin/sh"
     2751      (list  "-c" command)
     2752      :input nil :output *verbose-out*))
     2753
    27552754    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
    27562755    (si:system command)
     
    27672766     :output-stream *verbose-out*)
    27682767
     2768    #+mcl
     2769    (ccl::with-cstrs ((%command command)) (_system %command))
     2770
    27692771    #+sbcl
    27702772    (sb-ext:process-exit-code
     
    27752777            #+win32 '(:search t) #-win32 nil))
    27762778
    2777     #+(or cmu scl)
    2778     (ext:process-exit-code
    2779      (ext:run-program
    2780       "/bin/sh"
    2781       (list  "-c" command)
    2782       :input nil :output *verbose-out*))
    2783 
    27842779    #+xcl
    27852780    (ext:run-shell-command command)
    27862781
    2787     #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl)
     2782    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl xcl)
    27882783    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
    27892784
     
    28132808directory in which the system specification (.asd file) is
    28142809located."
    2815      (make-pathname :name nil
    2816                  :type nil
    2817                  :defaults (system-source-file system-designator)))
     2810  (pathname-directory-pathname (system-source-file system-designator)))
    28182811
    28192812(defun* relativize-directory (directory)
     
    28422835;;;
    28432836;;; produce a string to identify current implementation.
    2844 ;;; Initially stolen from SLIME's SWANK, hacked since.
    2845 
    2846 (defparameter *implementation-features*
    2847   '((:abcl :armedbear)
    2848     (:acl :allegro)
    2849     (:mcl :digitool) ; before clozure, so it won't get preempted by ccl
    2850     (:ccl :clozure)
    2851     (:corman :cormanlisp)
    2852     (:lw :lispworks)
    2853     :clisp :cmu :ecl :gcl :sbcl :scl :symbolics :xcl))
    2854 
    2855 (defparameter *os-features*
    2856   '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
    2857     (:solaris :sunos)
    2858     (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
    2859     (:macosx :darwin :darwin-target :apple)
    2860     :freebsd :netbsd :openbsd :bsd
    2861     :unix
    2862     :genera))
    2863 
    2864 (defparameter *architecture-features*
    2865   '((:x64 :amd64 :x86-64 :x86_64 :x8664-target #+(and clisp word-size=64) :pc386)
    2866     (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
    2867     :hppa64 :hppa
    2868     (:ppc64 :ppc64-target) (:ppc32 :ppc32-target :ppc :powerpc)
    2869     :sparc64 (:sparc32 :sparc)
    2870     (:arm :arm-target)
    2871     (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)
    2872     :mipsel :mipseb :mips
    2873     :alpha
    2874     :imach))
    2875 
    2876 (defun* lisp-version-string ()
     2837;;; Initially stolen from SLIME's SWANK, rewritten since.
     2838;;; The (car '(...)) idiom avoids unreachable code warnings.
     2839
     2840(defparameter *implementation-type*
     2841  (car '(#+abcl :abcl #+allegro :acl
     2842         #+clozure :ccl #+clisp :clisp #+cormanlisp :corman #+cmu :cmu
     2843         #+ecl :ecl #+gcl :gcl #+lispworks :lw #+mcl :mcl
     2844         #+sbcl :sbcl #+scl :scl #+symbolics :symbolic #+xcl :xcl)))
     2845
     2846(defparameter *operating-system*
     2847  (car '(#+cygwin :cygwin #+(or windows mswindows win32 mingw32) :win
     2848         #+(or linux linux-target) :linux ;; for GCL at least, must appear before :bsd.
     2849         #+(or macosx darwin darwin-target apple) :macosx ; also before :bsd
     2850         #+(or solaris sunos) :solaris
     2851         #+(or freebsd netbsd openbsd bsd) :bsd
     2852         #+unix :unix
     2853         #+genera :genera)))
     2854
     2855(defparameter *architecture*
     2856  (car '(#+(or amd64 x86-64 x86_64 x8664-target (and word-size=64 pc386)) :x64
     2857         #+(or x86 i386 i486 i586 i686 pentium3 pentium4 pc386 iapx386 x8632-target) :x86
     2858         #+hppa64 :hppa64 #+hppa :hppa
     2859         #+(or ppc64 ppc64-target) :ppc64
     2860         #+(or ppc32 ppc32-target ppc powerpc) :ppc32
     2861         #+sparc64 :sparc64 #+(or sparc32 sparc) :sparc32
     2862         #+(or arm arm-target) :arm
     2863         #+(or java java-1.4 java-1.5 java-1.6 java-1.7) :java
     2864         #+mipsel :mispel #+mipseb :mipseb #+mips :mips
     2865         #+alpha :alpha #+imach :imach)))
     2866
     2867(defparameter *lisp-version-string*
    28772868  (let ((s (lisp-implementation-version)))
    28782869    (or
    2879      #+allegro (format nil
    2880                        "~A~A~A"
    2881                        excl::*common-lisp-version-number*
    2882                        ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
    2883                        (if (eq excl:*current-case-mode*
    2884                                :case-sensitive-lower) "M" "A")
    2885                        ;; Note if not using International ACL
    2886                        ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
    2887                        (excl:ics-target-case
    2888                         (:-ics "8")
    2889                         (:+ics ""))) ; redundant? (if (member :64bit *features*) "-64bit" ""))
     2870     #+allegro
     2871     (format nil "~A~A~@[~A~]"
     2872       excl::*common-lisp-version-number*
     2873       ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
     2874       (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A")
     2875       ;; Note if not using International ACL
     2876       ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
     2877       (excl:ics-target-case (:-ics "8")))
    28902878     #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
    2891      #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
    2892      #+clozure (format nil "~d.~d-f~d" ; shorten for windows
    2893                        ccl::*openmcl-major-version*
    2894                        ccl::*openmcl-minor-version*
    2895                        (logand ccl::fasl-version #xFF))
     2879     #+clisp
     2880     (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
     2881     #+clozure
     2882     (format nil "~d.~d-f~d" ; shorten for windows
     2883       ccl::*openmcl-major-version*
     2884       ccl::*openmcl-minor-version*
     2885       (logand ccl::fasl-version #xFF))
    28962886     #+cmu (substitute #\- #\/ s)
    28972887     #+ecl (format nil "~A~@[-~A~]" s
    2898                    (let ((vcs-id (ext:lisp-implementation-vcs-id)))
    2899                      (when (>= (length vcs-id) 8)
    2900                        (subseq vcs-id 0 8))))
     2888       (let ((vcs-id (ext:lisp-implementation-vcs-id)))
     2889         (subseq vcs-id 0 (min (length vcs-id) 8))))
    29012890     #+gcl (subseq s (1+ (position #\space s)))
    2902      #+genera (multiple-value-bind (major minor) (sct:get-system-version "System")
    2903                 (format nil "~D.~D" major minor))
    2904      ;; #+lispworks (format nil "~A~@[~A~]" s (when (member :lispworks-64bit *features*) "-64bit")     #+mcl (subseq s 8) ; strip the leading "Version "
    2905      ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
     2891     #+genera
     2892     (multiple-value-bind (major minor) (sct:get-system-version "System")
     2893       (format nil "~D.~D" major minor))
     2894     #+mcl (subseq s 8) ; strip the leading "Version "
    29062895     s)))
    29072896
    2908 (defun* first-feature (features)
    2909   (labels
    2910       ((fp (thing)
    2911          (etypecase thing
    2912            (symbol
    2913             (let ((feature (find thing *features*)))
    2914               (when feature (return-from fp feature))))
    2915            ;; allows features to be lists of which the first
    2916            ;; member is the "main name", the rest being aliases
    2917            (cons
    2918             (dolist (subf thing)
    2919               (when (find subf *features*) (return-from fp (first thing))))))
    2920          nil))
    2921     (loop :for f :in features
    2922       :when (fp f) :return :it)))
    2923 
    29242897(defun* implementation-type ()
    2925   (first-feature *implementation-features*))
     2898  *implementation-type*)
    29262899
    29272900(defun* implementation-identifier ()
    2928   (labels
    2929       ((maybe-warn (value fstring &rest args)
    2930          (cond (value)
    2931                (t (apply 'warn fstring args)
    2932                   "unknown"))))
    2933     (let ((lisp (maybe-warn (implementation-type)
    2934                             (compatfmt "~@<No implementation feature found in ~a.~@:>")
    2935                             *implementation-features*))
    2936           (os   (maybe-warn (first-feature *os-features*)
    2937                             (compatfmt "~@<No OS feature found in ~a.~@:>") *os-features*))
    2938           (arch (or #-clisp
    2939                     (maybe-warn (first-feature *architecture-features*)
    2940                                 (compatfmt "~@<No architecture feature found in ~a.~@:>")
    2941                                 *architecture-features*)))
    2942           (version (maybe-warn (lisp-version-string)
    2943                                "Don't know how to get Lisp implementation version.")))
    2944       (substitute-if
    2945        #\_ #'(lambda (x) (find x " /:\\(){}[]$#`'\""))
    2946        (format nil "~(~a~@{~@[-~a~]~}~)" lisp version os arch)))))
     2901  (substitute-if
     2902   #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
     2903   (format nil "~(~a~@{~@[-~a~]~}~)"
     2904     (or *implementation-type* (lisp-implementation-type))
     2905           (or *lisp-version-string* (lisp-implementation-version))
     2906           (or *operating-system* (software-type))
     2907           (or *architecture* (machine-type)))))
    29472908
    29482909
     
    29532914  #+asdf-unix #\:
    29542915  #-asdf-unix #\;)
    2955 
    2956 ;; Note: ASDF may expect user-homedir-pathname to provide the pathname of
    2957 ;; the current user's home directory, while MCL by default provides the
    2958 ;; directory from which MCL was started.
    2959 ;; See http://code.google.com/p/mcl/wiki/Portability
    2960 #.(or #+mcl ;; the #$ doesn't work on other implementations, even inside #+mcl
    2961       `(defun current-user-homedir-pathname ()
    2962          ,(read-from-string "(ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))")))
    29632916
    29642917(defun* user-homedir ()
     
    31273080          "common-lisp" "cache" :implementation)
    31283081     '(:home ".cache" "common-lisp" :implementation))))
    3129 (defvar *system-cache*
    3130   ;; No good default, plus there's a security problem
    3131   ;; with other users messing with such directories.
    3132   *user-cache*)
    31333082
    31343083(defun* output-translations ()
     
    31613110                resolve-location))
    31623111
    3163 (defun* resolve-relative-location-component (super x &key directory wilden)
    3164   (let* ((r (etypecase x
    3165               (pathname x)
    3166               (string x)
    3167               (cons
    3168                (return-from resolve-relative-location-component
    3169                  (if (null (cdr x))
     3112(defun* resolve-relative-location-component (x &key directory wilden)
     3113  (let ((r (etypecase x
     3114             (pathname x)
     3115             (string (coerce-pathname x :type (when directory :directory)))
     3116             (cons
     3117              (if (null (cdr x))
     3118                  (resolve-relative-location-component
     3119                   (car x) :directory directory :wilden wilden)
     3120                  (let* ((car (resolve-relative-location-component
     3121                               (car x) :directory t :wilden nil)))
     3122                    (merge-pathnames*
    31703123                     (resolve-relative-location-component
    3171                       super (car x) :directory directory :wilden wilden)
    3172                      (let* ((car (resolve-relative-location-component
    3173                                   super (car x) :directory t :wilden nil))
    3174                             (cdr (resolve-relative-location-component
    3175                                   (merge-pathnames* car super) (cdr x)
    3176                                   :directory directory :wilden wilden)))
    3177                        (merge-pathnames* cdr car)))))
    3178               ((eql :default-directory)
    3179                (relativize-pathname-directory (default-directory)))
    3180               ((eql :*/) *wild-directory*)
    3181               ((eql :**/) *wild-inferiors*)
    3182               ((eql :*.*.*) *wild-file*)
    3183               ((eql :implementation) (implementation-identifier))
    3184               ((eql :implementation-type) (string-downcase (implementation-type)))
    3185               #+asdf-unix
    3186               ((eql :uid) (princ-to-string (get-uid)))))
    3187          (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
    3188          (s (if (or (pathnamep x) (not wilden)) d (wilden d))))
    3189     (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
    3190       (error (compatfmt "~@<Pathname ~S is not relative to ~S~@:>") s super))
    3191     (merge-pathnames* s super)))
     3124                      (cdr x) :directory directory :wilden wilden)
     3125                     car))))
     3126             ((eql :default-directory)
     3127              (relativize-pathname-directory (default-directory)))
     3128             ((eql :*/) *wild-directory*)
     3129             ((eql :**/) *wild-inferiors*)
     3130             ((eql :*.*.*) *wild-file*)
     3131             ((eql :implementation)
     3132              (coerce-pathname (implementation-identifier) :type :directory))
     3133             ((eql :implementation-type)
     3134              (coerce-pathname (string-downcase (implementation-type)) :type :directory)))))
     3135    (when (absolute-pathname-p r)
     3136      (error (compatfmt "~@<pathname ~S is not relative~@:>") x))
     3137    (if (or (pathnamep x) (not wilden)) r (wilden r))))
    31923138
    31933139(defvar *here-directory* nil
     
    32003146          (etypecase x
    32013147            (pathname x)
    3202             (string (if directory (ensure-directory-pathname x) (parse-namestring x)))
     3148            (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x)))
     3149                      #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
     3150                      (if directory (ensure-directory-pathname p) p)))
    32033151            (cons
    32043152             (return-from resolve-absolute-location-component
     
    32063154                   (resolve-absolute-location-component
    32073155                    (car x) :directory directory :wilden wilden)
    3208                    (let* ((car (resolve-absolute-location-component
    3209                                 (car x) :directory t :wilden nil))
    3210                           (cdr (resolve-relative-location-component
    3211                                 car (cdr x) :directory directory :wilden wilden)))
    3212                      (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?
     3156                   (merge-pathnames*
     3157                    (resolve-relative-location-component
     3158                     (cdr x) :directory directory :wilden wilden)
     3159                    (resolve-absolute-location-component
     3160                     (car x) :directory t :wilden nil)))))
    32133161            ((eql :root)
    32143162             ;; special magic! we encode such paths as relative pathnames,
     
    32253173            ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
    32263174            ((eql :system-cache)
    3227              (warn "Using the :system-cache is deprecated. ~%~
    3228 Please remove it from your ASDF configuration")
    3229              (resolve-location *system-cache* :directory t :wilden nil))
     3175             (error "Using the :system-cache is deprecated. ~%~
     3176Please remove it from your ASDF configuration"))
    32303177            ((eql :default-directory) (default-directory))))
    32313178         (s (if (and wilden (not (pathnamep x)))
     
    32333180                r)))
    32343181    (unless (absolute-pathname-p s)
    3235       (error (compatfmt "~@<Not an absolute pathname: ~3i~_~S~@:>") s))
     3182      (error (compatfmt "~@<Invalid designator for an absolute pathname: ~3i~_~S~@:>") x))
    32363183    s))
    32373184
     
    32453192        :for dir = (and (or morep directory) t)
    32463193        :for wild = (and wilden (not morep))
    3247         :do (setf path (resolve-relative-location-component
    3248                         path component :directory dir :wilden wild))
     3194        :do (setf path (merge-pathnames*
     3195                        (resolve-relative-location-component
     3196                         component :directory dir :wilden wild)
     3197                        path))
    32493198        :finally (return path))))
    32503199
     
    37363685  (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
    37373686
     3687(defun* filter-logical-directory-results (directory entries merger)
     3688  (if (typep directory 'logical-pathname)
     3689      ;; Try hard to not resolve logical-pathname into physical pathnames;
     3690      ;; otherwise logical-pathname users/lovers will be disappointed.
     3691      ;; If directory* could use some implementation-dependent magic,
     3692      ;; we will have logical pathnames already; otherwise,
     3693      ;; we only keep pathnames for which specifying the name and
     3694      ;; translating the LPN commute.
     3695      (loop :for f :in entries
     3696        :for p = (or (and (typep f 'logical-pathname) f)
     3697                     (let* ((u (ignore-errors (funcall merger f))))
     3698                       (and u (equal (ignore-errors (truename u)) f) u)))
     3699        :when p :collect p)
     3700      entries))
     3701
     3702(defun* directory-files (directory &optional (pattern *wild-file*))
     3703  (when (wild-pathname-p directory)
     3704    (error "Invalid wild in ~S" directory))
     3705  (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
     3706    (error "Invalid file pattern ~S" pattern))
     3707  (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory)))))
     3708    (filter-logical-directory-results
     3709     directory entries
     3710     #'(lambda (f)
     3711         (make-pathname :defaults directory :version (pathname-version f)
     3712                        :name (pathname-name f) :type (pathname-type f))))))
     3713
    37383714(defun* directory-asd-files (directory)
    3739   (ignore-errors
    3740     (directory* (merge-pathnames* *wild-asd* directory))))
     3715  (directory-files directory *wild-asd*))
    37413716
    37423717(defun* subdirectories (directory)
     
    37663741                                  #+genera (ensure-directory-pathname (first x))
    37673742                                  #+(or cmu lispworks scl) x)))
    3768     dirs))
     3743    (filter-logical-directory-results
     3744     directory dirs
     3745     (let ((prefix (normalize-pathname-directory-component
     3746                    (pathname-directory directory))))
     3747       #'(lambda (d)
     3748           (let ((dir (normalize-pathname-directory-component
     3749                       (pathname-directory d))))
     3750             (and (consp dir) (consp (cdr dir))
     3751                  (make-pathname
     3752                   :defaults directory :name nil :type nil :version nil
     3753                   :directory (append prefix (last dir))))))))))
    37693754
    37703755(defun* collect-asds-in-directory (directory collect)
     
    39933978         directory :recurse recurse :exclude exclude :collect
    39943979         #'(lambda (asd)
    3995              (let ((name (pathname-name asd)))
     3980             (let* ((name (pathname-name asd))
     3981                    (name (if (typep asd 'logical-pathname)
     3982                              ;; logical pathnames are upper-case,
     3983                              ;; at least in the CLHS and on SBCL,
     3984                              ;; yet (coerce-name :foo) is lower-case.
     3985                              ;; won't work well with (load-system "Foo")
     3986                              ;; instead of (load-system 'foo)
     3987                              (string-downcase name)
     3988                              name)))
    39963989               (cond
    39973990                 ((gethash name registry) ; already shadowed by something else
Note: See TracChangeset for help on using the changeset viewer.