[cmucl-cvs] CMUCL commit: src (contrib/asdf/asdf.lisp general-info/release-20c.txt)
Raymond Toy
rtoy at common-lisp.net
Tue Aug 23 04:16:04 UTC 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-cvs
mailing list