Date: Wednesday, June 8, 2011 @ 08:42:22 Author: rtoy Path: /project/cmucl/cvsroot/src/contrib/asdf

Modified: asdf.lisp

Update to release 2.016.

-----------+ asdf.lisp | 1221 ++++++++++++++++++++++++++++++++++++------------------------ 1 file changed, 747 insertions(+), 474 deletions(-)

Index: src/contrib/asdf/asdf.lisp diff -u src/contrib/asdf/asdf.lisp:1.14 src/contrib/asdf/asdf.lisp:1.15 --- src/contrib/asdf/asdf.lisp:1.14 Tue Mar 29 21:27:50 2011 +++ src/contrib/asdf/asdf.lisp Wed Jun 8 08:42:22 2011 @@ -1,5 +1,5 @@ ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.014.1: Another System Definition Facility. +;;; This is ASDF 2.016: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to asdf-devel@common-lisp.net. @@ -19,7 +19,7 @@ ;;; http://www.opensource.org/licenses/mit-license.html on or about ;;; Monday; July 13, 2009) ;;; -;;; Copyright (c) 2001-2010 Daniel Barlow and contributors +;;; Copyright (c) 2001-2011 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the @@ -49,41 +49,28 @@

(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)

+#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl) +(error "ASDF is not supported on your implementation. Please help us with it.") + #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this

(eval-when (:compile-toplevel :load-toplevel :execute) - ;;; 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 '(: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)) + :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below #+(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*)) + #+(or unix cygwin) (pushnew :asdf-unix *features*) + ;;; 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 '(:common-lisp))))

(in-package :asdf)

-;;; Strip out formating that is not supported on Genera. -(defmacro compatfmt (format) - #-genera format - #+genera - (let ((r '(("~@<" . "") - ("; ~@;" . "; ") - ("~3i~_" . "") - ("~@:>" . "") - ("~:>" . "")))) - (dolist (i r) - (loop :for found = (search (car i) format) :while found :do - (setf format (concatenate 'simple-string (subseq format 0 found) - (cdr i) - (subseq format (+ found (length (car i)))))))) - format)) - ;;;; Create packages in a way that is compatible with hot-upgrade. ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 ;;;; See more near the end of the file. @@ -91,6 +78,26 @@ (eval-when (:load-toplevel :compile-toplevel :execute) (defvar *asdf-version* nil) (defvar *upgraded-p* nil) + (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12. + (defun find-symbol* (s p) + (find-symbol (string s) p)) + ;; Strip out formatting that is not supported on Genera. + ;; Has to be inside the eval-when to make Lispworks happy (!) + (defmacro compatfmt (format) + #-genera format + #+genera + (loop :for (unsupported . replacement) :in + '(("~@<" . "") + ("; ~@;" . "; ") + ("~3i~_" . "") + ("~@:>" . "") + ("~:>" . "")) :do + (loop :for found = (search unsupported format) :while found :do + (setf format + (concatenate 'simple-string + (subseq format 0 found) replacement + (subseq format (+ found (length unsupported))))))) + format) (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). @@ -99,18 +106,18 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.014.1") - (existing-asdf (fboundp 'find-system)) + (asdf-version "2.016") + (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) (unless (and existing-asdf already-there) - (when existing-asdf + (when (and existing-asdf *asdf-verbose*) (format *trace-output* - (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") - existing-version asdf-version)) + (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") + existing-version asdf-version)) (labels ((present-symbol-p (symbol package) - (member (nth-value 1 (find-sym symbol package)) '(:internal :external))) + (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) @@ -140,14 +147,12 @@ p) (t (make-package name :nicknames nicknames :use use)))))) - (find-sym (symbol package) - (find-symbol (string symbol) package)) (intern* (symbol package) (intern (string symbol) package)) (remove-symbol (symbol package) - (let ((sym (find-sym symbol package))) + (let ((sym (find-symbol* symbol package))) (when sym - (unexport sym package) + #-cormanlisp (unexport sym package) (unintern sym package) sym))) (ensure-unintern (package symbols) @@ -156,19 +161,19 @@ :for removed = (remove-symbol sym package) :when removed :do (loop :for p :in packages :do - (when (eq removed (find-sym sym p)) + (when (eq removed (find-symbol* sym p)) (unintern removed p))))) (ensure-shadow (package symbols) (shadow symbols package)) (ensure-use (package use) (dolist (used (reverse use)) (do-external-symbols (sym used) - (unless (eq sym (find-sym sym package)) + (unless (eq sym (find-symbol* sym package)) (remove-symbol sym package))) (use-package used package))) (ensure-fmakunbound (package symbols) (loop :for name :in symbols - :for sym = (find-sym name package) + :for sym = (find-symbol* name package) :when sym :do (fmakunbound sym))) (ensure-export (package export) (let ((formerly-exported-symbols nil) @@ -184,7 +189,7 @@ (loop :for user :in (package-used-by-list package) :for shadowing = (package-shadowing-symbols user) :do (loop :for new :in newly-exported-symbols - :for old = (find-sym new user) + :for old = (find-symbol* new user) :when (and old (not (member old shadowing))) :do (unintern old user))) (loop :for x :in newly-exported-symbols :do @@ -213,7 +218,7 @@ #:perform-with-restarts #:component-relative-pathname #:system-source-file #:operate #:find-component #:find-system #:apply-output-translations #:translate-pathname* #:resolve-location - #:compile-file*) + #:compile-file* #:source-file-type) :unintern (#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector @@ -225,7 +230,8 @@ #:inherit-source-registry #:process-source-registry-directive) :export (#:defsystem #:oos #:operate #:find-system #:run-shell-command - #:system-definition-pathname #:find-component ; miscellaneous + #:system-definition-pathname #:with-system-definitions + #:search-for-system-definition #:find-component ; miscellaneous #:compile-system #:load-system #:test-system #:clear-system #:compile-op #:load-op #:load-source-op #:test-op @@ -233,12 +239,15 @@ #:feature ; sort-of operation #:version ; metaphorically sort-of an operation #:version-satisfies + #:upgrade-asdf + #:implementation-identifier #:implementation-type

#:input-files #:output-files #:output-file #:perform ; operation methods #:operation-done-p #:explain

#:component #:source-file #:c-source-file #:cl-source-file #:java-source-file + #:cl-source-file.cl #:cl-source-file.lsp #:static-file #:doc-file #:html-file @@ -349,7 +358,7 @@ #:subdirectories #:truenamize #:while-collecting))) - #+genera (import 'scl:boolean :asdf) + #+genera (import 'scl:boolean :asdf) (setf *asdf-version* asdf-version *upgraded-p* (if existing-version (cons existing-version *upgraded-p*) @@ -361,7 +370,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.013")." +(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) "2.345.67")." *asdf-version*)

(defvar *resolve-symlinks* t @@ -382,8 +391,6 @@

(defvar *verbose-out* nil)

-(defvar *asdf-verbose* t) - (defparameter +asdf-methods+ '(perform-with-restarts perform explain output-files operation-done-p))

@@ -396,6 +403,41 @@ (setf excl:*warn-on-nested-reader-conditionals* nil)))

;;;; ------------------------------------------------------------------------- +;;;; Resolve forward references + +(declaim (ftype (function (t) t) + format-arguments format-control + error-name error-pathname error-condition + duplicate-names-name + error-component error-operation + module-components module-components-by-name + circular-dependency-components + condition-arguments condition-form + condition-format condition-location + coerce-name) + #-cormanlisp + (ftype (function (t t) t) (setf module-components-by-name))) + +;;;; ------------------------------------------------------------------------- +;;;; Compatibility with Corman Lisp +#+cormanlisp +(progn + (deftype logical-pathname () nil) + (defun make-broadcast-stream () *error-output*) + (defun file-namestring (p) + (setf p (pathname p)) + (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))) + (defparameter *count* 3) + (defun dbg (&rest x) + (format *error-output* "~S~%" x))) +#+cormanlisp +(defun maybe-break () + (decf *count*) + (unless (plusp *count*) + (setf *count* 3) + (break))) + +;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities

(macrolet @@ -403,8 +445,9 @@ `(defmacro ,def* (name formals &rest rest) `(progn #+(or ecl gcl) (fmakunbound ',name) - ,(when (and #+ecl (symbolp name)) - `(declaim (notinline ,name))) ; fails for setf functions on ecl + #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( + ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl + `(declaim (notinline ,name))) (,',def ,name ,formals ,@rest))))) (defdef defgeneric* defgeneric) (defdef defun* defun)) @@ -512,7 +555,8 @@ 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)) + :directory (merge-pathname-directory-components + '(:relative :back) (pathname-directory pathname)) :defaults pathname)))

@@ -528,10 +572,10 @@ (defun* last-char (s) (and (stringp s) (plusp (length s)) (char s (1- (length s)))))

- + (defun* asdf-message (format-string &rest format-args) (declare (dynamic-extent format-args)) - (apply #'format *verbose-out* format-string format-args)) + (apply 'format *verbose-out* format-string format-args))

(defun* split-string (string &key max (separator '(#\Space #\Tab))) "Split STRING into a list of components separated by @@ -539,10 +583,10 @@ If MAX is specified, then no more than max(1,MAX) components will be returned, starting the separation from the end, e.g. when called with arguments "a.b.c.d.e" :max 3 :separator "." it will return ("a.b.c" "d" "e")." - (block nil + (catch nil (let ((list nil) (words 0) (end (length string))) (flet ((separatorp (char) (find char separator)) - (done () (return (cons (subseq string 0 end) list)))) + (done () (throw nil (cons (subseq string 0 end) list)))) (loop :for start = (if (and max (>= words (1- max))) (done) @@ -622,10 +666,20 @@

(defun* getenv (x) (declare (ignorable x)) - #+(or abcl clisp) (ext:getenv x) + #+(or abcl clisp xcl) (ext:getenv x) #+allegro (sys:getenv x) #+clozure (ccl:getenv x) #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=)) + #+cormanlisp + (let* ((buffer (ct:malloc 1)) + (cname (ct:lisp-string-to-c-string x)) + (needed-size (win:getenvironmentvariable cname buffer 0)) + (buffer1 (ct:malloc (1+ needed-size)))) + (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size)) + nil + (ct:c-string-to-lisp-string buffer1)) + (ct:free buffer) + (ct:free buffer1))) #+ecl (si:getenv x) #+gcl (system:getenv x) #+genera nil @@ -635,8 +689,8 @@ (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")) + #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl) + (error "~S is not supported on your implementation" 'getenv))

(defun* directory-pathname-p (pathname) "Does PATHNAME represent a directory? @@ -712,6 +766,7 @@ '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>")) (defun* get-uid () #+allegro (excl.osi:getuid) + #+ccl (ccl::getuid) #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid") :for f = (ignore-errors (read-from-string s)) :when f :return (funcall f)) @@ -720,7 +775,7 @@ '(ffi:c-inline () () :int "getuid()" :one-liner t) '(ext::getuid)) #+sbcl (sb-unix:unix-getuid) - #-(or allegro clisp cmu ecl sbcl scl) + #-(or allegro ccl clisp cmu ecl sbcl scl) (let ((uid-string (with-output-to-string (*verbose-out*) (run-shell-command "id -ur")))) @@ -732,22 +787,21 @@ (defun* pathname-root (pathname) (make-pathname :directory '(:absolute) :name nil :type nil :version nil - :defaults pathname ;; host device, and on scl scheme scheme-specific-part port username password + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: . #.(or #+scl '(:parameters nil :query nil :fragment nil))))

-(defun* find-symbol* (s p) - (find-symbol (string s) p)) - (defun* probe-file* (p) "when given a pathname P, probes the filesystem for a file or directory with given pathname and if it exists return its truename." (etypecase p - (null nil) - (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))))))) + (null nil) + (string (probe-file* (parse-namestring p))) + (pathname (unless (wild-pathname-p p) + #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p) + #+clisp (aif (find-symbol* '#:probe-pathname :ext) + `(ignore-errors (,it p))) + '(ignore-errors (truename p)))))))

(defun* truenamize (p) "Resolve as much of a pathname as possible" @@ -788,16 +842,32 @@ path (excl:pathname-resolve-symbolic-links path)))

+(defun* resolve-symlinks* (path) + (if *resolve-symlinks* + (and path (resolve-symlinks path)) + path)) + +(defun ensure-pathname-absolute (path) + (cond + ((absolute-pathname-p path) path) + ((stringp path) (ensure-pathname-absolute (pathname path))) + ((not (pathnamep path)) (error "not a valid pathname designator ~S" path)) + (t (let ((resolved (resolve-symlinks path))) + (assert (absolute-pathname-p resolved)) + resolved)))) + (defun* default-directory () (truenamize (pathname-directory-pathname *default-pathname-defaults*)))

(defun* lispize-pathname (input-file) (make-pathname :type "lisp" :defaults input-file))

+(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*") (defparameter *wild-file* - (make-pathname :name :wild :type :wild :version :wild :directory nil)) + (make-pathname :name *wild* :type *wild* + :version (or #-(or abcl xcl) *wild*) :directory nil)) (defparameter *wild-directory* - (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)) + (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* @@ -834,27 +904,27 @@ #+scl (defun* directorize-pathname-host-device (pathname) (let ((scheme (ext:pathname-scheme pathname)) - (host (pathname-host pathname)) - (port (ext:pathname-port pathname)) - (directory (pathname-directory pathname))) + (host (pathname-host pathname)) + (port (ext:pathname-port pathname)) + (directory (pathname-directory pathname))) (flet ((not-unspecific (component) - (and (not (eq component :unspecific)) component))) + (and (not (eq component :unspecific)) component))) (cond ((or (not-unspecific port) - (and (not-unspecific host) (plusp (length host))) - (not-unspecific scheme)) - (let ((prefix "")) - (when (not-unspecific port) - (setf prefix (format nil ":~D" port))) - (when (and (not-unspecific host) (plusp (length host))) - (setf prefix (concatenate 'string host prefix))) - (setf prefix (concatenate 'string ":" prefix)) - (when (not-unspecific scheme) - (setf prefix (concatenate 'string scheme prefix))) - (assert (and directory (eq (first directory) :absolute))) - (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) - :defaults pathname))) - (t - pathname))))) + (and (not-unspecific host) (plusp (length host))) + (not-unspecific scheme)) + (let ((prefix "")) + (when (not-unspecific port) + (setf prefix (format nil ":~D" port))) + (when (and (not-unspecific host) (plusp (length host))) + (setf prefix (concatenate 'string host prefix))) + (setf prefix (concatenate 'string ":" prefix)) + (when (not-unspecific scheme) + (setf prefix (concatenate 'string scheme prefix))) + (assert (and directory (eq (first directory) :absolute))) + (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) + (t + pathname)))))

;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. @@ -891,6 +961,9 @@

(defgeneric* (setf component-property) (new-value component property))

+(eval-when (:compile-toplevel :load-toplevel :execute) + (defgeneric* (setf module-components-by-name) (new-value module))) + (defgeneric* version-satisfies (component version))

(defgeneric* find-component (base path) @@ -967,12 +1040,12 @@ (when *upgraded-p* (when (find-class 'module nil) (eval - `(defmethod update-instance-for-redefined-class :after + '(defmethod update-instance-for-redefined-class :after ((m module) added deleted plist &key) (declare (ignorable deleted plist)) - (when (or *asdf-verbose* *load-verbose*) + (when *asdf-verbose* (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%") - m ,(asdf-version))) + m (asdf-version))) (when (member 'components-by-name added) (compute-module-components-by-name m)) (when (typep m 'system) @@ -994,44 +1067,31 @@ ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] #+cmu (:report print-object))

-(declaim (ftype (function (t) t) - format-arguments format-control - error-name error-pathname error-condition - duplicate-names-name - error-component error-operation - module-components module-components-by-name - circular-dependency-components - condition-arguments condition-form - condition-format condition-location - coerce-name) - (ftype (function (t t) t) (setf module-components-by-name))) - - (define-condition formatted-system-definition-error (system-definition-error) ((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 'format 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 (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>") - (error-name c) (error-pathname c) (error-condition c))))) + (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~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 (compatfmt "~@<Circular dependency: ~3i~_~S~@:>") - (circular-dependency-components c))))) + (format s (compatfmt "~@<Circular dependency: ~3i~_~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 (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>") - (duplicate-names-name c))))) + (format s (compatfmt "~@<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) @@ -1073,8 +1133,11 @@ ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))

(defclass component () - ((name :accessor component-name :initarg :name :documentation + ((name :accessor component-name :initarg :name :type string :documentation "Component name: designator for a string composed of portable pathname characters") + ;; We might want to constrain version with + ;; :type (and string (satisfies parse-version)) + ;; but we cannot until we fix all systems that don't use it correctly! (version :accessor component-version :initarg :version) (description :accessor component-description :initarg :description) (long-description :accessor component-long-description :initarg :long-description) @@ -1154,7 +1217,7 @@ (missing-requires c) (missing-version c) (when (missing-parent c) - (component-name (missing-parent c))))) + (coerce-name (missing-parent c)))))

(defmethod component-system ((component component)) (aif (component-parent component) @@ -1244,21 +1307,41 @@

(defmethod version-satisfies ((c component) version) (unless (and version (slot-boundp c 'version)) + (when version + (warn "Requested version ~S but component ~S has no version" version c)) (return-from version-satisfies t)) (version-satisfies (component-version c) version))

+(defun parse-version (string &optional on-error) + "Parse a version string as a series of natural integers separated by dots. +Return a (non-null) list of integers if the string is valid, NIL otherwise. +If on-error is error, warn, or designates a function of compatible signature, +the function is called with an explanation of what is wrong with the argument. +NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3" + (and + (or (stringp string) + (when on-error + (funcall on-error "~S: ~S is not a string" + 'parse-version string)) nil) + (or (loop :for prev = nil :then c :for c :across string + :always (or (digit-char-p c) + (and (eql c #.) prev (not (eql prev #.)))) + :finally (return (and c (digit-char-p c)))) + (when on-error + (funcall on-error "~S: ~S doesn't follow asdf version numbering convention" + 'parse-version string)) nil) + (mapcar #'parse-integer (split-string string :separator ".")))) + (defmethod version-satisfies ((cver string) version) - (let ((x (mapcar #'parse-integer - (split-string cver :separator "."))) - (y (mapcar #'parse-integer - (split-string version :separator ".")))) + (let ((x (parse-version cver 'warn)) + (y (parse-version version 'warn))) (labels ((bigger (x y) (cond ((not y) t) ((not x) nil) ((> (car x) (car y)) t) ((= (car x) (car y)) (bigger (cdr x) (cdr y)))))) - (and (= (car x) (car y)) + (and x y (= (car x) (car y)) (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))

;;;; ------------------------------------------------------------------------- @@ -1284,12 +1367,21 @@ (defun* system-registered-p (name) (gethash (coerce-name name) *defined-systems*))

+(defun* register-system (system) + (check-type system system) + (let ((name (component-name system))) + (check-type name string) + (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) + (unless (eq system (cdr (gethash name *defined-systems*))) + (setf (gethash name *defined-systems*) + (cons (get-universal-time) system))))) + (defun* clear-system (name) "Clear the entry for a system in the database of systems previously loaded. 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 - ;; to global data structures. + ;; 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 to global data structures. (remhash (coerce-name name) *defined-systems*))

(defun* map-systems (fn) @@ -1308,16 +1400,14 @@ ;;; convention that functions in this list are prefixed SYSDEF-

(defparameter *system-definition-search-functions* - '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf)) + '(sysdef-central-registry-search + sysdef-source-registry-search + sysdef-find-asdf))

-(defun* system-definition-pathname (system) +(defun* search-for-system-definition (system) (let ((system-name (coerce-name system))) - (or - (some #'(lambda (x) (funcall x system-name)) - *system-definition-search-functions*) - (let ((system-pair (system-registered-p system-name))) - (and system-pair - (system-source-file (cdr system-pair))))))) + (some #'(lambda (x) (funcall x system-name)) + (cons 'find-system-if-being-defined *system-definition-search-functions*))))

(defvar *central-registry* nil "A list of 'system directory designators' ASDF uses to find systems. @@ -1381,8 +1471,8 @@ (push dir to-remove)) (coerce-entry-to-directory () :report (lambda (s) - (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>") - (ensure-directory-pathname defaults) dir)) + (format s (compatfmt "~@<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) @@ -1414,72 +1504,98 @@ ;; 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) (ignore-errors (file-write-date pathname))) (progn (when (and pathname *asdf-verbose*) (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>") pathname)) 0)))

+(defmethod find-system ((name null) &optional (error-p t)) + (when error-p + (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>")))) + (defmethod find-system (name &optional (error-p t)) (find-system (coerce-name name) error-p))

-(defun load-sysdef (name pathname) +(defvar *systems-being-defined* nil + "A hash-table of systems currently being defined keyed by name, or NIL") + +(defun* find-system-if-being-defined (name) + (when *systems-being-defined* + (gethash (coerce-name name) *systems-being-defined*))) + +(defun* call-with-system-definitions (thunk) + (if *systems-being-defined* + (funcall thunk) + (let ((*systems-being-defined* (make-hash-table :test 'equal))) + (funcall thunk)))) + +(defmacro with-system-definitions (() &body body) + `(call-with-system-definitions #'(lambda () ,@body))) + +(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 (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") - pathname package) - (load pathname))) - (delete-package package)))) + (with-system-definitions () + (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 (compatfmt "~&~@<; ~@;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 + (with-system-definitions () (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) + (previous (cdr in-memory)) + (previous (and (typep previous 'system) previous)) + (previous-time (car in-memory)) + (found (search-for-system-definition name)) + (found-system (and (typep found 'system) found)) + (pathname (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous))))) + (setf pathname (resolve-symlinks* pathname)) + (when (and pathname (not (absolute-pathname-p pathname))) + (setf pathname (ensure-pathname-absolute pathname)) + (when found-system + (%set-system-source-file pathname found-system))) + (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp + (system-source-file previous) pathname))) + (%set-system-source-file pathname previous) + (setf previous-time nil)) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and pathname + (or (not previous-time) ;; 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)) + (< previous-time (safe-file-write-date pathname) (get-universal-time)))) + (load-sysdef name pathname)) (let ((in-memory (system-registered-p name))) ; try again after loading from disk (cond (in-memory - (when on-disk - (setf (car in-memory) (safe-file-write-date on-disk))) + (when pathname + (setf (car in-memory) (safe-file-write-date pathname))) (cdr in-memory)) (error-p (error 'missing-component :requires name)))))))

-(defun* register-system (name system) - (setf name (coerce-name name)) - (assert (equal name (component-name system))) - (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) - (setf (gethash name *defined-systems*) (cons (get-universal-time) system))) - (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) (setf fallback (coerce-name fallback) - source-file (or source-file - (if *resolve-symlinks* - (or *compile-file-truename* *load-truename*) - (or *compile-file-pathname* *load-pathname*))) requested (coerce-name requested)) (when (equal requested fallback) - (let* ((registered (cdr (gethash fallback *defined-systems*))) - (system (or registered - (apply 'make-instance 'system - :name fallback :source-file source-file keys)))) - (unless registered - (register-system fallback system)) - (throw 'find-system system)))) + (let ((registered (cdr (gethash fallback *defined-systems*)))) + (or registered + (apply 'make-instance 'system + :name fallback :source-file source-file keys)))))

(defun* sysdef-find-asdf (name) ;; Bug: :version *asdf-version* won't be updated when ASDF is updated. @@ -1523,6 +1639,10 @@

(defclass cl-source-file (source-file) ((type :initform "lisp"))) +(defclass cl-source-file.cl (cl-source-file) + ((type :initform "cl"))) +(defclass cl-source-file.lsp (cl-source-file) + ((type :initform "lsp"))) (defclass c-source-file (source-file) ((type :initform "c"))) (defclass java-source-file (source-file) @@ -1572,12 +1692,13 @@ (values filename type)) (t (split-name-type filename))) - (make-pathname :directory `(,relative ,@path) :name name :type type - :defaults (or defaults *default-pathname-defaults*))))))) + (apply 'make-pathname :directory (cons relative path) :name name :type type + (when defaults `(:defaults ,defaults))))))))

(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. + ;; Will be removed in a future release, e.g. 2.016. + (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.") (coerce-pathname name :type type :defaults defaults))

(defmethod component-relative-pathname ((component component)) @@ -1593,15 +1714,14 @@ ;;; one of these is instantiated whenever #'operate is called

(defclass operation () - ( - ;; as of danb's 2003-03-16 commit e0d02781, :force can be: - ;; T to force the inside of existing system, + (;; as of danb's 2003-03-16 commit e0d02781, :force can be: + ;; T to force the inside of the specified system, ;; but not recurse to other systems we depend on. ;; :ALL (or any other atom) to force all systems ;; including other systems we depend on. ;; (SYSTEM1 SYSTEM2 ... SYSTEMN) ;; to force systems named in a given list - ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out. + ;; However, but this feature has only ever worked but starting with ASDF 2.014.5 (forced :initform nil :initarg :force :accessor operation-forced) (original-initargs :initform nil :initarg :original-initargs :accessor operation-original-initargs) @@ -1643,13 +1763,13 @@ (not (eql c dep-c))) (when (eql force-p t) (setf (getf args :force) nil)) - (apply #'make-instance dep-o + (apply 'make-instance dep-o :parent o :original-initargs args args)) ((subtypep (type-of o) dep-o) o) (t - (apply #'make-instance dep-o + (apply 'make-instance dep-o :parent o :original-initargs args args)))))

@@ -1681,11 +1801,13 @@ (gethash node (operation-visiting-nodes (operation-ancestor o)))))

(defmethod component-depends-on ((op-spec symbol) (c component)) + ;; Note: we go from op-spec to operation via make-instance + ;; to allow for specialization through defmethod's, even though + ;; it's a detour in the default case below. (component-depends-on (make-instance op-spec) c))

(defmethod component-depends-on ((o operation) (c component)) - (cdr (assoc (class-name (class-of o)) - (component-in-order-to c)))) + (cdr (assoc (type-of o) (component-in-order-to c))))

(defmethod component-self-dependencies ((o operation) (c component)) (let ((all-deps (component-depends-on o c))) @@ -1802,13 +1924,13 @@ required-op required-c required-v)) (retry () :report (lambda (s) - (format s "~@<Retry loading component ~3i~_~S.~@:>" required-c)) + (format s "~@<Retry loading ~3i~_~A.~@:>" 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: @@ -1855,11 +1977,11 @@ (funcall collect x))

(defmethod do-traverse ((operation operation) (c component) collect) - (let ((flag nil)) ;; return value: must we rebuild this and its dependencies? + (let ((*forcing* *forcing*) + (flag nil)) ;; return value: must we rebuild this and its dependencies? (labels ((update-flag (x) - (when x - (setf flag t))) + (orf flag x)) (dep (op comp) (update-flag (do-dep operation c collect op comp)))) ;; Have we been visited yet? If so, just process the result. @@ -1873,6 +1995,13 @@ (setf (visiting-component operation c) t) (unwind-protect (progn + (let ((f (operation-forced + (operation-ancestor operation)))) + (when (and f (or (not (consp f)) ;; T or :ALL + (and (typep c 'system) ;; list of names of systems to force + (member (component-name c) f + :test #'string=)))) + (setf *forcing* t))) ;; first we check and do all the dependencies for the module. ;; Operations planned in this loop will show up ;; in the results, and are consumed below. @@ -1912,22 +2041,13 @@ :try-next) (not at-least-one)) (error error))))))) - (update-flag - (or - *forcing* - (not (operation-done-p operation c)) + (update-flag (or *forcing* (not (operation-done-p operation c)))) ;; For sub-operations, check whether ;; the original ancestor operation was forced, ;; or names us amongst an explicit list of things to force... ;; except that this check doesn't distinguish ;; between all the things with a given name. Sigh. ;; BROKEN! - (let ((f (operation-forced - (operation-ancestor operation)))) - (and f (or (not (consp f)) ;; T or :ALL - (and (typep c 'system) ;; list of names of systems to force - (member (component-name c) f - :test #'string=))))))) (when flag (let ((do-first (cdr (assoc (class-name (class-of operation)) (component-do-first c))))) @@ -1956,12 +2076,7 @@ (r* l))))

(defmethod traverse ((operation operation) (c component)) - ;; cerror'ing a feature that seems to have NEVER EVER worked - ;; ever since danb created it in his 2003-03-16 commit e0d02781. - ;; It was both fixed and disabled in the 1.700 rewrite. (when (consp (operation-forced operation)) - (cerror "Continue nonetheless." - "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.") (setf (operation-forced operation) (mapcar #'coerce-name (operation-forced operation)))) (flatten-tree @@ -1979,11 +2094,12 @@ nil)

(defmethod explain ((operation operation) (component component)) - (asdf-message "~&;;; ~A~%" (operation-description operation component))) + (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") + (operation-description operation component)))

(defmethod operation-description (operation component) - (format nil (compatfmt "~@<~A on component ~S~@:>") - (class-of operation) (component-find-path component))) + (format nil (compatfmt "~@<~A on ~A~@:>") + (class-of operation) component))

;;;; ------------------------------------------------------------------------- ;;;; compile-op @@ -2030,13 +2146,8 @@ (multiple-value-bind (output warnings-p failure-p) (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 - (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>") - operation c)) - (:error (error 'compile-warned :component c :operation operation)) - (:ignore nil))) + (unless output + (error 'compile-error :component c :operation operation)) (when failure-p (case (operation-on-failure operation) (:warn (warn @@ -2044,8 +2155,13 @@ operation c)) (:error (error 'compile-failed :component c :operation operation)) (:ignore nil))) - (unless output - (error 'compile-error :component c :operation operation))))) + (when warnings-p + (case (operation-on-warnings operation) + (:warn (warn + (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>") + operation c)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil))))))

(defmethod output-files ((operation compile-op) (c cl-source-file)) (declare (ignorable operation)) @@ -2067,7 +2183,12 @@

(defmethod operation-description ((operation compile-op) component) (declare (ignorable operation)) - (format nil "compiling component ~S" (component-find-path component))) + (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component)) + +(defmethod operation-description ((operation compile-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component)) +

;;;; ------------------------------------------------------------------------- ;;;; load-op @@ -2080,6 +2201,7 @@ (map () #'load (input-files o c)))

(defmethod perform-with-restarts (operation component) + ;;(when *asdf-verbose* (explain operation component)) ; TOO verbose, especially as the default. (perform operation component))

(defmethod perform-with-restarts ((o load-op) (c cl-source-file)) @@ -2094,7 +2216,7 @@ (setf state :success)) (:failed-load (setf state :recompiled) - (perform (make-instance 'compile-op) c)) + (perform (make-sub-operation c o c 'compile-op) c)) (t (with-simple-restart (try-recompiling "Recompile ~a and try loading it again" @@ -2142,9 +2264,18 @@

(defmethod operation-description ((operation load-op) component) (declare (ignorable operation)) - (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>") - (component-find-path component))) + (format nil (compatfmt "~@<loading ~3i~_~A~@:>") + component)) + +(defmethod operation-description ((operation load-op) (component cl-source-file)) + (declare (ignorable operation)) + (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") + component))

+(defmethod operation-description ((operation load-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@<loaded ~3i~_~A~@:>") + component))

;;;; ------------------------------------------------------------------------- ;;;; load-source-op @@ -2166,16 +2297,12 @@ (declare (ignorable operation c)) nil)

-;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. +;;; FIXME: We simply copy load-op's dependencies. This is Just Not Right. (defmethod component-depends-on ((o load-source-op) (c component)) (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)) - what-would-load-op-do))) + (loop :with what-would-load-op-do = (component-depends-on 'load-op c) + :for (op . co) :in what-would-load-op-do + :when (eq op 'load-op) :collect (cons 'load-source-op co)))

(defmethod operation-done-p ((o load-source-op) (c source-file)) (declare (ignorable o)) @@ -2186,8 +2313,12 @@

(defmethod operation-description ((operation load-source-op) component) (declare (ignorable operation)) - (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>") - (component-find-path component))) + (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") + component)) + +(defmethod operation-description ((operation load-source-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component))

;;;; ------------------------------------------------------------------------- @@ -2213,48 +2344,93 @@ ;;;; Invoking Operations

(defgeneric* operate (operation-class system &key &allow-other-keys)) +(defgeneric* perform-plan (plan &key)) + +;;;; Try to upgrade of ASDF. If a different version was used, return T. +;;;; We need do that before we operate on anything that depends on ASDF. +(defun* upgrade-asdf () + (let ((version (asdf:asdf-version))) + (handler-bind (((or style-warning warning) #'muffle-warning)) + (operate 'load-op :asdf :verbose nil)) + (let ((new-version (asdf:asdf-version))) + (block nil + (cond + ((equal version new-version) + (return nil)) + ((version-satisfies new-version version) + (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") + version new-version)) + ((version-satisfies version new-version) + (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%") + version new-version)) + (t + (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") + version new-version))) + (let ((asdf (find-system :asdf))) + ;; invalidate all systems but ASDF itself + (setf *defined-systems* (make-defined-systems-table)) + (register-system asdf) + t))))) + +(defmethod perform-plan ((steps list) &key) + (let ((*package* *package*) + (*readtable* *readtable*)) + (with-compilation-unit () + (loop :for (op . component) :in steps :do + (loop + (restart-case + (progn + (perform-with-restarts op component) + (return)) + (retry () + :report + (lambda (s) + (format s (compatfmt "~@<Retry ~A.~@:>") + (operation-description op component)))) + (accept () + :report + (lambda (s) + (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>") + (operation-description op component))) + (setf (gethash (type-of op) + (component-operation-times component)) + (get-universal-time)) + (return))))))))

(defmethod operate (operation-class system &rest args &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force &allow-other-keys) (declare (ignore force)) - (let* ((*package* *package*) - (*readtable* *readtable*) - (op (apply #'make-instance operation-class - :original-initargs args - args)) - (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream))) - (system (if (typep system 'component) system (find-system system)))) - (unless (version-satisfies system version) - (error 'missing-component-of-version :requires system :version version)) - (let ((steps (traverse op system))) - (with-compilation-unit () - (loop :for (op . component) :in steps :do - (loop - (restart-case - (progn - (perform-with-restarts op component) - (return)) - (retry () - :report - (lambda (s) - (format s (compatfmt "~@<Retry ~A.~@:>") - (operation-description op component)))) - (accept () - :report - (lambda (s) - (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>") - (operation-description op component))) - (setf (gethash (type-of op) - (component-operation-times component)) - (get-universal-time)) - (return)))))) - (values op steps)))) + (with-system-definitions () + (let* ((op (apply 'make-instance operation-class + :original-initargs args + args)) + (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream))) + (system (etypecase system + (system system) + ((or string symbol) (find-system system))))) + (unless (version-satisfies system version) + (error 'missing-component-of-version :requires system :version version)) + (let ((steps (traverse op system))) + (when (and (not (equal '("asdf") (component-find-path system))) + (find '("asdf") (mapcar 'cdr steps) + :test 'equal :key 'component-find-path) + (upgrade-asdf)) + ;; If we needed to upgrade ASDF to achieve our goal, + ;; then do it specially as the first thing, then + ;; invalidate all existing system + ;; retry the whole thing with the new OPERATE function, + ;; which on some implementations + ;; has a new symbol shadowing the current one. + (return-from operate + (apply (find-symbol* 'operate :asdf) operation-class system args))) + (perform-plan steps) + (values op steps)))))

(defun* oos (operation-class system &rest args &key force verbose version &allow-other-keys) (declare (ignore force verbose version)) - (apply #'operate operation-class system args)) + (apply 'operate operation-class system args))

(let ((operate-docstring "Operate does three things: @@ -2281,12 +2457,11 @@ (setf (documentation 'operate 'function) operate-docstring))

-(defun* load-system (system &rest args &key force verbose version - &allow-other-keys) - "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for -details." +(defun* load-system (system &rest args &key force verbose version &allow-other-keys) + "Shorthand for `(operate 'asdf:load-op system)`. +See OPERATE for details." (declare (ignore force verbose version)) - (apply #'operate 'load-op system args) + (apply 'operate 'load-op system args) t)

(defun* compile-system (system &rest args &key force verbose version @@ -2294,7 +2469,7 @@ "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE for details." (declare (ignore force verbose version)) - (apply #'operate 'compile-op system args) + (apply 'operate 'compile-op system args) t)

(defun* test-system (system &rest args &key force verbose version @@ -2302,17 +2477,14 @@ "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for details." (declare (ignore force verbose version)) - (apply #'operate 'test-op system args) + (apply 'operate 'test-op system args) t)

;;;; ------------------------------------------------------------------------- ;;;; Defsystem

(defun* load-pathname () - (let ((pn (or *load-pathname* *compile-file-pathname*))) - (if *resolve-symlinks* - (and pn (resolve-symlinks pn)) - pn))) + (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))

(defun* determine-system-pathname (pathname pathname-supplied-p) ;; The defsystem macro calls us to determine @@ -2328,45 +2500,18 @@ directory-pathname (default-directory))))

-(defmacro defsystem (name &body options) - (setf name (coerce-name name)) - (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) - defsystem-depends-on &allow-other-keys) - options - (let ((component-options (remove-keys '(:class) options))) - `(progn - ;; system must be registered before we parse the body, otherwise - ;; we recur when trying to find an existing system of the same name - ;; to reuse options (e.g. pathname) from - ,@(loop :for system :in defsystem-depends-on - :collect `(load-system ',(coerce-name system))) - (let ((s (system-registered-p ',name))) - (cond ((and s (eq (type-of (cdr s)) ',class)) - (setf (car s) (get-universal-time))) - (s - (change-class (cdr s) ',class)) - (t - (register-system (quote ,name) - (make-instance ',class :name ',name)))) - (%set-system-source-file (load-pathname) - (cdr (system-registered-p ',name)))) - (parse-component-form - nil (list* - :module (coerce-name ',name) - :pathname - ,(determine-system-pathname pathname pathname-arg-p) - ',component-options)))))) - (defun* class-for-type (parent type) (or (loop :for symbol :in (list type (find-symbol* type *package*) (find-symbol* type :asdf)) :for class = (and symbol (find-class symbol nil)) - :when (and class (subtypep class 'component)) + :when (and class + (#-cormanlisp subtypep #+cormanlisp cl::subclassp + class (find-class 'component))) :return class) (and (eq type :file) - (or (module-default-component-class parent) + (or (and parent (module-default-component-class parent)) (find-class *default-component-class*))) (sysdef-error "don't recognize component type ~A" type)))

@@ -2458,6 +2603,7 @@ perform explain output-files operation-done-p weakly-depends-on depends-on serial in-order-to + (version nil versionp) ;; list ends &allow-other-keys) options (declare (ignorable perform explain output-files operation-done-p)) @@ -2471,6 +2617,11 @@ (class-for-type parent type)))) (error 'duplicate-names :name name))

+ (when versionp + (unless (parse-version version nil) + (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>") + version name parent))) + (let* ((other-args (remove-keys '(components pathname default-component-class perform explain output-files operation-done-p @@ -2484,7 +2635,7 @@ (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))) (when *serial-depends-on* (push *serial-depends-on* depends-on)) - (apply #'reinitialize-instance ret + (apply 'reinitialize-instance ret :name (coerce-name name) :pathname pathname :parent parent @@ -2517,6 +2668,40 @@ (%refresh-component-inline-methods ret rest) ret)))

+(defun* do-defsystem (name &rest options + &key (pathname nil pathname-arg-p) (class 'system) + defsystem-depends-on &allow-other-keys) + ;; The system must be registered before we parse the body, + ;; otherwise we recur when trying to find an existing system + ;; of the same name to reuse options (e.g. pathname) from. + ;; To avoid infinite recursion in cases where you defsystem a system + ;; that is registered to a different location to find-system, + ;; we also need to remember it in a special variable *systems-being-defined*. + (with-system-definitions () + (let* ((name (coerce-name name)) + (registered (system-registered-p name)) + (system (cdr (or registered + (register-system (make-instance 'system :name name))))) + (component-options (remove-keys '(:class) options))) + (%set-system-source-file (load-pathname) system) + (setf (gethash name *systems-being-defined*) system) + (when registered + (setf (car registered) (get-universal-time))) + (map () 'load-system defsystem-depends-on) + ;; We change-class (when necessary) AFTER we load the defsystem-dep's + ;; since the class might not be defined as part of those. + (let ((class (class-for-type nil class))) + (unless (eq (type-of system) class) + (change-class system class))) + (parse-component-form + nil (list* + :module name + :pathname (determine-system-pathname pathname pathname-arg-p) + component-options))))) + +(defmacro defsystem (name &body options) + `(apply 'do-defsystem ',name ',options)) + ;;;; --------------------------------------------------------------------------- ;;;; run-shell-command ;;;; @@ -2534,7 +2719,7 @@ "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and synchronously execute the result using a Bourne-compatible shell, with output to *VERBOSE-OUT*. Returns the shell's exit code." - (let ((command (apply #'format nil control-string args))) + (let ((command (apply 'format nil control-string args))) (asdf-message "; $ ~A~%" command)

#+abcl @@ -2552,8 +2737,8 @@ (asdf-message "~{~&; ~a~%~}~%" stdout) exit-code)

- #+clisp ;XXX not exactly *verbose-out*, I know - (or (ext:run-shell-command command :output :terminal :wait t) 0) + #+clisp ;XXX not exactly *verbose-out*, I know + (or (ext:run-shell-command command :output (and *verbose-out* :terminal) :wait t) 0)

#+clozure (nth-value 1 @@ -2578,7 +2763,7 @@

#+sbcl (sb-ext:process-exit-code - (apply #'sb-ext:run-program + (apply 'sb-ext:run-program #+win32 "sh" #-win32 "/bin/sh" (list "-c" command) :input nil :output *verbose-out* @@ -2591,12 +2776,28 @@ (list "-c" command) :input nil :output *verbose-out*))

- #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) + #+xcl + (ext:run-shell-command command) + + #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl) (error "RUN-SHELL-COMMAND not implemented for this Lisp")))

;;;; --------------------------------------------------------------------------- ;;;; system-relative-pathname

+(defun* system-definition-pathname (x) + ;; As of 2.014.8, we mean to make this function obsolete, + ;; but that won't happen until all clients have been updated. + ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead" + "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete. +It used to expose ASDF internals with subtle differences with respect to +user expectations, that have been refactored away since. +We recommend you use ASDF:SYSTEM-SOURCE-FILE instead +for a mostly compatible replacement that we're supporting, +or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME +if that's whay you mean." ;;) + (system-source-file x)) + (defmethod system-source-file ((system-name string)) (system-source-file (find-system system-name))) (defmethod system-source-file ((system-name symbol)) @@ -2644,10 +2845,10 @@ (:ccl :clozure) (:corman :cormanlisp) (:lw :lispworks) - :clisp :cmu :ecl :gcl :sbcl :scl :symbolics)) + :clisp :cmu :ecl :gcl :sbcl :scl :symbolics :xcl))

(defparameter *os-features* - '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows + '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows (:solaris :sunos) (:linux :linux-target) ;; for GCL at least, must appear before :bsd. (:macosx :darwin :darwin-target :apple) @@ -2656,54 +2857,48 @@ :genera))

(defparameter *architecture-features* - '((:amd64 :x86-64 :x86_64 :x8664-target) + '((:x64 :amd64 :x86-64 :x86_64 :x8664-target #+(and clisp word-size=64) :pc386) (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) - :hppa64 - :hppa - (:ppc64 :ppc64-target) - (:ppc32 :ppc32-target :ppc :powerpc) - :sparc64 - (:sparc32 :sparc) + :hppa64 :hppa + (:ppc64 :ppc64-target) (:ppc32 :ppc32-target :ppc :powerpc) + :sparc64 (:sparc32 :sparc) (:arm :arm-target) (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7) + :mipsel :mipseb :mips + :alpha :imach))

(defun* lisp-version-string () (let ((s (lisp-implementation-version))) - (declare (ignorable s)) - #+allegro (format nil - "~A~A~A~A" - excl::*common-lisp-version-number* - ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox - (if (eq excl:*current-case-mode* - :case-sensitive-lower) "M" "A") - ;; Note if not using International ACL - ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target... - (excl:ics-target-case - (:-ics "8") - (:+ics "")) - (if (member :64bit *features*) "-64bit" "")) - #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) - #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.) - #+clozure (format nil "~d.~d-f~d" ; shorten for windows - ccl::*openmcl-major-version* - ccl::*openmcl-minor-version* - (logand ccl::fasl-version #xFF)) - #+cmu (substitute #- #/ s) - #+ecl (format nil "~A~@[-~A~]" s - (let ((vcs-id (ext:lisp-implementation-vcs-id))) - (when (>= (length vcs-id) 8) - (subseq vcs-id 0 8)))) - #+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 - #+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)) + (or + #+allegro (format nil + "~A~A~A" + excl::*common-lisp-version-number* + ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox + (if (eq excl:*current-case-mode* + :case-sensitive-lower) "M" "A") + ;; Note if not using International ACL + ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target... + (excl:ics-target-case + (:-ics "8") + (:+ics ""))) ; redundant? (if (member :64bit *features*) "-64bit" "")) + #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) + #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.) + #+clozure (format nil "~d.~d-f~d" ; shorten for windows + ccl::*openmcl-major-version* + ccl::*openmcl-minor-version* + (logand ccl::fasl-version #xFF)) + #+cmu (substitute #- #/ s) + #+ecl (format nil "~A~@[-~A~]" s + (let ((vcs-id (ext:lisp-implementation-vcs-id))) + (when (>= (length vcs-id) 8) + (subseq vcs-id 0 8)))) + #+gcl (subseq s (1+ (position #\space s))) + #+genera (multiple-value-bind (major minor) (sct:get-system-version "System") + (format nil "~D.~D" major minor)) + ;; #+lispworks (format nil "~A~@[~A~]" s (when (member :lispworks-64bit *features*) "-64bit") #+mcl (subseq s 8) ; strip the leading "Version " + ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version + s)))

(defun* first-feature (features) (labels @@ -2728,7 +2923,7 @@ (labels ((maybe-warn (value fstring &rest args) (cond (value) - (t (apply #'warn fstring args) + (t (apply 'warn fstring args) "unknown")))) (let ((lisp (maybe-warn (implementation-type) (compatfmt "~@<No implementation feature found in ~a.~@:>") @@ -2753,8 +2948,19 @@ #+asdf-unix #: #-asdf-unix #;)

+;; Note: ASDF may expect user-homedir-pathname to provide the pathname of +;; the current user's home directory, while MCL by default provides the +;; directory from which MCL was started. +;; See http://code.google.com/p/mcl/wiki/Portability +#.(or #+mcl ;; the #$ doesn't work on other implementations, even inside #+mcl + `(defun current-user-homedir-pathname () + ,(read-from-string "(ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))"))) + (defun* user-homedir () - (truenamize (pathname-directory-pathname (user-homedir-pathname)))) + (truenamize + (pathname-directory-pathname + #+mcl (current-user-homedir-pathname) + #-mcl (user-homedir-pathname))))

(defun* try-directory-subpath (x sub &key type) (let* ((p (and x (ensure-directory-pathname x))) @@ -2763,29 +2969,34 @@ (ts (and sp (probe-file* sp)))) (and ts (values sp ts)))) (defun* user-configuration-directories () - (remove-if - #'null - (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) - `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/") - ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") - :for dir :in (split-string dirs :separator ":") - :collect (try dir "common-lisp/")) - #+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/")) - ,(try (user-homedir) ".config/common-lisp/"))))) + (let ((dirs + (flet ((try (x sub) (try-directory-subpath x sub))) + `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/") + ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") + :for dir :in (split-string dirs :separator ":") + :collect (try dir "common-lisp/")) + #+asdf-windows + ,@`(,(try (or #+lispworks (sys:get-folder-path :local-appdata) + (getenv "LOCALAPPDATA")) + "common-lisp/config/") + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData + ,(try (or #+lispworks (sys:get-folder-path :appdata) + (getenv "APPDATA")) + "common-lisp/config/")) + ,(try (user-homedir) ".config/common-lisp/"))))) + (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal))) (defun* system-configuration-directories () (remove-if #'null - (append - #+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/")))) + `(#+asdf-windows + ,(flet ((try (x sub) (try-directory-subpath x sub))) + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData + (try (or #+lispworks (sys:get-folder-path :common-appdata) + (getenv "ALLUSERSAPPDATA") + (try (getenv "ALLUSERSPROFILE") "Application Data/")) + "common-lisp/config/")) + #+asdf-unix #p"/etc/common-lisp/"))) + (defun* in-first-directory (dirs x) (loop :for dir :in dirs :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir)))))) @@ -2845,7 +3056,7 @@ (let ((forms (read-file-forms file))) (unless (length=n-p forms 1) (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%") - description forms)) + description forms)) (funcall validator (car forms) :location file)))

(defun* hidden-file-p (pathname) @@ -2857,7 +3068,8 @@ #+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)))))) + #+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 @@ -2903,7 +3115,11 @@ (or (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation) #+asdf-windows - (try (getenv "APPDATA") "common-lisp" "cache" :implementation) + (try (or #+lispworks (sys:get-folder-path :local-appdata) + (getenv "LOCALAPPDATA") + #+lispworks (sys:get-folder-path :appdata) + (getenv "APPDATA")) + "common-lisp" "cache" :implementation) '(:home ".cache" "common-lisp" :implementation)))) (defvar *system-cache* ;; No good default, plus there's a security problem @@ -3002,7 +3218,10 @@ :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 :system-cache) + (warn "Using the :system-cache is deprecated. ~%~ +Please remove it from your ASDF configuration") + (resolve-location *system-cache* :directory t :wilden nil)) ((eql :default-directory) (default-directory)))) (s (if (and wilden (not (pathnamep x))) (wilden r) @@ -3101,7 +3320,7 @@ ((equal "" s) (when inherit (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") - string)) + string)) (setf inherit t) (push :inherit-configuration directives)) (t @@ -3110,7 +3329,7 @@ (when (> start end) (when source (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>") - string)) + string)) (unless inherit (push :ignore-inherited-configuration directives)) (return `(:output-translations ,@(nreverse directives))))))))) @@ -3128,8 +3347,9 @@ ;; so we must disable translations for implementation paths. #+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 + ;; The below two are not needed: no precompiled ASDF system there + ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) + ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ;; All-import, here is where we want user stuff to be: :inherit-configuration ;; These are for convenience, and can be overridden by the user: @@ -3142,7 +3362,7 @@ (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))

(defun* user-output-translations-pathname () - (in-user-configuration-directory *output-translations-file* )) + (in-user-configuration-directory *output-translations-file*)) (defun* system-output-translations-pathname () (in-system-configuration-directory *output-translations-file*)) (defun* user-output-translations-directory-pathname () @@ -3216,8 +3436,9 @@ ((eq dst t) (funcall collect (list trusrc t))) (t - (let* ((trudst (make-pathname - :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc))) + (let* ((trudst (if dst + (resolve-location dst :directory t :wilden t) + trusrc)) (wilddst (merge-pathnames* *wild-file* trudst))) (funcall collect (list wilddst t)) (funcall collect (list trusrc trudst))))))))))) @@ -3271,6 +3492,7 @@

(defun* apply-output-translations (path) (etypecase path + #+cormanlisp (t (truenamize path)) (logical-pathname path) ((or pathname string) @@ -3300,7 +3522,8 @@ t))

(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) - (or output-file + (if (absolute-pathname-p output-file) + (apply 'compile-file-pathname (lispize-pathname input-file) keys) (apply-output-translations (apply 'compile-file-pathname (truenamize (lispize-pathname input-file)) @@ -3316,7 +3539,7 @@ (delete-file x)))

(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys) - (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys))) + (let* ((output-file (apply 'compile-file-pathname* input-file :output-file output-file keys)) (tmp-file (tmpize-pathname output-file)) (status :error)) (multiple-value-bind (output-truename warnings-p failure-p) @@ -3383,7 +3606,7 @@ (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"))) (mapped-files (if map-all-source-files *wild-file* - (make-pathname :name :wild :version :wild :type fasl-type))) + (make-pathname :type fasl-type :defaults *wild-file*))) (destination-directory (if centralize-lisp-binaries `(,default-toplevel-directory @@ -3417,8 +3640,7 @@ :do (write-char (code-char code) out))))

(defun* read-little-endian (s &optional (bytes 4)) - (loop - :for i :from 0 :below bytes + (loop :for i :from 0 :below bytes :sum (ash (read-byte s) (* 8 i))))

(defun* parse-file-location-info (s) @@ -3485,64 +3707,62 @@ ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" "_sgbak" "autom4te.cache" "cover_db" "_build" - "debian")) ;; debian often build stuff under the debian directory... BAD. + "debian")) ;; debian often builds stuff under the debian directory... BAD.

(defvar *source-registry-exclusions* *default-source-registry-exclusions*)

-(defvar *source-registry* () - "Either NIL (for uninitialized), or a list of one element, -said element itself being a list of directory pathnames where to look for .asd files") - -(defun* source-registry () - (car *source-registry*)) - -(defun* (setf source-registry) (new-value) - (setf *source-registry* (list new-value)) - new-value) +(defvar *source-registry* nil + "Either NIL (for uninitialized), or an equal hash-table, mapping +system names to pathnames of .asd files")

(defun* source-registry-initialized-p () - (and *source-registry* t)) + (typep *source-registry* 'hash-table))

(defun* clear-source-registry () "Undoes any initialization of the source registry. You might want to call that before you dump an image that would be resumed with a different configuration, so the configuration would be re-read then." - (setf *source-registry* '()) + (setf *source-registry* nil) (values))

(defparameter *wild-asd* - (make-pathname :directory nil :name :wild :type "asd" :version :newest)) + (make-pathname :directory nil :name *wild* :type "asd" :version :newest))

-(defun directory-has-asd-files-p (directory) +(defun directory-asd-files (directory) (ignore-errors - (and (directory* (merge-pathnames* *wild-asd* directory)) t))) + (directory* (merge-pathnames* *wild-asd* directory))))

(defun subdirectories (directory) (let* ((directory (ensure-directory-pathname directory)) - #-(or cormanlisp genera) + #-(or abcl cormanlisp genera xcl) (wild (merge-pathnames* - #-(or abcl allegro cmu lispworks scl) + #-(or abcl allegro cmu lispworks scl xcl) *wild-directory* - #+(or abcl allegro cmu lispworks scl) "*.*" + #+(or abcl allegro cmu lispworks scl xcl) "*.*" directory)) (dirs - #-(or cormanlisp genera) + #-(or abcl cormanlisp genera xcl) (ignore-errors (directory* wild . #.(or #+clozure '(:directories t :files nil) #+mcl '(:directories t)))) + #+(or abcl xcl) (system:list-directory directory) #+cormanlisp (cl::directory-subdirs directory) #+genera (fs:directory-list directory)) - #+(or abcl allegro cmu genera lispworks scl) - (dirs (remove-if-not #+abcl #'extensions:probe-directory - #+allegro #'excl:probe-directory - #+lispworks #'lw:file-directory-p - #+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))) + #+(or abcl allegro cmu genera lispworks scl xcl) + (dirs (loop :for x :in dirs + :for d = #+(or abcl xcl) (extensions:probe-directory x) + #+allegro (excl:probe-directory x) + #+(or cmu scl) (directory-pathname-p x) + #+genera (getf (cdr x) :directory) + #+lispworks (lw:file-directory-p x) + :when d :collect #+(or abcl allegro xcl) d + #+genera (ensure-directory-pathname (first x)) + #+(or cmu lispworks scl) x))) dirs))

+(defun collect-asds-in-directory (directory collect) + (map () collect (directory-asd-files directory))) + (defun collect-sub*directories (directory collectp recursep collector) (when (funcall collectp directory) (funcall collector directory)) @@ -3550,15 +3770,15 @@ (when (funcall recursep subdir) (collect-sub*directories subdir collectp recursep collector))))

-(defun collect-sub*directories-with-asd +(defun collect-sub*directories-asd-files (directory &key (exclude *default-source-registry-exclusions*) collect) (collect-sub*directories directory - #'directory-has-asd-files-p + (constantly t) #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal))) - collect)) + #'(lambda (dir) (collect-asds-in-directory dir collect))))

(defun* validate-source-registry-directive (directive) (or (member directive '(:default-registry)) @@ -3603,17 +3823,21 @@ :with end = (length string) :for pos = (position *inter-directory-separator* string :start start) :do (let ((s (subseq string start (or pos end)))) - (cond - ((equal "" s) ; empty element: inherit - (when inherit - (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") - string)) - (setf inherit t) - (push ':inherit-configuration directives)) - ((ends-with s "//") - (push `(:tree ,(subseq s 0 (1- (length s)))) directives)) - (t - (push `(:directory ,s) directives))) + (flet ((check (dir) + (unless (absolute-pathname-p dir) + (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string)) + dir)) + (cond + ((equal "" s) ; empty element: inherit + (when inherit + (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") + string)) + (setf inherit t) + (push ':inherit-configuration directives)) + ((ends-with s "//") ;; TODO: allow for doubling of separator even outside Unix? + (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives)) + (t + (push `(:directory ,(check s)) directives)))) (cond (pos (setf start (1+ pos))) @@ -3624,8 +3848,8 @@

(defun* register-asd-directory (directory &key recurse exclude collect) (if (not recurse) - (funcall collect directory) - (collect-sub*directories-with-asd + (collect-asds-in-directory directory collect) + (collect-sub*directories-asd-files directory :exclude exclude :collect collect)))

(defparameter *default-source-registries* @@ -3645,30 +3869,27 @@ :inherit-configuration #+cmu (:tree #p"modules:"))) (defun* default-source-registry () - (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) + (flet ((try (x sub) (try-directory-subpath x sub))) `(:source-registry - #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir))) + #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/")) (:directory ,(default-directory)) - ,@(let* - #+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 ":")))) - #+asdf-windows - ((datahome (getenv "APPDATA")) - (datadir - #+lispworks (sys:get-folder-path :local-appdata) - #-lispworks (try (getenv "ALLUSERSPROFILE") - "Application Data")) - (dirs (list datahome datadir))) - #-(or asdf-unix asdf-windows) - ((dirs ())) - (loop :for dir :in dirs - :collect `(:directory ,(try dir "common-lisp/systems/")) - :collect `(:tree ,(try dir "common-lisp/source/")))) + ,@(loop :for dir :in + `(#+asdf-unix + ,@`(,(or (getenv "XDG_DATA_HOME") + (try (user-homedir) ".local/share/")) + ,@(split-string (or (getenv "XDG_DATA_DIRS") + "/usr/local/share:/usr/share") + :separator ":")) + #+asdf-windows + ,@`(,(or #+lispworks (sys:get-folder-path :local-appdata) + (getenv "LOCALAPPDATA")) + ,(or #+lispworks (sys:get-folder-path :appdata) + (getenv "APPDATA")) + ,(or #+lispworks (sys:get-folder-path :common-appdata) + (getenv "ALLUSERSAPPDATA") + (try (getenv "ALLUSERSPROFILE") "Application Data/")))) + :collect `(:directory ,(try dir "common-lisp/systems/")) + :collect `(:tree ,(try dir "common-lisp/source/"))) :inherit-configuration))) (defun* user-source-registry () (in-user-configuration-directory *source-registry-file*)) @@ -3757,19 +3978,34 @@

;; Will read the configuration and initialize all internal variables, ;; and return the new configuration. -(defun* compute-source-registry (&optional parameter) - (while-collecting (collect) - (dolist (entry (flatten-source-registry parameter)) - (destructuring-bind (directory &key recurse exclude) entry +(defun* compute-source-registry (&optional parameter (registry *source-registry*)) + (dolist (entry (flatten-source-registry parameter)) + (destructuring-bind (directory &key recurse exclude) entry + (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates (register-asd-directory - directory - :recurse recurse :exclude exclude :collect #'collect))))) + directory :recurse recurse :exclude exclude :collect + #'(lambda (asd) + (let ((name (pathname-name asd))) + (cond + ((gethash name registry) ; already shadowed by something else + nil) + ((gethash name h) ; conflict at current level + (when *asdf-verbose* + (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~ + found several entries for ~A - picking ~S over ~S~:>") + directory recurse name (gethash name h) asd))) + (t + (setf (gethash name registry) asd) + (setf (gethash name h) asd)))))) + h))) + (values))

(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))) + (setf *source-registry-parameter* parameter) + (setf *source-registry* (make-hash-table :test 'equal)) + (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 @@ -3780,24 +4016,60 @@ ;; you may override the configuration explicitly by calling ;; initialize-source-registry directly with your parameter. (defun* ensure-source-registry (&optional parameter) - (if (source-registry-initialized-p) - (source-registry) - (initialize-source-registry parameter))) + (unless (source-registry-initialized-p) + (initialize-source-registry parameter)) + (values))

(defun* sysdef-source-registry-search (system) (ensure-source-registry) - (loop :with name = (coerce-name system) - :for defaults :in (source-registry) - :for file = (probe-asd name defaults) - :when file :return file)) + (values (gethash (coerce-name system) *source-registry*)))

(defun* clear-configuration () (clear-source-registry) (clear-output-translations))

+ +;;; ECL support for COMPILE-OP / LOAD-OP +;;; +;;; In ECL, these operations produce both FASL files and the +;;; object files that they are built from. Having both of them allows +;;; us to later on reuse the object files for bundles, libraries, +;;; standalone executables, etc. +;;; +;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes +;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp. +;;; +#+ecl +(progn + (setf *compile-op-compile-file-function* + (lambda (input-file &rest keys &key output-file &allow-other-keys) + (declare (ignore output-file)) + (multiple-value-bind (object-file flags1 flags2) + (apply 'compile-file* input-file :system-p t keys) + (values (and object-file + (c::build-fasl (compile-file-pathname object-file :type :fasl) + :lisp-files (list object-file)) + object-file) + flags1 + flags2)))) + + (defmethod output-files ((operation compile-op) (c cl-source-file)) + (declare (ignorable operation)) + (let ((p (lispize-pathname (component-pathname c)))) + (list (compile-file-pathname p :type :object) + (compile-file-pathname p :type :fasl)))) + + (defmethod perform ((o load-op) (c cl-source-file)) + (map () #'load + (loop :for i :in (input-files o c) + :unless (string= (pathname-type i) "fas") + :collect (compile-file-pathname (lispize-pathname i)))))) + ;;;; ----------------------------------------------------------------- ;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL ;;;; +(defvar *require-asdf-operator* 'load-op) + (defun* module-provide-asdf (name) (handler-bind ((style-warning #'muffle-warning) @@ -3806,9 +4078,10 @@ (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%") name e)))) (let ((*verbose-out* (make-broadcast-stream)) - (system (find-system (string-downcase name) nil))) + (system (find-system (string-downcase name) nil))) (when system - (load-system system))))) + (operate *require-asdf-operator* system :verbose nil) + t))))

#+(or abcl clisp clozure cmu ecl sbcl) (let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))