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
......@@ -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))))
......
......@@ -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))
......
......@@ -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.
......
;; -*- 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 <asdf-devel@common-lisp.net>.
......
......@@ -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)))))
......@@ -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
......
......@@ -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)))
......
......@@ -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)))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment