[cmucl-commit] CMUCL commit: src (contrib/asdf/asdf.lisp general-info/release-20c.txt)

Raymond Toy rtoy at common-lisp.net
Tue Aug 23 06:16:04 CEST 2011


    Date: Monday, August 22, 2011 @ 21:16:04
  Author: rtoy
    Path: /project/cmucl/cvsroot/src

Modified: contrib/asdf/asdf.lisp general-info/release-20c.txt

contrib/asdf/asdf.lisp
general-info/release-20c.txt
o Update to asdf2 2.017.


------------------------------+
 contrib/asdf/asdf.lisp       |  518 ++++++++++++++++++++---------------------
 general-info/release-20c.txt |    2 
 2 files changed, 260 insertions(+), 260 deletions(-)


Index: src/contrib/asdf/asdf.lisp
diff -u src/contrib/asdf/asdf.lisp:1.15 src/contrib/asdf/asdf.lisp:1.16
--- src/contrib/asdf/asdf.lisp:1.15	Wed Jun  8 08:42:22 2011
+++ src/contrib/asdf/asdf.lisp	Mon Aug 22 21:16:04 2011
@@ -1,5 +1,5 @@
 ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.016: 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,6 +62,11 @@
         (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 ;; 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*))
   #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
   #+(or unix cygwin) (pushnew :asdf-unix *features*)
   ;;; make package if it doesn't exist yet.
@@ -84,14 +89,15 @@
   ;; Strip out formatting that is not supported on Genera.
   ;; Has to be inside the eval-when to make Lispworks happy (!)
   (defmacro compatfmt (format)
-    #-genera format
-    #+genera
+    #-(or gcl genera) format
+    #+(or gcl genera)
     (loop :for (unsupported . replacement) :in
-      '(("~@<" . "")
-        ("; ~@;" . "; ")
-        ("~3i~_" . "")
-        ("~@:>" . "")
-        ("~:>" . "")) :do
+      `(("~3i~_" . "")
+        #+genera
+        ,@(("~@<" . "")
+           ("; ~@;" . "; ")
+           ("~@:>" . "")
+           ("~:>" . ""))) :do
       (loop :for found = (search unsupported format) :while found :do
         (setf format
               (concatenate 'simple-string
@@ -106,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")
+         (asdf-version "2.017")
          (existing-asdf (find-class 'component nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
@@ -194,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
@@ -207,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.
@@ -342,7 +350,6 @@
             ;; #:ends-with
             #:ensure-directory-pathname
             #:getenv
-            ;; #:get-uid
             ;; #:length=n-p
             ;; #:find-symbol*
             #:merge-pathnames*
@@ -367,12 +374,6 @@
 ;;;; -------------------------------------------------------------------------
 ;;;; User-visible parameters
 ;;;;
-(defun asdf-version ()
-  "Exported interface to the version of ASDF currently installed. A string.
-You can compare this string with e.g.:
-(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
-  *asdf-version*)
-
 (defvar *resolve-symlinks* t
   "Determine whether or not ASDF resolves symlinks when defining systems.
 
@@ -415,27 +416,37 @@
                 condition-arguments condition-form
                 condition-format condition-location
                 coerce-name)
-         #-cormanlisp
+         #-(or cormanlisp gcl-pre2.7)
          (ftype (function (t t) t) (setf module-components-by-name)))
 
 ;;;; -------------------------------------------------------------------------
-;;;; Compatibility with Corman Lisp
+;;;; Compatibility various implementations
 #+cormanlisp
 (progn
   (deftype logical-pathname () nil)
-  (defun make-broadcast-stream () *error-output*)
-  (defun file-namestring (p)
+  (defun* make-broadcast-stream () *error-output*)
+  (defun* file-namestring (p)
     (setf p (pathname p))
-    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))
-  (defparameter *count* 3)
-  (defun dbg (&rest x)
-    (format *error-output* "~S~%" x)))
-#+cormanlisp
-(defun maybe-break ()
-  (decf *count*)
-  (unless (plusp *count*)
-    (setf *count* 3)
-    (break)))
+    (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
@@ -444,7 +455,7 @@
     ((defdef (def* def)
        `(defmacro ,def* (name formals &rest rest)
           `(progn
-             #+(or ecl gcl) (fmakunbound ',name)
+             #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
              #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
              ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
                 `(declaim (notinline ,name)))
@@ -515,8 +526,11 @@
               :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
 
 (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
-  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
-does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
+  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
+if the SPECIFIED pathname does not have an absolute directory,
+then the HOST and DEVICE both come from the DEFAULTS, whereas
+if the SPECIFIED pathname does have an absolute directory,
+then the HOST and DEVICE both come from the SPECIFIED.
 Also, if either argument is NIL, then the other argument is returned unmodified."
   (when (null specified) (return-from merge-pathnames* defaults))
   (when (null defaults) (return-from merge-pathnames* specified))
@@ -559,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.
 
@@ -660,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)
@@ -730,7 +739,7 @@
 
 #+genera
 (unless (fboundp 'ensure-directories-exist)
-  (defun ensure-directories-exist (path)
+  (defun* ensure-directories-exist (path)
     (fs:create-directories-recursively (pathname path))))
 
 (defun* absolute-pathname-p (pathspec)
@@ -760,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
@@ -798,22 +783,25 @@
     (null nil)
     (string (probe-file* (parse-namestring p)))
     (pathname (unless (wild-pathname-p p)
-                #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p)
+                #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks sbcl scl)
+                      '(probe-file p)
                       #+clisp (aif (find-symbol* '#:probe-pathname :ext)
                                    `(ignore-errors (,it p)))
                       '(ignore-errors (truename p)))))))
 
-(defun* truenamize (p)
+(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*))
   "Resolve as much of a pathname as possible"
   (block nil
-    (when (typep p '(or null logical-pathname)) (return p))
-    (let* ((p (merge-pathnames* p))
-           (directory (pathname-directory p)))
+    (when (typep pathname '(or null logical-pathname)) (return pathname))
+    (let ((p (merge-pathnames* pathname defaults)))
       (when (typep p 'logical-pathname) (return p))
       (let ((found (probe-file* p)))
         (when found (return found)))
-      #-(or cmu sbcl scl) (when (stringp directory) (return p))
-      (when (not (eq :absolute (car directory))) (return p))
+      (unless (absolute-pathname-p p)
+        (let ((true-defaults (ignore-errors (truename defaults))))
+          (when true-defaults
+            (setf p (merge-pathnames pathname true-defaults)))))
+      (unless (absolute-pathname-p p) (return p))
       (let ((sofar (probe-file* (pathname-root p))))
         (unless sofar (return p))
         (flet ((solution (directories)
@@ -824,7 +812,9 @@
                                  :type (pathname-type p)
                                  :version (pathname-version p))
                   sofar)))
-          (loop :for component :in (cdr directory)
+          (loop :with directory = (normalize-pathname-directory-component
+                                   (pathname-directory p))
+            :for component :in (cdr directory)
             :for rest :on (cdr directory)
             :for more = (probe-file*
                          (merge-pathnames*
@@ -847,7 +837,7 @@
       (and path (resolve-symlinks path))
       path))
 
-(defun ensure-pathname-absolute (path)
+(defun* ensure-pathname-absolute (path)
   (cond
     ((absolute-pathname-p path) path)
     ((stringp path) (ensure-pathname-absolute (pathname path)))
@@ -877,7 +867,7 @@
   (merge-pathnames* *wild-path* path))
 
 #-scl
-(defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
+(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
   (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
     (last-char (namestring foo))))
 
@@ -961,7 +951,7 @@
 
 (defgeneric* (setf component-property) (new-value component property))
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-gcl :compile-toplevel :load-toplevel :execute)
   (defgeneric* (setf module-components-by-name) (new-value module)))
 
 (defgeneric* version-satisfies (component version))
@@ -1270,8 +1260,8 @@
       (slot-value component 'absolute-pathname)
       (let ((pathname
              (merge-pathnames*
-             (component-relative-pathname component)
-             (pathname-directory-pathname (component-parent-pathname component)))))
+              (component-relative-pathname component)
+              (pathname-directory-pathname (component-parent-pathname component)))))
         (unless (or (null pathname) (absolute-pathname-p pathname))
           (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
                  pathname (component-find-path component)))
@@ -1312,7 +1302,13 @@
     (return-from version-satisfies t))
   (version-satisfies (component-version c) version))
 
-(defun parse-version (string &optional on-error)
+(defun* asdf-version ()
+  "Exported interface to the version of ASDF currently installed. A string.
+You can compare this string with e.g.:
+(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
+  *asdf-version*)
+
+(defun* parse-version (string &optional on-error)
   "Parse a version string as a series of natural integers separated by dots.
 Return a (non-null) list of integers if the string is valid, NIL otherwise.
 If on-error is error, warn, or designates a function of compatible signature,
@@ -1427,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))
@@ -2113,7 +2107,7 @@
    (flags :initarg :flags :accessor compile-op-flags
           :initform nil)))
 
-(defun output-file (operation component)
+(defun* output-file (operation component)
   "The unique output file of performing OPERATION on COMPONENT"
   (let ((files (output-files operation component)))
     (assert (length=n-p files 1))
@@ -2144,8 +2138,8 @@
         (*compile-file-warnings-behaviour* (operation-on-warnings operation))
         (*compile-file-failure-behaviour* (operation-on-failure operation)))
     (multiple-value-bind (output warnings-p failure-p)
-        (apply *compile-op-compile-file-function* source-file :output-file output-file
-               (compile-op-flags operation))
+        (apply *compile-op-compile-file-function* source-file
+               :output-file output-file (compile-op-flags operation))
       (unless output
         (error 'compile-error :component c :operation operation))
       (when failure-p
@@ -2366,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)
@@ -2602,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
@@ -2663,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)))
@@ -2747,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)
 
@@ -2761,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
@@ -2769,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")))
 
 ;;;; ---------------------------------------------------------------------------
@@ -2807,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
@@ -2836,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)))))
 
 
 ;;; ---------------------------------------------------------------------------
@@ -2948,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
@@ -3121,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*))
@@ -3155,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
@@ -3194,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".
@@ -3219,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)
@@ -3239,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)
@@ -3523,11 +3477,13 @@
 
 (defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
   (if (absolute-pathname-p output-file)
-      (apply 'compile-file-pathname (lispize-pathname input-file) keys)
+      ;; what cfp should be doing, w/ mp* instead of mp
+      (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys)))
+             (defaults (make-pathname
+                        :type type :defaults (merge-pathnames* input-file))))
+        (merge-pathnames* output-file defaults))
       (apply-output-translations
-       (apply 'compile-file-pathname
-              (truenamize (lispize-pathname input-file))
-              keys))))
+       (apply 'compile-file-pathname input-file keys))))
 
 (defun* tmpize-pathname (x)
   (make-pathname
@@ -3728,11 +3684,37 @@
 (defparameter *wild-asd*
   (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
 
-(defun directory-asd-files (directory)
-  (ignore-errors
-    (directory* (merge-pathnames* *wild-asd* directory))))
+(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)
+  (directory-files directory *wild-asd*))
 
-(defun subdirectories (directory)
+(defun* subdirectories (directory)
   (let* ((directory (ensure-directory-pathname directory))
          #-(or abcl cormanlisp genera xcl)
          (wild (merge-pathnames*
@@ -3758,19 +3740,29 @@
                  :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)
+(defun* collect-asds-in-directory (directory collect)
   (map () collect (directory-asd-files directory)))
 
-(defun collect-sub*directories (directory collectp recursep collector)
+(defun* collect-sub*directories (directory collectp recursep collector)
   (when (funcall collectp directory)
     (funcall collector directory))
   (dolist (subdir (subdirectories directory))
     (when (funcall recursep subdir)
       (collect-sub*directories subdir collectp recursep collector))))
 
-(defun collect-sub*directories-asd-files
+(defun* collect-sub*directories-asd-files
     (directory &key
      (exclude *default-source-registry-exclusions*)
      collect)
@@ -3985,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)
Index: src/general-info/release-20c.txt
diff -u src/general-info/release-20c.txt:1.29 src/general-info/release-20c.txt:1.30
--- src/general-info/release-20c.txt:1.29	Sun Aug 21 08:16:01 2011
+++ src/general-info/release-20c.txt	Mon Aug 22 21:16:04 2011
@@ -28,7 +28,7 @@
       with all features available, except only Unicode is supported.
 
   * Changes
-    - ASDF2 updated to version 2.016.
+    - ASDF2 updated to version 2.017.
     - COMPILE-FILE now accepts a :DECODING-ERROR argument that
       indicates how to handle decoding errors when reading the file.
       It has the same meaning and effect as the :DECODING-ERROR


More information about the cmucl-commit mailing list