Index: /trunk/source/tools/asdf.lisp =================================================================== --- /trunk/source/tools/asdf.lisp (revision 14788) +++ /trunk/source/tools/asdf.lisp (revision 14789) @@ -1,4 +1,4 @@ ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.014: Another System Definition Facility. +;;; This is ASDF 2.015: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: @@ -20,5 +20,5 @@ ;;; 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 @@ -50,11 +50,10 @@ (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. @@ -62,26 +61,14 @@ (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. @@ -92,4 +79,22 @@ (defvar *asdf-version* nil) (defvar *upgraded-p* nil) + (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12. + ;; 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 @@ -100,13 +105,13 @@ ;; "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") + (asdf-version "2.015") (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 + (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) @@ -148,5 +153,5 @@ (let ((sym (find-sym symbol package))) (when sym - (unexport sym package) + #-cormanlisp (unexport sym package) (unintern sym package) sym))) @@ -214,5 +219,5 @@ #: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 @@ -226,5 +231,6 @@ :export (#:defsystem #:oos #:operate #:find-system #:run-shell-command - #:system-definition-pathname #:find-component ; miscellaneous + #:system-definition-pathname + #:search-for-system-definition #:find-component ; miscellaneous #:compile-system #:load-system #:test-system #:clear-system #:compile-op #:load-op #:load-source-op @@ -234,4 +240,6 @@ #:version ; metaphorically sort-of an operation #:version-satisfies + #:upgrade-asdf + #:implementation-identifier #:implementation-type #:input-files #:output-files #:output-file #:perform ; operation methods @@ -240,4 +248,5 @@ #:component #:source-file #:c-source-file #:cl-source-file #:java-source-file + #:cl-source-file.cl #:cl-source-file.lsp #:static-file #:doc-file @@ -350,5 +359,5 @@ #:truenamize #:while-collecting))) - #+genera (import 'scl:boolean :asdf) + #+genera (import 'scl:boolean :asdf) (setf *asdf-version* asdf-version *upgraded-p* (if existing-version @@ -362,5 +371,5 @@ "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*) @@ -382,6 +391,4 @@ (defvar *verbose-out* nil) - -(defvar *asdf-verbose* t) (defparameter +asdf-methods+ @@ -397,4 +404,39 @@ ;;;; ------------------------------------------------------------------------- +;;;; 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 @@ -404,6 +446,7 @@ `(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) @@ -529,8 +572,8 @@ (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))) @@ -540,8 +583,8 @@ 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))) @@ -623,8 +666,18 @@ (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) @@ -636,6 +689,6 @@ (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) @@ -713,4 +766,5 @@ (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)) @@ -721,5 +775,5 @@ '(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*) @@ -743,10 +797,10 @@ 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 (string '#:probe-pathname) :ext) `(ignore-errors (,it p))) + '(ignore-errors (truename p))))))) (defun* truenamize (p) @@ -789,4 +843,18 @@ (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*))) @@ -795,8 +863,9 @@ (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 *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)) @@ -835,25 +904,25 @@ (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))))) ;;;; ------------------------------------------------------------------------- @@ -892,4 +961,7 @@ (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)) @@ -968,10 +1040,10 @@ (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)) @@ -995,22 +1067,9 @@ #+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) @@ -1019,18 +1078,18 @@ (condition :initarg :condition :reader error-condition)) (:report (lambda (c s) - (format s (compatfmt "~@") - (error-name c) (error-pathname c) (error-condition c))))) + (format s (compatfmt "~@") + (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-components c))))) + (format s (compatfmt "~@") + (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 "~@") - (duplicate-names-name c))))) + (format s (compatfmt "~@") + (duplicate-names-name c))))) (define-condition missing-component (system-definition-error) @@ -1074,7 +1133,7 @@ (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") - (version :accessor component-version :initarg :version) + (version :accessor component-version :initarg :version) ;; :type (and string (satisfies parse-version)) -- not until we fix all systems that don't use it correctly! (description :accessor component-description :initarg :description) (long-description :accessor component-long-description :initarg :long-description) @@ -1155,5 +1214,5 @@ (missing-version c) (when (missing-parent c) - (component-name (missing-parent c))))) + (coerce-name (missing-parent c))))) (defmethod component-system ((component component)) @@ -1245,12 +1304,32 @@ (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) @@ -1259,5 +1338,5 @@ ((= (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))))))) @@ -1285,10 +1364,19 @@ (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*)) @@ -1309,14 +1397,12 @@ (defparameter *system-definition-search-functions* - '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf)) - -(defun* system-definition-pathname (system) + '(sysdef-central-registry-search + sysdef-source-registry-search + sysdef-find-asdf)) + +(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)) + *system-definition-search-functions*))) (defvar *central-registry* nil @@ -1382,6 +1468,6 @@ (coerce-entry-to-directory () :report (lambda (s) - (format s (compatfmt "~@") - (ensure-directory-pathname defaults) dir)) + (format s (compatfmt "~@") + (ensure-directory-pathname defaults) dir)) (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) ;; cleanup @@ -1415,5 +1501,5 @@ ;; 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*) @@ -1421,4 +1507,8 @@ pathname)) 0))) + +(defmethod find-system ((name null) &optional (error-p t)) + (when error-p + (sysdef-error (compatfmt "~@")))) (defmethod find-system (name &optional (error-p t)) @@ -1436,49 +1526,53 @@ (let ((*package* package)) (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") - pathname package) + 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)) ; load from disk if absent or newer on disk - (on-disk (system-definition-pathname name))) - (when (and on-disk - (or (not in-memory) - ;; 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 - (setf (car in-memory) (safe-file-write-date on-disk))) - (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))) + (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk + (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. + (< 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 pathname + (setf (car in-memory) (safe-file-write-date pathname))) + (cdr in-memory)) + (error-p + (error 'missing-component :requires name)))))) (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) @@ -1524,4 +1618,8 @@ (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"))) @@ -1573,10 +1671,12 @@ (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 + ;; XCL 0.0.0.291 and ABCL 0.25 have a bug, whereby make-pathname merges directories like merge-pathnames when a :defaults is provided. Fixed in the latest XCL. + (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)) @@ -1594,7 +1694,6 @@ (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 @@ -1602,5 +1701,5 @@ ;; (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 @@ -1644,5 +1743,5 @@ (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)) @@ -1650,5 +1749,5 @@ o) (t - (apply #'make-instance dep-o + (apply 'make-instance dep-o :parent o :original-initargs args args))))) @@ -1682,9 +1781,11 @@ (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)) @@ -1803,11 +1904,11 @@ (retry () :report (lambda (s) - (format s "~@" required-c)) + (format 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) @@ -1856,9 +1957,9 @@ (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)))) @@ -1874,4 +1975,11 @@ (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 @@ -1913,8 +2021,5 @@ (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, @@ -1923,10 +2028,4 @@ ;; 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)) @@ -1957,10 +2056,5 @@ (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)))) @@ -1980,9 +2074,10 @@ (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)) ;;;; ------------------------------------------------------------------------- @@ -2068,5 +2163,10 @@ (defmethod operation-description ((operation compile-op) component) (declare (ignorable operation)) - (format nil "compiling component ~S" (component-find-path component))) + (format nil (compatfmt "~@") component)) + +(defmethod operation-description ((operation compile-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@") component)) + ;;;; ------------------------------------------------------------------------- @@ -2081,4 +2181,5 @@ (defmethod perform-with-restarts (operation component) + ;;(when *asdf-verbose* (explain operation component)) ; TOO verbose, especially as the default. (perform operation component)) @@ -2095,5 +2196,5 @@ (: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 @@ -2143,7 +2244,16 @@ (defmethod operation-description ((operation load-op) component) (declare (ignorable operation)) - (format nil (compatfmt "~@") - (component-find-path component))) - + (format nil (compatfmt "~@") + component)) + +(defmethod operation-description ((operation load-op) (component cl-source-file)) + (declare (ignorable operation)) + (format nil (compatfmt "~@") + component)) + +(defmethod operation-description ((operation load-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@") + component)) ;;;; ------------------------------------------------------------------------- @@ -2170,11 +2280,7 @@ (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)) @@ -2187,6 +2293,10 @@ (defmethod operation-description ((operation load-source-op) component) (declare (ignorable operation)) - (format nil (compatfmt "~@") - (component-find-path component))) + (format nil (compatfmt "~@") + component)) + +(defmethod operation-description ((operation load-source-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@") component)) @@ -2214,4 +2324,56 @@ (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 "~&~@~%") + 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 "~@") + (operation-description op component)))) + (accept () + :report + (lambda (s) + (format s (compatfmt "~@") + (operation-description op component))) + (setf (gethash (type-of op) + (component-operation-times component)) + (get-universal-time)) + (return)))))))) (defmethod operate (operation-class system &rest args @@ -2219,35 +2381,28 @@ &allow-other-keys) (declare (ignore force)) - (let* ((*package* *package*) - (*readtable* *readtable*) - (op (apply #'make-instance operation-class + (let* ((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)))) + (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))) - (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 "~@") - (operation-description op component)))) - (accept () - :report - (lambda (s) - (format s (compatfmt "~@") - (operation-description op component))) - (setf (gethash (type-of op) - (component-operation-times component)) - (get-universal-time)) - (return)))))) + (when (and (not (equal '("asdf") (component-find-path system))) + (find-if #'(lambda (x) (equal '("asdf") + (component-find-path (cdr x)))) + steps) + (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)))) @@ -2255,5 +2410,5 @@ &allow-other-keys) (declare (ignore force verbose version)) - (apply #'operate operation-class system args)) + (apply 'operate operation-class system args)) (let ((operate-docstring @@ -2282,10 +2437,9 @@ 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) @@ -2295,5 +2449,5 @@ for details." (declare (ignore force verbose version)) - (apply #'operate 'compile-op system args) + (apply 'operate 'compile-op system args) t) @@ -2303,5 +2457,5 @@ details." (declare (ignore force verbose version)) - (apply #'operate 'test-op system args) + (apply 'operate 'test-op system args) t) @@ -2310,8 +2464,5 @@ (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) @@ -2347,6 +2498,5 @@ (change-class (cdr s) ',class)) (t - (register-system (quote ,name) - (make-instance ',class :name ',name)))) + (register-system (make-instance ',class :name ',name)))) (%set-system-source-file (load-pathname) (cdr (system-registered-p ',name)))) @@ -2364,5 +2514,7 @@ (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) @@ -2459,4 +2611,5 @@ weakly-depends-on depends-on serial in-order-to + (version nil versionp) ;; list ends &allow-other-keys) options @@ -2471,4 +2624,9 @@ (class-for-type parent type)))) (error 'duplicate-names :name name)) + + (when versionp + (unless (parse-version version nil) + (warn (compatfmt "~@") + version name parent))) (let* ((other-args (remove-keys @@ -2485,5 +2643,5 @@ (when *serial-depends-on* (push *serial-depends-on* depends-on)) - (apply #'reinitialize-instance ret + (apply 'reinitialize-instance ret :name (coerce-name name) :pathname pathname @@ -2535,5 +2693,5 @@ 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) @@ -2553,6 +2711,6 @@ 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 @@ -2579,5 +2737,5 @@ #+sbcl (sb-ext:process-exit-code - (apply #'sb-ext:run-program + (apply 'sb-ext:run-program #+win32 "sh" #-win32 "/bin/sh" (list "-c" command) @@ -2592,9 +2750,25 @@ :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)) @@ -2645,5 +2819,5 @@ (:corman :cormanlisp) (:lw :lispworks) - :clisp :cmu :ecl :gcl :sbcl :scl :symbolics)) + :clisp :cmu :ecl :gcl :sbcl :scl :symbolics :xcl)) (defparameter *os-features* @@ -2659,12 +2833,11 @@ '((:amd64 :x86-64 :x86_64 :x8664-target) (: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)) @@ -2729,5 +2902,5 @@ ((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) @@ -2846,5 +3019,5 @@ (unless (length=n-p forms 1) (error (compatfmt "~@~%") - description forms)) + description forms)) (funcall validator (car forms) :location file))) @@ -3102,5 +3275,5 @@ (when inherit (error (compatfmt "~@") - string)) + string)) (setf inherit t) (push :inherit-configuration directives)) @@ -3111,5 +3284,5 @@ (when source (error (compatfmt "~@") - string)) + string)) (unless inherit (push :ignore-inherited-configuration directives)) @@ -3143,5 +3316,5 @@ (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*)) @@ -3272,4 +3445,5 @@ (defun* apply-output-translations (path) (etypecase path + #+cormanlisp (t (truenamize path)) (logical-pathname path) @@ -3490,17 +3664,10 @@ (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 () @@ -3508,39 +3675,44 @@ 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)) - -(defun directory-has-asd-files-p (directory) + (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) + +(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 cormanlisp genera xcl) (wild (merge-pathnames* - #-(or abcl allegro lispworks scl) + #-(or abcl allegro cmu lispworks scl xcl) *wild-directory* - #+(or abcl allegro lispworks scl) "*.*" + #+(or abcl allegro cmu lispworks scl xcl) "*.*" directory)) (dirs - #-(or cormanlisp genera) + #-(or cormanlisp genera xcl) (ignore-errors (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 - #+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))) + #+genera (fs:directory-list directory) + #+xcl (system:list-directory directory)) + #+(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) @@ -3551,5 +3723,5 @@ (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*) @@ -3557,7 +3729,7 @@ (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) @@ -3608,5 +3780,5 @@ (when inherit (error (compatfmt "~@") - string)) + string)) (setf inherit t) (push ':inherit-configuration directives)) @@ -3625,6 +3797,6 @@ (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))) @@ -3758,17 +3930,32 @@ ;; 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))) (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 "~@") + 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 @@ -3781,14 +3968,11 @@ ;; 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 () @@ -3796,7 +3980,46 @@ (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 @@ -3807,7 +4030,8 @@ 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)