Commit 0a621ca2 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.121: integrate deferred-warnings support to asdf/defsystem

Also, have convenience methods for operation and component designators.
Enhance the incidental traversal functions.
Move compile-file error handling to lisp-build.

Passes tests on CCL and SBCL.
parent fb3d1204
......@@ -2,24 +2,57 @@
;;;; Actions
(asdf/package:define-package :asdf/action
(:nicknames :asdf-action)
(:recycle :asdf/action :asdf)
(:use :common-lisp :asdf/driver :asdf/upgrade
:asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation)
#+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:type-of)
(:intern #:stamp #:done-p)
(:export
#:action
#:action #:define-convenience-action-methods
#:explain #:operation-description
#:downward-operation #:upward-operation
#:operation-error #:error-component #:error-operation
#:downward-operation #:upward-operation #:sibling-operation
#:component-depends-on #:component-self-dependencies
#:input-files #:output-files #:output-file #:operation-done-p
#:action-status #:action-stamp #:action-done-p
#:component-operation-time #:mark-operation-done #:compute-action-stamp
#:perform #:perform-with-restarts #:retry #:accept #:feature))
#:perform #:perform-with-restarts #:retry #:accept #:feature
#:gather-actions #:operated-components
#:traverse-sub-actions #:dependency-files
))
(in-package :asdf/action)
(deftype action () '(cons operation component)) ;; a step to be performed while building the system
(declaim (ftype (function (t &rest t) t) operated-components traverse-actions)
(ftype (function (t t &rest t) t)
traverse-sub-actions dependency-files))
;;;; Convenience methods
(defmacro define-convenience-action-methods
(function (operation component &rest more-args) &key if-no-operation if-no-component)
(let ((rest (gensym "REST"))
(found (gensym "FOUND")))
`(progn
(defmethod ,function ((,operation symbol) ,component
,@(when more-args `(&rest ,rest))
,@(when (member '&key more-args) `(&key &allow-other-keys)))
(if ,operation
,(if more-args
`(apply ',function (make-operation ,operation) ,component ,rest)
`(,function (make-operation ,operation) ,component))
,if-no-operation))
(defmethod ,function ((,operation operation) ,component
,@(when more-args `(&rest ,rest))
,@(when (member '&key more-args) `(&key &allow-other-keys)))
(if (typep ,component 'component)
(error "No defined method for ~S on ~S" ',function ,component)
(let ((,found (find-component () ,component)))
(if ,found
,(if more-args
`(apply ',function ,operation ,found ,rest)
`(,function ,operation ,found))
,if-no-component)))))))
;;;; self-description
......@@ -30,23 +63,17 @@ You can put together sentences using this phrase."))
(defmethod operation-description (operation component)
(format nil (compatfmt "~@<~A on ~A~@:>")
(class-of operation) component))
(define-convenience-action-methods operation-description (operation component))
(defgeneric* explain (operation component))
(defmethod explain ((o operation) (c component))
(asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (operation-description o c)))
(define-convenience-action-methods explain (operation component))
;;;; Error
(define-condition operation-error (error) ;; Bad, backward-compatible name
;; We want to rename it to action-error, but that breaks upgrade on SBCL.
;; Before to rename it, fix these other culprits, too:
;; cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
((component :reader error-component :initarg :component)
(operation :reader error-operation :initarg :operation))
(:report (lambda (c s)
(format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
(type-of c) (error-operation c) (error-component c)))))
(defun* format-action (stream action &optional colon-p at-sign-p)
(assert (null colon-p)) (assert (null at-sign-p))
(destructuring-bind (operation . component) action
(princ (operation-description operation component) stream)))
;;;; Dependencies
......@@ -68,6 +95,8 @@ You can put together sentences using this phrase."))
should usually append the results of CALL-NEXT-METHOD to the
list."))
(defgeneric* component-self-dependencies (operation component))
(define-convenience-action-methods component-depends-on (operation component))
(define-convenience-action-methods component-self-dependencies (operation component))
(defmethod component-depends-on ((o operation) (c component))
(cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies
......@@ -82,17 +111,34 @@ You can put together sentences using this phrase."))
;; These together handle actions that propagate along the component hierarchy.
;; Downward operations like load-op or compile-op propagate down the hierarchy:
;; operation on a parent depends-on operation on its children.
(defclass downward-operation (operation) ())
;; By default, an operation propagates itself, but it may propagate another one instead.
(defclass downward-operation (operation)
((downward-operation
:initform nil :initarg :downward-operation :reader downward-operation)))
(defmethod component-depends-on ((o downward-operation) (c parent-component))
`((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method)))
;; Upward operations like prepare-op propagate up the component hierarchy:
;; operation on a child depends-on operation on its parent.
(defclass upward-operation (operation) ())
(defmethod component-depends-on ((o downward-operation) (c parent-component))
`((,o ,@(component-children c)) ,@(call-next-method)))
;; By default, an operation propagates itself, but it may propagate another one instead.
(defclass upward-operation (operation)
((upward-operation
:initform nil :initarg :downward-operation :reader upward-operation)))
;; For backward-compatibility reasons, a system inherits from module and is a child-component
;; so we must guard against this case. ASDF3: remove that.
(defmethod component-depends-on ((o upward-operation) (c child-component))
`(,@(if-let (p (component-parent c)) `((,o ,p))) ,@(call-next-method)))
`(,@(if-let (p (component-parent c))
`((,(or (upward-operation o) o) ,p))) ,@(call-next-method)))
;; Sibling operations propagate to siblings in the component hierarchy:
;; operation on a child depends-on operation on its parent.
;; By default, an operation propagates itself, but it may propagate another one instead.
(defclass sibling-operation (operation)
((sibling-operation
:initform nil :initarg :sibling-operation :reader sibling-operation)))
(defmethod component-depends-on ((o sibling-operation) (c component))
`((,(or (sibling-operation o) o)
,@(loop :for dep :in (component-sibling-dependencies c)
:collect (resolve-dependency-spec c dep)))
,@(call-next-method)))
;;;; Inputs, Outputs, and invisible dependencies
......@@ -100,6 +146,9 @@ You can put together sentences using this phrase."))
(defgeneric* input-files (operation component))
(defgeneric* operation-done-p (operation component)
(:documentation "Returns a boolean, which is NIL if the action is forced to be performed again"))
(define-convenience-action-methods output-files (operation component))
(define-convenience-action-methods input-files (operation component))
(define-convenience-action-methods operation-done-p (operation component))
(defmethod operation-done-p ((o operation) (c component))
(declare (ignorable o c))
......@@ -145,6 +194,9 @@ You can put together sentences using this phrase."))
;;;; Done performing
(defgeneric* component-operation-time (operation component)) ;; ASDF3: hide it behind plan-action-stamp
(define-convenience-action-methods component-operation-time (operation component))
(defgeneric* mark-operation-done (operation component)) ;; ASDF3: hide it behind (setf plan-action-stamp)
(defgeneric* compute-action-stamp (plan operation component &key just-done)
(:documentation "Has this action been successfully done already,
......@@ -188,6 +240,7 @@ in some previous image, or T if it needs to be done.")
(defgeneric* perform-with-restarts (operation component))
(defgeneric* perform (operation component))
(define-convenience-action-methods perform (operation component))
(defmethod perform :before ((o operation) (c component))
(ensure-all-directories-exist (output-files o c)))
......
......@@ -15,10 +15,10 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.120" ;; to be automatically updated by bin/bump-revision
:version "2.26.121" ;; 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))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op asdf/defsystem))))
#-asdf2.27
(defmethod perform :before
......
......@@ -8,6 +8,8 @@
:asdf/lisp-build :asdf/operate :asdf/output-translations)
(:export
#:*asdf-verbose*
#:operation-error #:compile-error #:compile-failed #:compile-warned
#:error-component #:error-operation
#:component-load-dependencies
#:enable-asdf-binary-locations-compatibility
#:operation-forced
......@@ -17,6 +19,17 @@
#:system-definition-pathname))
(in-package :asdf/backward-interface)
(define-condition operation-error (error) ;; Bad, backward-compatible name
;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
((component :reader error-component :initarg :component)
(operation :reader error-operation :initarg :operation))
(:report (lambda (c s)
(format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
(type-of c) (error-operation c) (error-component c)))))
(define-condition compile-error (operation-error) ())
(define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ())
(defun* component-load-dependencies (component)
;; Old deprecated name for the same thing. Please update your software.
(component-sibling-dependencies component))
......
......@@ -15,7 +15,6 @@
#:compiled-file #:precompiled-system #:prebuilt-system
#:operation-monolithic-p
#:user-system-p #:user-system #:trivial-system-p
#:gather-actions #:operated-components
#+ecl #:make-build
#:register-pre-built-system
#:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library
......@@ -192,23 +191,6 @@
(remf args :ld-flags)
args))
(defclass filtered-sequential-plan (sequential-plan)
((action-filter :initarg :action-filter :reader plan-action-filter)))
(defmethod action-valid-p ((plan filtered-sequential-plan) o c)
(and (funcall (plan-action-filter plan) o c) (call-next-method)))
(defun* gather-actions (operation component &key other-systems (filter t))
;; This function creates a list of sub-actions performed
;; while building the targeted action.
;; This list may be restricted to sub-components of SYSTEM
;; if OTHER-SYSTEMS is NIL (default).
(traverse operation component
:plan-class 'filtered-sequential-plan
:action-filter (ensure-function filter)
:force (if other-systems :all t)
:force-not (if other-systems nil :all)))
(defun* bundlable-file-p (pathname)
(let ((type (pathname-type pathname)))
(declare (ignorable type))
......@@ -217,19 +199,6 @@
#+mkcl (equal type (compile-file-type :fasl-p nil))
#+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal type (compile-file-type)))))
(defun* operated-components (system &key (goal-operation 'load-op) (keep-operation goal-operation)
(component-type t) (keep-component t) other-systems)
(let ((goal-op (make-operation goal-operation)))
(flet ((filter (o c)
(declare (ignore o))
(or (eq c system)
(typep c component-type))))
(loop :for (o . c) :in (gather-actions goal-op system
:other-systems other-systems
:filter #'filter)
:when (and (typep o keep-operation) (typep c keep-component))
:collect c))))
(defgeneric* trivial-system-p (component))
(defun* user-system-p (s)
......
......@@ -190,14 +190,9 @@ another pathname in a degenerate way."))
;;;; component pathnames
(defun* component-parent-pathname (component)
;; No default anymore (in particular, no *default-pathname-defaults*).
;; If you force component to have a NULL pathname, you better arrange
;; for any of its children to explicitly provide a proper absolute pathname
;; wherever a pathname is actually wanted.
(let ((parent (component-parent component)))
(when parent
(component-pathname parent))))
(defgeneric* component-parent-pathname (component))
(defmethod component-parent-pathname (component)
(component-pathname (component-parent component)))
(defmethod component-pathname ((component component))
(if (slot-boundp component 'absolute-pathname)
......
......@@ -33,7 +33,8 @@
;; If no absolute pathname was found, we return NIL.
(check-type pathname (or null string pathname))
(absolutize-pathnames
(list pathname (load-pathname) *default-pathname-defaults* (getcwd))
(list pathname (load-pathname) *default-pathname-defaults*
#-(or abcl gcl genera) (getcwd))
:resolve-symlinks *resolve-symlinks*))
......
......@@ -158,7 +158,8 @@ Going forward, we recommend new users should be using the source-registry.
(let* ((file (probe-file*
(absolutize-pathnames
(list (make-pathname :name name :type "asd")
defaults *default-pathname-defaults* (getcwd))
defaults *default-pathname-defaults*
#-(or abcl gcl genera) (getcwd))
:resolve-symlinks truename)
:truename truename)))
(when file
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.120: Another System Definition Facility.
;;; This is ASDF 2.26.121: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -7,7 +7,7 @@
(:use :common-lisp :asdf/driver :asdf/upgrade
:asdf/component :asdf/system :asdf/find-component :asdf/operation :asdf/action)
(:export
#:compile-error #:compile-failed #:compile-warned #:try-recompiling
#:try-recompiling
#:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
#:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations
#:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
......@@ -15,16 +15,8 @@
#:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source))
(in-package :asdf/lisp-action)
;;;; Conditions
(define-condition compile-error (operation-error) ())
(define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ())
;;;; Component classes
(defclass cl-source-file (source-file)
((type :initform "lisp")))
(defclass cl-source-file.cl (cl-source-file)
......@@ -34,7 +26,6 @@
;;;; Operation classes
(defclass basic-load-op (operation) ())
(defclass basic-compile-op (operation)
((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
......@@ -42,12 +33,15 @@
:initform nil)))
;;; Our default operations: loading into the current lisp image
(defclass load-op (basic-load-op downward-operation) ())
(defclass prepare-op (upward-operation) ())
(defclass compile-op (basic-compile-op downward-operation) ())
(defclass load-op (basic-load-op downward-operation sibling-operation) ())
(defclass prepare-op (upward-operation sibling-operation)
((sibling-operation :initform 'load-op :allocation :class)))
(defclass compile-op (basic-compile-op downward-operation)
((downward-operation :initform 'load-op :allocation :class)))
(defclass load-source-op (basic-load-op downward-operation) ())
(defclass prepare-source-op (upward-operation) ())
(defclass prepare-source-op (upward-operation sibling-operation)
((sibling-operation :initform 'load-source-op :allocation :class)))
(defclass test-op (operation) ())
......@@ -58,11 +52,6 @@
(defmethod operation-description ((o prepare-op) (c component))
(declare (ignorable o))
(format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c))
(defmethod component-depends-on ((o prepare-op) (c component))
(declare (ignorable o))
`((load-op ,@(loop :for dep :in (component-sibling-dependencies c)
:collect (resolve-dependency-spec c dep)))
,@(call-next-method)))
(defmethod perform ((o prepare-op) (c component))
(declare (ignorable o c))
nil)
......@@ -79,7 +68,7 @@
(format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c))
(defmethod operation-description ((o compile-op) (c parent-component))
(declare (ignorable o))
(format nil (compatfmt "~@<compiled ~3i~_~A~@:>") c))
(format nil (compatfmt "~@<completing compilation for ~3i~_~A~@:>") c))
(defgeneric* call-with-around-compile-hook (component thunk))
(defmethod call-with-around-compile-hook ((c component) function)
(call-around-hook (around-compile-hook c) function))
......@@ -89,44 +78,47 @@
(input-file (first (input-files o c)))
;; on some implementations, there are more than one output-file,
;; but the first one should always be the primary fasl that gets loaded.
(output-file (first (output-files o c))))
(outputs (output-files o c)))
(multiple-value-bind (output warnings-p failure-p)
(call-with-around-compile-hook
c #'(lambda (&rest flags)
(with-muffled-compiler-conditions ()
(apply 'compile-file* input-file
:output-file output-file
:external-format (component-external-format c)
(append flags (compile-op-flags o))))))
(unless output
(error 'compile-error :component c :operation o))
(when failure-p
(case *compile-file-failure-behaviour*
(:warn (warn
(compatfmt "~@<COMPILE-FILE failed while performing ~A.~@:>")
(operation-description o c)))
(:error (error 'compile-failed :component c :operation o))
(:ignore nil)))
(when warnings-p
(case *compile-file-warnings-behaviour*
(:warn (warn
(compatfmt "~@<COMPILE-FILE warned while performing ~A.~@:>")
(operation-description o c)))
(:error (error 'compile-warned :component c :operation o))
(:ignore nil))))))
(destructuring-bind
(output-file &optional #+(or ecl mkcl) object-file #+sbcl warnings-file) outputs
(call-with-around-compile-hook
c #'(lambda (&rest flags)
(with-muffled-compiler-conditions ()
(apply 'compile-file* input-file
:output-file output-file
:external-format (component-external-format c)
(append
#+(or ecl mkcl) (list :object-file object-file)
#+sbcl (list :warnings-file warnings-file)
flags (compile-op-flags o)))))))
(check-lisp-compile-results output warnings-p failure-p
"~/asdf-action::format-action/" (list (cons o c))))))
(defun* report-file-p (f)
(equal (pathname-type f) "build-report"))
(defun* perform-lisp-warnings-check (o c)
(check-deferred-warnings
(remove-if-not #'warnings-file-p (input-files o c))
"~/asdf-action::format-action/" (list (cons o c)))
(let* ((output (output-files o c))
(report (find-if #'report-file-p output)))
(when report
(with-open-file (s report :direction :output :if-exists :supersede)
(format s ":success~%")))))
(defmethod perform ((o compile-op) (c cl-source-file))
(perform-lisp-compilation o c))
(defmethod output-files ((o compile-op) (c cl-source-file))
(declare (ignorable o))
(let* ((i (first (input-files o c)))
(f (compile-file-pathname
i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))
#+mkcl (o (compile-file-pathname i :fasl-p nil))) ;; object file
#+ecl (if (use-ecl-byte-compiler-p)
(list f)
(list f (compile-file-pathname i :type :object)))
#+mkcl (list f o)
#-(or ecl mkcl) (list f)))
i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)))
`(,f ;; the fasl is the primary output, in first position
#+ecl ,@(unless (use-ecl-byte-compiler-p)
(compile-file-pathname i :type :object))
#+mkcl ,(compile-file-pathname i :fasl-p nil) ;; object file
#+sbcl ,@(unless (builtin-system-p (component-system c))
`(,(make-pathname :type "sbcl-warnings" :defaults f))))))
(defmethod component-depends-on ((o compile-op) (c component))
(declare (ignorable o))
`((prepare-op ,c) ,@(call-next-method)))
......@@ -136,6 +128,25 @@
(defmethod output-files ((o compile-op) (c static-file))
(declare (ignorable o c))
nil)
(defmethod perform ((o compile-op) (c system))
(declare (ignorable o c))
nil
#+sbcl (perform-lisp-warnings-check o c))
#+sbcl
(defmethod input-files ((o compile-op) (c system))
(declare (ignorable o c))
(unless (builtin-system-p c)
(loop :for (sub-o . sub-c)
:in (traverse-sub-actions
o c :other-systems nil
:keep-operation 'compile-op :keep-component 'cl-source-file)
:append (remove-if-not 'warnings-file-p
(output-files sub-o sub-c)))))
#+sbcl
(defmethod output-files ((o compile-op) (c system))
(unless (builtin-system-p c)
(if-let ((pathname (component-pathname c)))
(list (subpathname pathname (component-name c) :type "build-report")))))
;;; load-op
(defmethod operation-description ((o load-op) (c cl-source-file))
......@@ -143,7 +154,7 @@
(format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c))
(defmethod operation-description ((o load-op) (c parent-component))
(declare (ignorable o))
(format nil (compatfmt "~@<loaded ~3i~_~A~@:>") c))
(format nil (compatfmt "~@<completing load for ~3i~_~A~@:>") c))
(defmethod operation-description ((o load-op) component)
(declare (ignorable o))
(format nil (compatfmt "~@<loading ~3i~_~A~@:>")
......@@ -167,10 +178,10 @@
nil)
(defmethod component-depends-on ((o load-op) (c component))
(declare (ignorable o))
`((prepare-op ,c) ,@(call-next-method)))
(defmethod component-depends-on ((o load-op) (c source-file))
(declare (ignorable o))
`((compile-op ,c) ,@(call-next-method)))
;; NB: even though compile-op depends-on on prepare-op,
;; it is not needed-in-image-p, whereas prepare-op is,
;; so better not omit prepare-op and think it will happen.
`((prepare-op ,c) (compile-op ,c) ,@(call-next-method)))
;;;; prepare-source-op, load-source-op
......@@ -179,9 +190,6 @@
(defmethod operation-description ((o prepare-source-op) (c component))
(declare (ignorable o))
(format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:>") c))
(defmethod component-depends-on ((o prepare-source-op) (c source-file))
(declare (ignorable o))
`((load-source-op ,@(component-sibling-dependencies c)) ,@(call-next-method)))
(defmethod input-files ((o prepare-source-op) (c component))
(declare (ignorable o c))
nil)
......
......@@ -10,6 +10,9 @@
#:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
#:*output-translation-function*
#:*optimization-settings* #:*previous-optimization-settings*
#:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
#:compile-warned-warning #:compile-failed-warning
#:check-lisp-compile-results #:check-lisp-compile-warnings
#:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
#:*deferred-warnings*
;; Functions & Macros
......@@ -18,8 +21,8 @@
#: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
#:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings
#:with-saved-deferred-warnings #:warnings-file-p
#:call-with-asdf-compilation-unit #:with-asdf-compilation-unit
#:current-lisp-file-pathname #:load-pathname
#:lispize-pathname #:compile-file-type #:call-around-hook
......@@ -114,6 +117,57 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
`(call-with-muffled-loader-conditions #'(lambda () ,@body)))
;;;; Handle warnings and failures
(define-condition compile-condition (condition)
((context-format
:initform nil :reader compile-condition-context-format :initarg :context-format)
(context-arguments
:initform nil :reader compile-condition-context-arguments :initarg :context-arguments)
(description
:initform nil :reader compile-condition-description :initarg :description))
(:report (lambda (c s)
(format s (compatfmt "~@<~A~@[ while ~?~]~@:>")
(or (compile-condition-description c) (type-of c))
(compile-condition-context-format c)
(compile-condition-context-arguments c)))))
(define-condition compile-file-error (compile-condition error) ())
(define-condition compile-warned-warning (compile-condition warning) ())
(define-condition compile-warned-error (compile-condition error) ())
(define-condition compile-failed-warning (compile-condition warning) ())
(define-condition compile-failed-error (compile-condition error) ())
(defun* check-lisp-compile-warnings (warnings-p failure-p
&optional context-format context-arguments)
(when failure-p
(case *compile-file-failure-behaviour*
(:warn (warn 'compile-failed-warning
:description "Lisp compilation failed"
:context-format context-format
:context-arguments context-arguments))
(:error (error 'compile-failed-error
:description "Lisp compilation failed"
:context-format context-format
:context-arguments context-arguments))
(:ignore nil)))
(when warnings-p
(case *compile-file-warnings-behaviour*
(:warn (warn 'compile-warned-warning
:description "Lisp compilation had style-warnings"
:context-format context-format
:context-arguments context-arguments))
(:error (error 'compile-warned-error
:description "Lisp compilation had style-warnings"
:context-format context-format
:context-arguments context-arguments))
(:ignore nil))))
(defun* check-lisp-compile-results (output warnings-p failure-p
&optional context-format context-arguments)
(unless output
(error 'compile-file-error :context-format context-format :context-arguments context-arguments))
(check-lisp-compile-warnings warnings-p failure-p context-format context-arguments))
;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman.
(defun reify-simple-sexp (sexp)
......@@ -179,17 +233,16 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
(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))))))
(unless (case kind (:function (fboundp name)))
(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
......@@ -209,12 +262,39 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
"Save forward reference conditions so they may be issued at a latter time,
possibly in a different process."
(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))))
(with-safe-io-syntax ()
(write (reify-deferred-warnings) :stream s :pretty t :readably t)
(terpri s)))
(reset-deferred-warnings))
(defun* warnings-file-p (file)
(equal (pathname-type file) "sbcl-warnings"))
(defun* check-deferred-warnings (files &optional context-format context-arguments)
(let ((file-errors nil)
(failure-p nil)
(warnings-p nil))
(handler-bind
((warning #'(lambda (c)
(setf warnings-p t)
(unless (typep c 'style-warning)
(setf failure-p t)))))
(with-compilation-unit (:override t)
(reset-deferred-warnings)
(dolist (file files)
(unreify-deferred-warnings
(handler-case (safe-read-file-form file)
(error (c)
(delete-file-if-exists file)
(push c file-errors)
nil))))))
(dolist (error file-errors) (error error))
(check-lisp-compile-warnings
(or failure-p warnings-p) failure-p context-format context-arguments)))
;;;; Deferred warnings
(defun* call-with-saved-deferred-warnings (thunk warnings-file)
(if warnings-file
(with-compilation-unit (:override t)
......@@ -223,7 +303,8 @@ possibly in a different process."
(multiple-value-prog1
(with-muffled-compiler-conditions ()
(funcall thunk))
(save-deferred-warnings warnings-file))))
(save-deferred-warnings warnings-file)
(reset-deferred-warnings))))
(funcall thunk)))
(defmacro with-saved-deferred-warnings ((warnings-file) &body body)
......@@ -253,6 +334,19 @@ possibly in a different process. Otherwise just run the BODY."
(defun* call-around-hook (hook function)
(call-function (or hook 'funcall) function))
(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
(let* ((keys
(remove-plist-keys `(#+(and allegro (not (version>= 8 2))) :external-format
,@(unless output-file '(:output-file))) keys)))
(if (absolute-pathname-p output-file)
;; what cfp should be doing, w/ mp* instead of mp
(let* ((type (pathname-type (apply 'compile-file-type keys)))
(defaults (make-pathname
:type type :defaults (merge-pathnames* input-file))))
(merge-pathnames* output-file defaults))
(funcall *output-translation-function*
(apply 'compile-file-pathname input-file keys)))))
(defun* compile-file* (input-file &rest keys
&key compile-check output-file warnings-file
#+(or ecl mkcl) object-file
......@@ -322,19 +416,6 @@ it will filter them appropriately."
(setf output-truename nil)))
(values output-truename warnings-p failure-p))))
(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
(let* ((keys
(remove-plist-keys `(#+(and allegro (not (version>= 8 2))) :external-format
,@(unless output-file '(:output-file))) keys)))
(if (absolute-pathname-p output-file)
;; what cfp should be doing, w/ mp* instead of mp
(let* ((type (pathname-type (apply 'compile-file-type keys)))
(defaults (make-pathname
:type type :defaults (merge-pathnames* input-file))))
(merge-pathnames* output-file defaults))
(funcall *output-translation-function*
(apply 'compile-file-pathname input-file keys)))))
(defun* load* (x &rest keys &key &allow-other-keys)
(etypecase x
((or pathname string #-(or gcl<2.7 clozure allegro) stream)
......
......@@ -16,16 +16,19 @@
#:upgrade-asdf #:cleanup-upgraded-asdf #:*post-upgrade-hook*))
(in-package :asdf/operate)