X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fcompiler-error.lisp;h=43160414c0eef9fb277829aa08ef4f4488bc28c9;hb=bb9b382751d808c76592ce2484c33f8447db6568;hp=7a62e250ac993f364757d3541e25af4b27b7387a;hpb=d2508075f57f0b37c127a5145b009e7fbba76f6f;p=sbcl.git diff --git a/src/compiler/compiler-error.lisp b/src/compiler/compiler-error.lisp index 7a62e25..4316041 100644 --- a/src/compiler/compiler-error.lisp +++ b/src/compiler/compiler-error.lisp @@ -21,7 +21,7 @@ ;;;; which are nice to have visible everywhere ;;; a function that is called to unwind out of COMPILER-ERROR -(declaim (type (function () nil) *compiler-error-bailout*)) +(declaim (type (function (&optional condition) nil) *compiler-error-bailout*)) (defvar *compiler-error-bailout*) ;;; an application programmer's error caught by the compiler @@ -56,7 +56,7 @@ ;;; not be a generalized instance of ERROR, as otherwise code such as ;;; (IGNORE-ERRORS (DEFGENERIC IF (X))) will catch and claim to handle ;;; the COMPILER-ERROR. So we make COMPILER-ERROR inherit from -;;; SIMPLE-CONDITION instead, as of sbcl-0.8alpha.0.2x, so that unless +;;; CONDITION instead, as of sbcl-0.8alpha.0.2x, so that unless ;;; the user claims to be able to handle general CONDITIONs (and if he ;;; does, he deserves what's going to happen :-) [ Note: we don't make ;;; COMPILER-ERROR inherit from SERIOUS-CONDITION, because @@ -80,49 +80,57 @@ ;;; COMPILER-ERROR call, and all is well. ;;; ;;; CSR, 2003-05-13 -(define-condition compiler-error (simple-condition) ()) +(define-condition compiler-error (encapsulated-condition) () + (:report (lambda (condition stream) + (print-object (encapsulated-condition condition) stream)))) ;;; Signal the appropriate condition. COMPILER-ERROR calls the bailout ;;; function so that it never returns (but compilation continues). -;;; COMPILER-ABORT falls through to the default error handling, so -;;; compilation terminates. -;;; -;;; FIXME: what is COMPILER-ABORT for? It isn't currently -;;; (2003-05-27) used in SBCL at all. -(declaim (ftype (function (string &rest t) nil) compiler-error compiler-abort)) -(declaim (ftype (function (string &rest t) (values)) - compiler-warning compiler-style-warning)) -(defun compiler-abort (format-string &rest format-args) - (error 'compiler-error - :format-control format-string - :format-arguments format-args)) -(defun compiler-error (format-string &rest format-args) - (restart-case - (progn - (cerror "Replace form with call to ERROR." - 'compiler-error - :format-control format-string - :format-arguments format-args) - (funcall *compiler-error-bailout*) - (bug "Control returned from *COMPILER-ERROR-BAILOUT*.")) - (signal-program-error () - (error 'simple-program-error - :format-control format-string - :format-arguments format-args)))) -(defun compiler-warn (format-string &rest format-args) - (apply #'warn format-string format-args) +(declaim (ftype (function (t &rest t) nil) compiler-error)) +(defun compiler-error (datum &rest arguments) + (let ((condition (coerce-to-condition datum arguments + 'simple-program-error 'compiler-error))) + (restart-case + (progn + (cerror "Replace form with call to ERROR." + 'compiler-error + :condition condition) + (funcall *compiler-error-bailout* condition) + (bug "Control returned from *COMPILER-ERROR-BAILOUT*.")) + (signal-error () + (error condition))))) + +(defun compiler-warn (datum &rest arguments) + (apply #'warn datum arguments) (values)) -(defun compiler-style-warn (format-string &rest format-args) - (apply #'style-warn format-string format-args) + +(defun compiler-style-warn (datum &rest arguments) + (apply #'style-warn datum arguments) (values)) +(defun source-to-string (source) + (write-to-string source + :escape t :readably nil :pretty t + :circle t :array nil)) + +(defun make-compiler-error-form (condition source) + `(error 'compiled-program-error + :message ,(princ-to-string condition) + :source ,(source-to-string source))) + +;;; Fatal compiler errors. We export FATAL-COMPILER-ERROR as an +;;; interface for errors that kill the compiler dead +;;; +;;; These are not a COMPILER-ERRORs, since we don't try to recover +;;; from them and keep chugging along, but instead immediately bail +;;; out of the entire COMPILE-FILE. + +(define-condition fatal-compiler-error (encapsulated-condition) + ()) + ;;; the condition of COMPILE-FILE being unable to READ from the ;;; source file ;;; -;;; This is not a COMPILER-ERROR, since we don't try to recover from -;;; it and keep chugging along, but instead immediately bail out of -;;; the entire COMPILE-FILE. -;;; ;;; (The old CMU CL code did try to recover from this condition, but ;;; the code for doing that was messy and didn't always work right. ;;; Since in Common Lisp the simple act of reading and compiling code @@ -131,20 +139,23 @@ ;;; deeply confused, so we violate what'd otherwise be good compiler ;;; practice by not trying to recover from this error and bailing out ;;; instead.) -(define-condition input-error-in-compile-file (error) - (;; the original error which was trapped to produce this condition - (error :reader input-error-in-compile-file-error - :initarg :error) - ;; the position where the bad READ began, or NIL if unavailable, +(define-condition input-error-in-compile-file (reader-error encapsulated-condition) + (;; the position where the bad READ began, or NIL if unavailable, ;; redundant, or irrelevant (position :reader input-error-in-compile-file-position - :initarg :position - :initform nil)) + :initarg :position + :initform nil)) (:report (lambda (condition stream) (format stream - "~@<~S failure in ~S~@[ at character ~W~]: ~2I~_~A~:>" - 'read - 'compile-file - (input-error-in-compile-file-position condition) - (input-error-in-compile-file-error condition))))) + "~@<~S error during ~S:~ + ~@:_ ~2I~_~A~ + ~@[~@:_~@:_(in form starting at ~:{~(~A~): ~S~:^, ~:_~})~]~ + ~:>" + 'read + 'compile-file + (encapsulated-condition condition) + (when (input-error-in-compile-file-position condition) + (sb!kernel::stream-error-position-info + (stream-error-stream condition) + (input-error-in-compile-file-position condition)))))))