Changeset 13417


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

Upgrade to asdf-2.017.

Location:
trunk/abcl
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • trunk/abcl/doc/asdf/asdf.texinfo

    r13311 r13417  
    432432
    433433
    434 @section Configuring ASDF to find your systems -- old style
     434@section Configuring ASDF to find your systems --- old style
    435435
    436436The old way to configure ASDF to find your systems is by
    … …  
    499499ASDF knows how to follow such @emph{symlinks}
    500500to the actual file location when resolving the paths of system components
    501 (on Windows, you can use Windows shortcuts instead of POSIX symlinks).
     501(on Windows, you can use Windows shortcuts instead of POSIX symlinks;
     502if you try aliases under MacOS, we are curious to hear about your experience).
    502503
    503504For example, if @code{#p"/home/me/cl/systems/"} (note the trailing slash)
    … …  
    18991900before it searches in the source registry above.
    19001901
    1901 @xref{Configuring ASDF,,Configuring ASDF to find your systems -- old style}.
     1902@xref{Configuring ASDF,,Configuring ASDF to find your systems --- old style}.
    19021903
    19031904By default, @code{asdf:*central-registry*} will be empty.
    … …  
    19381939
    19391940    ;; override the defaults for exclusion patterns
    1940     (:exclude PATTERN ...) |
     1941    (:exclude EXCLUSION-PATTERN ...) |
    19411942    ;; augment the defaults for exclusion patterns
    1942     (:also-exclude PATTERN ...) |
     1943    (:also-exclude EXCLUSION-PATTERN ...) |
    19431944    ;; Note that the scope of a an exclude pattern specification is
    19441945    ;; the rest of the current configuration expression or file.
    … …  
    19541955
    19551956PATHNAME-DESIGNATOR :=
    1956     NULL | ;; Special: skip this entry.
    1957     ABSOLUTE-COMPONENT-DESIGNATOR |
    1958     (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...)
    1959 
    1960 ABSOLUTE-COMPONENT-DESIGNATOR :=
    1961     STRING | ;; namestring (better be absolute or bust, directory assumed where applicable)
    1962     PATHNAME | ;; pathname (better be an absolute path, or bust)
    1963     :HOME | ;; designates the user-homedir-pathname ~/
    1964     :USER-CACHE | ;; designates the default location for the user cache
    1965     :SYSTEM-CACHE | ;; designates the default location for the system cache
    1966     :HERE  ;; designates the location of the configuration file
    1967            ;; (or *default-pathname-defaults*, if invoked interactively)
    1968 
    1969 RELATIVE-COMPONENT-DESIGNATOR :=
    1970     STRING | ;; namestring (directory assumed where applicable)
    1971     PATHNAME | ;; pathname
    1972     :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.45-linux-amd64
    1973     :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
    1974     :UID | ;; current UID -- not available on Windows
    1975     :USER ;; current USER name -- NOT IMPLEMENTED(!)
    1976 
    1977 PATTERN := a string without wildcards, that will be matched exactly
     1957    NIL | ;; Special: skip this entry.
     1958    ABSOLUTE-COMPONENT-DESIGNATOR ;; see pathname DSL
     1959
     1960EXCLUSION-PATTERN := a string without wildcards, that will be matched exactly
    19781961  against the name of a any subdirectory in the directory component
    19791962        of a path. e.g. @code{"_darcs"} will match @file{#p"/foo/bar/_darcs/src/bar.asd"}
    19801963@end example
    19811964
     1965Pathnames are designated using another DSL,
     1966shared with the output-translations configuration DSL below.
     1967The DSL is resolved by the function @code{asdf::resolve-location},
     1968to be documented and exported at some point in the future.
     1969
     1970@example
     1971ABSOLUTE-COMPONENT-DESIGNATOR :=
     1972    (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) |
     1973    STRING | ;; namestring (better be absolute or bust, directory assumed where applicable).
     1974             ;; In output-translations, directory is assumed and **/*.*.* added if it's last.
     1975             ;; On MCL, a MacOSX-style POSIX namestring (for MacOS9 style, use #p"...");
     1976             ;; Note that none of the above applies to strings used in *central-registry*,
     1977             ;; which doesn't use this DSL: they are processed as normal namestrings.
     1978             ;; however, you can compute what you put in the *central-registry*
     1979             ;; based on the results of say (asdf::resolve-location "/Users/fare/cl/cl-foo/")
     1980    PATHNAME | ;; pathname (better be an absolute path, or bust)
     1981               ;; In output-translations, unless followed by relative components,
     1982               ;; it better have appropriate wildcards, as in **/*.*.*
     1983    :HOME | ;; designates the user-homedir-pathname ~/
     1984    :USER-CACHE | ;; designates the default location for the user cache
     1985    :HERE | ;; designates the location of the configuration file
     1986            ;; (or *default-pathname-defaults*, if invoked interactively)
     1987    :ROOT ;; magic, for output-translations source only: paths that are relative
     1988          ;; to the root of the source host and device
     1989    ;; Not valid anymore: :SYSTEM-CACHE (was a security hazard)
     1990
     1991RELATIVE-COMPONENT-DESIGNATOR :=
     1992    (RELATIVE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) |
     1993    STRING | ;; relative directory pathname as interpreted by coerce-pathname.
     1994             ;; In output translations, if last component, **/*.*.* is added
     1995    PATHNAME | ;; pathname; unless last component, directory is assumed.
     1996    :IMPLEMENTATION | ;; directory based on implementation, e.g. sbcl-1.0.49-linux-x64
     1997    :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
     1998    :DEFAULT-DIRECTORY | ;; a relativized version of the default directory
     1999    :*/ | ;; any direct subdirectory (since ASDF 2.011.4)
     2000    :**/ | ;; any recursively inferior subdirectory (since ASDF 2.011.4)
     2001    :*.*.* | ;; any file (since ASDF 2.011.4)
     2002    ;; Not supported (anymore): :UID and :USERNAME
     2003@end example
     2004
    19822005For instance, as a simple case, my @file{~/.config/common-lisp/source-registry.conf},
    1983 which is the default place ASDF looks for this configuration,
    1984 once contained:
     2006which is the default place ASDF looks for this configuration, once contained:
    19852007@example
    19862008(:source-registry
    … …  
    24542476
    24552477DIRECTORY-DESIGNATOR :=
     2478    NIL | ;; As source: skip this entry. As destination: same as source
    24562479    T | ;; as source matches anything, as destination leaves pathname unmapped.
    2457     ABSOLUTE-COMPONENT-DESIGNATOR |
    2458     (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...)
    2459 
    2460 ABSOLUTE-COMPONENT-DESIGNATOR :=
    2461     NULL | ;; As source: skip this entry. As destination: same as source
    2462     :ROOT | ;; magic: paths that are relative to the root of the source host and device
    2463     STRING | ;; namestring (directory is assumed, better be absolute or bust, ``/**/*.*'' added)
    2464     PATHNAME | ;; pathname (better be an absolute directory or bust)
    2465     :HOME | ;; designates the user-homedir-pathname ~/
    2466     :USER-CACHE | ;; designates the default location for the user cache
    2467     :SYSTEM-CACHE ;; designates the default location for the system cache
    2468 
    2469 RELATIVE-COMPONENT-DESIGNATOR :=
    2470     STRING | ;; namestring, directory is assumed. If the last component, /**/*.* is added
    2471     PATHNAME | ;; pathname; unless last component, directory is assumed.
    2472     :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.45-linux-amd64
    2473     :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
    2474     :*/ | ;; any direct subdirectory (since ASDF 2.011.4)
    2475     :**/ | ;; any recursively inferior subdirectory (since ASDF 2.011.4)
    2476     :*.*.* | ;; any file (since ASDF 2.011.4)
    2477     :UID | ;; current UID -- not available on Windows
    2478     :USER ;; current USER name -- NOT IMPLEMENTED(!)
     2480    ABSOLUTE-COMPONENT-DESIGNATOR ;; same as in the source-registry language
    24792481
    24802482TRANSLATION-FUNCTION :=
    … …  
    31843186Or you can fix your implementation to not be quite that slow
    31853187when recursing through directories.
    3186 @underline{Update}: performance bug fixed the hard way in 2.010.
     3188@emph{Update}: performance bug fixed the hard way in 2.010.
    31873189
    31883190@item

  • 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.