[armedbear-cvs] r13417 - in trunk/abcl: doc/asdf src/org/armedbear/lisp

mevenson at common-lisp.net mevenson at common-lisp.net
Wed Jul 27 06:44:51 UTC 2011


Author: mevenson
Date: Tue Jul 26 23:44:50 2011
New Revision: 13417

Log:
Upgrade to asdf-2.017.

Modified:
   trunk/abcl/doc/asdf/asdf.texinfo
   trunk/abcl/src/org/armedbear/lisp/asdf.lisp

Modified: trunk/abcl/doc/asdf/asdf.texinfo
==============================================================================
--- trunk/abcl/doc/asdf/asdf.texinfo	Tue Jul 26 12:55:04 2011	(r13416)
+++ trunk/abcl/doc/asdf/asdf.texinfo	Tue Jul 26 23:44:50 2011	(r13417)
@@ -431,7 +431,7 @@
 and the machine you resume it at the time you resume it.
 
 
- at section Configuring ASDF to find your systems -- old style
+ at section Configuring ASDF to find your systems --- old style
 
 The old way to configure ASDF to find your systems is by
 @code{push}ing directory pathnames onto the variable
@@ -498,7 +498,8 @@
 to the @code{asdf:*central-registry*}.
 ASDF knows how to follow such @emph{symlinks}
 to the actual file location when resolving the paths of system components
-(on Windows, you can use Windows shortcuts instead of POSIX symlinks).
+(on Windows, you can use Windows shortcuts instead of POSIX symlinks;
+if you try aliases under MacOS, we are curious to hear about your experience).
 
 For example, if @code{#p"/home/me/cl/systems/"} (note the trailing slash)
 is a member of @code{*central-registry*}, you could set up the
@@ -1898,7 +1899,7 @@
 @code{asdf:*central-registry*}
 before it searches in the source registry above.
 
- at xref{Configuring ASDF,,Configuring ASDF to find your systems -- old style}.
+ at xref{Configuring ASDF,,Configuring ASDF to find your systems --- old style}.
 
 By default, @code{asdf:*central-registry*} will be empty.
 
@@ -1937,9 +1938,9 @@
     (:tree DIRECTORY-PATHNAME-DESIGNATOR) |
 
     ;; override the defaults for exclusion patterns
-    (:exclude PATTERN ...) |
+    (:exclude EXCLUSION-PATTERN ...) |
     ;; augment the defaults for exclusion patterns
-    (:also-exclude PATTERN ...) |
+    (:also-exclude EXCLUSION-PATTERN ...) |
     ;; Note that the scope of a an exclude pattern specification is
     ;; the rest of the current configuration expression or file.
 
@@ -1953,35 +1954,56 @@
 DIRECTORY-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a directory name
 
 PATHNAME-DESIGNATOR :=
-    NULL | ;; Special: skip this entry.
-    ABSOLUTE-COMPONENT-DESIGNATOR |
-    (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...)
+    NIL | ;; Special: skip this entry.
+    ABSOLUTE-COMPONENT-DESIGNATOR ;; see pathname DSL
 
+EXCLUSION-PATTERN := a string without wildcards, that will be matched exactly
+	against the name of a any subdirectory in the directory component
+        of a path. e.g. @code{"_darcs"} will match @file{#p"/foo/bar/_darcs/src/bar.asd"}
+ at end example
+
+Pathnames are designated using another DSL,
+shared with the output-translations configuration DSL below.
+The DSL is resolved by the function @code{asdf::resolve-location},
+to be documented and exported at some point in the future.
+
+ at example
 ABSOLUTE-COMPONENT-DESIGNATOR :=
-    STRING | ;; namestring (better be absolute or bust, directory assumed where applicable)
+    (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) |
+    STRING | ;; namestring (better be absolute or bust, directory assumed where applicable).
+             ;; In output-translations, directory is assumed and **/*.*.* added if it's last.
+             ;; On MCL, a MacOSX-style POSIX namestring (for MacOS9 style, use #p"...");
+             ;; Note that none of the above applies to strings used in *central-registry*,
+             ;; which doesn't use this DSL: they are processed as normal namestrings.
+             ;; however, you can compute what you put in the *central-registry*
+             ;; based on the results of say (asdf::resolve-location "/Users/fare/cl/cl-foo/")
     PATHNAME | ;; pathname (better be an absolute path, or bust)
+               ;; In output-translations, unless followed by relative components,
+               ;; it better have appropriate wildcards, as in **/*.*.*
     :HOME | ;; designates the user-homedir-pathname ~/
     :USER-CACHE | ;; designates the default location for the user cache
-    :SYSTEM-CACHE | ;; designates the default location for the system cache
-    :HERE  ;; designates the location of the configuration file
-           ;; (or *default-pathname-defaults*, if invoked interactively)
+    :HERE | ;; designates the location of the configuration file
+            ;; (or *default-pathname-defaults*, if invoked interactively)
+    :ROOT ;; magic, for output-translations source only: paths that are relative
+          ;; to the root of the source host and device
+    ;; Not valid anymore: :SYSTEM-CACHE (was a security hazard)
 
 RELATIVE-COMPONENT-DESIGNATOR :=
-    STRING | ;; namestring (directory assumed where applicable)
-    PATHNAME | ;; pathname
-    :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.45-linux-amd64
+    (RELATIVE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) |
+    STRING | ;; relative directory pathname as interpreted by coerce-pathname.
+             ;; In output translations, if last component, **/*.*.* is added
+    PATHNAME | ;; pathname; unless last component, directory is assumed.
+    :IMPLEMENTATION | ;; directory based on implementation, e.g. sbcl-1.0.49-linux-x64
     :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
-    :UID | ;; current UID -- not available on Windows
-    :USER ;; current USER name -- NOT IMPLEMENTED(!)
-
-PATTERN := a string without wildcards, that will be matched exactly
-	against the name of a any subdirectory in the directory component
-        of a path. e.g. @code{"_darcs"} will match @file{#p"/foo/bar/_darcs/src/bar.asd"}
+    :DEFAULT-DIRECTORY | ;; a relativized version of the default directory
+    :*/ | ;; any direct subdirectory (since ASDF 2.011.4)
+    :**/ | ;; any recursively inferior subdirectory (since ASDF 2.011.4)
+    :*.*.* | ;; any file (since ASDF 2.011.4)
+    ;; Not supported (anymore): :UID and :USERNAME
 @end example
 
 For instance, as a simple case, my @file{~/.config/common-lisp/source-registry.conf},
-which is the default place ASDF looks for this configuration,
-once contained:
+which is the default place ASDF looks for this configuration, once contained:
 @example
 (:source-registry
   (:tree (:home "cl")) ;; will expand to e.g. "/home/joeluser/cl/"
@@ -2453,29 +2475,9 @@
     (DIRECTORY-DESIGNATOR (:function TRANSLATION-FUNCTION))
 
 DIRECTORY-DESIGNATOR :=
+    NIL | ;; As source: skip this entry. As destination: same as source
     T | ;; as source matches anything, as destination leaves pathname unmapped.
-    ABSOLUTE-COMPONENT-DESIGNATOR |
-    (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...)
-
-ABSOLUTE-COMPONENT-DESIGNATOR :=
-    NULL | ;; As source: skip this entry. As destination: same as source
-    :ROOT | ;; magic: paths that are relative to the root of the source host and device
-    STRING | ;; namestring (directory is assumed, better be absolute or bust, ``/**/*.*'' added)
-    PATHNAME | ;; pathname (better be an absolute directory or bust)
-    :HOME | ;; designates the user-homedir-pathname ~/
-    :USER-CACHE | ;; designates the default location for the user cache
-    :SYSTEM-CACHE ;; designates the default location for the system cache
-
-RELATIVE-COMPONENT-DESIGNATOR :=
-    STRING | ;; namestring, directory is assumed. If the last component, /**/*.* is added
-    PATHNAME | ;; pathname; unless last component, directory is assumed.
-    :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.45-linux-amd64
-    :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
-    :*/ | ;; any direct subdirectory (since ASDF 2.011.4)
-    :**/ | ;; any recursively inferior subdirectory (since ASDF 2.011.4)
-    :*.*.* | ;; any file (since ASDF 2.011.4)
-    :UID | ;; current UID -- not available on Windows
-    :USER ;; current USER name -- NOT IMPLEMENTED(!)
+    ABSOLUTE-COMPONENT-DESIGNATOR ;; same as in the source-registry language
 
 TRANSLATION-FUNCTION :=
     SYMBOL | ;; symbol of a function that takes two arguments,
@@ -3183,7 +3185,7 @@
 or shallow @code{:tree} entries.
 Or you can fix your implementation to not be quite that slow
 when recursing through directories.
- at underline{Update}: performance bug fixed the hard way in 2.010.
+ at emph{Update}: performance bug fixed the hard way in 2.010.
 
 @item
 On Windows, only LispWorks supports proper default configuration pathnames

Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/asdf.lisp	Tue Jul 26 12:55:04 2011	(r13416)
+++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp	Tue Jul 26 23:44:50 2011	(r13417)
@@ -1,5 +1,5 @@
 ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.016.1: Another System Definition Facility.
+;;; This is ASDF 2.017: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel at common-lisp.net>.
@@ -50,7 +50,7 @@
 (cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)
 
 #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
-(error "ASDF is not supported on your implementation. Please help us with it.")
+(error "ASDF is not supported on your implementation. Please help us port it.")
 
 #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
 
@@ -62,8 +62,8 @@
         (remove "asdf" excl::*autoload-package-name-alist*
                 :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
   #+(and ecl (not ecl-bytecmp)) (require :cmp)
-  #+gcl
-  (when (or (< system::*gcl-major-version* 2)
+  #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
+  (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
             (and (= system::*gcl-major-version* 2)
                  (< system::*gcl-minor-version* 7)))
     (pushnew :gcl-pre2.7 *features*))
@@ -112,7 +112,7 @@
          ;; "2.345.6" would be a development version in the official upstream
          ;; "2.345.0.7" would be your seventh local modification of official release 2.345
          ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
-         (asdf-version "2.016.1")
+         (asdf-version "2.017")
          (existing-asdf (find-class 'component nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
@@ -200,12 +200,13 @@
                    :do (unintern old user)))
                (loop :for x :in newly-exported-symbols :do
                  (export (intern* x package)))))
-           (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
+           (ensure-package (name &key nicknames use unintern fmakunbound
+				 shadow export redefined-functions)
              (let* ((p (ensure-exists name nicknames use)))
                (ensure-unintern p unintern)
                (ensure-shadow p shadow)
                (ensure-export p export)
-               (ensure-fmakunbound p fmakunbound)
+               (ensure-fmakunbound p (append fmakunbound redefined-functions))
                p)))
         (macrolet
             ((pkgdcl (name &key nicknames use export
@@ -213,8 +214,9 @@
                  `(ensure-package
                    ',name :nicknames ',nicknames :use ',use :export ',export
                    :shadow ',shadow
-                   :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
-                   :fmakunbound ',(append fmakunbound))))
+                   :unintern ',unintern
+		   :redefined-functions ',redefined-functions
+                   :fmakunbound ',fmakunbound)))
           (pkgdcl
            :asdf
            :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
@@ -348,7 +350,6 @@
             ;; #:ends-with
             #:ensure-directory-pathname
             #:getenv
-            ;; #:get-uid
             ;; #:length=n-p
             ;; #:find-symbol*
             #:merge-pathnames*
@@ -419,7 +420,7 @@
          (ftype (function (t t) t) (setf module-components-by-name)))
 
 ;;;; -------------------------------------------------------------------------
-;;;; Compatibility with Corman Lisp
+;;;; Compatibility various implementations
 #+cormanlisp
 (progn
   (deftype logical-pathname () nil)
@@ -428,6 +429,25 @@
     (setf p (pathname p))
     (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
 
+#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
+      (read-from-string
+       "(eval-when (:compile-toplevel :load-toplevel :execute)
+          (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
+          (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
+          ;; Note: ASDF may expect user-homedir-pathname to provide
+          ;; the pathname of the current user's home directory, whereas
+          ;; MCL by default provides the directory from which MCL was started.
+          ;; See http://code.google.com/p/mcl/wiki/Portability
+          (defun current-user-homedir-pathname ()
+            (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
+          (defun probe-posix (posix-namestring)
+            \"If a file exists for the posix namestring, return the pathname\"
+            (ccl::with-cstrs ((cpath posix-namestring))
+              (ccl::rlet ((is-dir :boolean)
+                          (fsref :fsref))
+                (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
+                  (ccl::%path-from-fsref fsref is-dir))))))"))
+
 ;;;; -------------------------------------------------------------------------
 ;;;; General Purpose Utilities
 
@@ -553,7 +573,6 @@
                                '(:relative :back) (pathname-directory pathname))
                    :defaults pathname)))
 
-
 (define-modify-macro appendf (&rest args)
   append "Append onto list") ;; only to be used on short lists.
 
@@ -654,10 +673,6 @@
     :unless (eq k key)
     :append (list k v)))
 
-#+mcl
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string))
-
 (defun* getenv (x)
   (declare (ignorable x))
   #+(or abcl clisp xcl) (ext:getenv x)
@@ -754,30 +769,6 @@
      :until (eq form eof)
      :collect form)))
 
-#+asdf-unix
-(progn
-  #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
-                  '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
-  (defun* get-uid ()
-    #+allegro (excl.osi:getuid)
-    #+ccl (ccl::getuid)
-    #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
-                  :for f = (ignore-errors (read-from-string s))
-                  :when f :return (funcall f))
-    #+(or cmu scl) (unix:unix-getuid)
-    #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
-                   '(ffi:c-inline () () :int "getuid()" :one-liner t)
-                   '(ext::getuid))
-    #+sbcl (sb-unix:unix-getuid)
-    #-(or allegro ccl clisp cmu ecl sbcl scl)
-    (let ((uid-string
-           (with-output-to-string (*verbose-out*)
-             (run-shell-command "id -ur"))))
-      (with-input-from-string (stream uid-string)
-        (read-line stream)
-        (handler-case (parse-integer (read-line stream))
-          (error () (error "Unable to find out user ID")))))))
-
 (defun* pathname-root (pathname)
   (make-pathname :directory '(:absolute)
                  :name nil :type nil :version nil
@@ -1432,11 +1423,9 @@
 (defun* probe-asd (name defaults)
   (block nil
     (when (directory-pathname-p defaults)
-      (let ((file
-             (make-pathname
-              :defaults defaults :version :newest :case :local
-              :name name
-              :type "asd")))
+      (let ((file (make-pathname
+                   :defaults defaults :name name
+                   :version :newest :case :local :type "asd")))
         (when (probe-file* file)
           (return file)))
       #+(and asdf-windows (not clisp))
@@ -1536,7 +1525,7 @@
       (let ((*systems-being-defined* (make-hash-table :test 'equal)))
         (funcall thunk))))
 
-(defmacro with-system-definitions ((&optional) &body body)
+(defmacro with-system-definitions (() &body body)
   `(call-with-system-definitions #'(lambda () , at body)))
 
 (defun* load-sysdef (name pathname)
@@ -2371,7 +2360,7 @@
           (t
            (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
                          version new-version)))
-        (let ((asdf (find-system :asdf)))
+        (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
           ;; invalidate all systems but ASDF itself
           (setf *defined-systems* (make-defined-systems-table))
           (register-system asdf)
@@ -2607,7 +2596,7 @@
               components pathname default-component-class
               perform explain output-files operation-done-p
               weakly-depends-on
-              depends-on serial in-order-to
+              depends-on serial in-order-to do-first
               (version nil versionp)
               ;; list ends
               &allow-other-keys) options
@@ -2668,7 +2657,10 @@
              in-order-to
              `((compile-op (compile-op , at depends-on))
                (load-op (load-op , at depends-on)))))
-      (setf (component-do-first ret) `((compile-op (load-op , at depends-on))))
+      (setf (component-do-first ret)
+            (union-of-dependencies
+             do-first
+	     `((compile-op (load-op , at depends-on)))))
 
       (%refresh-component-inline-methods ret rest)
       ret)))
@@ -2752,6 +2744,13 @@
                                  :input nil :output *verbose-out*
                                  :wait t)))
 
+    #+(or cmu scl)
+    (ext:process-exit-code
+     (ext:run-program
+      "/bin/sh"
+      (list  "-c" command)
+      :input nil :output *verbose-out*))
+
     #+ecl ;; courtesy of Juan Jose Garcia Ripoll
     (si:system command)
 
@@ -2766,6 +2765,9 @@
      :prefix ""
      :output-stream *verbose-out*)
 
+    #+mcl
+    (ccl::with-cstrs ((%command command)) (_system %command))
+
     #+sbcl
     (sb-ext:process-exit-code
      (apply 'sb-ext:run-program
@@ -2774,17 +2776,10 @@
             :input nil :output *verbose-out*
             #+win32 '(:search t) #-win32 nil))
 
-    #+(or cmu scl)
-    (ext:process-exit-code
-     (ext:run-program
-      "/bin/sh"
-      (list  "-c" command)
-      :input nil :output *verbose-out*))
-
     #+xcl
     (ext:run-shell-command command)
 
-    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl)
+    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl xcl)
     (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
 
 ;;;; ---------------------------------------------------------------------------
@@ -2812,9 +2807,7 @@
   "Return a pathname object corresponding to the
 directory in which the system specification (.asd file) is
 located."
-     (make-pathname :name nil
-                 :type nil
-                 :defaults (system-source-file system-designator)))
+  (pathname-directory-pathname (system-source-file system-designator)))
 
 (defun* relativize-directory (directory)
   (cond
@@ -2841,109 +2834,77 @@
 ;;; implementation-identifier
 ;;;
 ;;; produce a string to identify current implementation.
-;;; Initially stolen from SLIME's SWANK, hacked since.
+;;; Initially stolen from SLIME's SWANK, rewritten since.
+;;; The (car '(...)) idiom avoids unreachable code warnings.
 
-(defparameter *implementation-features*
-  '((:abcl :armedbear)
-    (:acl :allegro)
-    (:mcl :digitool) ; before clozure, so it won't get preempted by ccl
-    (:ccl :clozure)
-    (:corman :cormanlisp)
-    (:lw :lispworks)
-    :clisp :cmu :ecl :gcl :sbcl :scl :symbolics :xcl))
-
-(defparameter *os-features*
-  '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
-    (:solaris :sunos)
-    (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
-    (:macosx :darwin :darwin-target :apple)
-    :freebsd :netbsd :openbsd :bsd
-    :unix
-    :genera))
-
-(defparameter *architecture-features*
-  '((:x64 :amd64 :x86-64 :x86_64 :x8664-target #+(and clisp word-size=64) :pc386)
-    (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
-    :hppa64 :hppa
-    (:ppc64 :ppc64-target) (:ppc32 :ppc32-target :ppc :powerpc)
-    :sparc64 (:sparc32 :sparc)
-    (:arm :arm-target)
-    (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)
-    :mipsel :mipseb :mips
-    :alpha
-    :imach))
+(defparameter *implementation-type*
+  (car '(#+abcl :abcl #+allegro :acl
+         #+clozure :ccl #+clisp :clisp #+cormanlisp :corman #+cmu :cmu
+         #+ecl :ecl #+gcl :gcl #+lispworks :lw #+mcl :mcl
+         #+sbcl :sbcl #+scl :scl #+symbolics :symbolic #+xcl :xcl)))
+
+(defparameter *operating-system*
+  (car '(#+cygwin :cygwin #+(or windows mswindows win32 mingw32) :win
+         #+(or linux linux-target) :linux ;; for GCL at least, must appear before :bsd.
+         #+(or macosx darwin darwin-target apple) :macosx ; also before :bsd
+         #+(or solaris sunos) :solaris
+         #+(or freebsd netbsd openbsd bsd) :bsd
+         #+unix :unix
+         #+genera :genera)))
+
+(defparameter *architecture*
+  (car '(#+(or amd64 x86-64 x86_64 x8664-target (and word-size=64 pc386)) :x64
+         #+(or x86 i386 i486 i586 i686 pentium3 pentium4 pc386 iapx386 x8632-target) :x86
+         #+hppa64 :hppa64 #+hppa :hppa
+         #+(or ppc64 ppc64-target) :ppc64
+         #+(or ppc32 ppc32-target ppc powerpc) :ppc32
+         #+sparc64 :sparc64 #+(or sparc32 sparc) :sparc32
+         #+(or arm arm-target) :arm
+         #+(or java java-1.4 java-1.5 java-1.6 java-1.7) :java
+         #+mipsel :mispel #+mipseb :mipseb #+mips :mips
+         #+alpha :alpha #+imach :imach)))
 
-(defun* lisp-version-string ()
+(defparameter *lisp-version-string*
   (let ((s (lisp-implementation-version)))
     (or
-     #+allegro (format nil
-                       "~A~A~A"
-                       excl::*common-lisp-version-number*
-                       ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
-                       (if (eq excl:*current-case-mode*
-                               :case-sensitive-lower) "M" "A")
-                       ;; Note if not using International ACL
-                       ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
-                       (excl:ics-target-case
-                        (:-ics "8")
-                        (:+ics ""))) ; redundant? (if (member :64bit *features*) "-64bit" ""))
+     #+allegro
+     (format nil "~A~A~@[~A~]"
+	     excl::*common-lisp-version-number*
+	     ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
+	     (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A")
+	     ;; Note if not using International ACL
+	     ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
+	     (excl:ics-target-case (:-ics "8")))
      #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
-     #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
-     #+clozure (format nil "~d.~d-f~d" ; shorten for windows
-                       ccl::*openmcl-major-version*
-                       ccl::*openmcl-minor-version*
-                       (logand ccl::fasl-version #xFF))
+     #+clisp
+     (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
+     #+clozure
+     (format nil "~d.~d-f~d" ; shorten for windows
+	     ccl::*openmcl-major-version*
+	     ccl::*openmcl-minor-version*
+	     (logand ccl::fasl-version #xFF))
      #+cmu (substitute #\- #\/ s)
      #+ecl (format nil "~A~@[-~A~]" s
-                   (let ((vcs-id (ext:lisp-implementation-vcs-id)))
-                     (when (>= (length vcs-id) 8)
-                       (subseq vcs-id 0 8))))
+		   (let ((vcs-id (ext:lisp-implementation-vcs-id)))
+		     (subseq vcs-id 0 (min (length vcs-id) 8))))
      #+gcl (subseq s (1+ (position #\space s)))
-     #+genera (multiple-value-bind (major minor) (sct:get-system-version "System")
-                (format nil "~D.~D" major minor))
-     ;; #+lispworks (format nil "~A~@[~A~]" s (when (member :lispworks-64bit *features*) "-64bit")     #+mcl (subseq s 8) ; strip the leading "Version "
-     ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
+     #+genera
+     (multiple-value-bind (major minor) (sct:get-system-version "System")
+       (format nil "~D.~D" major minor))
+     #+mcl (subseq s 8) ; strip the leading "Version "
      s)))
 
-(defun* first-feature (features)
-  (labels
-      ((fp (thing)
-         (etypecase thing
-           (symbol
-            (let ((feature (find thing *features*)))
-              (when feature (return-from fp feature))))
-           ;; allows features to be lists of which the first
-           ;; member is the "main name", the rest being aliases
-           (cons
-            (dolist (subf thing)
-              (when (find subf *features*) (return-from fp (first thing))))))
-         nil))
-    (loop :for f :in features
-      :when (fp f) :return :it)))
-
 (defun* implementation-type ()
-  (first-feature *implementation-features*))
+  *implementation-type*)
 
 (defun* implementation-identifier ()
-  (labels
-      ((maybe-warn (value fstring &rest args)
-         (cond (value)
-               (t (apply 'warn fstring args)
-                  "unknown"))))
-    (let ((lisp (maybe-warn (implementation-type)
-                            (compatfmt "~@<No implementation feature found in ~a.~@:>")
-                            *implementation-features*))
-          (os   (maybe-warn (first-feature *os-features*)
-                            (compatfmt "~@<No OS feature found in ~a.~@:>") *os-features*))
-          (arch (or #-clisp
-                    (maybe-warn (first-feature *architecture-features*)
-                                (compatfmt "~@<No architecture feature found in ~a.~@:>")
-                                *architecture-features*)))
-          (version (maybe-warn (lisp-version-string)
-                               "Don't know how to get Lisp implementation version.")))
-      (substitute-if
-       #\_ #'(lambda (x) (find x " /:\\(){}[]$#`'\""))
-       (format nil "~(~a~@{~@[-~a~]~}~)" lisp version os arch)))))
+  (substitute-if
+   #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
+   (format nil "~(~a~@{~@[-~a~]~}~)"
+	   (or *implementation-type* (lisp-implementation-type))
+           (or *lisp-version-string* (lisp-implementation-version))
+           (or *operating-system* (software-type))
+           (or *architecture* (machine-type)))))
 
 
 ;;; ---------------------------------------------------------------------------
@@ -2953,14 +2914,6 @@
   #+asdf-unix #\:
   #-asdf-unix #\;)
 
-;; Note: ASDF may expect user-homedir-pathname to provide the pathname of
-;; the current user's home directory, while MCL by default provides the
-;; directory from which MCL was started.
-;; See http://code.google.com/p/mcl/wiki/Portability
-#.(or #+mcl ;; the #$ doesn't work on other implementations, even inside #+mcl
-      `(defun current-user-homedir-pathname ()
-         ,(read-from-string "(ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))")))
-
 (defun* user-homedir ()
   (truenamize
    (pathname-directory-pathname
@@ -3126,10 +3079,6 @@
               (getenv "APPDATA"))
           "common-lisp" "cache" :implementation)
      '(:home ".cache" "common-lisp" :implementation))))
-(defvar *system-cache*
-  ;; No good default, plus there's a security problem
-  ;; with other users messing with such directories.
-  *user-cache*)
 
 (defun* output-translations ()
   (car *output-translations*))
@@ -3160,35 +3109,32 @@
                           (values (or null pathname) &optional))
                 resolve-location))
 
-(defun* resolve-relative-location-component (super x &key directory wilden)
-  (let* ((r (etypecase x
-              (pathname x)
-              (string x)
-              (cons
-               (return-from resolve-relative-location-component
-                 (if (null (cdr x))
+(defun* resolve-relative-location-component (x &key directory wilden)
+  (let ((r (etypecase x
+             (pathname x)
+             (string (coerce-pathname x :type (when directory :directory)))
+             (cons
+              (if (null (cdr x))
+                  (resolve-relative-location-component
+                   (car x) :directory directory :wilden wilden)
+                  (let* ((car (resolve-relative-location-component
+                               (car x) :directory t :wilden nil)))
+                    (merge-pathnames*
                      (resolve-relative-location-component
-                      super (car x) :directory directory :wilden wilden)
-                     (let* ((car (resolve-relative-location-component
-                                  super (car x) :directory t :wilden nil))
-                            (cdr (resolve-relative-location-component
-                                  (merge-pathnames* car super) (cdr x)
-                                  :directory directory :wilden wilden)))
-                       (merge-pathnames* cdr car)))))
-              ((eql :default-directory)
-               (relativize-pathname-directory (default-directory)))
-              ((eql :*/) *wild-directory*)
-              ((eql :**/) *wild-inferiors*)
-              ((eql :*.*.*) *wild-file*)
-              ((eql :implementation) (implementation-identifier))
-              ((eql :implementation-type) (string-downcase (implementation-type)))
-              #+asdf-unix
-              ((eql :uid) (princ-to-string (get-uid)))))
-         (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
-         (s (if (or (pathnamep x) (not wilden)) d (wilden d))))
-    (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
-      (error (compatfmt "~@<Pathname ~S is not relative to ~S~@:>") s super))
-    (merge-pathnames* s super)))
+                      (cdr x) :directory directory :wilden wilden)
+                     car))))
+             ((eql :default-directory)
+              (relativize-pathname-directory (default-directory)))
+             ((eql :*/) *wild-directory*)
+             ((eql :**/) *wild-inferiors*)
+             ((eql :*.*.*) *wild-file*)
+             ((eql :implementation)
+              (coerce-pathname (implementation-identifier) :type :directory))
+             ((eql :implementation-type)
+              (coerce-pathname (string-downcase (implementation-type)) :type :directory)))))
+    (when (absolute-pathname-p r)
+      (error (compatfmt "~@<pathname ~S is not relative~@:>") x))
+    (if (or (pathnamep x) (not wilden)) r (wilden r))))
 
 (defvar *here-directory* nil
   "This special variable is bound to the currect directory during calls to
@@ -3199,17 +3145,19 @@
   (let* ((r
           (etypecase x
             (pathname x)
-            (string (if directory (ensure-directory-pathname x) (parse-namestring x)))
+            (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x)))
+                      #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
+                      (if directory (ensure-directory-pathname p) p)))
             (cons
              (return-from resolve-absolute-location-component
                (if (null (cdr x))
                    (resolve-absolute-location-component
                     (car x) :directory directory :wilden wilden)
-                   (let* ((car (resolve-absolute-location-component
-                                (car x) :directory t :wilden nil))
-                          (cdr (resolve-relative-location-component
-                                car (cdr x) :directory directory :wilden wilden)))
-                     (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?
+                   (merge-pathnames*
+                    (resolve-relative-location-component
+                     (cdr x) :directory directory :wilden wilden)
+                    (resolve-absolute-location-component
+                     (car x) :directory t :wilden nil)))))
             ((eql :root)
              ;; special magic! we encode such paths as relative pathnames,
              ;; but it means "relative to the root of the source pathname's host and device".
@@ -3224,15 +3172,14 @@
                           :directory t :wilden nil))
             ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
             ((eql :system-cache)
-             (warn "Using the :system-cache is deprecated. ~%~
-Please remove it from your ASDF configuration")
-             (resolve-location *system-cache* :directory t :wilden nil))
+             (error "Using the :system-cache is deprecated. ~%~
+Please remove it from your ASDF configuration"))
             ((eql :default-directory) (default-directory))))
          (s (if (and wilden (not (pathnamep x)))
                 (wilden r)
                 r)))
     (unless (absolute-pathname-p s)
-      (error (compatfmt "~@<Not an absolute pathname: ~3i~_~S~@:>") s))
+      (error (compatfmt "~@<Invalid designator for an absolute pathname: ~3i~_~S~@:>") x))
     s))
 
 (defun* resolve-location (x &key directory wilden)
@@ -3244,8 +3191,10 @@
         :for (component . morep) :on (cdr x)
         :for dir = (and (or morep directory) t)
         :for wild = (and wilden (not morep))
-        :do (setf path (resolve-relative-location-component
-                        path component :directory dir :wilden wild))
+        :do (setf path (merge-pathnames*
+                        (resolve-relative-location-component
+                         component :directory dir :wilden wild)
+                        path))
         :finally (return path))))
 
 (defun* location-designator-p (x)
@@ -3735,9 +3684,35 @@
 (defparameter *wild-asd*
   (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
 
+(defun* filter-logical-directory-results (directory entries merger)
+  (if (typep directory 'logical-pathname)
+      ;; Try hard to not resolve logical-pathname into physical pathnames;
+      ;; otherwise logical-pathname users/lovers will be disappointed.
+      ;; If directory* could use some implementation-dependent magic,
+      ;; we will have logical pathnames already; otherwise,
+      ;; we only keep pathnames for which specifying the name and
+      ;; translating the LPN commute.
+      (loop :for f :in entries
+        :for p = (or (and (typep f 'logical-pathname) f)
+                     (let* ((u (ignore-errors (funcall merger f))))
+                       (and u (equal (ignore-errors (truename u)) f) u)))
+        :when p :collect p)
+      entries))
+
+(defun* directory-files (directory &optional (pattern *wild-file*))
+  (when (wild-pathname-p directory)
+    (error "Invalid wild in ~S" directory))
+  (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
+    (error "Invalid file pattern ~S" pattern))
+  (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory)))))
+    (filter-logical-directory-results
+     directory entries
+     #'(lambda (f)
+         (make-pathname :defaults directory :version (pathname-version f)
+                        :name (pathname-name f) :type (pathname-type f))))))
+
 (defun* directory-asd-files (directory)
-  (ignore-errors
-    (directory* (merge-pathnames* *wild-asd* directory))))
+  (directory-files directory *wild-asd*))
 
 (defun* subdirectories (directory)
   (let* ((directory (ensure-directory-pathname directory))
@@ -3765,7 +3740,17 @@
                  :when d :collect #+(or abcl allegro xcl) d
                                   #+genera (ensure-directory-pathname (first x))
                                   #+(or cmu lispworks scl) x)))
-    dirs))
+    (filter-logical-directory-results
+     directory dirs
+     (let ((prefix (normalize-pathname-directory-component
+                    (pathname-directory directory))))
+       #'(lambda (d)
+           (let ((dir (normalize-pathname-directory-component
+                       (pathname-directory d))))
+             (and (consp dir) (consp (cdr dir))
+                  (make-pathname
+                   :defaults directory :name nil :type nil :version nil
+                   :directory (append prefix (last dir))))))))))
 
 (defun* collect-asds-in-directory (directory collect)
   (map () collect (directory-asd-files directory)))
@@ -3992,7 +3977,15 @@
         (register-asd-directory
          directory :recurse recurse :exclude exclude :collect
          #'(lambda (asd)
-             (let ((name (pathname-name asd)))
+             (let* ((name (pathname-name asd))
+                    (name (if (typep asd 'logical-pathname)
+                              ;; logical pathnames are upper-case,
+                              ;; at least in the CLHS and on SBCL,
+                              ;; yet (coerce-name :foo) is lower-case.
+                              ;; won't work well with (load-system "Foo")
+                              ;; instead of (load-system 'foo)
+                              (string-downcase name)
+                              name)))
                (cond
                  ((gethash name registry) ; already shadowed by something else
                   nil)




More information about the armedbear-cvs mailing list