Skip to content
Snippets Groups Projects
Commit d8508de1 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.26.114: import the deferred warnings support from POIU to ASDF-DRIVER.

Still not used by ASDF itself.

Also, don't use compile-file-pathname after all, it's a bad idea,
since we may be loading a .asd from within an eval-when during a compile-file,
but we won't be compiling the .asd.
parent 500dbe23
No related branches found
No related tags found
No related merge requests found
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :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 () :depends-on ()
:components ((:module "build" :components ((:file "asdf")))) :components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf)))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......
...@@ -22,18 +22,20 @@ ...@@ -22,18 +22,20 @@
;; the pathname of a system as follows: ;; the pathname of a system as follows:
;; 1. if the pathname argument is an pathname object (NOT a namestring), ;; 1. if the pathname argument is an pathname object (NOT a namestring),
;; that is already an absolute pathname, return it. ;; 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 ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and
;; if it is indeed available and an absolute pathname, then ;; if it is indeed available and an absolute pathname, then
;; the PATHNAME argument is normalized to a relative pathname ;; the PATHNAME argument is normalized to a relative pathname
;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T) ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
;; and merged into that DIRECTORY as per SUBPATHNAME. ;; 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. ;; If no absolute pathname was found, we return NIL.
(check-type pathname (or null string pathname)) (check-type pathname (or null string pathname))
(or (and (pathnamep pathname) (absolute-pathname-p pathname) (resolve-symlinks* pathname)) (or (and (pathnamep pathname) (absolute-pathname-p pathname) (resolve-symlinks* pathname))
(let* ((lisp-file-pathname (resolve-symlinks* (current-lisp-file-pathname)))) (let* ((load-pathname (resolve-symlinks* (load-pathname))))
(when (absolute-pathname-p lisp-file-pathname) (when (absolute-pathname-p load-pathname)
(subpathname lisp-file-pathname pathname :type :directory))))) (subpathname load-pathname pathname :type :directory)))))
;;; Component class ;;; Component class
...@@ -169,7 +171,7 @@ ...@@ -169,7 +171,7 @@
;; we also need to remember it in a special variable *systems-being-defined*. ;; we also need to remember it in a special variable *systems-being-defined*.
(with-system-definitions () (with-system-definitions ()
(let* ((name (coerce-name name)) (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 (system-registered-p name))
(registered! (if registered (registered! (if registered
(rplaca registered (safe-file-write-date source-file)) (rplaca registered (safe-file-write-date source-file))
......
...@@ -133,10 +133,9 @@ called with an object of type asdf:system." ...@@ -133,10 +133,9 @@ called with an object of type asdf:system."
(cleanup-system-definition-search-functions) (cleanup-system-definition-search-functions)
(defun* search-for-system-definition (system) (defun* search-for-system-definition (system)
(with-pathname-defaults () (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
(some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name))) (cons 'find-system-if-being-defined
(cons 'find-system-if-being-defined *system-definition-search-functions*)))
*system-definition-search-functions*))))
(defvar *central-registry* nil (defvar *central-registry* nil
"A list of 'system directory designators' ASDF uses to find systems. "A list of 'system directory designators' ASDF uses to find systems.
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- ;; -*- 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: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
......
...@@ -16,8 +16,13 @@ ...@@ -16,8 +16,13 @@
#:get-optimization-settings #:proclaim-optimization-settings #:get-optimization-settings #:proclaim-optimization-settings
#:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
#:call-with-muffled-loader-conditions #:with-muffled-loader-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 #: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* #:compile-file* #:compile-file-pathname*
#:load* #:load-from-string #:combine-fasls) #:load* #:load-from-string #:combine-fasls)
(:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body)) (: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 ...@@ -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" "Run BODY where uninteresting compiler and additional loader conditions are muffled"
`(call-with-muffled-loader-conditions #'(lambda () ,@body))) `(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, "Save forward reference conditions so they may be issued at a latter time,
possibly in a different process." possibly in a different process."
#+sbcl (with-open-file (s warnings-file :direction :output :if-exists :supersede)
(loop :for w :in sb-c::*undefined-warnings* (if-let ((deferred-warnings (reify-deferred-warnings)))
:for kind = (sb-c::undefined-warning-kind w) ; :function :variable :type (with-safe-io-syntax ()
:for name = (sb-c::undefined-warning-name w) (write deferred-warnings :stream s :pretty t :readably t)
:for symbol = (cond (terpri s))))
((consp name) (reset-deferred-warnings))
(unless (eq kind :function)
(error "unrecognized warning ~S not a function?" w)) (defun* call-with-saved-deferred-warnings (thunk warnings-file)
(ecase (car name) (if warnings-file
((setf) (with-compilation-unit (:override t)
(assert (and (consp (cdr name)) (null (cddr name))) ()) (let ((*deferred-warnings* ())
(setf kind :setf-function) #+sbcl (sb-c::*undefined-warnings* nil))
(second name)) (multiple-value-prog1
((sb-pcl::slot-accessor) (with-muffled-compiler-conditions ()
(assert (eq :global (second name))) (funcall thunk))
(assert (eq 'boundp (fourth name))) (save-deferred-warnings warnings-file))))
(assert (null (nthcdr 4 name))) (funcall thunk)))
(setf kind :sb-pcl-global-boundp-slot-accessor)
(third name)))) (defmacro with-saved-deferred-warnings ((warnings-file) &body body)
(t "If WARNINGS-FILE is not nil, records the deferred-warnings around the BODY
(assert (member kind '(:function :variable :type)) ()) and saves those warnings to the given file for latter use,
name)) possibly in a different process. Otherwise just run the BODY."
:for symbol-name = (symbol-name symbol) `(call-with-saved-deferred-warnings #'(lambda () ,@body) ,warnings-file))
: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))
;;; from ASDF ;;; from ASDF
...@@ -164,6 +238,9 @@ for processing later (possibly in a different process)." ...@@ -164,6 +238,9 @@ for processing later (possibly in a different process)."
(defun* current-lisp-file-pathname () (defun* current-lisp-file-pathname ()
(or *compile-file-pathname* *load-pathname*)) (or *compile-file-pathname* *load-pathname*))
(defun* load-pathname ()
*load-pathname*)
(defun* lispize-pathname (input-file) (defun* lispize-pathname (input-file)
(make-pathname :type "lisp" :defaults input-file)) (make-pathname :type "lisp" :defaults input-file))
...@@ -177,7 +254,8 @@ for processing later (possibly in a different process)." ...@@ -177,7 +254,8 @@ for processing later (possibly in a different process)."
(call-function (or hook 'funcall) function)) (call-function (or hook 'funcall) function))
(defun* compile-file* (input-file &rest keys (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) &allow-other-keys)
"This function provides a portable wrapper around COMPILE-FILE. "This function provides a portable wrapper around COMPILE-FILE.
It ensures that the OUTPUT-FILE value is only returned and It ensures that the OUTPUT-FILE value is only returned and
...@@ -193,11 +271,12 @@ with appropriate implementation-dependent defaults, ...@@ -193,11 +271,12 @@ with appropriate implementation-dependent defaults,
and if a failure (respectively warnings) are reported by COMPILE-FILE and if a failure (respectively warnings) are reported by COMPILE-FILE
with consider it an error unless the respective behaviour flag with consider it an error unless the respective behaviour flag
is one of :SUCCESS :WARN :IGNORE. 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 ECL or MKCL, it creates both the linkable object and loadable fasl files.
On implementations that erroneously do not recognize standard keyword arguments, On implementations that erroneously do not recognize standard keyword arguments,
it will filter them appropriately." it will filter them appropriately."
(let* ((keywords (remove-keys (let* ((keywords (remove-keys
`(:compile-check `(:compile-check :warnings-file
#+gcl<2.7 ,@'(:external-format :print :verbose)) keys)) #+gcl<2.7 ,@'(:external-format :print :verbose)) keys))
(output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords)) (output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))
#+ecl #+ecl
...@@ -211,12 +290,14 @@ it will filter them appropriately." ...@@ -211,12 +290,14 @@ it will filter them appropriately."
(compile-file-pathname output-file :fasl-p nil))) (compile-file-pathname output-file :fasl-p nil)))
(tmp-file (tmpize-pathname output-file))) (tmp-file (tmpize-pathname output-file)))
(multiple-value-bind (output-truename warnings-p failure-p) (multiple-value-bind (output-truename warnings-p failure-p)
(or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords) (with-saved-deferred-warnings (warnings-file)
#+ecl (apply 'compile-file input-file :output-file (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords)
(if object-file #+ecl (apply 'compile-file input-file :output-file
(list* object-file :system-p t keywords) (if object-file
(list* output-file keywords))) (list* object-file :system-p t keywords)
#+mkcl (apply 'compile-file input-file :output-file object-file :fasl-p nil keywords)) (list* output-file keywords)))
#+mkcl (apply 'compile-file input-file
:output-file object-file :fasl-p nil keywords)))
(cond (cond
((and output-truename ((and output-truename
(flet ((check-flag (flag behaviour) (flet ((check-flag (flag behaviour)
...@@ -301,3 +382,4 @@ it will filter them appropriately." ...@@ -301,3 +382,4 @@ it will filter them appropriately."
(scm:concatenate-system output :fasls-to-concatenate)) (scm:concatenate-system output :fasls-to-concatenate))
(loop :for f :in fasls :do (ignore-errors (delete-file f))) (loop :for f :in fasls :do (ignore-errors (delete-file f)))
(ignore-errors (lispworks:delete-system :fasls-to-concatenate))))) (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))
...@@ -7,7 +7,8 @@ ...@@ -7,7 +7,8 @@
:asdf/component :asdf/system :asdf/operation :asdf/action :asdf/component :asdf/system :asdf/operation :asdf/action
:asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan) :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan)
(:export (:export
#:operate #:oos #:*systems-being-operated* #:*asdf-upgrade-already-attempted* #:operate #:oos
#:*systems-being-operated* #:*asdf-upgrade-already-attempted*
#:build-system #:build-system
#:load-system #:load-systems #:compile-system #:test-system #:require-system #:load-system #:load-systems #:compile-system #:test-system #:require-system
#:*load-system-operation* #:module-provide-asdf #:*load-system-operation* #:module-provide-asdf
......
...@@ -7,12 +7,9 @@ ...@@ -7,12 +7,9 @@
:asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/component :asdf/system :asdf/find-system :asdf/find-component
:asdf/operation :asdf/action) :asdf/operation :asdf/action)
#+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:type-of) #+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 (:export
#:component-operation-time #:mark-operation-done #: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 #:planned-action-status #:plan-action-status #:action-already-done-p
#:circular-dependency #:circular-dependency-actions #:circular-dependency #:circular-dependency-actions
#:node-for #:needed-in-image-p #:node-for #:needed-in-image-p
...@@ -22,7 +19,10 @@ ...@@ -22,7 +19,10 @@
#:visit-dependencies #:compute-action-stamp #:traverse-action #:visit-dependencies #:compute-action-stamp #:traverse-action
#:circular-dependency #:circular-dependency-actions #:circular-dependency #:circular-dependency-actions
#:call-while-visiting-action #:while-visiting-action #: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) (in-package :asdf/plan)
;;;; Planned action status ;;;; Planned action status
...@@ -316,9 +316,11 @@ processed in order by OPERATE.")) ...@@ -316,9 +316,11 @@ processed in order by OPERATE."))
(defgeneric* perform-plan (plan &key)) (defgeneric* perform-plan (plan &key))
(defgeneric* plan-operates-on-p (plan component)) (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) (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
(let ((plan (apply 'make-instance (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)))) :system (component-system c) (remove-key :plan-class keys))))
(traverse-action plan o c t) (traverse-action plan o c t)
(plan-actions plan))) (plan-actions plan)))
......
...@@ -45,7 +45,7 @@ ...@@ -45,7 +45,7 @@
;; "2.345.6" would be a development version in the official upstream ;; "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.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 ;; "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-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*) (existing-version *asdf-version*)
(already-there (equal asdf-version existing-version))) (already-there (equal asdf-version existing-version)))
......
"2.26.113" "2.26.114"
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment