Changeset 13417 for trunk/abcl/src/org/armedbear/lisp/asdf.lisp
- Timestamp:
- 07/27/11 06:44:50 (10 years ago)
- File:
-
- 1 edited
-
trunk/abcl/src/org/armedbear/lisp/asdf.lisp (modified) (33 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/asdf.lisp
r13319 r13417 1 1 ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- 2 ;;; This is ASDF 2.01 6.1: Another System Definition Facility.2 ;;; This is ASDF 2.017: Another System Definition Facility. 3 3 ;;; 4 4 ;;; Feedback, bug reports, and patches are all welcome: … … 51 51 52 52 #-(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 withit.")53 (error "ASDF is not supported on your implementation. Please help us port it.") 54 54 55 55 #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this … … 63 63 :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below 64 64 #+(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 67 67 (and (= system::*gcl-major-version* 2) 68 68 (< system::*gcl-minor-version* 7))) … … 113 113 ;; "2.345.0.7" would be your seventh local modification of official release 2.345 114 114 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 115 (asdf-version "2.01 6.1")115 (asdf-version "2.017") 116 116 (existing-asdf (find-class 'component nil)) 117 117 (existing-version *asdf-version*) … … 201 201 (loop :for x :in newly-exported-symbols :do 202 202 (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) 204 205 (let* ((p (ensure-exists name nicknames use))) 205 206 (ensure-unintern p unintern) 206 207 (ensure-shadow p shadow) 207 208 (ensure-export p export) 208 (ensure-fmakunbound p fmakunbound)209 (ensure-fmakunbound p (append fmakunbound redefined-functions)) 209 210 p))) 210 211 (macrolet … … 214 215 ',name :nicknames ',nicknames :use ',use :export ',export 215 216 :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))) 218 220 (pkgdcl 219 221 :asdf … … 349 351 #:ensure-directory-pathname 350 352 #:getenv 351 ;; #:get-uid352 353 ;; #:length=n-p 353 354 ;; #:find-symbol* … … 420 421 421 422 ;;;; ------------------------------------------------------------------------- 422 ;;;; Compatibility with Corman Lisp423 ;;;; Compatibility various implementations 423 424 #+cormanlisp 424 425 (progn … … 428 429 (setf p (pathname p)) 429 430 (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))))))")) 430 450 431 451 ;;;; ------------------------------------------------------------------------- … … 554 574 :defaults pathname))) 555 575 556 557 576 (define-modify-macro appendf (&rest args) 558 577 append "Append onto list") ;; only to be used on short lists. … … 654 673 :unless (eq k key) 655 674 :append (list k v))) 656 657 #+mcl658 (eval-when (:compile-toplevel :load-toplevel :execute)659 (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string))660 675 661 676 (defun* getenv (x) … … 754 769 :until (eq form eof) 755 770 :collect form))) 756 757 #+asdf-unix758 (progn759 #+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-string774 (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")))))))780 771 781 772 (defun* pathname-root (pathname) … … 1433 1424 (block nil 1434 1425 (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"))) 1440 1429 (when (probe-file* file) 1441 1430 (return file))) … … 1537 1526 (funcall thunk)))) 1538 1527 1539 (defmacro with-system-definitions (( &optional) &body body)1528 (defmacro with-system-definitions (() &body body) 1540 1529 `(call-with-system-definitions #'(lambda () ,@body))) 1541 1530 … … 2372 2361 (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") 2373 2362 version new-version))) 2374 (let ((asdf (f ind-system:asdf)))2363 (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) 2375 2364 ;; invalidate all systems but ASDF itself 2376 2365 (setf *defined-systems* (make-defined-systems-table)) … … 2608 2597 perform explain output-files operation-done-p 2609 2598 weakly-depends-on 2610 depends-on serial in-order-to 2599 depends-on serial in-order-to do-first 2611 2600 (version nil versionp) 2612 2601 ;; list ends … … 2669 2658 `((compile-op (compile-op ,@depends-on)) 2670 2659 (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))))) 2672 2664 2673 2665 (%refresh-component-inline-methods ret rest) … … 2753 2745 :wait t))) 2754 2746 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 2755 2754 #+ecl ;; courtesy of Juan Jose Garcia Ripoll 2756 2755 (si:system command) … … 2767 2766 :output-stream *verbose-out*) 2768 2767 2768 #+mcl 2769 (ccl::with-cstrs ((%command command)) (_system %command)) 2770 2769 2771 #+sbcl 2770 2772 (sb-ext:process-exit-code … … 2775 2777 #+win32 '(:search t) #-win32 nil)) 2776 2778 2777 #+(or cmu scl)2778 (ext:process-exit-code2779 (ext:run-program2780 "/bin/sh"2781 (list "-c" command)2782 :input nil :output *verbose-out*))2783 2784 2779 #+xcl 2785 2780 (ext:run-shell-command command) 2786 2781 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) 2788 2783 (error "RUN-SHELL-COMMAND not implemented for this Lisp"))) 2789 2784 … … 2813 2808 directory in which the system specification (.asd file) is 2814 2809 located." 2815 (make-pathname :name nil 2816 :type nil 2817 :defaults (system-source-file system-designator))) 2810 (pathname-directory-pathname (system-source-file system-designator))) 2818 2811 2819 2812 (defun* relativize-directory (directory) … … 2842 2835 ;;; 2843 2836 ;;; 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* 2877 2868 (let ((s (lisp-implementation-version))) 2878 2869 (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"))) 2890 2878 #+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)) 2896 2886 #+cmu (substitute #\- #\/ s) 2897 2887 #+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)))) 2901 2890 #+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/ version2891 #+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 " 2906 2895 s))) 2907 2896 2908 (defun* first-feature (features)2909 (labels2910 ((fp (thing)2911 (etypecase thing2912 (symbol2913 (let ((feature (find thing *features*)))2914 (when feature (return-from fp feature))))2915 ;; allows features to be lists of which the first2916 ;; member is the "main name", the rest being aliases2917 (cons2918 (dolist (subf thing)2919 (when (find subf *features*) (return-from fp (first thing))))))2920 nil))2921 (loop :for f :in features2922 :when (fp f) :return :it)))2923 2924 2897 (defun* implementation-type () 2925 (first-feature *implementation-features*))2898 *implementation-type*) 2926 2899 2927 2900 (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))))) 2947 2908 2948 2909 … … 2953 2914 #+asdf-unix #\: 2954 2915 #-asdf-unix #\;) 2955 2956 ;; Note: ASDF may expect user-homedir-pathname to provide the pathname of2957 ;; the current user's home directory, while MCL by default provides the2958 ;; directory from which MCL was started.2959 ;; See http://code.google.com/p/mcl/wiki/Portability2960 #.(or #+mcl ;; the #$ doesn't work on other implementations, even inside #+mcl2961 `(defun current-user-homedir-pathname ()2962 ,(read-from-string "(ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))")))2963 2916 2964 2917 (defun* user-homedir () … … 3127 3080 "common-lisp" "cache" :implementation) 3128 3081 '(:home ".cache" "common-lisp" :implementation)))) 3129 (defvar *system-cache*3130 ;; No good default, plus there's a security problem3131 ;; with other users messing with such directories.3132 *user-cache*)3133 3082 3134 3083 (defun* output-translations () … … 3161 3110 resolve-location)) 3162 3111 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* 3170 3123 (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)))) 3192 3138 3193 3139 (defvar *here-directory* nil … … 3200 3146 (etypecase x 3201 3147 (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))) 3203 3151 (cons 3204 3152 (return-from resolve-absolute-location-component … … 3206 3154 (resolve-absolute-location-component 3207 3155 (car x) :directory directory :wilden wilden) 3208 ( let* ((car (resolve-absolute-location-component3209 (car x) :directory t :wilden nil))3210 (cdr (resolve-relative-location-component3211 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))))) 3213 3161 ((eql :root) 3214 3162 ;; special magic! we encode such paths as relative pathnames, … … 3225 3173 ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil)) 3226 3174 ((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. ~%~ 3176 Please remove it from your ASDF configuration")) 3230 3177 ((eql :default-directory) (default-directory)))) 3231 3178 (s (if (and wilden (not (pathnamep x))) … … 3233 3180 r))) 3234 3181 (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)) 3236 3183 s)) 3237 3184 … … 3245 3192 :for dir = (and (or morep directory) t) 3246 3193 :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)) 3249 3198 :finally (return path)))) 3250 3199 … … 3736 3685 (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) 3737 3686 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 3738 3714 (defun* directory-asd-files (directory) 3739 (ignore-errors 3740 (directory* (merge-pathnames* *wild-asd* directory)))) 3715 (directory-files directory *wild-asd*)) 3741 3716 3742 3717 (defun* subdirectories (directory) … … 3766 3741 #+genera (ensure-directory-pathname (first x)) 3767 3742 #+(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)))))))))) 3769 3754 3770 3755 (defun* collect-asds-in-directory (directory collect) … … 3993 3978 directory :recurse recurse :exclude exclude :collect 3994 3979 #'(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))) 3996 3989 (cond 3997 3990 ((gethash name registry) ; already shadowed by something else
Note: See TracChangeset
for help on using the changeset viewer.
