diff --git a/asdf.asd b/asdf.asd index 77e9deea1fa836d1db7eadde17d1a0d705983252..02d15b0af09c9bd9df6898168508988519c76169 100644 --- a/asdf.asd +++ b/asdf.asd @@ -15,7 +15,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.26.113" ;; to be automatically updated by bin/bump-revision + :version "2.26.114" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:module "build" :components ((:file "asdf")))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf)))) diff --git a/defsystem.lisp b/defsystem.lisp index 40dcdb0aeed93d1c3db292ed253a1505aceff02b..692036122a9659dfcf1483ce66b870653fd2f021 100644 --- a/defsystem.lisp +++ b/defsystem.lisp @@ -22,18 +22,20 @@ ;; the pathname of a system as follows: ;; 1. if the pathname argument is an pathname object (NOT a namestring), ;; that is already an absolute pathname, return it. - ;; 2. otherwise, the directory containing the CURRENT-LISP-FILE-PATHNAME + ;; 2. otherwise, the directory containing the LOAD-PATHNAME ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and ;; if it is indeed available and an absolute pathname, then ;; the PATHNAME argument is normalized to a relative pathname ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T) ;; and merged into that DIRECTORY as per SUBPATHNAME. + ;; Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded, + ;; and may be from within the EVAL-WHEN of a file compilation. ;; If no absolute pathname was found, we return NIL. (check-type pathname (or null string pathname)) (or (and (pathnamep pathname) (absolute-pathname-p pathname) (resolve-symlinks* pathname)) - (let* ((lisp-file-pathname (resolve-symlinks* (current-lisp-file-pathname)))) - (when (absolute-pathname-p lisp-file-pathname) - (subpathname lisp-file-pathname pathname :type :directory))))) + (let* ((load-pathname (resolve-symlinks* (load-pathname)))) + (when (absolute-pathname-p load-pathname) + (subpathname load-pathname pathname :type :directory))))) ;;; Component class @@ -169,7 +171,7 @@ ;; we also need to remember it in a special variable *systems-being-defined*. (with-system-definitions () (let* ((name (coerce-name name)) - (source-file (if sfp source-file (resolve-symlinks* (current-lisp-file-pathname)))) + (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))) (registered (system-registered-p name)) (registered! (if registered (rplaca registered (safe-file-write-date source-file)) diff --git a/find-system.lisp b/find-system.lisp index 2e15feccd8f16e03c38905ddaa2bf2bfe0816761..e50284c7702e333ae6bfd45e88c294875663a97b 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -133,10 +133,9 @@ called with an object of type asdf:system." (cleanup-system-definition-search-functions) (defun* search-for-system-definition (system) - (with-pathname-defaults () - (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name))) - (cons 'find-system-if-being-defined - *system-definition-search-functions*)))) + (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name))) + (cons 'find-system-if-being-defined + *system-definition-search-functions*))) (defvar *central-registry* nil "A list of 'system directory designators' ASDF uses to find systems. diff --git a/header.lisp b/header.lisp index 0489cb02b4b0a62a55d59ed892c1669390cdedab..1d40043f0d35000c983f3156946abd67b3653b42 100644 --- a/header.lisp +++ b/header.lisp @@ -1,5 +1,5 @@ ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.26.113: Another System Definition Facility. +;;; This is ASDF 2.26.114: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . diff --git a/lisp-build.lisp b/lisp-build.lisp index f2527bca8dd5f13c1d6d2bec2bbac29b26d3b4b9..8e664de3ebb46ac0109acc06d271ef857e674b47 100644 --- a/lisp-build.lisp +++ b/lisp-build.lisp @@ -16,8 +16,13 @@ #:get-optimization-settings #:proclaim-optimization-settings #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions + #:reify-simple-sexp #:unreify-simple-sexp + #:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-warnings + #:reset-deferred-warnings #:save-deferred-warnings + #:with-saved-deferred-warnings #:call-with-asdf-compilation-unit #:with-asdf-compilation-unit - #:current-lisp-file-pathname #:lispize-pathname #:compile-file-type #:call-around-hook + #:current-lisp-file-pathname #:load-pathname + #:lispize-pathname #:compile-file-type #:call-around-hook #:compile-file* #:compile-file-pathname* #:load* #:load-from-string #:combine-fasls) (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body)) @@ -108,55 +113,124 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when "Run BODY where uninteresting compiler and additional loader conditions are muffled" `(call-with-muffled-loader-conditions #'(lambda () ,@body))) -(defun* save-forward-references (forward-references) - ;; TODO: replace with stuff in POIU + +;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman. + +(defun reify-simple-sexp (sexp) + (etypecase sexp + (symbol (reify-symbol sexp)) + ((or number character simple-string pathname) sexp) + (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp)))))) +(defun unreify-simple-sexp (sexp) + (etypecase sexp + ((or symbol number character simple-string pathname) sexp) + (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp)))) + ((simple-vector 2) (unreify-symbol sexp)))) + +(defun reify-undefined-warning (warning) + ;; Extracting undefined-warnings from the compilation-unit + ;; To be passed through the above reify/unreify link, it must be a "simple-sexp" + #-sbcl (declare (ignore warning)) + #+sbcl + (list* + (sb-c::undefined-warning-kind warning) + (sb-c::undefined-warning-name warning) + (sb-c::undefined-warning-count warning) + (mapcar + #'(lambda (frob) + ;; the lexenv slot can be ignored for reporting purposes + `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob) + :source ,(sb-c::compiler-error-context-source frob) + :original-source ,(sb-c::compiler-error-context-original-source frob) + :context ,(sb-c::compiler-error-context-context frob) + :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname + :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer + :original-source-path ,(sb-c::compiler-error-context-original-source-path frob))) + (sb-c::undefined-warning-warnings warning)))) + +(defun reify-deferred-warnings () + #-sbcl nil + #+sbcl + (when sb-c::*in-compilation-unit* + ;; Try to send nothing through the pipe if nothing needs to be accumulated + `(,@(when sb-c::*undefined-warnings* + `((sb-c::*undefined-warnings* + ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings*)))) + ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count* + sb-c::*compiler-error-count* + sb-c::*compiler-warning-count* + sb-c::*compiler-style-warning-count* + sb-c::*compiler-note-count*) + :for value = (symbol-value what) + :when (plusp value) + :collect `(,what . ,value))))) + +(defun unreify-deferred-warnings (constructor-list) + #-sbcl (declare (ignore constructor-list)) + #+sbcl + (dolist (item constructor-list) + ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol. + ;; For *undefined-warnings*, the adjustment is a list of initargs. + ;; For everything else, it's an integer. + (destructuring-bind (symbol . adjustment) item + (case symbol + ((sb-c::*undefined-warnings*) + (setf sb-c::*undefined-warnings* + (nconc (mapcan + #'(lambda (stuff) + (destructuring-bind (kind name count . rest) stuff + (if (and (eq kind :function) (fboundp name)) + nil + (list + (sb-c::make-undefined-warning + :name name + :kind kind + :count count + :warnings + (mapcar #'(lambda (x) + (apply #'sb-c::make-compiler-error-context x)) + rest)))))) + adjustment) + sb-c::*undefined-warnings*))) + (otherwise + (set symbol (+ (symbol-value symbol) adjustment))))))) + +(defun reset-deferred-warnings () + #+sbcl + (when sb-c::*in-compilation-unit* + (setf sb-c::*undefined-warnings* nil + sb-c::*aborted-compilation-unit-count* 0 + sb-c::*compiler-error-count* 0 + sb-c::*compiler-warning-count* 0 + sb-c::*compiler-style-warning-count* 0 + sb-c::*compiler-note-count* 0))) + +(defun* save-deferred-warnings (warnings-file) "Save forward reference conditions so they may be issued at a latter time, possibly in a different process." - #+sbcl - (loop :for w :in sb-c::*undefined-warnings* - :for kind = (sb-c::undefined-warning-kind w) ; :function :variable :type - :for name = (sb-c::undefined-warning-name w) - :for symbol = (cond - ((consp name) - (unless (eq kind :function) - (error "unrecognized warning ~S not a function?" w)) - (ecase (car name) - ((setf) - (assert (and (consp (cdr name)) (null (cddr name))) ()) - (setf kind :setf-function) - (second name)) - ((sb-pcl::slot-accessor) - (assert (eq :global (second name))) - (assert (eq 'boundp (fourth name))) - (assert (null (nthcdr 4 name))) - (setf kind :sb-pcl-global-boundp-slot-accessor) - (third name)))) - (t - (assert (member kind '(:function :variable :type)) ()) - name)) - :for symbol-name = (symbol-name symbol) - :for package-name = (package-name (symbol-package symbol)) - :collect `(:undefined ,symbol-name ,package-name ,kind) :into undefined-warnings - :finally (setf *deferred-warnings* undefined-warnings - sb-c::*undefined-warnings* nil)) - (when forward-references - (with-open-file (s forward-references :direction :output :if-exists :supersede) - (write *deferred-warnings* :stream s :pretty t :readably t) - (terpri s)))) - -(defun* call-with-asdf-compilation-unit (thunk &key forward-references) - (with-compilation-unit (:override t) - (let ((*deferred-warnings* ()) - #+sbcl (sb-c::*undefined-warnings* nil)) - (multiple-value-prog1 - (with-muffled-compiler-conditions () - (funcall thunk)) - (save-forward-references forward-references))))) - -(defmacro with-asdf-compilation-unit ((&key forward-references) &body body) - "Like WITH-COMPILATION-UNIT, but saving forward-reference issues -for processing later (possibly in a different process)." - `(call-with-xcvb-compilation-unit #'(lambda () ,@body) :forward-references ,forward-references)) + (with-open-file (s warnings-file :direction :output :if-exists :supersede) + (if-let ((deferred-warnings (reify-deferred-warnings))) + (with-safe-io-syntax () + (write deferred-warnings :stream s :pretty t :readably t) + (terpri s)))) + (reset-deferred-warnings)) + +(defun* call-with-saved-deferred-warnings (thunk warnings-file) + (if warnings-file + (with-compilation-unit (:override t) + (let ((*deferred-warnings* ()) + #+sbcl (sb-c::*undefined-warnings* nil)) + (multiple-value-prog1 + (with-muffled-compiler-conditions () + (funcall thunk)) + (save-deferred-warnings warnings-file)))) + (funcall thunk))) + +(defmacro with-saved-deferred-warnings ((warnings-file) &body body) + "If WARNINGS-FILE is not nil, records the deferred-warnings around the BODY +and saves those warnings to the given file for latter use, +possibly in a different process. Otherwise just run the BODY." + `(call-with-saved-deferred-warnings #'(lambda () ,@body) ,warnings-file)) ;;; from ASDF @@ -164,6 +238,9 @@ for processing later (possibly in a different process)." (defun* current-lisp-file-pathname () (or *compile-file-pathname* *load-pathname*)) +(defun* load-pathname () + *load-pathname*) + (defun* lispize-pathname (input-file) (make-pathname :type "lisp" :defaults input-file)) @@ -177,7 +254,8 @@ for processing later (possibly in a different process)." (call-function (or hook 'funcall) function)) (defun* compile-file* (input-file &rest keys - &key compile-check output-file #+(or ecl mkcl) object-file + &key compile-check output-file warnings-file + #+(or ecl mkcl) object-file &allow-other-keys) "This function provides a portable wrapper around COMPILE-FILE. It ensures that the OUTPUT-FILE value is only returned and @@ -193,11 +271,12 @@ with appropriate implementation-dependent defaults, and if a failure (respectively warnings) are reported by COMPILE-FILE with consider it an error unless the respective behaviour flag is one of :SUCCESS :WARN :IGNORE. +If WARNINGS-FILE is defined, deferred warnings are saved to that file. On ECL or MKCL, it creates both the linkable object and loadable fasl files. On implementations that erroneously do not recognize standard keyword arguments, it will filter them appropriately." (let* ((keywords (remove-keys - `(:compile-check + `(:compile-check :warnings-file #+gcl<2.7 ,@'(:external-format :print :verbose)) keys)) (output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords)) #+ecl @@ -211,12 +290,14 @@ it will filter them appropriately." (compile-file-pathname output-file :fasl-p nil))) (tmp-file (tmpize-pathname output-file))) (multiple-value-bind (output-truename warnings-p failure-p) - (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords) - #+ecl (apply 'compile-file input-file :output-file - (if object-file - (list* object-file :system-p t keywords) - (list* output-file keywords))) - #+mkcl (apply 'compile-file input-file :output-file object-file :fasl-p nil keywords)) + (with-saved-deferred-warnings (warnings-file) + (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords) + #+ecl (apply 'compile-file input-file :output-file + (if object-file + (list* object-file :system-p t keywords) + (list* output-file keywords))) + #+mkcl (apply 'compile-file input-file + :output-file object-file :fasl-p nil keywords))) (cond ((and output-truename (flet ((check-flag (flag behaviour) @@ -301,3 +382,4 @@ it will filter them appropriately." (scm:concatenate-system output :fasls-to-concatenate)) (loop :for f :in fasls :do (ignore-errors (delete-file f))) (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))) + diff --git a/operate.lisp b/operate.lisp index 3d73f3be8a6c2371bf5d28f44e4f0b710ca3e043..1ca31be92645a52a9331d8b8803c919fb87a240d 100644 --- a/operate.lisp +++ b/operate.lisp @@ -7,7 +7,8 @@ :asdf/component :asdf/system :asdf/operation :asdf/action :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan) (:export - #:operate #:oos #:*systems-being-operated* #:*asdf-upgrade-already-attempted* + #:operate #:oos + #:*systems-being-operated* #:*asdf-upgrade-already-attempted* #:build-system #:load-system #:load-systems #:compile-system #:test-system #:require-system #:*load-system-operation* #:module-provide-asdf diff --git a/plan.lisp b/plan.lisp index 2ed943b0287b38fbc6eda30143dbc4a30138f9a3..0cc484f1e8b096398051949891d66f6bccdf417d 100644 --- a/plan.lisp +++ b/plan.lisp @@ -7,12 +7,9 @@ :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation :asdf/action) #+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:type-of) - (:intern #:planned-p #:index #:forced #:forced-not #:total-action-count - #:planned-action-count #:planned-output-action-count #:visited-actions - #:visiting-action-set #:visiting-action-list #:actions-r) (:export #:component-operation-time #:mark-operation-done - #:plan-traversal #:sequential-plan + #:plan-traversal #:sequential-plan #:*default-plan-class* #:planned-action-status #:plan-action-status #:action-already-done-p #:circular-dependency #:circular-dependency-actions #:node-for #:needed-in-image-p @@ -22,7 +19,10 @@ #:visit-dependencies #:compute-action-stamp #:traverse-action #:circular-dependency #:circular-dependency-actions #:call-while-visiting-action #:while-visiting-action - #:traverse #:plan-actions #:perform-plan #:plan-operates-on-p)) + #:traverse #:plan-actions #:perform-plan #:plan-operates-on-p + #:planned-p #:index #:forced #:forced-not #:total-action-count + #:planned-action-count #:planned-output-action-count #:visited-actions + #:visiting-action-set #:visiting-action-list #:actions-r)) (in-package :asdf/plan) ;;;; Planned action status @@ -316,9 +316,11 @@ processed in order by OPERATE.")) (defgeneric* perform-plan (plan &key)) (defgeneric* plan-operates-on-p (plan component)) +(defparameter *default-plan-class* 'sequential-plan) + (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys) (let ((plan (apply 'make-instance - (or plan-class 'sequential-plan) + (or plan-class *default-plan-class*) :system (component-system c) (remove-key :plan-class keys)))) (traverse-action plan o c t) (plan-actions plan))) diff --git a/upgrade.lisp b/upgrade.lisp index 76f38f3f9ac1db19af3401a9522390c07ab5b3df..81b9478996d65e1eac26fa735a253498e55eb311 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -45,7 +45,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.26.113") + (asdf-version "2.26.114") (existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) diff --git a/version.lisp-expr b/version.lisp-expr index 9fa3492caa42fe8652ade0aac8753d249630a145..4a80d3979f3f74f4a98b954fbadfe053c72d0259 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -1 +1 @@ -"2.26.113" +"2.26.114"