diff --git a/Makefile b/Makefile index 743ac9cd42e0ee82cfa56791ef6793b4fc952dcc..8e56422fc755b7209651567287b5928189a2413a 100644 --- a/Makefile +++ b/Makefile @@ -80,7 +80,7 @@ XCL ?= xcl header_lisp := header.lisp driver_lisp := uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp -defsystem_lisp := upgrade.lisp session.lisp component.lisp operation.lisp system.lisp action.lisp find-system.lisp find-component.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp +defsystem_lisp := upgrade.lisp session.lisp component.lisp operation.lisp system.lisp system-registry.lisp action.lisp lisp-action.lisp find-component.lisp plan.lisp operate.lisp find-system.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp) print-% : ; @echo $* = $($*) diff --git a/asdf.asd b/asdf.asd index 8693b0e0f4ba375c245b3ab287b13aadd638889d..855064fad6a1f332e53f38d1d57e445e43fedf4a 100644 --- a/asdf.asd +++ b/asdf.asd @@ -48,16 +48,17 @@ (:file "component" :depends-on ("session")) (:file "operation" :depends-on ("session")) (:file "system" :depends-on ("component")) + (:file "system-registry" :depends-on ("system")) (:file "action" :depends-on ("session" "system" "operation")) - (:file "find-system" :depends-on ("session" "system" "action")) - (:file "find-component" :depends-on ("find-system")) - (:file "lisp-action" :depends-on ("action" "find-system")) + (:file "lisp-action" :depends-on ("action")) + (:file "find-component" :depends-on ("component")) (:file "plan" :depends-on ("lisp-action" "find-component")) (:file "operate" :depends-on ("plan")) - (:file "parse-defsystem" :depends-on ("system" "lisp-action" "operate")) + (:file "find-system" :depends-on ("system-registry" "operate")) + (:file "parse-defsystem" :depends-on ("system-registry" "lisp-action" "operate")) (:file "bundle" :depends-on ("lisp-action" "operate" "parse-defsystem")) (:file "concatenate-source" :depends-on ("plan" "parse-defsystem" "bundle")) - (:file "package-inferred-system" :depends-on ("find-system" "parse-defsystem")) + (:file "package-inferred-system" :depends-on ("parse-defsystem")) (:file "output-translations" :depends-on ("operate")) (:file "source-registry" :depends-on ("find-system")) (:file "backward-internals" :depends-on ("find-system" "parse-defsystem")) diff --git a/find-component.lisp b/find-component.lisp index e85c5dc59a94b7634b3adb2dba64e75da03bd9cf..53fa65d30f8957d1434b0ea54e188969a53e151c 100644 --- a/find-component.lisp +++ b/find-component.lisp @@ -2,15 +2,15 @@ ;;;; Finding components (uiop/package:define-package :asdf/find-component - (:recycle :asdf/find-component :asdf) + (:recycle :asdf/find-component :asdf/find-system :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session - :asdf/component :asdf/system :asdf/find-system) + :asdf/component :asdf/system :asdf/system-registry) (:export #:find-component #:resolve-dependency-name #:resolve-dependency-spec #:resolve-dependency-combination ;; Conditions - #:missing-component #:missing-component-of-version #:retry + #:missing-component #:missing-requires #:missing-parent #:missing-component-of-version #:retry #:missing-dependency #:missing-dependency-of-version #:missing-requires #:missing-parent #:missing-required-by #:missing-version)) @@ -19,6 +19,10 @@ ;;;; Missing component conditions (with-upgradability () + (define-condition missing-component (system-definition-error) + ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) + (parent :initform nil :reader missing-parent :initarg :parent))) + (define-condition missing-component-of-version (missing-component) ((version :initform nil :reader missing-version :initarg :version))) diff --git a/find-system.lisp b/find-system.lisp index 1458f2fd4e659aab850add07ab4b814dcba32486..bc77cd9afd8e1e43a9113f1725f565e945af4129 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -4,35 +4,15 @@ (uiop/package:define-package :asdf/find-system (:recycle :asdf/find-system :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade - :asdf/session :asdf/component :asdf/operation :asdf/action :asdf/system) + :asdf/session :asdf/component :asdf/system :asdf/operation :asdf/action :asdf/lisp-action + :asdf/find-component :asdf/system-registry :asdf/plan :asdf/operate) (:export - #:remove-entry-from-registry #:coerce-entry-to-directory - #:coerce-name #:primary-system-name #:coerce-filename #:find-system #:locate-system #:load-asd #:define-op - #:system-registered-p #:registered-system #:register-system - #:registered-systems* #:registered-systems - #:clear-system #:map-systems - #:missing-component #:missing-requires #:missing-parent #:load-system-definition-error #:error-name #:error-pathname #:error-condition - #:*system-definition-search-functions* #:search-for-system-definition - #:*central-registry* #:probe-asd #:sysdef-central-registry-search - #:find-system-if-being-defined - #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed - #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* - #:mark-component-preloaded ;; forward reference to asdf/operate - #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems* - #:*defined-systems* #:clear-defined-systems - ;; defined in source-registry, but specially mentioned here: - #:initialize-source-registry #:sysdef-source-registry-search)) + )) (in-package :asdf/find-system) (with-upgradability () - (declaim (ftype (function (&optional t) t) initialize-source-registry)) ; forward reference - - (define-condition missing-component (system-definition-error) - ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) - (parent :initform nil :reader missing-parent :initarg :parent))) - (define-condition load-system-definition-error (system-definition-error) ((name :initarg :name :reader error-name) (pathname :initarg :pathname :reader error-pathname) @@ -41,326 +21,6 @@ (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))))) - ;;; Canonicalizing system names - - (defun coerce-name (name) - "Given a designator for a component NAME, return the name as a string. -The designator can be a COMPONENT (designing its name; note that a SYSTEM is a component), -a SYMBOL (designing its name, downcased), or a STRING (designing itself)." - (typecase name - (component (component-name name)) - (symbol (string-downcase name)) - (string name) - (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name)))) - - (defun primary-system-name (name) - "Given a system designator NAME, return the name of the corresponding primary system, -after which the .asd file is named. That's the first component when dividing the name -as a string by / slashes." - (first (split-string (coerce-name name) :separator "/"))) - - (defun coerce-filename (name) - "Coerce a system designator NAME into a string suitable as a filename component. -The (current) transformation is to replace characters /:\\ each by --, -the former being forbidden in a filename component. -NB: The onus is unhappily on the user to avoid clashes." - (frob-substrings (coerce-name name) '("/" ":" "\\") "--")) - - - ;;; Registry of Defined Systems - - (defvar *defined-systems* (make-hash-table :test 'equal) - "This is a hash table whose keys are strings -- the -names of systems -- and whose values are pairs, the first -element of which is a universal-time indicating when the -system definition was last updated, and the second element -of which is a system object. - A system is referred to as \"registered\" if it is present -in this table.") - - (defun system-registered-p (name) - "Return a generalized boolean that is true if a system of given NAME was registered already. -NAME is a system designator, to be normalized by COERCE-NAME. -The value returned if true is a pair of a timestamp and a system object." - (gethash (coerce-name name) *defined-systems*)) - - (defun registered-system (name) - "Return a system of given NAME that was registered already, -if such a system exists. NAME is a system designator, to be -normalized by COERCE-NAME. The value returned is a system object, -or NIL if not found." - (cdr (system-registered-p name))) - - (defun registered-systems* () - "Return a list containing every registered system (as a system object)." - (loop :for registered :being :the :hash-values :of *defined-systems* - :collect (cdr registered))) - - (defun registered-systems () - "Return a list of the names of every registered system." - (mapcar 'coerce-name (registered-systems*))) - - (defun register-system (system) - "Given a SYSTEM object, register it." - (check-type system system) - (let ((name (component-name system))) - (check-type name string) - (asdf-message (compatfmt "~&~@<; ~@;Registering system ~3i~_~A~@:>~%") name) - (unless (eq system (registered-system name)) - (setf (gethash name *defined-systems*) - (cons (ignore-errors (get-file-stamp (system-source-file system))) - system))))) - - (defun map-systems (fn) - "Apply FN to each defined system. - -FN should be a function of one argument. It will be -called with an object of type asdf:system." - (loop :for registered :being :the :hash-values :of *defined-systems* - :do (funcall fn (cdr registered)))) - - - ;;; Preloaded systems: in the image even if you can't find source files backing them. - - (defvar *preloaded-systems* (make-hash-table :test 'equal) - "Registration table for preloaded systems.") - - (declaim (ftype (function (t) t) mark-component-preloaded)) ; defined in asdf/operate - - (defun make-preloaded-system (name keys) - "Make a preloaded system of given NAME with build information from KEYS" - (let ((system (apply 'make-instance (getf keys :class 'system) - :name name :source-file (getf keys :source-file) - (remove-plist-keys '(:class :name :source-file) keys)))) - (mark-component-preloaded system) - system)) - - (defun sysdef-preloaded-system-search (requested) - "If REQUESTED names a system registered as preloaded, return a new system -with its registration information." - (let ((name (coerce-name requested))) - (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*) - (when foundp - (make-preloaded-system name keys))))) - - (defun ensure-preloaded-system-registered (name) - "If there isn't a registered _defined_ system of given NAME, -and a there is a registered _preloaded_ system of given NAME, -then define and register said preloaded system." - (if-let (system (and (not (registered-system name)) (sysdef-preloaded-system-search name))) - (register-system system))) - - (defun register-preloaded-system (system-name &rest keys &key (version t) &allow-other-keys) - "Register a system as being preloaded. If the system has not been loaded from the filesystem -yet, or if its build information is later cleared with CLEAR-SYSTEM, a dummy system will be -registered without backing filesystem information, based on KEYS (e.g. to provide a VERSION). -If VERSION is the default T, and a system was already loaded, then its version will be preserved." - (let ((name (coerce-name system-name))) - (when (eql version t) - (if-let (system (registered-system name)) - (setf (getf keys :version) (component-version system)))) - (setf (gethash name *preloaded-systems*) keys) - (ensure-preloaded-system-registered system-name))) - - - ;;; Immutable systems: in the image and can't be reloaded from source. - - (defvar *immutable-systems* nil - "A hash-set (equal hash-table mapping keys to T) of systems that are immutable, -i.e. already loaded in memory and not to be refreshed from the filesystem. -They will be treated specially by find-system, and passed as :force-not argument to make-plan. - -For instance, to can deliver an image with many systems precompiled, that *will not* check the -filesystem for them every time a user loads an extension, what more risk a problematic upgrade - or catastrophic downgrade, before you dump an image, you may use: - (map () 'asdf:register-immutable-system (asdf:already-loaded-systems)) - -Note that direct access to this variable from outside ASDF is not supported. -Please call REGISTER-IMMUTABLE-SYSTEM to add new immutable systems, and -contact maintainers if you need a stable API to do more than that.") - - (defun sysdef-immutable-system-search (requested) - (let ((name (coerce-name requested))) - (when (and *immutable-systems* (gethash name *immutable-systems*)) - (or (registered-system requested) - (error 'formatted-system-definition-error - :format-control "Requested system ~A registered as an immutable-system, ~ -but not even registered as defined" - :format-arguments (list name)))))) - - (defun register-immutable-system (system-name &rest keys) - "Register SYSTEM-NAME as preloaded and immutable. -It will automatically be considered as passed to FORCE-NOT in a plan." - (let ((system-name (coerce-name system-name))) - (apply 'register-preloaded-system system-name keys) - (unless *immutable-systems* - (setf *immutable-systems* (list-to-hash-set nil))) - (setf (gethash system-name *immutable-systems*) t))) - - - ;;; Making systems undefined. - - (defun clear-system (system) - "Clear the entry for a SYSTEM in the database of systems previously defined. -However if the system was registered as PRELOADED (which it is if it is IMMUTABLE), -then a new system with the same name will be defined and registered in its place -from which build details will have been cleared. -Note that this does NOT in any way cause any of the code of the system to be unloaded. -Returns T if system was or is now undefined, NIL if a new preloaded system was redefined." - ;; 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. - (let ((name (coerce-name system))) - (remhash name *defined-systems*) - (unset-asdf-cache-entry `(find-system ,name)) - (not (ensure-preloaded-system-registered name)))) - - (defun clear-defined-systems () - "Clear all currently registered defined systems. -Preloaded systems (including immutable ones) will be reset, other systems will be de-registered." - (loop :for name :being :the :hash-keys :of *defined-systems* - :unless (member name '("asdf" "uiop") :test 'equal) :do (clear-system name))) - - - ;;; Searching for system definitions - - ;; For the sake of keeping things reasonably neat, we adopt a convention that - ;; only symbols are to be pushed to this list (rather than e.g. function objects), - ;; which makes upgrade easier. Also, the name of these symbols shall start with SYSDEF- - (defvar *system-definition-search-functions* '() - "A list that controls the ways that ASDF looks for system definitions. -It contains symbols to be funcalled in order, with a requested system name as argument, -until one returns a non-NIL result (if any), which must then be a fully initialized system object -with that name.") - - ;; Initialize and/or upgrade the *system-definition-search-functions* - ;; so it doesn't contain obsolete symbols, and does contain the current ones. - (defun cleanup-system-definition-search-functions () - (setf *system-definition-search-functions* - (append - ;; Remove known-incompatible sysdef functions from old versions of asdf. - ;; Order matters, so we can't just use set-difference. - (let ((obsolete - '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search))) - (remove-if #'(lambda (x) (member x obsolete)) *system-definition-search-functions*)) - ;; Tuck our defaults at the end of the list if they were absent. - ;; This is imperfect, in case they were removed on purpose, - ;; but then it will be the responsibility of whoever removes these symmbols - ;; to upgrade asdf before he does such a thing rather than after. - (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) - '(sysdef-central-registry-search - sysdef-source-registry-search))))) - (cleanup-system-definition-search-functions) - - ;; This (private) function does the search for a system definition using *s-d-s-f*; - ;; it is to be called by locate-system. - (defun search-for-system-definition (system) - ;; Search for valid definitions of the system available in the current session. - ;; Previous definitions as registered in *defined-systems* MUST NOT be considered; - ;; they will be reconciled by locate-system then find-system. - ;; There are two special treatments: first, specially search for objects being defined - ;; in the current session, to avoid definition races between several files; - ;; second, specially search for immutable systems, so they cannot be redefined. - ;; Finally, use the search functions specified in *system-definition-search-functions*. - (let ((name (coerce-name system))) - (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x)))) - (try 'find-system-if-being-defined) - (try 'sysdef-immutable-system-search) - (map () #'try *system-definition-search-functions*)))) - - - ;;; The legacy way of finding a system: the *central-registry* - - ;; This variable contains a list of directories to be lazily searched for the requested asd - ;; by sysdef-central-registry-search. - (defvar *central-registry* nil - "A list of 'system directory designators' ASDF uses to find systems. - -A 'system directory designator' is a pathname or an expression -which evaluates to a pathname. For example: - - (setf asdf:*central-registry* - (list '*default-pathname-defaults* - #p\"/home/me/cl/systems/\" - #p\"/usr/share/common-lisp/systems/\")) - -This variable is for backward compatibility. -Going forward, we recommend new users should be using the source-registry.") - - ;; Function to look for an asd file of given NAME under a directory provided by DEFAULTS. - ;; Return the truename of that file if it is found and TRUENAME is true. - ;; Return NIL if the file is not found. - ;; On Windows, follow shortcuts to .asd files. - (defun probe-asd (name defaults &key truename) - (block nil - (when (directory-pathname-p defaults) - (if-let (file (probe-file* - (ensure-absolute-pathname - (parse-unix-namestring name :type "asd") - #'(lambda () (ensure-absolute-pathname defaults 'get-pathname-defaults nil)) - nil) - :truename truename)) - (return file)) - #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) - (os-cond - ((os-windows-p) - (when (physical-pathname-p defaults) - (let ((shortcut - (make-pathname - :defaults defaults :case :local - :name (strcat name ".asd") - :type "lnk"))) - (when (probe-file* shortcut) - (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native))))))))) - - ;; Function to push onto *s-d-s-f* to use the *central-registry* - (defun sysdef-central-registry-search (system) - (let ((name (primary-system-name system)) - (to-remove nil) - (to-replace nil)) - (block nil - (unwind-protect - (dolist (dir *central-registry*) - (let ((defaults (eval dir)) - directorized) - (when defaults - (cond ((directory-pathname-p defaults) - (let* ((file (probe-asd name defaults :truename *resolve-symlinks*))) - (when file - (return file)))) - (t - (restart-case - (let* ((*print-circle* nil) - (message - (format nil - (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not an absolute directory.~@:>") - system dir defaults))) - (error message)) - (remove-entry-from-registry () - :report "Remove entry from *central-registry* and continue" - (push dir to-remove)) - (coerce-entry-to-directory () - :test (lambda (c) (declare (ignore c)) - (and (not (directory-pathname-p defaults)) - (directory-pathname-p - (setf directorized - (ensure-directory-pathname defaults))))) - :report (lambda (s) - (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>") - directorized dir)) - (push (cons dir directorized) to-replace)))))))) - ;; cleanup - (dolist (dir to-remove) - (setf *central-registry* (remove dir *central-registry*))) - (dolist (pair to-replace) - (let* ((current (car pair)) - (new (cdr pair)) - (position (position current *central-registry*))) - (setf *central-registry* - (append (subseq *central-registry* 0 position) - (list new) - (subseq *central-registry* (1+ position)))))))))) - ;;; Methods for find-system @@ -386,52 +46,90 @@ Going forward, we recommend new users should be using the source-registry.") (defclass define-op (non-propagating-operation) () (:documentation "An operation to record dependencies on loading a .asd file.")) + (defmethod record-dependency ((plan null) (operation t) (component t)) + (unless (or (typep operation 'define-op) + (and (typep operation 'load-op) + (typep component 'system) + (equal "asdf" (coerce-name component)))) + (let* ((action (first (visiting-action-list *asdf-session*))) + (parent-operation (car action)) + (parent-component (cdr action))) + (when (and parent-operation parent-component) + (unless (and (typep parent-operation 'define-op) (typep parent-component 'system)) + (error "Invalid recursive use of (OPERATE ~S ~S) while visiting ~S ~ +- please use proper dependencies instead." + operation component action)) + (push action (definition-dependencies parent-component)))))) + (defmethod component-depends-on ((o define-op) (s system)) - `((load-op ,@(system-defsystem-depends-on s)) - ,@(loop* :for (o . c) :in (definition-dependencies s) :collect (list o c)) + `(;;NB: 1- ,@(system-defsystem-depends-on s)) ; Should be already included in the below. + ;; 2- We don't call-next-method to avoid other methods + ,@(loop* :for (o . c) :in (definition-dependencies s) :collect (list o c)))) + + (defmethod component-depends-on ((o operation) (s system)) + `(,@(when (and (not (typep o 'define-op)) + (or (system-source-file s) (definition-dependencies s))) + `((define-op ,(primary-system-name s)))) ,@(call-next-method))) - (defmethod component-depends-on ((o operation) (c undefined-system)) + (defmethod perform ((o operation) (c undefined-system)) (sysdef-error "Trying to use undefined or incompletely defined system ~A" (coerce-name c))) - (defun load-asd (pathname - &key name (external-format (encoding-external-format (detect-encoding pathname))) - &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*)) - "Load system definitions from PATHNAME. -NAME if supplied is the name of a system expected to be defined in that file. + ;; TODO: could this file be refactored so that locate-system is merely + ;; the cache-priming call to input-files here? + (defmethod input-files ((o define-op) (s system)) + (assert (equal (coerce-name s) (primary-system-name s))) + (if-let ((asd (system-source-file s))) (list asd))) -Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." + (defmethod perform ((o define-op) (s system)) + (assert (equal (coerce-name s) (primary-system-name s))) (nest - (with-asdf-session ()) + (if-let ((pathname (first (input-files o s))))) (with-standard-io-syntax) - (let* ((primary-name (primary-system-name (or name (pathname-name pathname)))) - (*package* (find-package :asdf-user)) - ;; Note that our backward-compatible *readtable* is - ;; a global readtable that gets globally side-effected. Ouch. - ;; Same for the *print-pprint-dispatch* table. - ;; We should do something about that for ASDF3 if possible, or else ASDF4. - (*readtable* readtable) - (*print-pprint-dispatch* print-pprint-dispatch) - (*print-readably* nil) - (*default-pathname-defaults* - ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. - (pathname-directory-pathname (physicalize-pathname pathname))) - (operation (make-operation 'define-op)) - (system (or (registered-system primary-name) - (let ((system - (make-instance 'undefined-system - :name primary-name :source-file pathname))) - (register-system system) - system))))) - (while-visiting-action (operation system)) + (let ((*print-readably* nil) + ;; Note that our backward-compatible *readtable* is + ;; a global readtable that gets globally side-effected. Ouch. + ;; Same for the *print-pprint-dispatch* table. + ;; We should do something about that for ASDF3 if possible, or else ASDF4. + (*readtable* *readtable*) + (*print-pprint-dispatch* *print-pprint-dispatch*) + (*package* (find-package :asdf-user)) + (*default-pathname-defaults* + ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. + (pathname-directory-pathname (physicalize-pathname pathname))))) (handler-bind (((and error (not missing-component)) #'(lambda (condition) (error 'load-system-definition-error - :name name :pathname pathname :condition condition)))) + :name (coerce-name s) :pathname pathname :condition condition)))) (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%") - name pathname) - (load* pathname :external-format external-format)))) + (coerce-name s) pathname) + ;; dependencies will depend on what's loaded via definition-dependencies + (unset-asdf-cache-entry `(component-depends-on ,o ,s)) + (load* pathname :external-format (encoding-external-format (detect-encoding pathname)))))) + + (defun load-asd (pathname &key name) + "Load system definitions from PATHNAME. +NAME if supplied is the name of a system expected to be defined in that file. + +Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." + (with-asdf-session () + ;; TODO: use OPERATE, so we consult the cache and only load once per session. + (flet ((do-it (o c) (operate o c))) + (let ((primary-name (primary-system-name (or name (pathname-name pathname)))) + (operation (make-operation 'define-op))) + (if-let (system (registered-system primary-name)) + (progn + ;; We already determine this to be obsolete --- + ;; or should we move some tests from find-system to check for up-to-date-ness here? + (setf (component-operation-time operation system) nil) + (do-it operation system)) + (let ((system (make-instance 'undefined-system + :name primary-name :source-file pathname))) + (register-system system) + (unwind-protect (do-it operation system) + (when (typep system 'undefined-system) + (clear-system system))))))))) (defvar *old-asdf-systems* (make-hash-table :test 'equal)) @@ -446,8 +144,7 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." (read-file-form version-pathname))) (old-version (asdf-version))) (cond - ((version< old-version version) t) ;; newer version: good! - ((equal old-version version) nil) ;; same version: don't load, but don't warn + ((version<= old-version version) t) ;; newer or same version: good! (t ;; old version: bad (ensure-gethash (list (namestring pathname) version) *old-asdf-systems* @@ -511,7 +208,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (values foundp found-system pathname previous previous-time)))) ;; Main method for find-system: first, make sure the computation is memoized in a session cache. - ;; unless the system is immutable, use locate-system to find the primary system; + ;; Unless the system is immutable, use locate-system to find the primary system; ;; reconcile the finding (if any) with any previous definition (in a previous session, ;; preloaded, with a previous configuration, or before filesystem changes), and ;; load a found .asd if appropriate. Finally, update registration table and return results. @@ -530,26 +227,22 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (register-system found-system)) (when (and system pathname) (setf (system-source-file system) pathname)) - (when (and pathname - (let ((stamp (get-file-stamp pathname))) - (and stamp - (not (and previous - (or (pathname-equal pathname previous-pathname) - (and pathname previous-pathname - (pathname-equal - (physicalize-pathname pathname) - (physicalize-pathname previous-pathname)))) - (stamp<= stamp previous-time)))))) - ;; Only load when it's a pathname that is different or has newer content. - (load-asd pathname :name name))) + (if-let ((stamp (get-file-stamp pathname))) + (let ((up-to-date-p + (and previous + (or (pathname-equal pathname previous-pathname) + (and pathname previous-pathname + (pathname-equal + (physicalize-pathname pathname) + (physicalize-pathname previous-pathname)))) + (stamp<= stamp previous-time) + ;; TODO: check that all dependencies are up-to-date. + ;; This necessitates traversing them without triggering + ;; the adding of nodes to the plan. + ))) + (unless up-to-date-p + (load-asd pathname :name name))))) ;; Try again after having loaded from disk if needed - (let ((in-memory (system-registered-p name))) - (cond - (in-memory - (when pathname - (setf (car in-memory) (get-file-stamp pathname))) - (cdr in-memory)) - (error-p - (error 'missing-component :requires name)) - (t - (return-from find-system nil))))))))) + (or (registered-system name) + (when error-p (error 'missing-component :requires name)))))))) + diff --git a/footer.lisp b/footer.lisp index 12c213c4f2c88a596370bdeb9685ac94ef4b3728..1cf442e07f8710c84f11ccceb2020ceda83aa3e1 100644 --- a/footer.lisp +++ b/footer.lisp @@ -4,7 +4,7 @@ (uiop/package:define-package :asdf/footer (:recycle :asdf/footer :asdf) (:use :uiop/common-lisp :uiop - :asdf/upgrade :asdf/find-system :asdf/operate :asdf/bundle) + :asdf/upgrade :asdf/system-registry :asdf/operate :asdf/bundle) ;; Happily, all those implementations all have the same module-provider hook interface. #+(or abcl clasp cmucl clozure ecl mkcl sbcl) (:import-from #+abcl :sys #+(or clasp cmucl ecl) :ext #+clozure :ccl #+mkcl :mk-ext #+sbcl sb-ext diff --git a/interface.lisp b/interface.lisp index 41ddbeb248acd84e7d598d3904122d15b46bb3f7..d6e6ec7f0c12d99e423fcc70c6a278f4365d8333 100644 --- a/interface.lisp +++ b/interface.lisp @@ -8,7 +8,7 @@ #:loaded-systems ; makes for annoying SLIME completion #:output-files-for-system-and-operation) ; ASDF-BINARY-LOCATION function we use to detect ABL (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session - :asdf/component :asdf/system :asdf/find-system :asdf/find-component + :asdf/component :asdf/system :asdf/system-registry :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action :asdf/output-translations :asdf/source-registry :asdf/plan :asdf/operate :asdf/parse-defsystem :asdf/bundle :asdf/concatenate-source diff --git a/lisp-action.lisp b/lisp-action.lisp index b345767294cb6dc8963bc5f1f77ef44d50b13604..221907a4b244a3e7773c7e77bbf833ee9e375c60 100644 --- a/lisp-action.lisp +++ b/lisp-action.lisp @@ -4,8 +4,7 @@ (uiop/package:define-package :asdf/lisp-action (:recycle :asdf/lisp-action :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session - :asdf/component :asdf/system :asdf/find-system - :asdf/operation :asdf/action) + :asdf/component :asdf/system :asdf/operation :asdf/action) (:export #:try-recompiling #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp diff --git a/make-asdf.bat b/make-asdf.bat index 5cad197376e7e8dafd6baf13354a70c0ea95b295..c40e200949f69122f093959d81725ff0b8b32e0c 100644 --- a/make-asdf.bat +++ b/make-asdf.bat @@ -5,7 +5,7 @@ set here=%~dp0 set header_lisp=header.lisp set driver_lisp=uiop\package.lisp + uiop\common-lisp.lisp + uiop\utility.lisp + uiop\version.lisp + uiop\os.lisp + uiop\pathname.lisp + uiop\filesystem.lisp + uiop\stream.lisp + uiop\image.lisp + uiop\lisp-build.lisp + uiop\launch-program.lisp + uiop\run-program.lisp + uiop\configuration.lisp + uiop\backward-driver.lisp + uiop\driver.lisp -set defsystem_lisp=upgrade.lisp + session.lisp + component.lisp + operation.lisp + system.lisp + action.lisp + find-system.lisp + find-component.lisp + lisp-action.lisp + plan.lisp + operate.lisp + parse-defsystem.lisp + bundle.lisp + concatenate-source.lisp + package-inferred-system.lisp + output-translations.lisp + source-registry.lisp + backward-internals.lisp + backward-interface.lisp + interface.lisp + user.lisp + footer.lisp +set defsystem_lisp=upgrade.lisp + session.lisp + component.lisp + operation.lisp + system.lisp + system-registry.lisp + action.lisp + lisp-action.lisp + find-component.lisp + plan.lisp + operate.lisp + find-system.lisp + parse-defsystem.lisp + bundle.lisp + concatenate-source.lisp + package-inferred-system.lisp + output-translations.lisp + source-registry.lisp + backward-internals.lisp + backward-interface.lisp + interface.lisp + user.lisp + footer.lisp %~d0 cd "%~p0" diff --git a/make-asdf.sh b/make-asdf.sh index fa65dcdefd40bed70f0ea6814eda9723e69b2030..a3cc62cef07adb459bb1bd4380022724ea57b900 100755 --- a/make-asdf.sh +++ b/make-asdf.sh @@ -6,7 +6,7 @@ here="$(dirname $0)" header_lisp="header.lisp" driver_lisp="uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp" -defsystem_lisp="upgrade.lisp session.lisp component.lisp operation.lisp system.lisp action.lisp find-system.lisp find-component.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp" +defsystem_lisp="upgrade.lisp session.lisp component.lisp operation.lisp system.lisp system-registry.lisp action.lisp lisp-action.lisp find-component.lisp plan.lisp operate.lisp find-system.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp" all () { # Default action: bootstrap asdf.lisp diff --git a/operate.lisp b/operate.lisp index a5d8ffc197cdc5da2e6adc9093c2fa8e6cb51f85..051afe5582919a8f077d5e13aa21b823dbdefda5 100644 --- a/operate.lisp +++ b/operate.lisp @@ -4,14 +4,12 @@ (uiop/package:define-package :asdf/operate (:recycle :asdf/operate :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session - :asdf/component :asdf/system :asdf/operation :asdf/action - :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan) + :asdf/component :asdf/system :asdf/system-registry :asdf/find-component + :asdf/operation :asdf/action :asdf/lisp-action :asdf/plan) (:export - #:operate #:oos - #:build-op #:make + #:operate #:oos #:build-op #:make #:load-system #:load-systems #:load-systems* - #:compile-system #:test-system #:require-system - #:module-provide-asdf + #:compile-system #:test-system #:require-system #:module-provide-asdf #:component-loaded-p #:already-loaded-systems)) (in-package :asdf/operate) diff --git a/package-inferred-system.lisp b/package-inferred-system.lisp index ebacb56bb01d4f216a63151c1dff81d59739a14b..c1a649c1ebecb213b0ed7a88256f18586a8cade5 100644 --- a/package-inferred-system.lisp +++ b/package-inferred-system.lisp @@ -5,7 +5,7 @@ (:recycle :asdf/package-inferred-system :asdf/package-system :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session - :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action + :asdf/component :asdf/system :asdf/system-registry :asdf/lisp-action :asdf/parse-defsystem) (:export #:package-inferred-system #:sysdef-package-inferred-system-search diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index ca675575479b4c6b9a193f26f6501b745abfb97a..55843562e1d8a6cc57de0c582bc3033ddb3a460e 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -5,8 +5,8 @@ (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf) (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares (:use :uiop/common-lisp :asdf/driver :asdf/upgrade - :asdf/session :asdf/component :asdf/system - :asdf/find-system :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate) + :asdf/session :asdf/component :asdf/system :asdf/system-registry + :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate) (:import-from :asdf/system #:depends-on #:weakly-depends-on) (:export #:defsystem #:register-system-definition diff --git a/plan.lisp b/plan.lisp index 3c90412e0b54e60f1f5dcf0ee409ca255b533619..00a363b4b6801884c120558b8cb6fa16b90aba33 100644 --- a/plan.lisp +++ b/plan.lisp @@ -6,8 +6,8 @@ ;; that used to live there before 3.2.0. (:recycle :asdf/plan :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session - :asdf/component :asdf/operation :asdf/action :asdf/lisp-action :asdf/system - :asdf/find-component :asdf/find-system) + :asdf/component :asdf/operation :asdf/action :asdf/lisp-action + :asdf/system :asdf/system-registry :asdf/find-component) (:export #:component-operation-time #:plan #:plan-traversal #:sequential-plan #:*plan-class* @@ -48,7 +48,7 @@ (:documentation "Returns the ACTION-STATUS associated to the action of OPERATION on COMPONENT in the PLAN")) - (defgeneric (setf action-status) (new-status session operation component) + (defgeneric (setf action-status) (new-status plan operation component) (:documentation "Sets the ACTION-STATUS associated to the action of OPERATION on COMPONENT in the PLAN")) @@ -285,17 +285,7 @@ initialized with SEED." (values (gethash (cons o c) (visited-actions *asdf-session*))))) (defgeneric record-dependency (plan operation component) - (:documentation "Record an action as a dependency in the current plan")) - - (defmethod record-dependency ((plan null) (operation t) (component t)) - (let* ((action (first (visiting-action-list *asdf-session*))) - (parent-operation (action-operation action)) - (parent-component (action-component action))) - (when (and parent-operation parent-component) - (unless (and (typep parent-operation 'define-op) (typep parent-component 'system)) - (cerror "Invalid recursive use of (OPERATE ~S ~S) while visiting ~S" - operation component action)) - (push action (definition-dependencies parent-component)))))) + (:documentation "Record an action as a dependency in the current plan"))) ;;;; Actual traversal: traverse-action @@ -420,15 +410,12 @@ initialized with SEED." (with-compilation-unit () ;; backward-compatibility. (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build. - (defmethod perform-plan ((plan t) &rest keys &key &allow-other-keys) - (apply 'perform-plan (plan-actions plan) keys)) - - (defmethod perform-plan ((steps list) &key force &allow-other-keys) - (loop :for action :in steps + (defmethod perform-plan ((plan t) &key &allow-other-keys) + (loop :for action :in (plan-actions plan) :as o = (action-operation action) - :as c = (action-component action) - :when (or force (not (nth-value 1 (compute-action-stamp nil o c)))) - :do (perform-with-restarts o c))) + :as c = (action-component action) :do + (unless (nth-value 1 (compute-action-stamp plan o c)) + (perform-with-restarts o c)))) (defmethod plan-operates-on-p ((plan plan-traversal) (component-path list)) (plan-operates-on-p (plan-actions plan) component-path)) diff --git a/source-registry.lisp b/source-registry.lisp index 0e070d01aeee1ea57ef892d67fcbdeb28a7e9fd0..bcfe266c87c076b68b79a1689990b7350e1f7614 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -4,7 +4,7 @@ (uiop/package:define-package :asdf/source-registry (:recycle :asdf/source-registry :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/system :asdf/system-registry) (:export #:*source-registry-parameter* #:*default-source-registries* #:invalid-source-registry diff --git a/system-registry.lisp b/system-registry.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a6a647bd9ebc84ca57d0143715a21e46df6c20fa --- /dev/null +++ b/system-registry.lisp @@ -0,0 +1,318 @@ +;;;; ------------------------------------------------------------------------- +;;;; Finding systems + +(uiop/package:define-package :asdf/system-registry + (:recycle :asdf/system-registry :asdf/find-system :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade + :asdf/session :asdf/component :asdf/system) + (:export + #:remove-entry-from-registry #:coerce-entry-to-directory + #:system-registered-p #:registered-system #:register-system + #:registered-systems* #:registered-systems + #:clear-system #:map-systems + #:*system-definition-search-functions* #:search-for-system-definition + #:*central-registry* #:probe-asd #:sysdef-central-registry-search + #:find-system-if-being-defined + #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed + #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* + #:mark-component-preloaded ;; forward reference to asdf/operate + #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems* + #:*defined-systems* #:clear-defined-systems + ;; defined in source-registry, but specially mentioned here: + #:sysdef-source-registry-search)) +(in-package :asdf/system-registry) + +(with-upgradability () + ;;; Registry of Defined Systems + + (defvar *defined-systems* (make-hash-table :test 'equal) + "This is a hash table whose keys are strings -- the +names of systems -- and whose values are pairs, the first +element of which is a universal-time indicating when the +system definition was last updated, and the second element +of which is a system object. + A system is referred to as \"registered\" if it is present +in this table.") + + (defun system-registered-p (name) + "Return a generalized boolean that is true if a system of given NAME was registered already. +NAME is a system designator, to be normalized by COERCE-NAME. +The value returned if true is a pair of a timestamp and a system object." + (gethash (coerce-name name) *defined-systems*)) + + (defun registered-system (name) + "Return a system of given NAME that was registered already, +if such a system exists. NAME is a system designator, to be +normalized by COERCE-NAME. The value returned is a system object, +or NIL if not found." + (cdr (system-registered-p name))) + + (defun registered-systems* () + "Return a list containing every registered system (as a system object)." + (loop :for registered :being :the :hash-values :of *defined-systems* + :collect (cdr registered))) + + (defun registered-systems () + "Return a list of the names of every registered system." + (mapcar 'coerce-name (registered-systems*))) + + (defun register-system (system) + "Given a SYSTEM object, register it." + (check-type system system) + (let ((name (component-name system))) + (check-type name string) + (asdf-message (compatfmt "~&~@<; ~@;Registering system ~3i~_~A~@:>~%") name) + (unless (eq system (registered-system name)) + (setf (gethash name *defined-systems*) + (cons (ignore-errors (get-file-stamp (system-source-file system))) + system))))) + + (defun map-systems (fn) + "Apply FN to each defined system. + +FN should be a function of one argument. It will be +called with an object of type asdf:system." + (loop :for registered :being :the :hash-values :of *defined-systems* + :do (funcall fn (cdr registered)))) + + + ;;; Preloaded systems: in the image even if you can't find source files backing them. + + (defvar *preloaded-systems* (make-hash-table :test 'equal) + "Registration table for preloaded systems.") + + (declaim (ftype (function (t) t) mark-component-preloaded)) ; defined in asdf/operate + + (defun make-preloaded-system (name keys) + "Make a preloaded system of given NAME with build information from KEYS" + (let ((system (apply 'make-instance (getf keys :class 'system) + :name name :source-file (getf keys :source-file) + (remove-plist-keys '(:class :name :source-file) keys)))) + (mark-component-preloaded system) + system)) + + (defun sysdef-preloaded-system-search (requested) + "If REQUESTED names a system registered as preloaded, return a new system +with its registration information." + (let ((name (coerce-name requested))) + (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*) + (when foundp + (make-preloaded-system name keys))))) + + (defun ensure-preloaded-system-registered (name) + "If there isn't a registered _defined_ system of given NAME, +and a there is a registered _preloaded_ system of given NAME, +then define and register said preloaded system." + (if-let (system (and (not (registered-system name)) (sysdef-preloaded-system-search name))) + (register-system system))) + + (defun register-preloaded-system (system-name &rest keys &key (version t) &allow-other-keys) + "Register a system as being preloaded. If the system has not been loaded from the filesystem +yet, or if its build information is later cleared with CLEAR-SYSTEM, a dummy system will be +registered without backing filesystem information, based on KEYS (e.g. to provide a VERSION). +If VERSION is the default T, and a system was already loaded, then its version will be preserved." + (let ((name (coerce-name system-name))) + (when (eql version t) + (if-let (system (registered-system name)) + (setf (getf keys :version) (component-version system)))) + (setf (gethash name *preloaded-systems*) keys) + (ensure-preloaded-system-registered system-name))) + + + ;;; Immutable systems: in the image and can't be reloaded from source. + + (defvar *immutable-systems* nil + "A hash-set (equal hash-table mapping keys to T) of systems that are immutable, +i.e. already loaded in memory and not to be refreshed from the filesystem. +They will be treated specially by find-system, and passed as :force-not argument to make-plan. + +For instance, to can deliver an image with many systems precompiled, that *will not* check the +filesystem for them every time a user loads an extension, what more risk a problematic upgrade + or catastrophic downgrade, before you dump an image, you may use: + (map () 'asdf:register-immutable-system (asdf:already-loaded-systems)) + +Note that direct access to this variable from outside ASDF is not supported. +Please call REGISTER-IMMUTABLE-SYSTEM to add new immutable systems, and +contact maintainers if you need a stable API to do more than that.") + + (defun sysdef-immutable-system-search (requested) + (let ((name (coerce-name requested))) + (when (and *immutable-systems* (gethash name *immutable-systems*)) + (or (registered-system requested) + (error 'formatted-system-definition-error + :format-control "Requested system ~A registered as an immutable-system, ~ +but not even registered as defined" + :format-arguments (list name)))))) + + (defun register-immutable-system (system-name &rest keys) + "Register SYSTEM-NAME as preloaded and immutable. +It will automatically be considered as passed to FORCE-NOT in a plan." + (let ((system-name (coerce-name system-name))) + (apply 'register-preloaded-system system-name keys) + (unless *immutable-systems* + (setf *immutable-systems* (list-to-hash-set nil))) + (setf (gethash system-name *immutable-systems*) t))) + + + ;;; Making systems undefined. + + (defun clear-system (system) + "Clear the entry for a SYSTEM in the database of systems previously defined. +However if the system was registered as PRELOADED (which it is if it is IMMUTABLE), +then a new system with the same name will be defined and registered in its place +from which build details will have been cleared. +Note that this does NOT in any way cause any of the code of the system to be unloaded. +Returns T if system was or is now undefined, NIL if a new preloaded system was redefined." + ;; 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. + (let ((name (coerce-name system))) + (remhash name *defined-systems*) + (unset-asdf-cache-entry `(find-system ,name)) + (not (ensure-preloaded-system-registered name)))) + + (defun clear-defined-systems () + "Clear all currently registered defined systems. +Preloaded systems (including immutable ones) will be reset, other systems will be de-registered." + (loop :for name :being :the :hash-keys :of *defined-systems* :do (clear-system name))) + + + ;;; Searching for system definitions + + ;; For the sake of keeping things reasonably neat, we adopt a convention that + ;; only symbols are to be pushed to this list (rather than e.g. function objects), + ;; which makes upgrade easier. Also, the name of these symbols shall start with SYSDEF- + (defvar *system-definition-search-functions* '() + "A list that controls the ways that ASDF looks for system definitions. +It contains symbols to be funcalled in order, with a requested system name as argument, +until one returns a non-NIL result (if any), which must then be a fully initialized system object +with that name.") + + ;; Initialize and/or upgrade the *system-definition-search-functions* + ;; so it doesn't contain obsolete symbols, and does contain the current ones. + (defun cleanup-system-definition-search-functions () + (setf *system-definition-search-functions* + (append + ;; Remove known-incompatible sysdef functions from old versions of asdf. + ;; Order matters, so we can't just use set-difference. + (let ((obsolete + '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search))) + (remove-if #'(lambda (x) (member x obsolete)) *system-definition-search-functions*)) + ;; Tuck our defaults at the end of the list if they were absent. + ;; This is imperfect, in case they were removed on purpose, + ;; but then it will be the responsibility of whoever removes these symmbols + ;; to upgrade asdf before he does such a thing rather than after. + (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) + '(sysdef-central-registry-search + sysdef-source-registry-search))))) + (cleanup-system-definition-search-functions) + + ;; This (private) function does the search for a system definition using *s-d-s-f*; + ;; it is to be called by locate-system. + (defun search-for-system-definition (system) + ;; Search for valid definitions of the system available in the current session. + ;; Previous definitions as registered in *defined-systems* MUST NOT be considered; + ;; they will be reconciled by locate-system then find-system. + ;; There are two special treatments: first, specially search for objects being defined + ;; in the current session, to avoid definition races between several files; + ;; second, specially search for immutable systems, so they cannot be redefined. + ;; Finally, use the search functions specified in *system-definition-search-functions*. + (let ((name (coerce-name system))) + (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x)))) + (try 'find-system-if-being-defined) + (try 'sysdef-immutable-system-search) + (map () #'try *system-definition-search-functions*)))) + + + ;;; The legacy way of finding a system: the *central-registry* + + ;; This variable contains a list of directories to be lazily searched for the requested asd + ;; by sysdef-central-registry-search. + (defvar *central-registry* nil + "A list of 'system directory designators' ASDF uses to find systems. + +A 'system directory designator' is a pathname or an expression +which evaluates to a pathname. For example: + + (setf asdf:*central-registry* + (list '*default-pathname-defaults* + #p\"/home/me/cl/systems/\" + #p\"/usr/share/common-lisp/systems/\")) + +This variable is for backward compatibility. +Going forward, we recommend new users should be using the source-registry.") + + ;; Function to look for an asd file of given NAME under a directory provided by DEFAULTS. + ;; Return the truename of that file if it is found and TRUENAME is true. + ;; Return NIL if the file is not found. + ;; On Windows, follow shortcuts to .asd files. + (defun probe-asd (name defaults &key truename) + (block nil + (when (directory-pathname-p defaults) + (if-let (file (probe-file* + (ensure-absolute-pathname + (parse-unix-namestring name :type "asd") + #'(lambda () (ensure-absolute-pathname defaults 'get-pathname-defaults nil)) + nil) + :truename truename)) + (return file)) + #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) + (os-cond + ((os-windows-p) + (when (physical-pathname-p defaults) + (let ((shortcut + (make-pathname + :defaults defaults :case :local + :name (strcat name ".asd") + :type "lnk"))) + (when (probe-file* shortcut) + (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native))))))))) + + ;; Function to push onto *s-d-s-f* to use the *central-registry* + (defun sysdef-central-registry-search (system) + (let ((name (primary-system-name system)) + (to-remove nil) + (to-replace nil)) + (block nil + (unwind-protect + (dolist (dir *central-registry*) + (let ((defaults (eval dir)) + directorized) + (when defaults + (cond ((directory-pathname-p defaults) + (let* ((file (probe-asd name defaults :truename *resolve-symlinks*))) + (when file + (return file)))) + (t + (restart-case + (let* ((*print-circle* nil) + (message + (format nil + (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not an absolute directory.~@:>") + system dir defaults))) + (error message)) + (remove-entry-from-registry () + :report "Remove entry from *central-registry* and continue" + (push dir to-remove)) + (coerce-entry-to-directory () + :test (lambda (c) (declare (ignore c)) + (and (not (directory-pathname-p defaults)) + (directory-pathname-p + (setf directorized + (ensure-directory-pathname defaults))))) + :report (lambda (s) + (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>") + directorized dir)) + (push (cons dir directorized) to-replace)))))))) + ;; cleanup + (dolist (dir to-remove) + (setf *central-registry* (remove dir *central-registry*))) + (dolist (pair to-replace) + (let* ((current (car pair)) + (new (cdr pair)) + (position (position current *central-registry*))) + (setf *central-registry* + (append (subseq *central-registry* 0 position) + (list new) + (subseq *central-registry* (1+ position))))))))))) + diff --git a/system.lisp b/system.lisp index b1290c18b776f1846f0018d5cf74e47924512bbe..fc31242683595181015b179158d068448d64cd89 100644 --- a/system.lisp +++ b/system.lisp @@ -2,8 +2,8 @@ ;;;; Systems (uiop/package:define-package :asdf/system - (:recycle :asdf :asdf/system) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component) + (:recycle :asdf :asdf/system :asdf/find-system) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component) (:export #:system #:proto-system #:undefined-system #:reset-system #:system-source-file #:system-source-directory #:system-relative-pathname @@ -18,6 +18,7 @@ #:mailto #:system-mailto #:long-name #:system-long-name #:source-control #:system-source-control + #:coerce-name #:primary-system-name #:coerce-filename #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system (in-package :asdf/system) @@ -106,6 +107,33 @@ based on supplied KEYS." (apply 'reinitialize-instance system keys))) +;;; Canonicalizing system names + +(with-upgradability () + (defun coerce-name (name) + "Given a designator for a component NAME, return the name as a string. +The designator can be a COMPONENT (designing its name; note that a SYSTEM is a component), +a SYMBOL (designing its name, downcased), or a STRING (designing itself)." + (typecase name + (component (component-name name)) + (symbol (string-downcase name)) + (string name) + (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name)))) + + (defun primary-system-name (name) + "Given a system designator NAME, return the name of the corresponding primary system, +after which the .asd file is named. That's the first component when dividing the name +as a string by / slashes." + (first (split-string (coerce-name name) :separator "/"))) + + (defun coerce-filename (name) + "Coerce a system designator NAME into a string suitable as a filename component. +The (current) transformation is to replace characters /:\\ each by --, +the former being forbidden in a filename component. +NB: The onus is unhappily on the user to avoid clashes." + (frob-substrings (coerce-name name) '("/" ":" "\\") "--"))) + + ;;;; Pathnames (with-upgradability () diff --git a/test/file3-only.asd b/test/file3-only.asd index aea6aaa2bbcee1e4adc0f0837cc0f08e026ca42f..3ee2d4ea9e5c68df1d80ae5fe0192f7a86cfb7ff 100644 --- a/test/file3-only.asd +++ b/test/file3-only.asd @@ -1,3 +1,6 @@ ;;; -*- Lisp -*- (asdf:defsystem file3-only :components ((:file "file3"))) + +(defvar *file3-only-asd-loaded* 0) +(incf *file3-only-asd-loaded*) diff --git a/test/file4.lisp b/test/file4.lisp index 45a709a86f00a64dbbee3a8e9055c98dc7f40efa..267c0060fb287b4861dfbd740258c800655b2ede 100644 --- a/test/file4.lisp +++ b/test/file4.lisp @@ -1,2 +1,4 @@ (in-package :test-package) (assert *file3*) +(defparameter *file4* t) + diff --git a/test/test-asdf.asd b/test/test-asdf.asd index 1c54687cb28d305a074b2c62ca523921d815bf79..3f1ed8402564466e42152dfb3af779dd3d3a5e31 100644 --- a/test/test-asdf.asd +++ b/test/test-asdf.asd @@ -1,9 +1,10 @@ (defpackage :test-asdf-system - (:use :cl :asdf)) + (:use :cl :asdf :uiop)) (in-package :test-asdf-system) (defvar *times-loaded* 0) (incf *times-loaded*) +;;(format! t "Times that test-asdf.asd was loaded: ~D~%" *times-loaded*) (defsystem :test-asdf :class package-inferred-system) @@ -75,7 +76,10 @@ (defsystem :test-asdf/force :depends-on (:test-asdf/force1) - :components ((:file "file3"))) + :components ((:file "file4"))) (defsystem :test-asdf/force1 + ;; Importantly, this depends on a system that is NOT defined in the same file, + ;; so that we can check that forcing causes one file to be reloaded but not the other. + :depends-on (:file3-only) :components ((:file "file1"))) diff --git a/test/test-cache.script b/test/test-cache.script index 15ce3e5fae58ec80cf07dbb5112184e4b926fdb0..f9798a4386c507211a50b7963329f742fe2f3110 100644 --- a/test/test-cache.script +++ b/test/test-cache.script @@ -1,34 +1,12 @@ ;;; -*- Lisp -*- -;;; test to check that the cache doesn't upset error signaling from FIND-SYSTEM +;;; Test to check that the cache doesn't upset error signaling from FIND-SYSTEM (in-package :asdf-test) -(defparameter *all-systems* - (list - "test-asdf" - "test-asdf/all" - "test-asdf/1" - "test-asdf/2" - "test-asdf/4" - "test-asdf/test9-1" - "test-asdf/test-module-depend" - "test-asdf/test9-2" - "test-asdf/test9-3" - "test-asdf/test-source-directory-1" - "test-asdf/test-source-directory-2" - "test-asdf/bundle-1" - "test-asdf/bundle-2" - "test-asdf/force" - "test-asdf/force1")) +(setf asdf::*asdf-session* nil) +(setf *central-registry* nil) +(asdf::clear-defined-systems) -(defun clear-caches-and-search () - (setf asdf:*central-registry* nil) - (mapc #'clear-system *all-systems*)) - -(clear-caches-and-search) -(assert (not (asdf:find-system "test-asdf/force1" nil))) -(multiple-value-bind (ret cond) - (ignore-errors (asdf:find-system "test-asdf/force1" t)) - (assert (not ret)) - (assert (typep cond 'asdf:missing-component))) +(assert-equal nil (find-system "test-asdf/force1" nil)) +(errors missing-component (find-system "test-asdf/force1" t)) diff --git a/test/test-defsystem-depends-on.script b/test/test-defsystem-depends-on.script index c01eaa28efc1cb6ad9e7b3b049c472431e2623f5..2d64319a1e830785d84e8e08f20c98bae1d8213a 100644 --- a/test/test-defsystem-depends-on.script +++ b/test/test-defsystem-depends-on.script @@ -44,16 +44,14 @@ (progn (reset-session) - (signals asdf:missing-dependency (def-test-system unloadable-system - :defsystem-depends-on (nonexistent-system))) + (signals missing-dependency (def-test-system unloadable-system + :defsystem-depends-on (nonexistent-system))) (assert (not (system-registered-p "unloadable-system")))) (progn - (signals asdf:missing-dependency (find-system "test-defsystem-depends-on-missing-system")) - (assert (typep (asdf::registered-system "test-defsystem-depends-on-missing-system") - 'asdf::undefined-system))) + (signals missing-dependency (find-system "test-defsystem-depends-on-missing-system")) + (assert (not (asdf::registered-system "test-defsystem-depends-on-missing-system")))) (progn (signals asdf::system-definition-error (find-system "test-defsystem-depends-on-circular")) - (assert (typep (asdf::registered-system "test-defsystem-depends-on-circular") - 'asdf::undefined-system))) + (assert (not (asdf::registered-system "test-defsystem-depends-on-circular")))) diff --git a/test/test-force.script b/test/test-force.script index cfd539bfd7701dc14c363ae75ab5e44b289c6794..4429d00824b88f4efcbf21363250b9037531655e 100644 --- a/test/test-force.script +++ b/test/test-force.script @@ -6,7 +6,9 @@ (require-system 'test-asdf/force) (assert (component-loaded-p 'test-asdf/force)) (assert-equal (asymval :*file3* :test-package) t) +(assert-equal (asymval :*file4* :test-package) t) (assert-equal (asymval :*times-loaded* :test-asdf-system) 1) +(assert-equal (asymval :*file3-only-asd-loaded* :asdf-user) 1) (defparameter file1 (test-fasl "file1")) (defparameter file1-date (file-write-date file1)) @@ -19,21 +21,24 @@ (reset-session-visited) (let ((plan (traverse 'load-op 'test-asdf/force :force t))) (DBG "Check that :force t forces the current system but not its dependencies" plan) - (assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file3"))) + (assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file4"))) + (assert (not (asdf::plan-operates-on-p plan '("file3-only" "file3")))) (assert (not (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1"))))) (reset-session-visited) (let ((plan (traverse 'load-op 'test-asdf/force :force :all))) (DBG "Check that :force :all forces the current system and its dependencies" plan) (assert plan) - (assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file3"))) + (assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file4"))) + (assert (asdf::plan-operates-on-p plan '("file3-only" "file3"))) (assert (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1")))) (reset-session-visited) (let ((plan (traverse 'load-op 'test-asdf/force :force :all :force-not t))) (DBG "Check that :force-not takes precedence over :force, with t means \"all but current system\"" plan) (assert plan) - (assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file3"))) + (assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file4"))) + (assert (not (asdf::plan-operates-on-p plan '("file3-only" "file3")))) (assert (not (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1"))))) (reset-session-visited) @@ -53,11 +58,13 @@ (assert (null plan))) (reset-session-visited) -(let* ((*immutable-systems* (list-to-hash-set '("test-asdf/force1"))) - (plan (traverse 'load-op 'test-asdf/force :force :all :force-not t))) +(let* ((asdf::*immutable-systems* (list-to-hash-set '("test-asdf/force1"))) + (plan (traverse 'load-op 'test-asdf/force :force :all))) (DBG "Check that immutable-systems will block forcing" plan) (assert plan) - (assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file3"))) + (assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file4"))) + ;; transitively included via force1 test-asdf/only, which blocks the traversal + (assert (not (asdf::plan-operates-on-p plan '("file3-only" "file3")))) (assert (not (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1"))))) ;; unforced, date should stay same @@ -78,23 +85,24 @@ (reset-session-visited) (DBG "Check that load-system will reload") +(setf test-package::*file1* nil) +(assert (not test-package::*file1*)) (load-system 'test-asdf/force1) -;; FIXME: It is unclear why this fails (at least on mkcl even randomly) -#-mkcl -(with-expected-failure (#+(or clasp clisp (and ecl (not ecl-bytecmp))) t) - (assert-equal (get-file-stamp file1) date2) - (assert-equal test-package::*file1* t)) +(assert test-package::*file1*) ;; forced, it should be later (reset-session-visited) (DBG "Check that force reloading loads again") (setf test-package::*file3* :reset) (load-system 'test-asdf/force :force :all) -(assert-compare (>= (get-file-stamp file1) file1-date)) +(assert-compare (>= (- (get-file-stamp file1) file1-date) 0)) (assert-equal test-package::*file3* t) -(DBG "Check that test-asdf was loaded only once all along") -(assert-equal (asymval :*times-loaded* :test-asdf-system) 1) +(DBG "Check that test-asdf.asd was loaded each time it was forced") +(assert-equal (asymval :*times-loaded* :test-asdf-system) 3) +(DBG "Check that file3-only.asd was loaded only twice, with the :force :all") +(assert-equal (asymval :*file3-only-asd-loaded* :asdf-user) 2) + (setf test-package::*file3* :reset) @@ -104,7 +112,7 @@ (unset-asdf-cache-entry '(find-system "test-asdf/force")) (touch-file "test-asdf.asd" :timestamp (+ 10000 (get-file-stamp file1))) (require-system 'test-asdf/force) -(assert-equal (asymval :*times-loaded* :test-asdf-system) 1) +(assert-equal (asymval :*times-loaded* :test-asdf-system) 3) (assert-equal test-package::*file3* :reset) (reset-session-visited) @@ -112,5 +120,5 @@ (require-system 'test-asdf/force) ;;; Somehow, it loads the system... -(assert-equal (asymval :*times-loaded* :test-asdf-system) 1) +(assert-equal (asymval :*times-loaded* :test-asdf-system) 3) (assert-equal test-package::*file3* :reset) diff --git a/test/test-mutual-redefinition.script b/test/test-mutual-redefinition.script index b1731403e2397e1599381bf924c14a86992f0471..74bb3d8332c70b3136fe2e96c89cb0a1e634384f 100644 --- a/test/test-mutual-redefinition.script +++ b/test/test-mutual-redefinition.script @@ -26,14 +26,14 @@ (current-system-source-file "test-mutual-redefinition-1")) (assert-pathname-equal (test-source "test-mutual-redefinition-1.asd") - (current-system-source-file "test-mutual-redefinition-2")) + (current-system-source-file "test-mutual-redefinition-2"))) - (with-asdf-session (:override t) - (DBG "loading test-mutual-redefinition-2 in a different cache session") - (load-system 'test-mutual-redefinition-2) - (assert-pathname-equal - (test-source "test-mutual-redefinition-2.asd") - (current-system-source-file "test-mutual-redefinition-1")) - (assert-pathname-equal - (test-source "test-mutual-redefinition-2.asd") - (current-system-source-file "test-mutual-redefinition-2")))) +(with-asdf-session (:override t) + (DBG "loading test-mutual-redefinition-2 in a different cache session") + (load-system 'test-mutual-redefinition-2) + (assert-pathname-equal + (test-source "test-mutual-redefinition-2.asd") + (current-system-source-file "test-mutual-redefinition-2")) + (assert-pathname-equal + (test-source "test-mutual-redefinition-2.asd") + (current-system-source-file "test-mutual-redefinition-1"))) diff --git a/test/test-preloaded.script b/test/test-preloaded.script index 98bc409daac41510a6a234a5d5c765a8c982718e..3ab2c4649d3728ee904384b5fb07c3995fe3e1d4 100644 --- a/test/test-preloaded.script +++ b/test/test-preloaded.script @@ -1,6 +1,8 @@ ;;; -*- Lisp -*- (in-package :asdf-test) +(reset-session) + (DBG "Consider a system that does not exist. Loading it fails.") (assert (null (find-system :this-system-does-not-exist nil))) (errors missing-component (load-system :this-system-does-not-exist)) diff --git a/test/test-sysdef-asdf.script b/test/test-sysdef-asdf.script index 193f26286975d040a6aa59b5a82cffbc12aa497d..adb1bd7e58831e2b5d6a7b0efc0565935701f7a3 100644 --- a/test/test-sysdef-asdf.script +++ b/test/test-sysdef-asdf.script @@ -3,6 +3,20 @@ (format! t "~%Using ASDF ~A~%" (asdf-version)) (assert (version< "3.0" (asdf-version))) ;; check that we have a recent enough ASDF +(DBG "Let's define some methods on input-files, to later check what an upgrade does to them.") +(def-test-system "fooey") +(defparameter *ticks* 0) +(defun tick () (incf *ticks*)) +(defsystem "foo") +(defmethod input-files :after ((o load-op) (c system)) (tick)) +(assert-equal *ticks* 0) +(input-files 'load-op "foo") +(assert-equal *ticks* 1) +(input-files 'load-op "foo") +(assert-equal *ticks* 1) ;; It was cached. +(assert (find-system "fooey" nil)) + + (DBG "Try load ASDF with an empty configuration") (initialize-source-registry '(:source-registry :ignore-inherited-configuration)) @@ -35,6 +49,7 @@ (error "Should not have issued warning, but did issue:~% ~A" c)))) (clear-system "asdf") (upgrade-asdf))) +(assert-equal nil (system-source-file (find-system :asdf))) (DBG "Load ASDF with proper configuration: should find asdf.asd from the source above") (initialize-source-registry @@ -43,27 +58,35 @@ (:directory ,*uiop-directory*) :ignore-inherited-configuration)) (clear-system "asdf") -(load-system :asdf) -;; This time we found it, but it was skipped because the version was the same -(assert-equal nil (system-source-file (find-system :asdf))) +(with-asdf-session (:override t) + (with-expected-failure (#+xcl t) + ;; expected-failure: XCL has trouble with the ASDF upgrade + (load-system :asdf) + (assert-pathname-equal (subpathname *asdf-directory* "asdf.asd") + (system-source-file (find-system :asdf)))) -;; But if we cheat on our version, that should work -(setf asdf::*asdf-version* "3.0") -(clear-system "asdf") -(def-test-system "fooey") -(defparameter *ticks* 0) -(defun tick () (incf *ticks*)) -(defmethod input-files :after ((load-op operation) (c system)) (tick)) -(input-files 'load-op "asdf") -(assert-equal *ticks* 3) + (DBG "Loading from the same version shouldn't have reset methods") + (setf *ticks* 2) + (input-files 'load-op "foo") + (assert-equal *ticks* 3)) + +(DBG "Loading from an ancient version WILL reset methods") (assert (find-system "fooey" nil)) +(defparameter *current-version* (asdf-version)) +(setf asdf::*asdf-version* "2.0" asdf/upgrade::*previous-asdf-versions* '("2.0")) +(assert (asdf/upgrade::upgrading-p)) +(clear-system "asdf") +(reset-session) + (with-expected-failure (#+xcl t) ;; expected-failure: XCL has trouble with the ASDF upgrade (load-system :asdf) + (assert-equal (asdf-version) *current-version*) (assert-pathname-equal (subpathname *asdf-directory* "asdf.asd") (system-source-file (find-system :asdf)))) + ;; Upgrading from an old-enough version redefined away the input-files method! (setf *ticks* 4) (input-files 'load-op "asdf") diff --git a/test/test-utilities.script b/test/test-utilities.script index ae5c2c7d5e7444e6e19dfd3fcfdef3a28e7cd83d..bc0ffb94b00325d772ba04ff7feb0e1fc754774f 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -255,8 +255,8 @@ ;; restarts asdf/action:accept asdf/find-component:retry - asdf/find-system:coerce-entry-to-directory - asdf/find-system:remove-entry-from-registry + asdf/system-registry:coerce-entry-to-directory + asdf/system-registry:remove-entry-from-registry asdf/lisp-action:try-recompiling ;; types asdf/bundle:user-system @@ -272,8 +272,8 @@ ;; backward compatibility upgrade only asdf/backward-interface:on-failure asdf/backward-interface:on-warnings - asdf/find-system:contrib-sysdef-search - asdf/find-system:sysdef-find-asdf + asdf/system-registry:contrib-sysdef-search + asdf/system-registry:sysdef-find-asdf ;; restart asdf/session:clear-configuration-and-retry ))