[cmucl-cvs] CMUCL commit: src/contrib/asdf (asdf.lisp)
Raymond Toy
rtoy at common-lisp.net
Thu Mar 24 16:40:59 UTC 2011
Date: Thursday, March 24, 2011 @ 12:40:59
Author: rtoy
Path: /project/cmucl/cvsroot/src/contrib/asdf
Modified: asdf.lisp
Update to upstream released version 2.013.
-----------+
asdf.lisp | 870 +++++++++++++++++++++++++++++++++++-------------------------
1 file changed, 520 insertions(+), 350 deletions(-)
Index: src/contrib/asdf/asdf.lisp
diff -u src/contrib/asdf/asdf.lisp:1.11 src/contrib/asdf/asdf.lisp:1.12
--- src/contrib/asdf/asdf.lisp:1.11 Wed Dec 8 18:57:02 2010
+++ src/contrib/asdf/asdf.lisp Thu Mar 24 12:40:59 2011
@@ -1,5 +1,5 @@
-;;; -*- mode: common-lisp; package: asdf; -*-
-;;; This is ASDF: Another System Definition Facility.
+;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
+;;; This is ASDF 2.013: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel at common-lisp.net>.
@@ -10,9 +10,9 @@
;;; trouble using it, or find bugs, you may want to check at the
;;; location above for a more recent version (and for documentation
;;; and test files, if your copy came without them) before reporting
-;;; bugs. There are usually two "supported" revisions - the git HEAD
-;;; is the latest development version, whereas the revision tagged
-;;; RELEASE may be slightly older but is considered `stable'
+;;; bugs. There are usually two "supported" revisions - the git master
+;;; branch is the latest development version, whereas the git release
+;;; branch may be slightly older but is considered `stable'
;;; -- LICENSE START
;;; (This is the MIT / X Consortium license as taken from
@@ -47,7 +47,7 @@
#+xcvb (module ())
-(cl:in-package :cl-user)
+(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)
#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
@@ -55,14 +55,16 @@
;;; make package if it doesn't exist yet.
;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
(unless (find-package :asdf)
- (make-package :asdf :use '(:cl)))
+ (make-package :asdf :use '(:common-lisp)))
;;; Implementation-dependent tweaks
;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
#+allegro
(setf excl::*autoload-package-name-alist*
(remove "asdf" excl::*autoload-package-name-alist*
:test 'equalp :key 'car))
- #+ecl (require :cmp))
+ #+(and ecl (not ecl-bytecmp)) (require :cmp)
+ #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
+ #+(or unix cygwin) (pushnew :asdf-unix *features*))
(in-package :asdf)
@@ -74,25 +76,35 @@
(defvar *asdf-version* nil)
(defvar *upgraded-p* nil)
(let* (;; For bug reporting sanity, please always bump this version when you modify this file.
+ ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
+ ;; can help you do these changes in synch (look at the source for documentation).
+ ;; Relying on its automation, the version is now redundantly present on top of this file.
;; "2.345" would be an official release
;; "2.345.6" would be a development version in the official upstream
- ;; "2.345.0.7" would be your local modification of an official release
- ;; "2.345.6.7" would be your local modification of a development version
- (asdf-version "2.011")
+ ;; "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.013")
(existing-asdf (fboundp 'find-system))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
(unless (and existing-asdf already-there)
(when existing-asdf
(format *trace-output*
- "~&~@<; ~@;Upgrading ASDF package ~@[from version ~A ~]to version ~A~@:>~%"
+ "~&; Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
existing-version asdf-version))
(labels
- ((unlink-package (package)
+ ((present-symbol-p (symbol package)
+ (member (nth-value 1 (find-symbol symbol package)) '(:internal :external)))
+ (present-symbols (package)
+ ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
+ (let (l)
+ (do-symbols (s package)
+ (when (present-symbol-p s package) (push s l)))
+ (reverse l)))
+ (unlink-package (package)
(let ((u (find-package package)))
(when u
- (ensure-unintern u
- (loop :for s :being :each :present-symbol :in u :collect s))
+ (ensure-unintern u (present-symbols u))
(loop :for p :in (package-used-by-list u) :do
(unuse-package u p))
(delete-package u))))
@@ -146,7 +158,7 @@
(let ((formerly-exported-symbols nil)
(bothly-exported-symbols nil)
(newly-exported-symbols nil))
- (loop :for sym :being :each :external-symbol :in package :do
+ (do-external-symbols (sym package)
(if (member sym export :test 'string-equal)
(push sym bothly-exported-symbols)
(push sym formerly-exported-symbols)))
@@ -184,7 +196,8 @@
(#:perform #:explain #:output-files #:operation-done-p
#:perform-with-restarts #:component-relative-pathname
#:system-source-file #:operate #:find-component #:find-system
- #:apply-output-translations #:translate-pathname* #:resolve-location)
+ #:apply-output-translations #:translate-pathname* #:resolve-location
+ #:compile-file*)
:unintern
(#:*asdf-revision* #:around #:asdf-method-combination
#:split #:make-collector
@@ -276,6 +289,7 @@
#:remove-entry-from-registry
#:clear-configuration
+ #:*output-translations-parameter*
#:initialize-output-translations
#:disable-output-translations
#:clear-output-translations
@@ -285,6 +299,7 @@
#:compile-file-pathname*
#:enable-asdf-binary-locations-compatibility
#:*default-source-registries*
+ #:*source-registry-parameter*
#:initialize-source-registry
#:compute-source-registry
#:clear-source-registry
@@ -306,6 +321,7 @@
;; #:length=n-p
;; #:find-symbol*
#:merge-pathnames*
+ #:coerce-pathname
#:pathname-directory-pathname
#:read-file-forms
;; #:remove-keys
@@ -317,6 +333,7 @@
#:subdirectories
#:truenamize
#:while-collecting)))
+ #+genera (import 'scl:boolean :asdf)
(setf *asdf-version* asdf-version
*upgraded-p* (if existing-version
(cons existing-version *upgraded-p*)
@@ -328,7 +345,7 @@
(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.000\")."
+(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.013\")."
*asdf-version*)
(defvar *resolve-symlinks* t
@@ -403,6 +420,41 @@
(when pathname
(make-pathname :name nil :type nil :version nil :defaults pathname)))
+(defun* normalize-pathname-directory-component (directory)
+ (cond
+ #-(or sbcl cmu)
+ ((stringp directory) `(:absolute ,directory) directory)
+ #+gcl
+ ((and (consp directory) (stringp (first directory)))
+ `(:absolute , at directory))
+ ((or (null directory)
+ (and (consp directory) (member (first directory) '(:absolute :relative))))
+ directory)
+ (t
+ (error "Unrecognized pathname directory component ~S" directory))))
+
+(defun* merge-pathname-directory-components (specified defaults)
+ (let ((directory (normalize-pathname-directory-component specified)))
+ (ecase (first directory)
+ ((nil) defaults)
+ (:absolute specified)
+ (:relative
+ (let ((defdir (normalize-pathname-directory-component defaults))
+ (reldir (cdr directory)))
+ (cond
+ ((null defdir)
+ directory)
+ ((not (eq :back (first reldir)))
+ (append defdir reldir))
+ (t
+ (loop :with defabs = (first defdir)
+ :with defrev = (reverse (rest defdir))
+ :while (and (eq :back (car reldir))
+ (or (and (eq :absolute defabs) (null defrev))
+ (stringp (car defrev))))
+ :do (pop reldir) (pop defrev)
+ :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.
@@ -411,19 +463,7 @@
(when (null defaults) (return-from merge-pathnames* specified))
(let* ((specified (pathname specified))
(defaults (pathname defaults))
- (directory (pathname-directory specified))
- (directory
- (cond
- #-(or sbcl cmu scl)
- ((stringp directory) `(:absolute ,directory) directory)
- #+gcl
- ((and (consp directory) (not (member (first directory) '(:absolute :relative))))
- `(:relative , at directory))
- ((or (null directory)
- (and (consp directory) (member (first directory) '(:absolute :relative))))
- directory)
- (t
- (error "Unrecognized directory component ~S in pathname ~S" directory specified))))
+ (directory (normalize-pathname-directory-component (pathname-directory specified)))
(name (or (pathname-name specified) (pathname-name defaults)))
(type (or (pathname-type specified) (pathname-type defaults)))
(version (or (pathname-version specified) (pathname-version defaults))))
@@ -433,28 +473,30 @@
(if (typep p 'logical-pathname) #'ununspecific #'identity)))
(multiple-value-bind (host device directory unspecific-handler)
(ecase (first directory)
- ((nil)
- (values (pathname-host defaults)
- (pathname-device defaults)
- (pathname-directory defaults)
- (unspecific-handler defaults)))
((:absolute)
(values (pathname-host specified)
(pathname-device specified)
directory
(unspecific-handler specified)))
- ((:relative)
+ ((nil :relative)
(values (pathname-host defaults)
(pathname-device defaults)
- (if (pathname-directory defaults)
- (append (pathname-directory defaults) (cdr directory))
- directory)
+ (merge-pathname-directory-components directory (pathname-directory defaults))
(unspecific-handler defaults))))
(make-pathname :host host :device device :directory directory
:name (funcall unspecific-handler name)
:type (funcall unspecific-handler type)
:version (funcall unspecific-handler version))))))
+(defun* pathname-parent-directory-pathname (pathname)
+ "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
+and NIL NAME, TYPE and VERSION components"
+ (when pathname
+ (make-pathname :name nil :type nil :version nil
+ :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname))
+ :defaults pathname)))
+
+
(define-modify-macro appendf (&rest args)
append "Append onto list") ;; only to be used on short lists.
@@ -467,9 +509,15 @@
(defun* last-char (s)
(and (stringp s) (plusp (length s)) (char s (1- (length s)))))
+(defun* errfmt (out format-string &rest format-args)
+ (declare (dynamic-extent format-args))
+ (apply #'format out
+ #-genera (format nil "~~@<~A~~:>" format-string) #+genera format-string
+ format-args))
+
(defun* asdf-message (format-string &rest format-args)
(declare (dynamic-extent format-args))
- (apply #'format *verbose-out* format-string format-args))
+ (apply #'errfmt *verbose-out* format-string format-args))
(defun* split-string (string &key max (separator '(#\Space #\Tab)))
"Split STRING into a list of components separated by
@@ -496,7 +544,7 @@
;; Giving :unspecific as argument to make-pathname is not portable.
;; See CLHS make-pathname and 19.2.2.2.3.
;; We only use it on implementations that support it.
- (or #+(or ccl ecl gcl lispworks sbcl) :unspecific)))
+ (or #+(or clozure gcl lispworks sbcl) :unspecific)))
(destructuring-bind (name &optional (type unspecific))
(split-string filename :max 2 :separator ".")
(if (equal name "")
@@ -533,7 +581,8 @@
(values :absolute (cdr components)))
(values :relative nil))
(values :relative components))
- (setf components (remove "" components :test #'equal))
+ (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))
+ (setf components (substitute :back ".." components :test #'equal))
(cond
((equal last-comp "")
(values relative components nil)) ; "" already removed
@@ -553,16 +602,27 @@
: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)
- (#+(or abcl clisp) ext:getenv
- #+allegro sys:getenv
- #+clozure ccl:getenv
- #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=)))
- #+ecl si:getenv
- #+gcl system:getenv
- #+lispworks lispworks:environment-variable
- #+sbcl sb-ext:posix-getenv
- x))
+ (declare (ignorable x))
+ #+(or abcl clisp) (ext:getenv x)
+ #+allegro (sys:getenv x)
+ #+clozure (ccl:getenv x)
+ #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
+ #+ecl (si:getenv x)
+ #+gcl (system:getenv x)
+ #+genera nil
+ #+lispworks (lispworks:environment-variable x)
+ #+mcl (ccl:with-cstrs ((name x))
+ (let ((value (_getenv name)))
+ (unless (ccl:%null-ptr-p value)
+ (ccl:%get-cstring value))))
+ #+sbcl (sb-ext:posix-getenv x)
+ #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl)
+ (error "getenv not available on your implementation"))
(defun* directory-pathname-p (pathname)
"Does PATHNAME represent a directory?
@@ -600,6 +660,11 @@
:name nil :type nil :version nil
:defaults pathspec))))
+#+genera
+(unless (fboundp 'ensure-directories-exist)
+ (defun ensure-directories-exist (path)
+ (fs:create-directories-recursively (pathname path))))
+
(defun* absolute-pathname-p (pathspec)
(and (typep pathspec '(or pathname string))
(eq :absolute (car (pathname-directory (pathname pathspec))))))
@@ -627,7 +692,7 @@
:until (eq form eof)
:collect form)))
-#-(and (or win32 windows mswindows mingw32) (not cygwin))
+#+asdf-unix
(progn
#+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
'(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
@@ -667,13 +732,13 @@
(string (probe-file* (parse-namestring p)))
(pathname (unless (wild-pathname-p p)
#.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
- #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))
- '(ignore-errors (truename p)))))))
+ #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))
+ '(ignore-errors (truename p)))))))
(defun* truenamize (p)
"Resolve as much of a pathname as possible"
(block nil
- (when (typep p 'logical-pathname) (return p))
+ (when (typep p '(or null logical-pathname)) (return p))
(let* ((p (merge-pathnames* p))
(directory (pathname-directory p)))
(when (typep p 'logical-pathname) (return p))
@@ -705,7 +770,9 @@
(defun* resolve-symlinks (path)
#-allegro (truenamize path)
- #+allegro (excl:pathname-resolve-symbolic-links path))
+ #+allegro (if (typep path 'logical-pathname)
+ path
+ (excl:pathname-resolve-symbolic-links path)))
(defun* default-directory ()
(truenamize (pathname-directory-pathname *default-pathname-defaults*)))
@@ -713,24 +780,32 @@
(defun* lispize-pathname (input-file)
(make-pathname :type "lisp" :defaults input-file))
+(defparameter *wild-file*
+ (make-pathname :name :wild :type :wild :version :wild :directory nil))
+(defparameter *wild-directory*
+ (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil))
+(defparameter *wild-inferiors*
+ (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
(defparameter *wild-path*
- (make-pathname :directory '(:relative :wild-inferiors)
- :name :wild :type :wild :version :wild))
+ (merge-pathnames *wild-file* *wild-inferiors*))
(defun* wilden (path)
(merge-pathnames* *wild-path* path))
+(defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
+ (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
+ (last-char (namestring foo))))
+
(defun* directorize-pathname-host-device (pathname)
(let* ((root (pathname-root pathname))
(wild-root (wilden root))
(absolute-pathname (merge-pathnames* pathname root))
- (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
- (separator (last-char (namestring foo)))
+ (separator (directory-separator-for-host root))
(root-namestring (namestring root))
(root-string
(substitute-if #\/
- (lambda (x) (or (eql x #\:)
- (eql x separator)))
+ #'(lambda (x) (or (eql x #\:)
+ (eql x separator)))
root-namestring)))
(multiple-value-bind (relative path filename)
(component-name-to-pathname-components root-string :force-directory t)
@@ -849,24 +924,21 @@
;;;; -------------------------------------------------------------------------
;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
(when *upgraded-p*
- #+ecl
- (when (find-class 'compile-op nil)
- (defmethod update-instance-for-redefined-class :after
- ((c compile-op) added deleted plist &key)
- (declare (ignore added deleted))
- (let ((system-p (getf plist 'system-p)))
- (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
(when (find-class 'module nil)
(eval
`(defmethod update-instance-for-redefined-class :after
((m module) added deleted plist &key)
(declare (ignorable deleted plist))
(when (or *asdf-verbose* *load-verbose*)
- (asdf-message "~&~@<; ~@; Updating ~A for ASDF ~A~@:>~%" m ,(asdf-version)))
+ (asdf-message "~&; Updating ~A for ASDF ~A~%" m ,(asdf-version)))
(when (member 'components-by-name added)
(compute-module-components-by-name m))
- (when (and (typep m 'system) (member 'source-file added))
- (%set-system-source-file (probe-asd (component-name m) (component-pathname m)) m))))))
+ (when (typep m 'system)
+ (when (member 'source-file added)
+ (%set-system-source-file
+ (probe-asd (component-name m) (component-pathname m)) m)
+ (when (equal (component-name m) "asdf")
+ (setf (component-version m) *asdf-version*))))))))
;;;; -------------------------------------------------------------------------
;;;; Classes, Conditions
@@ -886,7 +958,10 @@
duplicate-names-name
error-component error-operation
module-components module-components-by-name
- circular-dependency-components)
+ circular-dependency-components
+ condition-arguments condition-form
+ condition-format condition-location
+ coerce-name)
(ftype (function (t t) t) (setf module-components-by-name)))
@@ -894,26 +969,26 @@
((format-control :initarg :format-control :reader format-control)
(format-arguments :initarg :format-arguments :reader format-arguments))
(:report (lambda (c s)
- (apply #'format s (format-control c) (format-arguments c)))))
+ (apply #'errfmt s (format-control c) (format-arguments c)))))
(define-condition load-system-definition-error (system-definition-error)
((name :initarg :name :reader error-name)
(pathname :initarg :pathname :reader error-pathname)
(condition :initarg :condition :reader error-condition))
(:report (lambda (c s)
- (format s "~@<Error while trying to load definition for system ~A from pathname ~A: ~A~@:>"
- (error-name c) (error-pathname c) (error-condition c)))))
+ (errfmt s "Error while trying to load definition for system ~A from pathname ~A: ~A"
+ (error-name c) (error-pathname c) (error-condition c)))))
(define-condition circular-dependency (system-definition-error)
((components :initarg :components :reader circular-dependency-components))
(:report (lambda (c s)
- (format s "~@<Circular dependency: ~S~@:>" (circular-dependency-components c)))))
+ (errfmt s "Circular dependency: ~S" (circular-dependency-components c)))))
(define-condition duplicate-names (system-definition-error)
((name :initarg :name :reader duplicate-names-name))
(:report (lambda (c s)
- (format s "~@<Error while defining system: multiple components are given same name ~A~@:>"
- (duplicate-names-name c)))))
+ (errfmt s "Error while defining system: multiple components are given same name ~A"
+ (duplicate-names-name c)))))
(define-condition missing-component (system-definition-error)
((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
@@ -933,19 +1008,37 @@
((component :reader error-component :initarg :component)
(operation :reader error-operation :initarg :operation))
(:report (lambda (c s)
- (format s "~@<erred while invoking ~A on ~A~@:>"
- (error-operation c) (error-component c)))))
+ (errfmt s "erred while invoking ~A on ~A"
+ (error-operation c) (error-component c)))))
(define-condition compile-error (operation-error) ())
(define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ())
+(define-condition invalid-configuration ()
+ ((form :reader condition-form :initarg :form)
+ (location :reader condition-location :initarg :location)
+ (format :reader condition-format :initarg :format)
+ (arguments :reader condition-arguments :initarg :arguments :initform nil))
+ (:report (lambda (c s)
+ (errfmt s "~? (will be skipped)"
+ (condition-format c)
+ (list* (condition-form c) (condition-location c)
+ (condition-arguments c))))))
+(define-condition invalid-source-registry (invalid-configuration warning)
+ ((format :initform "invalid source registry ~S~@[ in ~S~]~@{ ~@?~}")))
+(define-condition invalid-output-translation (invalid-configuration warning)
+ ((format :initform "invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}")))
+
(defclass component ()
((name :accessor component-name :initarg :name :documentation
"Component name: designator for a string composed of portable pathname characters")
(version :accessor component-version :initarg :version)
- ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
- ;; POIU is a parallel (multi-process build) extension of ASDF. See
- ;; http://www.cliki.net/poiu
+ (description :accessor component-description :initarg :description)
+ (long-description :accessor component-long-description :initarg :long-description)
+ ;; This one below is used by POIU - http://www.cliki.net/poiu
+ ;; a parallelizing extension of ASDF that compiles in multiple parallel
+ ;; slave processes (forked on demand) and loads in the master process.
+ ;; Maybe in the future ASDF may use it internally instead of in-order-to.
(load-dependencies :accessor component-load-dependencies :initform nil)
;; In the ASDF object model, dependencies exist between *actions*
;; (an action is a pair of operation and component). They are represented
@@ -964,6 +1057,7 @@
;; it needn't be recompiled just because one of these dependencies
;; hasn't yet been loaded in the current image (do-first).
;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
+ ;; See our ASDF 2 paper for more complete explanations.
(in-order-to :initform nil :initarg :in-order-to
:accessor component-in-order-to)
(do-first :initform nil :initarg :do-first
@@ -991,13 +1085,13 @@
(defmethod print-object ((c component) stream)
(print-unreadable-object (c stream :type t :identity nil)
- (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c))))
+ (format stream "~{~S~^ ~}" (component-find-path c))))
;;;; methods: conditions
(defmethod print-object ((c missing-dependency) s)
- (format s "~@<~A, required by ~A~@:>"
+ (format s "~A, required by ~A"
(call-next-method c nil) (missing-required-by c)))
(defun* sysdef-error (format &rest arguments)
@@ -1007,13 +1101,13 @@
;;;; methods: components
(defmethod print-object ((c missing-component) s)
- (format s "~@<component ~S not found~@[ in ~A~]~@:>"
+ (format s "component ~S not found~@[ in ~A~]"
(missing-requires c)
(when (missing-parent c)
(coerce-name (missing-parent c)))))
(defmethod print-object ((c missing-component-of-version) s)
- (format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>"
+ (format s "component ~S does not match version ~A~@[ in ~A~]"
(missing-requires c)
(missing-version c)
(when (missing-parent c)
@@ -1090,9 +1184,10 @@
new-value)
(defclass system (module)
- ((description :accessor system-description :initarg :description)
- (long-description
- :accessor system-long-description :initarg :long-description)
+ (;; description and long-description are now available for all component's,
+ ;; but now also inherited from component, but we add the legacy accessor
+ (description :accessor system-description :initarg :description)
+ (long-description :accessor system-long-description :initarg :long-description)
(author :accessor system-author :initarg :author)
(maintainer :accessor system-maintainer :initarg :maintainer)
(licence :accessor system-licence :initarg :licence
@@ -1141,7 +1236,7 @@
(component (component-name name))
(symbol (string-downcase (symbol-name name)))
(string name)
- (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
+ (t (sysdef-error "invalid component designator ~A" name))))
(defun* system-registered-p (name)
(gethash (coerce-name name) *defined-systems*))
@@ -1151,22 +1246,19 @@
Note that this does NOT in any way cause the code of the system to be unloaded."
;; There is no "unload" operation in Common Lisp, and a general such operation
;; cannot be portably written, considering how much CL relies on side-effects
- ;; of global data structures.
- ;; Note that this does a setf gethash instead of a remhash
- ;; this way there remains a hint in the *defined-systems* table
- ;; that the system was loaded at some point.
- (setf (gethash (coerce-name name) *defined-systems*) nil))
+ ;; to global data structures.
+ (remhash (coerce-name name) *defined-systems*))
(defun* map-systems (fn)
"Apply FN to each defined system.
FN should be a function of one argument. It will be
called with an object of type asdf:system."
- (maphash (lambda (_ datum)
- (declare (ignore _))
- (destructuring-bind (_ . def) datum
+ (maphash #'(lambda (_ datum)
(declare (ignore _))
- (funcall fn def)))
+ (destructuring-bind (_ . def) datum
+ (declare (ignore _))
+ (funcall fn def)))
*defined-systems*))
;;; for the sake of keeping things reasonably neat, we adopt a
@@ -1178,7 +1270,7 @@
(defun* system-definition-pathname (system)
(let ((system-name (coerce-name system)))
(or
- (some (lambda (x) (funcall x system-name))
+ (some #'(lambda (x) (funcall x system-name))
*system-definition-search-functions*)
(let ((system-pair (system-registered-p system-name)))
(and system-pair
@@ -1207,15 +1299,15 @@
:defaults defaults :version :newest :case :local
:name name
:type "asd")))
- (when (probe-file file)
+ (when (probe-file* file)
(return file)))
- #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
+ #+(and asdf-windows (not clisp))
(let ((shortcut
(make-pathname
:defaults defaults :version :newest :case :local
:name (concatenate 'string name ".asd")
:type "lnk")))
- (when (probe-file shortcut)
+ (when (probe-file* shortcut)
(let ((target (parse-windows-shortcut shortcut)))
(when target
(return (pathname target)))))))))
@@ -1237,8 +1329,8 @@
(restart-case
(let* ((*print-circle* nil)
(message
- (format nil
- "~@<While searching for system ~S: ~S evaluated to ~S which is not a directory.~@:>"
+ (errfmt nil
+ "While searching for system ~S: ~S evaluated to ~S which is not a directory."
system dir defaults)))
(error message))
(remove-entry-from-registry ()
@@ -1246,8 +1338,8 @@
(push dir to-remove))
(coerce-entry-to-directory ()
:report (lambda (s)
- (format s "Coerce entry to ~a, replace ~a and continue."
- (ensure-directory-pathname defaults) dir))
+ (errfmt s "Coerce entry to ~a, replace ~a and continue."
+ (ensure-directory-pathname defaults) dir))
(push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
;; cleanup
(dolist (dir to-remove)
@@ -1279,7 +1371,7 @@
;; and we can survive and we will continue the planning
;; as if the file were very old.
;; (or should we treat the case in a different, special way?)
- (or (and pathname (probe-file pathname) (file-write-date pathname))
+ (or (and pathname (probe-file* pathname) (file-write-date pathname))
(progn
(when (and pathname *asdf-verbose*)
(warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
@@ -1289,27 +1381,34 @@
(defmethod find-system (name &optional (error-p t))
(find-system (coerce-name name) error-p))
+(defun load-sysdef (name pathname)
+ ;; Tries to load system definition with canonical NAME from PATHNAME.
+ (let ((package (make-temporary-package)))
+ (unwind-protect
+ (handler-bind
+ ((error #'(lambda (condition)
+ (error 'load-system-definition-error
+ :name name :pathname pathname
+ :condition condition))))
+ (let ((*package* package))
+ (asdf-message
+ "~&; Loading system definition from ~A into ~A~%"
+ pathname package)
+ (load pathname)))
+ (delete-package package))))
+
(defmethod find-system ((name string) &optional (error-p t))
(catch 'find-system
- (let* ((in-memory (system-registered-p name))
+ (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
(on-disk (system-definition-pathname name)))
(when (and on-disk
(or (not in-memory)
- (< (car in-memory) (safe-file-write-date on-disk))))
- (let ((package (make-temporary-package)))
- (unwind-protect
- (handler-bind
- ((error (lambda (condition)
- (error 'load-system-definition-error
- :name name :pathname on-disk
- :condition condition))))
- (let ((*package* package))
- (asdf-message
- "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%"
- on-disk *package*)
- (load on-disk)))
- (delete-package package))))
- (let ((in-memory (system-registered-p name)))
+ ;; don't reload if it's already been loaded,
+ ;; or its filestamp is in the future which means some clock is skewed
+ ;; and trying to load might cause an infinite loop.
+ (< (car in-memory) (safe-file-write-date on-disk) (get-universal-time))))
+ (load-sysdef name on-disk))
+ (let ((in-memory (system-registered-p name))) ; try again after loading from disk
(cond
(in-memory
(when on-disk
@@ -1319,7 +1418,7 @@
(error 'missing-component :requires name)))))))
(defun* register-system (name system)
- (asdf-message "~&~@<; ~@;Registering ~A as ~A~@:>~%" system name)
+ (asdf-message "~&; Registering ~A as ~A~%" system name)
(setf (gethash (coerce-name name) *defined-systems*)
(cons (get-universal-time) system)))
@@ -1340,7 +1439,8 @@
(throw 'find-system system))))
(defun* sysdef-find-asdf (name)
- (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated.
+ ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
+ (find-system-fallback name "asdf" :version *asdf-version*))
;;;; -------------------------------------------------------------------------
@@ -1397,6 +1497,20 @@
(source-file-explicit-type component))
(defun* merge-component-name-type (name &key type defaults)
+ ;; For backwards compatibility only, for people using internals.
+ ;; Will be removed in a future release, e.g. 2.014.
+ (coerce-pathname name :type type :defaults defaults))
+
+(defun* coerce-pathname (name &key type defaults)
+ "coerce NAME into a PATHNAME.
+When given a string, portably decompose it into a relative pathname:
+#\\/ separates subdirectories. The last #\\/-separated string is as follows:
+if TYPE is NIL, its last #\\. if any separates name and type from from type;
+if TYPE is a string, it is the type, and the whole string is the name;
+if TYPE is :DIRECTORY, the string is a directory component;
+if the string is empty, it's a directory.
+Any directory named .. is read as :BACK.
+Host, device and version components are taken from DEFAULTS."
;; The defaults are required notably because they provide the default host
;; to the below make-pathname, which may crucially matter to people using
;; merge-pathnames with non-default hosts, e.g. for logical-pathnames.
@@ -1405,10 +1519,10 @@
;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of
;; ASDF:MERGE-PATHNAMES*
(etypecase name
- (pathname
+ ((or null pathname)
name)
(symbol
- (merge-component-name-type (string-downcase name) :type type :defaults defaults))
+ (coerce-pathname (string-downcase name) :type type :defaults defaults))
(string
(multiple-value-bind (relative path filename)
(component-name-to-pathname-components name :force-directory (eq type :directory)
@@ -1429,7 +1543,7 @@
:host host :device device)))))))
(defmethod component-relative-pathname ((component component))
- (merge-component-name-type
+ (coerce-pathname
(or (slot-value component 'relative-pathname)
(component-name component))
:type (source-file-type component (component-system component))
@@ -1537,18 +1651,18 @@
(defmethod component-self-dependencies ((o operation) (c component))
(let ((all-deps (component-depends-on o c)))
- (remove-if-not (lambda (x)
- (member (component-name c) (cdr x) :test #'string=))
+ (remove-if-not #'(lambda (x)
+ (member (component-name c) (cdr x) :test #'string=))
all-deps)))
(defmethod input-files ((operation operation) (c component))
(let ((parent (component-parent c))
(self-deps (component-self-dependencies operation c)))
(if self-deps
- (mapcan (lambda (dep)
- (destructuring-bind (op name) dep
- (output-files (make-instance op)
- (find-component parent name))))
+ (mapcan #'(lambda (dep)
+ (destructuring-bind (op name) dep
+ (output-files (make-instance op)
+ (find-component parent name))))
self-deps)
;; no previous operations needed? I guess we work with the
;; original source file, then
@@ -1602,8 +1716,8 @@
;; than one second of filesystem time (or just crosses the
;; second). So that's cool.
(and
- (every #'probe-file in-files)
- (every #'probe-file out-files)
+ (every #'probe-file* in-files)
+ (every #'probe-file* out-files)
(>= (earliest-out) (latest-in))))))))
@@ -1650,14 +1764,13 @@
required-op required-c required-v))
(retry ()
:report (lambda (s)
- (format s "~@<Retry loading component ~S.~@:>"
- (component-find-path required-c)))
+ (errfmt s "Retry loading component ~S." required-c))
:test
(lambda (c)
- (or (null c)
- (and (typep c 'missing-dependency)
- (equalp (missing-requires c)
- required-c))))))))
+ (or (null c)
+ (and (typep c 'missing-dependency)
+ (equalp (missing-requires c)
+ required-c))))))))
(defun* do-dep (operation c collect op dep)
;; type of arguments uncertain:
@@ -1820,7 +1933,7 @@
(defmethod perform ((operation operation) (c source-file))
(sysdef-error
- "~@<required method PERFORM not implemented for operation ~A, component ~A~@:>"
+ "required method PERFORM not implemented for operation ~A, component ~A"
(class-of operation) (class-of c)))
(defmethod perform ((operation operation) (c module))
@@ -1843,7 +1956,7 @@
(on-failure :initarg :on-failure :accessor operation-on-failure
:initform *compile-file-failure-behaviour*)
(flags :initarg :flags :accessor compile-op-flags
- :initform #-ecl nil #+ecl '(:system-p t))))
+ :initform nil)))
(defun output-file (operation component)
"The unique output file of performing OPERATION on COMPONENT"
@@ -1852,25 +1965,18 @@
(first files)))
(defmethod perform :before ((operation compile-op) (c source-file))
- (map nil #'ensure-directories-exist (output-files operation c)))
-
-#+ecl
-(defmethod perform :after ((o compile-op) (c cl-source-file))
- ;; Note how we use OUTPUT-FILES to find the binary locations
- ;; This allows the user to override the names.
- (let* ((files (output-files o c))
- (object (first files))
- (fasl (second files)))
- (c:build-fasl fasl :lisp-files (list object))))
+ (loop :for file :in (asdf:output-files operation c)
+ :for pathname = (if (typep file 'logical-pathname)
+ (translate-logical-pathname file)
+ file)
+ :do (ensure-directories-exist pathname)))
(defmethod perform :after ((operation operation) (c component))
(setf (gethash (type-of operation) (component-operation-times c))
(get-universal-time)))
-(declaim (ftype (function ((or pathname string)
- &rest t &key (:output-file t) &allow-other-keys)
- (values t t t))
- compile-file*))
+(defvar *compile-op-compile-file-function* 'compile-file*
+ "Function used to compile lisp files.")
;;; perform is required to check output-files to find out where to put
;;; its answers, in case it has been overridden for site policy
@@ -1883,19 +1989,19 @@
(*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-file* source-file :output-file output-file
+ (apply *compile-op-compile-file-function* source-file :output-file output-file
(compile-op-flags operation))
(when warnings-p
(case (operation-on-warnings operation)
(:warn (warn
- "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
+ "COMPILE-FILE warned while performing ~A on ~A."
operation c))
(:error (error 'compile-warned :component c :operation operation))
(:ignore nil)))
(when failure-p
(case (operation-on-failure operation)
(:warn (warn
- "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
+ "COMPILE-FILE failed while performing ~A on ~A."
operation c))
(:error (error 'compile-failed :component c :operation operation))
(:ignore nil)))
@@ -1905,10 +2011,8 @@
(defmethod output-files ((operation compile-op) (c cl-source-file))
(declare (ignorable operation))
(let ((p (lispize-pathname (component-pathname c))))
- #-:broken-fasl-loader
- (list (compile-file-pathname p #+ecl :type #+ecl :object)
- #+ecl (compile-file-pathname p :type :fasl))
- #+:broken-fasl-loader (list p)))
+ #-broken-fasl-loader (list (compile-file-pathname p))
+ #+broken-fasl-loader (list p)))
(defmethod perform ((operation compile-op) (c static-file))
(declare (ignorable operation c))
@@ -1934,11 +2038,7 @@
(defclass load-op (basic-load-op) ())
(defmethod perform ((o load-op) (c cl-source-file))
- (map () #'load
- #-ecl (input-files o c)
- #+ecl (loop :for i :in (input-files o c)
- :unless (string= (pathname-type i) "fas")
- :collect (compile-file-pathname (lispize-pathname i)))))
+ (map () #'load (input-files o c)))
(defmethod perform-with-restarts (operation component)
(perform operation component))
@@ -2031,10 +2131,10 @@
(declare (ignorable o))
(let ((what-would-load-op-do (cdr (assoc 'load-op
(component-in-order-to c)))))
- (mapcar (lambda (dep)
- (if (eq (car dep) 'load-op)
- (cons 'load-source-op (cdr dep))
- dep))
+ (mapcar #'(lambda (dep)
+ (if (eq (car dep) 'load-op)
+ (cons 'load-source-op (cdr dep))
+ dep))
what-would-load-op-do)))
(defmethod operation-done-p ((o load-source-op) (c source-file))
@@ -2097,12 +2197,12 @@
(retry ()
:report
(lambda (s)
- (format s "~@<Retry ~A.~@:>" (operation-description op component))))
+ (errfmt s "Retry ~A." (operation-description op component))))
(accept ()
:report
(lambda (s)
- (format s "~@<Continue, treating ~A as having been successful.~@:>"
- (operation-description op component)))
+ (errfmt s "Continue, treating ~A as having been successful."
+ (operation-description op component)))
(setf (gethash (type-of op)
(component-operation-times component))
(get-universal-time))
@@ -2180,7 +2280,9 @@
;; 3. taken from the *default-pathname-defaults* via default-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))
+ (or (and pathname-supplied-p
+ (merge-pathnames* (coerce-pathname pathname :type :directory)
+ directory-pathname))
directory-pathname
(default-directory))))
@@ -2223,7 +2325,7 @@
(and (eq type :file)
(or (module-default-component-class parent)
(find-class *default-component-class*)))
- (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
+ (sysdef-error "don't recognize component type ~A" type)))
(defun* maybe-add-tree (tree op1 op2 c)
"Add the node C at /OP1/OP2 in TREE, unless it's there already.
@@ -2280,8 +2382,8 @@
;; this is inefficient as most of the stored
;; methods will not be for this particular gf
;; But this is hardly performance-critical
- (lambda (m)
- (remove-method (symbol-function name) m))
+ #'(lambda (m)
+ (remove-method (symbol-function name) m))
(component-inline-methods component)))
;; clear methods, then add the new ones
(setf (component-inline-methods component) nil))
@@ -2408,7 +2510,7 @@
exit-code)
#+clisp ;XXX not exactly *verbose-out*, I know
- (ext:run-shell-command command :output :terminal :wait t)
+ (or (ext:run-shell-command command :output :terminal :wait t) 0)
#+clozure
(nth-value 1
@@ -2482,7 +2584,7 @@
(defun* system-relative-pathname (system name &key type)
(merge-pathnames*
- (merge-component-name-type name :type type)
+ (coerce-pathname name :type type)
(system-source-directory system)))
@@ -2493,13 +2595,13 @@
;;; Initially stolen from SLIME's SWANK, hacked since.
(defparameter *implementation-features*
- '((:acl :allegro)
- (:lw :lispworks)
- (:digitool) ; before clozure, so it won't get preempted by ccl
+ '((:abcl :armedbear)
+ (:acl :allegro)
+ (:mcl :digitool) ; before clozure, so it won't get preempted by ccl
(:ccl :clozure)
(:corman :cormanlisp)
- (:abcl :armedbear)
- :sbcl :cmu :clisp :gcl :ecl :scl))
+ (:lw :lispworks)
+ :clisp :cmu :ecl :gcl :sbcl :scl :symbolics))
(defparameter *os-features*
'((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
@@ -2507,7 +2609,8 @@
(:linux :linux-target) ;; for GCL at least, must appear before :bsd.
(:macosx :darwin :darwin-target :apple)
:freebsd :netbsd :openbsd :bsd
- :unix))
+ :unix
+ :genera))
(defparameter *architecture-features*
'((:amd64 :x86-64 :x86_64 :x8664-target)
@@ -2519,7 +2622,8 @@
:sparc64
(:sparc32 :sparc)
(:arm :arm-target)
- (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
+ (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)
+ :imach))
(defun* lisp-version-string ()
(let ((s (lisp-implementation-version)))
@@ -2537,24 +2641,26 @@
(:+ics ""))
(if (member :64bit *features*) "-64bit" ""))
#+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
- #+clisp (subseq s 0 (position #\space s))
+ #+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)
- #+digitool (subseq s 8)
#+ecl (format nil "~A~@[-~A~]" s
(let ((vcs-id (ext:lisp-implementation-vcs-id)))
(when (>= (length vcs-id) 8)
(subseq vcs-id 0 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"))
;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
- #+(or cormanlisp mcl sbcl scl) s
- #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
- ecl gcl lispworks mcl sbcl scl) s))
+ #+mcl (subseq s 8) ; strip the leading "Version "
+ #+(or cormanlisp sbcl scl) s
+ #-(or allegro armedbear clisp clozure cmu cormanlisp
+ ecl gcl genera lispworks mcl sbcl scl) s))
(defun* first-feature (features)
(labels
@@ -2586,31 +2692,31 @@
*implementation-features*))
(os (maybe-warn (first-feature *os-features*)
"No os feature found in ~a." *os-features*))
- (arch (maybe-warn (first-feature *architecture-features*)
- "No architecture feature found in ~a."
- *architecture-features*))
+ (arch (or #-clisp
+ (maybe-warn (first-feature *architecture-features*)
+ "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~^-~}~)" lisp version os arch)))))
-
+ #\_ #'(lambda (x) (find x " /:\\(){}[]$#`'\""))
+ (format nil "~(~a~@{~@[-~a~]~}~)" lisp version os arch)))))
;;; ---------------------------------------------------------------------------
;;; Generic support for configuration files
(defparameter *inter-directory-separator*
- #+(or unix cygwin) #\:
- #-(or unix cygwin) #\;)
+ #+asdf-unix #\:
+ #-asdf-unix #\;)
(defun* user-homedir ()
- (truename (user-homedir-pathname)))
+ (truenamize (pathname-directory-pathname (user-homedir-pathname))))
(defun* try-directory-subpath (x sub &key type)
(let* ((p (and x (ensure-directory-pathname x)))
(tp (and p (probe-file* p)))
- (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
+ (sp (and tp (merge-pathnames* (coerce-pathname sub :type type) p)))
(ts (and sp (probe-file* sp))))
(and ts (values sp ts))))
(defun* user-configuration-directories ()
@@ -2621,7 +2727,7 @@
,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
:for dir :in (split-string dirs :separator ":")
:collect (try dir "common-lisp/"))
- #+(and (or win32 windows mswindows mingw32) (not cygwin))
+ #+asdf-windows
,@`(#+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
,(try (getenv "APPDATA") "common-lisp/config/"))
@@ -2630,11 +2736,12 @@
(remove-if
#'null
(append
- #+(and (or win32 windows mswindows mingw32) (not cygwin))
+ #+asdf-windows
(flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
`(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
+ #+asdf-unix
(list #p"/etc/common-lisp/"))))
(defun* in-first-directory (dirs x)
(loop :for dir :in dirs
@@ -2649,40 +2756,88 @@
(or (member x kw)
(and (length=n-p x 1) (member (car x) kw)))))
+(defun* report-invalid-form (reporter &rest args)
+ (etypecase reporter
+ (null
+ (apply 'error 'invalid-configuration args))
+ (function
+ (apply reporter args))
+ ((or symbol string)
+ (apply 'error reporter args))
+ (cons
+ (apply 'apply (append reporter args)))))
+
+(defvar *ignored-configuration-form* nil)
+
(defun* validate-configuration-form (form tag directive-validator
- &optional (description tag))
+ &key location invalid-form-reporter)
(unless (and (consp form) (eq (car form) tag))
- (error "Error: Form doesn't specify ~A ~S~%" description form))
- (loop :with inherit = 0
- :for directive :in (cdr form) :do
- (if (configuration-inheritance-directive-p directive)
- (incf inherit)
- (funcall directive-validator directive))
+ (setf *ignored-configuration-form* t)
+ (report-invalid-form invalid-form-reporter :form form :location location)
+ (return-from validate-configuration-form nil))
+ (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
+ :for directive :in (cdr form)
+ :when (cond
+ ((configuration-inheritance-directive-p directive)
+ (incf inherit) t)
+ ((eq directive :ignore-invalid-entries)
+ (setf ignore-invalid-p t) t)
+ ((funcall directive-validator directive)
+ t)
+ (ignore-invalid-p
+ nil)
+ (t
+ (setf *ignored-configuration-form* t)
+ (report-invalid-form invalid-form-reporter :form directive :location location)
+ nil))
+ :do (push directive x)
:finally
(unless (= inherit 1)
- (error "One and only one of ~S or ~S is required"
- :inherit-configuration :ignore-inherited-configuration)))
- form)
+ (report-invalid-form invalid-form-reporter
+ :arguments (list "One and only one of ~S or ~S is required"
+ :inherit-configuration :ignore-inherited-configuration)))
+ (return (nreverse x))))
-(defun* validate-configuration-file (file validator description)
+(defun* validate-configuration-file (file validator &key description)
(let ((forms (read-file-forms file)))
(unless (length=n-p forms 1)
(error "One and only one form allowed for ~A. Got: ~S~%" description forms))
- (funcall validator (car forms))))
+ (funcall validator (car forms) :location file)))
(defun* hidden-file-p (pathname)
(equal (first-char (pathname-name pathname)) #\.))
-(defun* validate-configuration-directory (directory tag validator)
+(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
+ (apply 'directory pathname-spec
+ (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
+ #+clozure '(:follow-links nil)
+ #+clisp '(:circle t :if-does-not-exist :ignore)
+ #+(or cmu scl) '(:follow-links nil :truenamep nil)
+ #+sbcl (when (find-symbol "RESOLVE-SYMLINKS" "SB-IMPL") '(:resolve-symlinks nil))))))
+
+(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)
+ "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
+be applied to the results to yield a configuration form. Current
+values of TAG include :source-registry and :output-translations."
(let ((files (sort (ignore-errors
(remove-if
'hidden-file-p
- (directory (make-pathname :name :wild :type "conf" :defaults directory)
- #+sbcl :resolve-symlinks #+sbcl nil)))
+ (directory* (make-pathname :name :wild :type "conf" :defaults directory))))
#'string< :key #'namestring)))
`(,tag
,@(loop :for file :in files :append
- (mapcar validator (read-file-forms file)))
+ (loop :with ignore-invalid-p = nil
+ :for form :in (read-file-forms file)
+ :when (eq form :ignore-invalid-entries)
+ :do (setf ignore-invalid-p t)
+ :else
+ :when (funcall validator form)
+ :collect form
+ :else
+ :when ignore-invalid-p
+ :do (setf *ignored-configuration-form* t)
+ :else
+ :do (report-invalid-form invalid-form-reporter :form form :location file)))
:inherit-configuration)))
@@ -2703,7 +2858,7 @@
(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))
+ #+asdf-windows
(try (getenv "APPDATA") "common-lisp" "cache" :implementation)
'(:home ".cache" "common-lisp" :implementation))))
(defvar *system-cache*
@@ -2718,11 +2873,12 @@
(setf *output-translations*
(list
(stable-sort (copy-list new-value) #'>
- :key (lambda (x)
- (etypecase (car x)
- ((eql t) -1)
- (pathname
- (length (pathname-directory (car x)))))))))
+ :key #'(lambda (x)
+ (etypecase (car x)
+ ((eql t) -1)
+ (pathname
+ (let ((directory (pathname-directory (car x))))
+ (if (listp directory) (length directory) 0))))))))
new-value)
(defun* output-translations-initialized-p ()
@@ -2756,9 +2912,12 @@
(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)))
- #-(and (or win32 windows mswindows mingw32) (not cygwin))
+ #+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))))
@@ -2766,6 +2925,11 @@
(error "pathname ~S is not relative to ~S" s super))
(merge-pathnames* s super)))
+(defvar *here-directory* nil
+ "This special variable is bound to the currect directory during calls to
+PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
+directive.")
+
(defun* resolve-absolute-location-component (x &key directory wilden)
(let* ((r
(etypecase x
@@ -2788,6 +2952,11 @@
(let ((p (make-pathname :directory '(:relative))))
(if wilden (wilden p) p))))
((eql :home) (user-homedir))
+ ((eql :here)
+ (resolve-location (or *here-directory*
+ ;; give semantics in the case of use interactively
+ :default-directory)
+ :directory t :wilden nil))
((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
((eql :default-directory) (default-directory))))
@@ -2812,8 +2981,17 @@
:finally (return path))))
(defun* location-designator-p (x)
- (flet ((componentp (c) (typep c '(or string pathname keyword))))
- (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
+ (flet ((absolute-component-p (c)
+ (typep c '(or string pathname
+ (member :root :home :here :user-cache :system-cache :default-directory))))
+ (relative-component-p (c)
+ (typep c '(or string pathname
+ (member :default-directory :*/ :**/ :*.*.*
+ :implementation :implementation-type
+ #+asdf-unix :uid)))))
+ (or (typep x 'boolean)
+ (absolute-component-p x)
+ (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
(defun* location-function-p (x)
(and
@@ -2826,47 +3004,43 @@
(length=n-p (second x) 2)))))
(defun* validate-output-translations-directive (directive)
- (unless
- (or (member directive '(:inherit-configuration
- :ignore-inherited-configuration
- :enable-user-cache :disable-cache nil))
- (and (consp directive)
- (or (and (length=n-p directive 2)
- (or (and (eq (first directive) :include)
- (typep (second directive) '(or string pathname null)))
- (and (location-designator-p (first directive))
- (or (location-designator-p (second directive))
- (location-function-p (second directive))))))
- (and (length=n-p directive 1)
- (location-designator-p (first directive))))))
- (error "Invalid directive ~S~%" directive))
- directive)
+ (or (member directive '(:enable-user-cache :disable-cache nil))
+ (and (consp directive)
+ (or (and (length=n-p directive 2)
+ (or (and (eq (first directive) :include)
+ (typep (second directive) '(or string pathname null)))
+ (and (location-designator-p (first directive))
+ (or (location-designator-p (second directive))
+ (location-function-p (second directive))))))
+ (and (length=n-p directive 1)
+ (location-designator-p (first directive)))))))
-(defun* validate-output-translations-form (form)
+(defun* validate-output-translations-form (form &key location)
(validate-configuration-form
form
:output-translations
'validate-output-translations-directive
- "output translations"))
+ :location location :invalid-form-reporter 'invalid-output-translation))
(defun* validate-output-translations-file (file)
(validate-configuration-file
- file 'validate-output-translations-form "output translations"))
+ file 'validate-output-translations-form :description "output translations"))
(defun* validate-output-translations-directory (directory)
(validate-configuration-directory
- directory :output-translations 'validate-output-translations-directive))
+ directory :output-translations 'validate-output-translations-directive
+ :invalid-form-reporter 'invalid-output-translation))
-(defun* parse-output-translations-string (string)
+(defun* parse-output-translations-string (string &key location)
(cond
((or (null string) (equal string ""))
'(:output-translations :inherit-configuration))
((not (stringp string))
(error "environment string isn't: ~S" string))
((eql (char string 0) #\")
- (parse-output-translations-string (read-from-string string)))
+ (parse-output-translations-string (read-from-string string) :location location))
((eql (char string 0) #\()
- (validate-output-translations-form (read-from-string string)))
+ (validate-output-translations-form (read-from-string string) :location location))
(t
(loop
:with inherit = nil
@@ -2906,7 +3080,8 @@
`(:output-translations
;; Some implementations have precompiled ASDF systems,
;; so we must disable translations for implementation paths.
- #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ())))
+ #+sbcl ,(let ((h (getenv "SBCL_HOME")))
+ (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
#+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
#+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
;; All-import, here is where we want user stuff to be:
@@ -2917,8 +3092,8 @@
;; We enable the user cache by default, and here is the place we do:
:enable-user-cache))
-(defparameter *output-translations-file* #p"asdf-output-translations.conf")
-(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
+(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))
+(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
(defun* user-output-translations-pathname ()
(in-user-configuration-directory *output-translations-file* ))
@@ -2946,7 +3121,7 @@
((directory-pathname-p pathname)
(process-output-translations (validate-output-translations-directory pathname)
:inherit inherit :collect collect))
- ((probe-file pathname)
+ ((probe-file* pathname)
(process-output-translations (validate-output-translations-file pathname)
:inherit inherit :collect collect))
(t
@@ -2974,7 +3149,7 @@
(process-output-translations-directive '(t t) :collect collect))
((:inherit-configuration)
(inherit-output-translations inherit :collect collect))
- ((:ignore-inherited-configuration nil)
+ ((:ignore-inherited-configuration :ignore-invalid-entries nil)
nil))
(let ((src (first directive))
(dst (second directive)))
@@ -2997,9 +3172,7 @@
(t
(let* ((trudst (make-pathname
:defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
- (wilddst (make-pathname
- :name :wild :type :wild :version :wild
- :defaults trudst)))
+ (wilddst (merge-pathnames* *wild-file* trudst)))
(funcall collect (list wilddst t))
(funcall collect (list trusrc trudst)))))))))))
@@ -3011,10 +3184,13 @@
`(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
:test 'equal :from-end t))
-(defun* initialize-output-translations (&optional parameter)
+(defvar *output-translations-parameter* nil)
+
+(defun* initialize-output-translations (&optional (parameter *output-translations-parameter*))
"read the configuration, initialize the internal configuration variable,
return the configuration"
- (setf (output-translations) (compute-output-translations parameter)))
+ (setf *output-translations-parameter* parameter
+ (output-translations) (compute-output-translations parameter)))
(defun* disable-output-translations ()
"Initialize output translations in a way that maps every file to itself,
@@ -3090,7 +3266,7 @@
:defaults x))
(defun* delete-file-if-exists (x)
- (when (and x (probe-file x))
+ (when (and x (probe-file* x))
(delete-file x)))
(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
@@ -3160,21 +3336,19 @@
(when (null map-all-source-files)
(error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
(let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
- (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
- (mapped-files (make-pathname
- :name :wild :version :wild
- :type (if map-all-source-files :wild fasl-type)))
+ (mapped-files (if map-all-source-files *wild-file*
+ (make-pathname :name :wild :version :wild :type fasl-type)))
(destination-directory
(if centralize-lisp-binaries
`(,default-toplevel-directory
,@(when include-per-user-information
(cdr (pathname-directory (user-homedir))))
- :implementation ,wild-inferiors)
- `(:root ,wild-inferiors :implementation))))
+ :implementation ,*wild-inferiors*)
+ `(:root ,*wild-inferiors* :implementation))))
(initialize-output-translations
`(:output-translations
, at source-to-target-mappings
- ((:root ,wild-inferiors ,mapped-files)
+ ((:root ,*wild-inferiors* ,mapped-files)
(, at destination-directory ,mapped-files))
(t t)
:ignore-inherited-configuration))))
@@ -3185,7 +3359,7 @@
;;;; Jesse Hager: The Windows Shortcut File Format.
;;;; http://www.wotsit.org/list.asp?fc=13
-#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
+#+(and asdf-windows (not clisp))
(progn
(defparameter *link-initial-dword* 76)
(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
@@ -3294,38 +3468,33 @@
(make-pathname :directory nil :name :wild :type "asd" :version :newest))
(defun directory-has-asd-files-p (directory)
- (and (ignore-errors
- (directory (merge-pathnames* *wild-asd* directory)
- #+sbcl #+sbcl :resolve-symlinks nil
- #+ccl #+ccl :follow-links nil
- #+clisp #+clisp :circle t))
- t))
+ (ignore-errors
+ (and (directory* (merge-pathnames* *wild-asd* directory)) t)))
(defun subdirectories (directory)
(let* ((directory (ensure-directory-pathname directory))
- #-cormanlisp
+ #-(or cormanlisp genera)
(wild (merge-pathnames*
#-(or abcl allegro lispworks scl)
- (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
+ *wild-directory*
#+(or abcl allegro lispworks scl) "*.*"
directory))
(dirs
- #-cormanlisp
+ #-(or cormanlisp genera)
(ignore-errors
- (directory wild .
- #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
- #+ccl '(:follow-links nil :directories t :files nil)
- #+clisp '(:circle t :if-does-not-exist :ignore)
- #+(or cmu scl) '(:follow-links nil :truenamep nil)
- #+digitool '(:directories t)
- #+sbcl '(:resolve-symlinks nil))))
- #+cormanlisp (cl::directory-subdirs directory))
- #+(or abcl allegro lispworks scl)
+ (directory* wild . #.(or #+clozure '(:directories t :files nil)
+ #+mcl '(:directories t))))
+ #+cormanlisp (cl::directory-subdirs directory)
+ #+genera (fs:directory-list directory))
+ #+(or abcl allegro genera lispworks scl)
(dirs (remove-if-not #+abcl #'extensions:probe-directory
#+allegro #'excl:probe-directory
#+lispworks #'lw:file-directory-p
- #-(or abcl allegro lispworks) #'directory-pathname-p
- dirs)))
+ #+genera #'(lambda (x) (getf (cdr x) :directory))
+ #-(or abcl allegro genera lispworks) #'directory-pathname-p
+ dirs))
+ #+genera
+ (dirs (mapcar #'(lambda (x) (ensure-directory-pathname (first x))) dirs)))
dirs))
(defun collect-sub*directories (directory collectp recursep collector)
@@ -3346,39 +3515,40 @@
collect))
(defun* validate-source-registry-directive (directive)
- (unless
- (or (member directive '(:default-registry (:default-registry)) :test 'equal)
- (destructuring-bind (kw &rest rest) directive
- (case kw
- ((:include :directory :tree)
- (and (length=n-p rest 1)
- (location-designator-p (first rest))))
- ((:exclude :also-exclude)
- (every #'stringp rest))
- (null rest))))
- (error "Invalid directive ~S~%" directive))
- directive)
+ (or (member directive '(:default-registry))
+ (and (consp directive)
+ (let ((rest (rest directive)))
+ (case (first directive)
+ ((:include :directory :tree)
+ (and (length=n-p rest 1)
+ (location-designator-p (first rest))))
+ ((:exclude :also-exclude)
+ (every #'stringp rest))
+ ((:default-registry)
+ (null rest)))))))
-(defun* validate-source-registry-form (form)
+(defun* validate-source-registry-form (form &key location)
(validate-configuration-form
- form :source-registry 'validate-source-registry-directive "a source registry"))
+ form :source-registry 'validate-source-registry-directive
+ :location location :invalid-form-reporter 'invalid-source-registry))
(defun* validate-source-registry-file (file)
(validate-configuration-file
- file 'validate-source-registry-form "a source registry"))
+ file 'validate-source-registry-form :description "a source registry"))
(defun* validate-source-registry-directory (directory)
(validate-configuration-directory
- directory :source-registry 'validate-source-registry-directive))
+ directory :source-registry 'validate-source-registry-directive
+ :invalid-form-reporter 'invalid-source-registry))
-(defun* parse-source-registry-string (string)
+(defun* parse-source-registry-string (string &key location)
(cond
((or (null string) (equal string ""))
'(:source-registry :inherit-configuration))
((not (stringp string))
(error "environment string isn't: ~S" string))
((find (char string 0) "\"(")
- (validate-source-registry-form (read-from-string string)))
+ (validate-source-registry-form (read-from-string string) :location location))
(t
(loop
:with inherit = nil
@@ -3419,35 +3589,35 @@
system-source-registry-directory
default-source-registry))
-(defparameter *source-registry-file* #p"source-registry.conf")
-(defparameter *source-registry-directory* #p"source-registry.conf.d/")
+(defparameter *source-registry-file* (coerce-pathname "source-registry.conf"))
+(defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/"))
(defun* wrapping-source-registry ()
`(:source-registry
- #+sbcl (:tree ,(getenv "SBCL_HOME"))
+ #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
:inherit-configuration
#+cmu (:tree #p"modules:")))
(defun* default-source-registry ()
(flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
`(:source-registry
#+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
- (:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
+ (:directory ,(default-directory))
,@(let*
- #+(or unix cygwin)
+ #+asdf-unix
((datahome
(or (getenv "XDG_DATA_HOME")
(try (user-homedir) ".local/share/")))
(datadirs
(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))
+ #+asdf-windows
((datahome (getenv "APPDATA"))
(datadir
#+lispworks (sys:get-folder-path :local-appdata)
#-lispworks (try (getenv "ALLUSERSPROFILE")
"Application Data"))
(dirs (list datahome datadir)))
- #-(or unix win32 windows mswindows mingw32 cygwin)
+ #-(or asdf-unix asdf-windows)
((dirs ()))
(loop :for dir :in dirs
:collect `(:directory ,(try dir "common-lisp/systems/"))
@@ -3475,11 +3645,13 @@
(defmethod process-source-registry ((pathname pathname) &key inherit register)
(cond
((directory-pathname-p pathname)
- (process-source-registry (validate-source-registry-directory pathname)
- :inherit inherit :register register))
- ((probe-file pathname)
- (process-source-registry (validate-source-registry-file pathname)
- :inherit inherit :register register))
+ (let ((*here-directory* (truenamize pathname)))
+ (process-source-registry (validate-source-registry-directory pathname)
+ :inherit inherit :register register)))
+ ((probe-file* pathname)
+ (let ((*here-directory* (pathname-directory-pathname pathname)))
+ (process-source-registry (validate-source-registry-file pathname)
+ :inherit inherit :register register)))
(t
(inherit-source-registry inherit :register register))))
(defmethod process-source-registry ((string string) &key inherit register)
@@ -3527,13 +3699,14 @@
(defun* flatten-source-registry (&optional parameter)
(remove-duplicates
(while-collecting (collect)
- (inherit-source-registry
- `(wrapping-source-registry
- ,parameter
- ,@*default-source-registries*)
- :register (lambda (directory &key recurse exclude)
- (collect (list directory :recurse recurse :exclude exclude)))))
- :test 'equal :from-end t))
+ (let ((*default-pathname-defaults* (default-directory)))
+ (inherit-source-registry
+ `(wrapping-source-registry
+ ,parameter
+ ,@*default-source-registries*)
+ :register #'(lambda (directory &key recurse exclude)
+ (collect (list directory :recurse recurse :exclude exclude)))))
+ :test 'equal :from-end t)))
;; Will read the configuration and initialize all internal variables,
;; and return the new configuration.
@@ -3545,8 +3718,11 @@
directory
:recurse recurse :exclude exclude :collect #'collect)))))
-(defun* initialize-source-registry (&optional parameter)
- (setf (source-registry) (compute-source-registry parameter)))
+(defvar *source-registry-parameter* nil)
+
+(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
+ (setf *source-registry-parameter* parameter
+ (source-registry) (compute-source-registry parameter)))
;; Checks an initial variable to see whether the state is initialized
;; or cleared. In the former case, return current configuration; in
@@ -3579,9 +3755,9 @@
(handler-bind
((style-warning #'muffle-warning)
(missing-component (constantly nil))
- (error (lambda (e)
- (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
- name e))))
+ (error #'(lambda (e)
+ (errfmt *error-output* "ASDF could not load ~(~A~) because ~A.~%"
+ name e))))
(let* ((*verbose-out* (make-broadcast-stream))
(system (find-system (string-downcase name) nil)))
(when system
@@ -3605,17 +3781,11 @@
;;;; Things to do in case we're upgrading from a previous version of ASDF.
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
;;;;
-;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1
-(eval-when (:compile-toplevel :load-toplevel :execute)
- #+ecl ;; Support upgrade from before ECL went to 1.369
- (when (fboundp 'compile-op-system-p)
- (defmethod compile-op-system-p ((op compile-op))
- (getf :system-p (compile-op-flags op)))
- (defmethod initialize-instance :after ((op compile-op)
- &rest initargs
- &key system-p &allow-other-keys)
- (declare (ignorable initargs))
- (when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))
+
+;;; If a previous version of ASDF failed to read some configuration, try again.
+(when *ignored-configuration-form*
+ (clear-configuration)
+ (setf *ignored-configuration-form* nil))
;;;; -----------------------------------------------------------------
;;;; Done!
More information about the cmucl-cvs
mailing list