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@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 ,@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 ,@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 ,@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 ,@source-to-target-mappings - ((:root ,wild-inferiors ,mapped-files) + ((:root ,*wild-inferiors* ,mapped-files) (,@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!