* SBCL now builds and runs on MacOS X (version 10.2), or perhaps
more accurately, on the Darwin kernel running on PowerPC hardware.
(thanks to Brian Mastenbrook, Pierre Mai and Patrik Nordebo)
+ * Compiler code deletion notes now signal a condition of type
+ SB-EXT:CODE-DELETION-NOTE (a subtype of SB-EXT:COMPILER-NOTE) with
+ an associated MUFFLE-WARNING restart.
* bug fix: WITH-OUTPUT-TO-STRING (and MAKE-STRING-OUTPUT-STREAM) now
accept and act upon their :ELEMENT-TYPE keyword argument.
(reported by Edi Weitz)
(:integer map-shared "MAP_SHARED" "mmap: shared memory")
(:integer map-private "MAP_PRIVATE" "mmap: private mapping")
(:integer map-fixed "MAP_FIXED" "mmap: map at given location")
- )
\ No newline at end of file
+ )
;; conditions that can be handled to reduce compiler
;; verbosity
- "COMPILER-NOTE"
+ "CODE-DELETION-NOTE" "COMPILER-NOTE"
;; FIXME: This name doesn't match the DEFFOO - vs. -
;; DEFINE-FOO convention used in the ANSI spec, and so
(/noshow0 "returning from SIGNAL")
nil))
-;;; a utility for SIGNAL, ERROR, CERROR, WARN, and INVOKE-DEBUGGER:
-;;; Parse the hairy argument conventions into a single argument that's
-;;; directly usable by all the other routines.
-(defun coerce-to-condition (datum arguments default-type fun-name)
- (cond ((typep datum 'condition)
- (if arguments
- (cerror "Ignore the additional arguments."
- 'simple-type-error
- :datum arguments
- :expected-type 'null
- :format-control "You may not supply additional arguments ~
- when giving ~S to ~S."
- :format-arguments (list datum fun-name)))
- datum)
- ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION)
- (apply #'make-condition datum arguments))
- ((or (stringp datum) (functionp datum))
- (make-condition default-type
- :format-control datum
- :format-arguments arguments))
- (t
- (error 'simple-type-error
- :datum datum
- :expected-type '(or symbol string)
- :format-control "bad argument to ~S: ~S"
- :format-arguments (list fun-name datum)))))
-
;;; a shared idiom in ERROR, CERROR, and BREAK: The user probably
;;; doesn't want to hear that the error "occurred in" one of these
;;; functions, so we try to point the top of the stack to our caller
:format-control format-control
:format-arguments format-arguments))
+;;; a utility for SIGNAL, ERROR, CERROR, WARN, COMPILER-NOTIFY and
+;;; INVOKE-DEBUGGER: Parse the hairy argument conventions into a
+;;; single argument that's directly usable by all the other routines.
+(defun coerce-to-condition (datum arguments default-type fun-name)
+ (cond ((typep datum 'condition)
+ (if arguments
+ (cerror "Ignore the additional arguments."
+ 'simple-type-error
+ :datum arguments
+ :expected-type 'null
+ :format-control "You may not supply additional arguments ~
+ when giving ~S to ~S."
+ :format-arguments (list datum fun-name)))
+ datum)
+ ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION)
+ (apply #'make-condition datum arguments))
+ ((or (stringp datum) (functionp datum))
+ (make-condition default-type
+ :format-control datum
+ :format-arguments arguments))
+ (t
+ (error 'simple-type-error
+ :datum datum
+ :expected-type '(or symbol string)
+ :format-control "bad argument to ~S: ~S"
+ :format-arguments (list fun-name datum)))))
+
(define-condition layout-invalid (type-error)
()
(:report
(setq *last-error-context* context)
+ ;; FIXME: this testing for effective equality of compiler messages
+ ;; is ugly, and really ought to be done at a higher level.
(unless (and (equal format-string *last-format-string*)
(tree-equal format-args *last-format-args*))
(note-message-repeats nil)
(values "~A"
(list (with-output-to-string (s)
(princ condition s)))))
- (print-compiler-message (format nil
- "caught ~S:~% ~A"
- what
- format-string)
- format-args)))
+ (print-compiler-message
+ (format nil "caught ~S:~% ~A" what format-string)
+ format-args)))
(values))
;;; The act of signalling one of these beasts must not cause WARNINGSP
;;; FIXME: the handling of compiler-notes could be unified with
;;; warnings and style-warnings (see the various handler functions
;;; below).
-(define-condition compiler-note (condition) ())
+(define-condition compiler-note (condition) ()
+ (:documentation
+ "Root of the hierarchy of conditions representing information discovered
+by the compiler that the user might wish to know, but which does not merit
+a STYLE-WARNING (or any more serious condition)."))
(define-condition simple-compiler-note (simple-condition compiler-note) ())
+(define-condition code-deletion-note (simple-compiler-note) ()
+ (:documentation
+ "A condition type signalled when the compiler deletes code that the user
+has written, having proved that it is unreachable."))
-(defun compiler-notify (format-string &rest format-args)
- ;; FORMAT-STRING and FORMAT-ARGS might well end up turning into
- ;; DATUM and REST, and COERCE-TO-CONDITION will be used.
+(defun compiler-notify (datum &rest args)
(unless (if *compiler-error-context*
(policy *compiler-error-context* (= inhibit-warnings 3))
(policy *lexenv* (= inhibit-warnings 3)))
- (restart-case
- (signal (make-condition 'simple-compiler-note
- :format-control format-string
- :format-arguments format-args))
- (muffle-warning ()
- (return-from compiler-notify (values))))
- (incf *compiler-note-count*)
- (print-compiler-message (format nil "note: ~A" format-string)
- format-args))
+ (let ((condition
+ (coerce-to-condition datum args
+ 'simple-compiler-note 'compiler-notify)))
+ (restart-case
+ (signal condition)
+ (muffle-warning ()
+ (return-from compiler-notify (values))))
+ (incf *compiler-note-count*)
+ (multiple-value-bind (format-string format-args)
+ (if (typep condition 'simple-condition)
+ (values (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition))
+ (values "~A"
+ (list (with-output-to-string (s)
+ (princ condition s)))))
+ (print-compiler-message (format nil "note: ~A" format-string)
+ format-args))))
(values))
;;; Issue a note when we might or might not be in the compiler.
(if (boundp '*lexenv*) ; if we're in the compiler
(apply #'compiler-notify rest)
(progn
- (restart-case
- (signal (make-condition 'simple-compiler-note
- :format-control (car rest)
- :format-arguments (cdr rest)))
- (muffle-warning ()
- (return-from maybe-compiler-notify (values))))
- (let ((stream *error-output*))
- (pprint-logical-block (stream nil :per-line-prefix ";")
- (format stream " note: ~3I~_")
- (pprint-logical-block (stream nil)
- (apply #'format stream rest)))
- ;; (outside logical block, no per-line-prefix)
- (fresh-line stream))
+ (let ((condition
+ (coerce-to-condition (car rest) (cdr rest)
+ 'simple-compiler-note
+ 'maybe-compiler-notify)))
+ (restart-case
+ (signal condition)
+ (muffle-warning ()
+ (return-from maybe-compiler-notify (values))))
+ (let ((stream *error-output*))
+ (pprint-logical-block (stream nil :per-line-prefix ";")
+ (format stream " note: ~3I~_")
+ (pprint-logical-block (stream nil)
+ (format stream "~A" condition)))
+ ;; (outside logical block, no per-line-prefix)
+ (fresh-line stream)))
(values))))
;;; The politically correct way to print out progress messages and
(return-block (and return (node-block return))))
(unless (leaf-ever-used clambda)
(let ((*compiler-error-context* bind))
- (compiler-notify "deleting unused function~:[.~;~:*~% ~S~]"
- (leaf-debug-name clambda))))
+ (compiler-notify 'code-deletion-note
+ :format-control "deleting unused function~:[.~;~:*~% ~S~]"
+ :format-arguments (list (leaf-debug-name clambda)))))
(unless (block-delete-p bind-block)
(unlink-blocks (component-head component) bind-block))
(when (and return-block (not (block-delete-p return-block)))
0)))
(unless (return-p node)
(let ((*compiler-error-context* node))
- (compiler-notify "deleting unreachable code")))
+ (compiler-notify 'code-deletion-note
+ :format-control "deleting unreachable code"
+ :format-arguments nil)))
(return))))))
(values))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.2.9"
+"0.8.2.10"
projects / sbcl.git / commitdiff