[armedbear-cvs] r13418 - in branches/0.26.x/abcl: doc/asdf src/org/armedbear/lisp
mevenson at common-lisp.net
mevenson at common-lisp.net
Wed Jul 27 06:49:22 UTC 2011
Author: mevenson
Date: Tue Jul 26 23:49:22 2011
New Revision: 13418
Log:
Backport r13417: Upgrade to asdf-2.017.
Modified:
branches/0.26.x/abcl/doc/asdf/asdf.texinfo
branches/0.26.x/abcl/src/org/armedbear/lisp/asdf.lisp
Modified: branches/0.26.x/abcl/doc/asdf/asdf.texinfo
==============================================================================
--- branches/0.26.x/abcl/doc/asdf/asdf.texinfo Tue Jul 26 23:44:50 2011 (r13417)
+++ branches/0.26.x/abcl/doc/asdf/asdf.texinfo Tue Jul 26 23:49:22 2011 (r13418)
@@ -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: branches/0.26.x/abcl/src/org/armedbear/lisp/asdf.lisp
==============================================================================
--- branches/0.26.x/abcl/src/org/armedbear/lisp/asdf.lisp Tue Jul 26 23:44:50 2011 (r13417)
+++ branches/0.26.x/abcl/src/org/armedbear/lisp/asdf.lisp Tue Jul 26 23:49:22 2011 (r13418)
@@ -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