From 5911ec7c63c626db03fde32169eb413c03800cf8 Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Tue, 26 Oct 2004 13:31:38 +0000 Subject: [PATCH] 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. --- compiler/ir1util.lisp | 19 +++++++++++++++++-- compiler/main.lisp | 15 +++++++-------- 2 files changed, 24 insertions(+), 10 deletions(-) diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp index c7791cca1..90618cd29 100644 --- a/compiler/ir1util.lisp +++ b/compiler/ir1util.lisp @@ -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)) diff --git a/compiler/main.lisp b/compiler/main.lisp index 4e4c6c73b..d36600ee2 100644 --- a/compiler/main.lisp +++ b/compiler/main.lisp @@ -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) -- GitLab