From cd1b14acf6f548b28b8a14e554d779f0473122ec Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Mon, 2 Sep 2013 09:44:38 +0400 Subject: [PATCH] Handle compiler-error in LOAD when it's not run from inside EVAL. When LOAD is run from the --load option or from within a new thread, it doesn't go though EVAL and doesn't inherit its compiler-error handler. Fixes lp#1219601. --- NEWS | 2 ++ package-data-list.lisp-expr | 2 +- src/code/eval.lisp | 36 ++++++++++++------------------------ src/code/full-eval.lisp | 37 +++++++++++++------------------------ src/code/target-load.lisp | 4 +++- src/compiler/compiler-error.lisp | 14 ++++++++++++++ 6 files changed, 45 insertions(+), 50 deletions(-) diff --git a/NEWS b/NEWS index 90e9f8b..a8a97e8 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,8 @@ changes relative to sbcl-1.1.11: * bug fix: SBCL can now be built on Solaris x86-64. * bug fix: Floating point exceptions do not persist on Solaris anymore. * bug fix: (setf . a) is pprinted correctly (reported by Douglas Katzman). + * bug fix: handle compiler-error in LOAD when it's not run from inside EVAL. + (lp#1219601) changes in sbcl-1.1.11 relative to sbcl-1.1.10: * enhancement: support building the manual under texinfo version 5. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index dd6870d..cf8fd1e 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -393,7 +393,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "GENERATE-CALL-SEQUENCE" "GENERATE-RETURN-SEQUENCE" "LOCATION-NUMBER" - + "WITH-COMPILER-ERROR-RESIGNALLING" "WITH-SOURCE-LOCATION" "*SOURCE-LOCATION-THUNKS*" diff --git a/src/code/eval.lisp b/src/code/eval.lisp index cafbb1c..977cd3d 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -127,25 +127,13 @@ (declare (optimize (safety 1))) ;; (aver (lexenv-simple-p lexenv)) (incf *eval-calls*) - (handler-bind - ((sb!c:compiler-error - (lambda (c) - (if (boundp 'sb!c::*compiler-error-bailout*) - ;; if we're in the compiler, delegate either to a higher - ;; authority or, if that's us, back down to the - ;; outermost compiler handler... - (progn - (signal c) - nil) - ;; ... if we're not in the compiler, better signal the - ;; error straight away. - (invoke-restart 'sb!c::signal-error))))) + (sb!c:with-compiler-error-resignalling (let ((exp (macroexpand original-exp lexenv))) (handler-bind ((eval-error - (lambda (condition) - (error 'interpreted-program-error - :condition (encapsulated-condition condition) - :form exp)))) + (lambda (condition) + (error 'interpreted-program-error + :condition (encapsulated-condition condition) + :form exp)))) (typecase exp (symbol (ecase (info :variable :kind exp) @@ -241,13 +229,13 @@ (destructuring-bind (definitions &rest body) (rest exp) (let ((lexenv - (let ((sb!c:*lexenv* lexenv)) - (sb!c::funcall-in-macrolet-lexenv - definitions - (lambda (&key funs) - (declare (ignore funs)) - sb!c:*lexenv*) - :eval)))) + (let ((sb!c:*lexenv* lexenv)) + (sb!c::funcall-in-macrolet-lexenv + definitions + (lambda (&key funs) + (declare (ignore funs)) + sb!c:*lexenv*) + :eval)))) (simple-eval-locally `(locally ,@body) lexenv)))) ((symbol-macrolet) (destructuring-bind (definitions &rest body) (rest exp) diff --git a/src/code/full-eval.lisp b/src/code/full-eval.lisp index 08af268..ca43691 100644 --- a/src/code/full-eval.lisp +++ b/src/code/full-eval.lisp @@ -1184,27 +1184,16 @@ (defun eval-in-native-environment (form lexenv) (handler-bind ((sb!impl::eval-error - (lambda (condition) - (error 'interpreted-program-error - :condition (sb!int:encapsulated-condition condition) - :form form))) - (sb!c:compiler-error - (lambda (c) - (if (boundp 'sb!c::*compiler-error-bailout*) - ;; if we're in the compiler, delegate either to a higher - ;; authority or, if that's us, back down to the - ;; outermost compiler handler... - (progn - (signal c) - nil) - ;; ... if we're not in the compiler, better signal the - ;; error straight away. - (invoke-restart 'sb!c::signal-error))))) - (handler-case - (let ((env (make-env-from-native-environment lexenv))) - (%eval form env)) - (compiler-environment-too-complex-error (condition) - (declare (ignore condition)) - (sb!int:style-warn 'sb!kernel:lexical-environment-too-complex - :form form :lexenv lexenv) - (sb!int:simple-eval-in-lexenv form lexenv))))) + (lambda (condition) + (error 'interpreted-program-error + :condition (sb!int:encapsulated-condition condition) + :form form)))) + (sb!c:with-compiler-error-resignalling + (handler-case + (let ((env (make-env-from-native-environment lexenv))) + (%eval form env)) + (compiler-environment-too-complex-error (condition) + (declare (ignore condition)) + (sb!int:style-warn 'sb!kernel:lexical-environment-too-complex + :form form :lexenv lexenv) + (sb!int:simple-eval-in-lexenv form lexenv)))))) diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index 79000f0..4a819e9 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -118,7 +118,9 @@ (return-from load (if faslp (load-as-fasl stream verbose print) - (load-as-source stream :verbose verbose :print print)))))) + (sb!c:with-compiler-error-resignalling + (load-as-source stream :verbose verbose + :print print))))))) ;; Case 1: stream. (when (streamp pathspec) (return-from load (load-stream pathspec (fasl-header-p pathspec)))) diff --git a/src/compiler/compiler-error.lisp b/src/compiler/compiler-error.lisp index ac0a366..41a1d3b 100644 --- a/src/compiler/compiler-error.lisp +++ b/src/compiler/compiler-error.lisp @@ -99,6 +99,20 @@ (funcall *compiler-error-bailout* condition) (bug "Control returned from *COMPILER-ERROR-BAILOUT*."))) +(defmacro with-compiler-error-resignalling (&body body) + `(handler-bind + ((compiler-error + (lambda (c) + (if (boundp '*compiler-error-bailout*) + ;; if we're in the compiler, delegate either to a higher + ;; authority or, if that's us, back down to the + ;; outermost compiler handler... + (signal c) + ;; ... if we're not in the compiler, better signal the + ;; error straight away. + (invoke-restart 'signal-error))))) + ,@body)) + (defun compiler-warn (datum &rest arguments) (apply #'warn datum arguments) (values)) -- 1.7.10.4