CMUCL commit: src/contrib/asdf (asdf.lisp)
Raymond Toy
rtoy at common-lisp.net
Wed May 12 03:55:04 CEST 2010
Date: Tuesday, May 11, 2010 @ 21:55:04
Author: rtoy
Path: /project/cmucl/cvsroot/src/contrib/asdf
Modified: asdf.lisp
Update to asdf version 1.721. Primarily to get modules: added to the
default source registry.
-----------+
asdf.lisp | 107 +++++++++++++++++++++++++++---------------------------------
1 file changed, 49 insertions(+), 58 deletions(-)
Index: src/contrib/asdf/asdf.lisp
diff -u src/contrib/asdf/asdf.lisp:1.1 src/contrib/asdf/asdf.lisp:1.2
--- src/contrib/asdf/asdf.lisp:1.1 Mon May 10 15:30:40 2010
+++ src/contrib/asdf/asdf.lisp Tue May 11 21:55:03 2010
@@ -49,8 +49,8 @@
(cl:in-package :cl-user)
-(declaim (optimize (speed 2) (debug 2) (safety 3))
- #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
+#|(declaim (optimize (speed 2) (debug 2) (safety 3))
+#+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))|#
#+ecl (require :cmp)
@@ -70,7 +70,7 @@
:test 'equalp :key 'car))
(let* ((asdf-version
;; the 1+ helps the version bumping script discriminate
- (subseq "VERSION:1.718" (1+ (length "VERSION"))))
+ (subseq "VERSION:1.721" (1+ (length "VERSION"))))
(existing-asdf (find-package :asdf))
(vername '#:*asdf-version*)
(versym (and existing-asdf
@@ -593,7 +593,7 @@
(last-comp (car (last components))))
(multiple-value-bind (relative components)
(if (equal (first components) "")
- (if (and (plusp (length s)) (eql (char s 0) #\/))
+ (if (equal (first-char s) #\/)
(values :absolute (cdr components))
(values :relative nil))
(values :relative components))
@@ -626,7 +626,7 @@
#+sbcl
(sb-ext:posix-getenv x)
#+clozure
- (ccl::getenv x)
+ (ccl:getenv x)
#+clisp
(ext:getenv x)
#+cmu
@@ -1174,7 +1174,7 @@
(defmethod find-component ((component component) (name symbol))
(if name
- (find-component component (string name))
+ (find-component component (coerce-name name))
component))
(defmethod find-component ((module module) (name cons))
@@ -1947,24 +1947,21 @@
;;;; -------------------------------------------------------------------------
;;;; Defsystem
+(defun load-pathname ()
+ (let ((pn (or *load-pathname* *compile-file-pathname*)))
+ (if *resolve-symlinks*
+ (and pn (resolve-symlinks pn))
+ pn)))
+
(defun determine-system-pathname (pathname pathname-supplied-p)
- ;; called from the defsystem macro.
- ;; the pathname of a system is either
+ ;; The defsystem macro calls us to determine
+ ;; the pathname of a system as follows:
;; 1. the one supplied,
- ;; 2. derived from the *load-truename* (see below), or
- ;; 3. taken from *default-pathname-defaults*
- ;;
- ;; if using *load-truename*, then we also deal with whether or not
- ;; to resolve symbolic links. If not resolving symlinks, then we use
- ;; *load-pathname* instead of *load-truename* since in some
- ;; implementations, the latter has *already resolved it.
- (let ((file-pathname
- (when (or *load-pathname* *compile-file-pathname*)
- (pathname-directory-pathname
- (if *resolve-symlinks*
- (resolve-symlinks (or *load-truename* *compile-file-truename*))
- *load-pathname*)))))
- (or (and pathname-supplied-p (merge-pathnames* pathname file-pathname))
+ ;; 2. derived from *load-pathname* via load-pathname
+ ;; 3. taken from the *default-pathname-defaults* via current-directory
+ (let* ((file-pathname (load-pathname))
+ (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
+ (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
file-pathname
(current-directory))))
@@ -1987,7 +1984,7 @@
(t
(register-system (quote ,name)
(make-instance ',class :name ',name))))
- (%set-system-source-file *load-truename*
+ (%set-system-source-file (load-pathname)
(cdr (system-registered-p ',name))))
(parse-component-form
nil (list*
@@ -2402,9 +2399,7 @@
#+(and (or win32 windows mswindows mingw32) (not cygwin))
,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
- #+(not cygwin)
- ,(try (or (getenv "USERPROFILE") (user-homedir))
- "Application Data/common-lisp/config/"))
+ ,(try (getenv "APPDATA") "common-lisp/config/"))
,(try (user-homedir) ".config/common-lisp/")))))
(defun system-configuration-directories ()
(remove-if
@@ -2451,10 +2446,15 @@
(error "One and only one form allowed for ~A. Got: ~S~%" description forms))
(funcall validator (car forms))))
+(defun hidden-file-p (pathname)
+ (equal (first-char (pathname-name pathname)) #\.))
+
(defun validate-configuration-directory (directory tag validator)
(let ((files (sort (ignore-errors
- (directory (make-pathname :name :wild :type :wild :defaults directory)
- #+sbcl :resolve-symlinks #+sbcl nil))
+ (remove-if
+ 'hidden-file-p
+ (directory (make-pathname :name :wild :type "conf" :defaults directory)
+ #+sbcl :resolve-symlinks #+sbcl nil)))
#'string< :key #'namestring)))
`(,tag
,@(loop :for file :in files :append
@@ -2476,27 +2476,16 @@
and the order is by decreasing length of namestring of the source pathname.")
(defvar *user-cache*
- (or
- (let ((h (getenv "XDG_CACHE_HOME")))
- (and h `(,h "common-lisp" :implementation)))
- #+(and windows lispworks)
- (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows???
- (and h `(,h "common-lisp" "cache")))
- #+(and (or win32 windows mswindows mingw32) (not cygwin))
- ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Cache
- (let ((h (or (getenv "USERPROFILE") (user-homedir))))
- (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp")))
- '(:home ".cache" "common-lisp" :implementation)))
+ (flet ((try (x &rest sub) (and x `(,x , at sub))))
+ (or
+ (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
+ #+(and (or win32 windows mswindows mingw32) (not cygwin))
+ (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
+ '(:home ".cache" "common-lisp" :implementation))))
(defvar *system-cache*
- (or
- #+(and windows lispworks)
- (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows???
- (and h `(,h "common-lisp" "cache")))
- #+(and (or win32 windows mswindows mingw32) (not cygwin))
- (let ((h (or (getenv "USERPROFILE") (user-homedir))))
- (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp")))
- #+(or unix cygwin)
- '("/var/cache/common-lisp" :uid :implementation)))
+ ;; No good default, plus there's a security problem
+ ;; with other users messing with such directories.
+ *user-cache*)
(defun output-translations ()
(car *output-translations*))
@@ -2576,6 +2565,7 @@
(relativize-pathname-directory (current-directory)))
((eql :implementation) (implementation-identifier))
((eql :implementation-type) (string-downcase (implementation-type)))
+ #-(and (or win32 windows mswindows mingw32) (not cygwin))
((eql :uid) (princ-to-string (get-uid)))))
(d (if (pathnamep x) r (ensure-directory-pathname r)))
(s (if (and wildenp (not (pathnamep x)))
@@ -2690,8 +2680,8 @@
;; Some implementations have precompiled ASDF systems,
;; so we must disable translations for implementation paths.
#+sbcl (,(getenv "SBCL_HOME") ())
- #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually.
- #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system
+ #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
+ #+clozure (,(wilden (truename #p"ccl:")) ()) ; not needed: no precompiled ASDF system
;; All-import, here is where we want user stuff to be:
:inherit-configuration
;; These are for convenience, and can be overridden by the user:
@@ -2842,6 +2832,9 @@
(translate-pathname p absolute-source destination)))
:finally (return p)))))
+(defun first-char (s)
+ (and (stringp s) (plusp (length s)) (char s 0)))
+
(defun last-char (s)
(and (stringp s) (plusp (length s)) (char s (1- (length s)))))
@@ -3154,6 +3147,7 @@
(defun wrapping-source-registry ()
`(:source-registry
+ #+cmu (:tree #p"modules:")
#+sbcl (:tree ,(getenv "SBCL_HOME"))
:inherit-configuration))
(defun default-source-registry ()
@@ -3170,10 +3164,7 @@
(or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
(dirs (cons datahome (split-string datadirs :separator ":"))))
#+(and (or win32 windows mswindows mingw32) (not cygwin))
- ((datahome
- #+lispworks (sys:get-folder-path :common-appdata)
- #-lispworks (try (or (getenv "USERPROFILE") (user-homedir))
- "Application Data"))
+ ((datahome (getenv "APPDATA"))
(datadir
#+lispworks (sys:get-folder-path :local-appdata)
#-lispworks (try (getenv "ALLUSERSPROFILE")
@@ -3290,16 +3281,16 @@
((style-warning #'muffle-warning)
(missing-component (constantly nil))
(error (lambda (e)
- (format *error-output* "ASDF could not load ~A because ~A.~%"
+ (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
name e))))
(let* ((*verbose-out* (make-broadcast-stream))
- (system (find-system name nil)))
+ (system (find-system (string-downcase name) nil)))
(when system
- (load-system name)
+ (load-system system)
t))))
(pushnew 'module-provide-asdf
#+abcl sys::*module-provider-functions*
- #+clozure ccl::*module-provider-functions*
+ #+clozure ccl:*module-provider-functions*
#+cmu ext:*module-provider-functions*
#+ecl si:*module-provider-functions*
#+sbcl sb-ext:*module-provider-functions*))
More information about the cmucl-commit
mailing list