Skip to content
Snippets Groups Projects
Commit 5911ec7c authored by rtoy's avatar rtoy
Browse files

Define a new condition class, COMPILER-READ-ERROR, a subtype of

COMPILER-ERROR, to allow slime better control of read errors.

Patch from Helmut Eller, cmucl-imp, 2004-10-25.
parent 3d733bdf
No related branches found
No related tags found
No related merge requests found
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.106 2004/08/23 11:37:52 emarsden Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.107 2004/10/26 13:31:38 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -2107,6 +2107,15 @@ these can be NIL if unavailable or inapplicable.")
;;;
(define-condition compiler-error (simple-program-error) ())
;;; A special condition for read time errors. It includes the source
;;; position where the error occured.
;;;
(define-condition compiler-read-error (compiler-error)
((position :initarg :position :reader compiler-read-error-position)
(message :initarg :message :reader compiler-read-error-message))
(:report (lambda (condition stream)
(format stream "~A~%" (compiler-read-error-message condition)))))
;;; COMPILER-{ERROR,WARNING,STYLE-WARNING}-HANDLER -- Interface
;;;
;;; Condition handlers established by the compiler. We re-signal the
......@@ -2138,7 +2147,8 @@ these can be NIL if unavailable or inapplicable.")
;;; simple-style-warning, inhibited if brevity is 3. anything when Brevity is
;;; 3. Compiler-Error calls the bailout function so that it never returns.
;;; Compiler-Error-Message returns like Compiler-Warning, but signals a
;;; Compiler-Error.
;;; Compiler-Error. Compiler-Read-Error is like Compiler-Error-Message but
;;; signals a Compile-Read-Error.
;;;
(defun compiler-error (format-string &rest format-args)
(declare (string format-string))
......@@ -2151,6 +2161,11 @@ these can be NIL if unavailable or inapplicable.")
(cerror "ignore it."
'compiler-error :format-control format-string
:format-arguments format-args))
;;;
(defun compiler-read-error (position format-string &rest format-args)
(cerror "replace form with call to ERROR."
'compiler-read-error :position position
:message (apply #'format nil format-string format-args)))
;;;
(defun compiler-warning (format-string &rest format-args)
(declare (string format-string))
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.142 2004/05/10 20:05:18 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.143 2004/10/26 13:31:38 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -768,11 +768,10 @@ in the user USER-INFO slot of STREAM-SOURCE-LOCATIONs.")
(let ((line (read-line stream nil))
(end (file-position stream)))
(when (>= end pos)
(compiler-error-message
"Read error at ~D:~% \"~A/\\~A\"~%~A"
pos
(string-left-trim " "
(subseq line 0 (- pos start)))
(compiler-read-error
pos "Read error at ~D:~% \"~A/\\~A\"~%~A"
pos (string-left-trim '(#\space #\tab)
(subseq line 0 (- pos start)))
(subseq line (- pos start))
condition)
(return))
......@@ -817,8 +816,8 @@ in the user USER-INFO slot of STREAM-SOURCE-LOCATIONs.")
(unless (or res (zerop (length line)))
(setq res line))))
(compiler-error-message
"Read error in form starting at ~D:~%~@[ \"~A\"~%~]~A"
(compiler-read-error
pos "Read error in form starting at ~D:~%~@[ \"~A\"~%~]~A"
pos res condition)
(file-position stream eof-pos)
......
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