From fea8ea02847ddc0864546a02480fb3e97d6fa318 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 4 Jul 2004 13:03:27 +0000 Subject: [PATCH] 0.8.12.18: Rearranging COMPILER-ERROR protocol * Enhance the protocol to attach the original condition and source to the PROGRAM-ERROR. * Make compile-time package-lock-violations from lexical constructs signal runtime PROGRAM-ERRORS, and not drop into debugger during compilation while still allowing users to handle them during compilation. * While at it, make file compiler errors from undumpable constants more informative. * Plus a few cosmetic changes to package locking guts. --- package-data-list.lisp-expr | 6 ++++ src/code/condition.lisp | 49 ++++++++++++++++++++++++------- src/code/cross-condition.lisp | 8 +++++ src/code/cross-misc.lisp | 13 ++------- src/code/early-package.lisp | 13 +++++++++ src/code/error.lisp | 55 +++++++++++++++++++++++++++++++++++ src/code/eval.lisp | 6 ++-- src/code/target-package.lisp | 58 ++++++++++++++++++------------------- src/cold/shared.lisp | 17 ++++++----- src/compiler/compiler-error.lisp | 56 ++++++++++++++++++----------------- src/compiler/ir1-translators.lisp | 16 +++++----- src/compiler/ir1tran.lisp | 41 ++++++++++++-------------- src/compiler/macros.lisp | 13 +-------- src/compiler/main.lisp | 14 ++++----- src/compiler/target-main.lisp | 3 +- tests/package-locks.impure.lisp | 10 +++++++ version.lisp-expr | 2 +- 17 files changed, 240 insertions(+), 140 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index f0ab524..76f327f 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -746,9 +746,14 @@ retained, possibly temporariliy, because it might be used internally." "*SETF-FDEFINITION-HOOK*" ;; error-reporting facilities + "MAKE-CONDITION-LOAD-FORM" + "COMPILED-PROGRAM-ERROR" + "ENCAPSULATED-CONDITION" + "MAKE-LOAD-FORM-ERROR" "SIMPLE-CONTROL-ERROR" "SIMPLE-FILE-ERROR" "SIMPLE-PARSE-ERROR" "SIMPLE-PROGRAM-ERROR" "SIMPLE-STREAM-ERROR" + "SIMPLE-STYLE-WARNING" "SPECIAL-FORM-FUNCTION" "STYLE-WARN" "SIMPLE-COMPILER-NOTE" @@ -1080,6 +1085,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "ALIEN-TYPE-TYPE-ALIEN-TYPE" "ALIEN-TYPE-TYPE-P" "ALLOCATE-VECTOR" "ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED" + "COMPILER-ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED" "DISABLED-PACKAGE-LOCKS" "WITH-SINGLE-PACKAGE-LOCKED-ERROR" "PACKAGE-ERROR-FORMAT-ARGUMENTS" diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 6b971ec..f462146 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -266,7 +266,6 @@ (return nil))) (setf (getf (condition-assigned-slots res) (condition-slot-name hslot)) (find-slot-default class hslot)))) - res)) ;;;; DEFINE-CONDITION @@ -558,6 +557,25 @@ (condition-actual-initargs condition) (condition-assigned-slots condition)))) +;;;; MAKE-LOAD-FORM equivalent for conditions. + +;;; We need this to be able to dump arbitrary encapsulated conditions +;;; with MAKE-LOAD-FORM for COMPILED-PROGRAM-ERRORs. Unfortunately +;;; ANSI specifies that MAKE-LOAD-FORM for conditions should signal an +;;; error, despite the fact that it also specifies that the +;;; file-compiler should use MAKE-LOAD-FORM for conditions. Bah. +;;; Badness results if this is called before PCL is in place. Unlike +;;; real make-load-form we return just a single form, so that it can +;;; easily be embedded in the surrounding condition. +(defun make-condition-load-form (condition &optional env) + (with-unique-names (instance) + (multiple-value-bind (create init) + (make-load-form-saving-slots condition :environment env) + (let ((fixed-init (subst instance condition init))) + `(let ((,instance ,create)) + ,fixed-init + ,instance))))) + ;;;; various CONDITIONs specified by ANSI (define-condition serious-condition (condition) ()) @@ -828,7 +846,7 @@ (print-reference r s) (unless (null (cdr rs)) (terpri s))))))) - + (define-condition duplicate-definition (reference-condition warning) ((name :initarg :name :reader duplicate-definition-name)) (:report (lambda (c s) @@ -901,15 +919,15 @@ :reader package-error-format-arguments)) (:report (lambda (condition stream) - (let ((control (package-error-format-control condition)) - (*print-pretty* nil)) + (let ((control (package-error-format-control condition))) (if control - (format stream "Package lock on ~S violated when ~?." - (package-error-package condition) - control - (package-error-format-arguments condition)) - (format stream "Package lock on ~S violated." - (package-error-package condition)))))) + (apply #'format stream + (format nil "~~@" + (package-name (package-error-package condition)) + control) + (package-error-format-arguments condition)) + (format stream "~@" + (package-name (package-error-package condition))))))) ;; no :default-initargs -- reference-stuff provided by the ;; signalling form in target-package.lisp #!+sb-doc @@ -923,7 +941,6 @@ when a package-lock is violated.")) "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is signalled when an operation on a package violates a package lock.")) - (define-condition symbol-package-locked-error (package-lock-violation) ((symbol :initarg :symbol :reader package-locked-error-symbol)) #!+sb-doc @@ -941,6 +958,16 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) ;;;; setup of CONDITION machinery, only because that makes it easier to ;;;; get cold init to work. +(define-condition encapsulated-condition (condition) + ((condition :initarg :condition :reader encapsulated-condition))) + +;;; This comes to play if we have multiple levels of encapsulated +;;; errors and we need to dump them with MAKE-CONDITION-LOAD-FORM. +;;; Should not see much/any use, but better to have it. +(def!method make-load-form ((condition encapsulated-condition) &optional env) + `(make-condition 'encapsulated-condition + :condition ,(make-condition-load-form (encapsulated-condition condition) env))) + (define-condition values-type-error (type-error) () (:report diff --git a/src/code/cross-condition.lisp b/src/code/cross-condition.lisp index 6867cb4..269241c 100644 --- a/src/code/cross-condition.lisp +++ b/src/code/cross-condition.lisp @@ -17,6 +17,8 @@ ;;; compiler, it will only be a style-warning. (define-condition format-too-many-args-warning (simple-warning) ()) +(define-condition encapsulated-condition () ()) + (define-condition bug (simple-error) () (:report @@ -33,3 +35,9 @@ an averrance that is violated (check your code!). If you are a user, ~ please submit a bug report to the developers' mailing list, details of ~ which can be found at .~:@>" ())))) + +;;; These are should never be instantiated before the real definitions +;;; come in. +(deftype package-lock-violation () nil) +(deftype package-locked-error () nil) +(deftype symbol-package-locked-error () nil) diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index 2b2a6c5..86d8082 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -162,10 +162,9 @@ (declare (ignore kind thing format)) `(progn ,@body)) -(defmacro with-deferred-package-lock-violations (&body body) - `(flet ((prepend-package-lock-violations (forms) forms) - (package-lock-violations () nil)) - ,@body)) +(defun compiler-assert-symbol-home-package-unlocked (symbol control) + (declare (ignore control)) + symbol) (defun assert-package-unlocked (package &optional control &rest args) (declare (ignore control args)) @@ -175,10 +174,4 @@ (declare (ignore format continuablep)) name) -(deftype package-lock-violation () nil) - -(deftype package-locked-error () nil) - -(deftype symbol-package-locked-error () nil) - (declaim (declaration enable-package-locks disable-package-locks)) diff --git a/src/code/early-package.lisp b/src/code/early-package.lisp index 1084cdf..c17ad6e 100644 --- a/src/code/early-package.lisp +++ b/src/code/early-package.lisp @@ -53,6 +53,19 @@ (when ,topmost (setf *ignored-package-locks* :invalid))))))) +(defun compiler-assert-symbol-home-package-unlocked (symbol control) + #!-sb-package-locks + (declare (ignore symbol control)) + #!+sb-package-locks + (flet ((resignal (condition) + ;; Signal the condition to give user defined handlers a chance, + ;; if they decline convert to compiler-error. + (signal condition) + (sb!c:compiler-error condition))) + (handler-bind ((package-lock-violation #'resignal)) + (with-single-package-locked-error () + (assert-symbol-home-package-unlocked symbol control))))) + (defmacro without-package-locks (&body body) #!+sb-doc "Ignores all runtime package lock violations during the execution of diff --git a/src/code/error.lisp b/src/code/error.lisp index f871e90..daa38c7 100644 --- a/src/code/error.lisp +++ b/src/code/error.lisp @@ -70,6 +70,61 @@ (case-failure-name condition) (case-failure-possibilities condition))))) +(define-condition compiled-program-error (encapsulated-condition program-error) + ((source :initarg :source :reader program-error-source)) + (:report (lambda (condition stream) + (let ((source (program-error-source condition))) + ;; Source may be either a list or string, and + ;; string needs to be printed without escapes. + (format stream "Execution of a form compiled with errors.~%~ + Form:~% ~ + ~:[~S~;~A~]~%~ + Compile-time-error:~% " + (stringp source) source) + (print-object (encapsulated-condition condition) stream))))) + +(def!method make-load-form ((condition compiled-program-error) &optional env) + (let ((source (program-error-source condition))) + ;; Safe since the encapsulated condition shouldn't contain + ;; references back up to the main condition. The source needs to + ;; be converted to a string, since it may contain arbitrary + ;; unexternalizable objects. + `(make-condition 'compiled-program-error + :condition ,(make-condition-load-form + (encapsulated-condition condition) env) + :source ,(if (stringp source) + source + (write-to-string + source :pretty t :circle t :escape t :readably nil))))) + +(define-condition make-load-form-error (encapsulated-condition error) + ((object :initarg :object :reader make-load-form-error-object)) + (:report (lambda (condition stream) + (let ((object (make-load-form-error-object condition))) + ;; If the MAKE-LOAD-FORM-ERROR itself has been + ;; externalized, the object will only have it's string + ;; representation. + (format stream "~@~% " + (stringp object) + object + 'make-load-form) + (print-object (encapsulated-condition condition) stream))))) + +(def!method make-load-form ((condition make-load-form-error) &optional env) + (let ((object (make-load-form-error-object condition))) + ;; Safe, because neither the object nor the encapsulated condition + ;; should contain any references to the error itself. However, the + ;; object will need to be converted to its string representation, + ;; since the chances are that it's not externalizable. + `(make-condition 'make-load-form-error + :condition ,(make-condition-load-form + (encapsulated-condition condition) env) + :object ,(if (stringp object) + object + (write-to-string + object :pretty t :circle t :escape t :readably nil))))) + (define-condition simple-control-error (simple-condition control-error) ()) (define-condition simple-file-error (simple-condition file-error) ()) (define-condition simple-program-error (simple-condition program-error) ()) diff --git a/src/code/eval.lisp b/src/code/eval.lisp index 9a3cdf1..7b3764e 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -94,9 +94,9 @@ (progn (signal c) nil) - ;; ... if we're not in the compiler, better signal a - ;; program error straight away. - (invoke-restart 'sb!c::signal-program-error))))) + ;; ... if we're not in the compiler, better signal the + ;; error straight away. + (invoke-restart 'sb!c::signal-error))))) (let ((exp (macroexpand original-exp lexenv))) (typecase exp (symbol diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 074e43d..2019023 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -152,35 +152,35 @@ error if any of PACKAGES is not a valid package designator." (defun package-lock-violation (package &key (symbol nil symbol-p) format-control format-arguments) - (let ((restart :continue) - (cl-violation-p (eq package (find-package :common-lisp)))) - (flet ((error-arguments () - (append (list (if symbol-p - 'symbol-package-locked-error - 'package-locked-error) - :package package - :format-control format-control - :format-arguments format-arguments) - (when symbol-p (list :symbol symbol)) - (list :references - (append '((:sbcl :node "Package Locks")) - (when cl-violation-p - '((:ansi-cl :section (11 1 2 1 2))))))))) - (restart-case - (apply #'cerror "Ignore the package lock." (error-arguments)) - (:ignore-all () - :report "Ignore all package locks in the context of this operation." - (setf restart :ignore-all)) - (:unlock-package () - :report "Unlock the package." - (setf restart :unlock-package))) - (ecase restart - (:continue - (pushnew package *ignored-package-locks*)) - (:ignore-all - (setf *ignored-package-locks* t)) - (:unlock-package - (unlock-package package)))))) + (let* ((restart :continue) + (cl-violation-p (eq package *cl-package*)) + (error-arguments + (append (list (if symbol-p + 'symbol-package-locked-error + 'package-locked-error) + :package package + :format-control format-control + :format-arguments format-arguments) + (when symbol-p (list :symbol symbol)) + (list :references + (append '((:sbcl :node "Package Locks")) + (when cl-violation-p + '((:ansi-cl :section (11 1 2 1 2))))))))) + (restart-case + (apply #'cerror "Ignore the package lock." error-arguments) + (:ignore-all () + :report "Ignore all package locks in the context of this operation." + (setf restart :ignore-all)) + (:unlock-package () + :report "Unlock the package." + (setf restart :unlock-package))) + (ecase restart + (:continue + (pushnew package *ignored-package-locks*)) + (:ignore-all + (setf *ignored-package-locks* t)) + (:unlock-package + (unlock-package package))))) (defun package-lock-violation-p (package &optional (symbol nil symbolp)) ;; KLUDGE: (package-lock package) needs to be before diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index f523aa8..5f86752 100644 --- a/src/cold/shared.lisp +++ b/src/cold/shared.lisp @@ -23,13 +23,16 @@ (in-package "SB-COLD") -;;; FIXME: This is embarassing -- SBCL violates SBCL style-package locks -;;; on the host lisp. Rather then find and fix all cases right now, -;;; let's just remain self-hosting. The problems at least involve -;;; a few defvars and local macros with names in the CL package. -#+(and sbcl sb-package-locks) -(dolist (p (list-all-packages)) - (sb-ext:unlock-package p)) +;;; FIXME: This is embarassing -- SBCL violates SBCL style-package +;;; locks on the host lisp. Rather then find and fix all the cases +;;; right now, let's just remain self-hosting. The problems at least +;;; involve a few defvars and local macros with names in the CL +;;; package. +#+sbcl +(let ((plp (find-symbol PACKAGE-LOCKED-P :sb-ext))) + (when (and plp (fboundp plp)) + (dolist (p (list-all-packages)) + (sb-ext::unlock-package p)))) ;;; prefixes for filename stems when cross-compiling. These are quite arbitrary ;;; (although of course they shouldn't collide with anything we don't want to diff --git a/src/compiler/compiler-error.lisp b/src/compiler/compiler-error.lisp index 80a7b85..bd19505 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,42 +80,44 @@ ;;; 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 (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))))) + (declaim (ftype (function (string &rest t) (values)) - compiler-warn compiler-style-warn)) -(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)))) + compiler-warn compiler-style-warn)) (defun compiler-warn (format-string &rest format-args) (apply #'warn format-string format-args) (values)) + (defun compiler-style-warn (format-string &rest format-args) (apply #'style-warn format-string format-args) (values)) +(defun make-compiler-error-form (condition source) + ;; The condition must be literal so the this form kicks off the + ;; MAKE-LOAD-FORM in the file-compiler for COMPILED-PROGRAM-ERROR, + ;; not the encapsulated condition. + `(error ,(make-condition 'compiled-program-error + :condition condition + :source source))) + ;;; the condition of COMPILE-FILE being unable to READ from the ;;; source file ;;; diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index fc91bee..d954575 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -281,8 +281,8 @@ (unless (symbolp name) (fail "The local macro name ~S is not a symbol." name)) (when (fboundp name) - (with-single-package-locked-error - (:symbol name "binding ~A as a local macro"))) + (compiler-assert-symbol-home-package-unlocked + name "binding ~A as a local macro")) (unless (listp arglist) (fail "The local macro argument list ~S is not a list." arglist)) @@ -332,8 +332,8 @@ (unless (symbolp name) (fail "The local symbol macro name ~S is not a symbol." name)) (when (or (boundp name) (eq (info :variable :kind name) :macro)) - (with-single-package-locked-error - (:symbol name "binding ~A as a local symbol-macro"))) + (compiler-assert-symbol-home-package-unlocked + name "binding ~A as a local symbol-macro")) (let ((kind (info :variable :kind name))) (when (member kind '(:special :constant)) (fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" @@ -534,8 +534,8 @@ (vals (second spec))))))) (dolist (name (names)) (when (eq (info :variable :kind name) :macro) - (with-single-package-locked-error - (:symbol name "lexically binding symbol-macro ~A")))) + (compiler-assert-symbol-home-package-unlocked + name "lexically binding symbol-macro ~A"))) (values (vars) (vals)))) (def-ir1-translator let ((bindings &body body) start next result) @@ -620,8 +620,8 @@ (let ((name (first def))) (check-fun-name name) (when (fboundp name) - (with-single-package-locked-error - (:symbol name "binding ~A as a local function"))) + (compiler-assert-symbol-home-package-unlocked + name "binding ~A as a local function")) (names name) (multiple-value-bind (forms decls) (parse-body (cddr def)) (defs `(lambda ,(second def) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 22654d1..6764c3a 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -449,23 +449,20 @@ (declaim (ftype (sfunction (ctran ctran (or lvar null) t) (values)) ir1-convert)) (macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws - ;; out of the body and converts a proxy form instead. - (ir1-error-bailout ((start next result - form - &optional - (proxy ``(error 'simple-program-error - :format-control "execution of a form compiled with errors:~% ~S" - :format-arguments (list ',,form)))) - &body body) - (with-unique-names (skip) - `(block ,skip - (catch 'ir1-error-abort + ;; out of the body and converts a condition signalling form + ;; instead. The source form is converted to a string since it + ;; may contain arbitrary non-externalizable objects. + (ir1-error-bailout ((start next result form) &body body) + (with-unique-names (skip condition) + `(block ,skip + (let ((,condition (catch 'ir1-error-abort (let ((*compiler-error-bailout* - (lambda () - (throw 'ir1-error-abort nil)))) + (lambda (&optional e) + (throw 'ir1-error-abort e)))) ,@body - (return-from ,skip nil))) - (ir1-convert ,start ,next ,result ,proxy))))) + (return-from ,skip nil))))) + (ir1-convert ,start ,next ,result + (make-compiler-error-form ,condition ,form))))))) ;; Translate FORM into IR1. The code is inserted as the NEXT of the ;; CTRAN START. RESULT is the LVAR which receives the value of the @@ -533,8 +530,7 @@ (declare (type ctran start next) (type (or lvar null) result) (inline find-constant)) - (ir1-error-bailout - (start next result value '(error "attempt to reference undumpable constant")) + (ir1-error-bailout (start next result value) (when (producing-fasl-file) (maybe-emit-make-load-forms value)) (let* ((leaf (find-constant value)) @@ -923,8 +919,8 @@ (new-vars nil cons)) (dolist (var-name (rest decl)) (when (boundp var-name) - (with-single-package-locked-error - (:symbol var-name "declaring the type of ~A"))) + (compiler-assert-symbol-home-package-unlocked var-name + "declaring the type of ~A")) (let* ((bound-var (find-in-bindings vars var-name)) (var (or bound-var (lexenv-find var-name vars) @@ -986,8 +982,8 @@ (collect ((res nil cons)) (dolist (name names) (when (fboundp name) - (with-single-package-locked-error - (:symbol name "declaring the ftype of ~A"))) + (compiler-assert-symbol-home-package-unlocked name + "declaring the ftype of ~A")) (let ((found (find name fvars :key #'leaf-source-name :test #'equal))) @@ -1012,8 +1008,7 @@ (declare (list spec vars) (type lexenv res)) (collect ((new-venv nil cons)) (dolist (name (cdr spec)) - (with-single-package-locked-error - (:symbol name "declaring ~A special")) + (compiler-assert-symbol-home-package-unlocked name "declaring ~A special") (let ((var (find-in-bindings vars name))) (etypecase var (cons diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 835f5a3..4378621 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -26,17 +26,6 @@ ;;;; source-hacking defining forms -;;; to be passed to PARSE-DEFMACRO when we want compiler errors -;;; instead of real errors -#!-sb-fluid (declaim (inline convert-condition-into-compiler-error)) -(defun convert-condition-into-compiler-error (datum &rest stuff) - (if (stringp datum) - (apply #'compiler-error datum stuff) - (compiler-error "~A" - (if (symbolp datum) - (apply #'make-condition datum stuff) - datum)))) - ;;; Parse a DEFMACRO-style lambda-list, setting things up so that a ;;; compiler error happens if the syntax is invalid. ;;; @@ -53,7 +42,7 @@ (multiple-value-bind (body decls doc) (parse-defmacro lambda-list n-form body name "special form" :environment n-env - :error-fun 'convert-condition-into-compiler-error + :error-fun 'compiler-error :wrap-block nil) `(progn (declaim (ftype (function (ctran ctran (or lvar null) t) (values)) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index ff1bcce..83c67e3 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1061,11 +1061,9 @@ (catch 'process-toplevel-form-error-abort (let* ((path (or (gethash form *source-paths*) (cons form path))) (*compiler-error-bailout* - (lambda () + (lambda (&optional condition) (convert-and-maybe-compile - `(error 'simple-program-error - :format-control "execution of a form compiled with errors:~% ~S" - :format-arguments (list ',form)) + (make-compiler-error-form condition form) path) (throw 'process-toplevel-form-error-abort nil)))) @@ -1695,11 +1693,11 @@ (throw 'pending-init circular-ref))) (multiple-value-bind (creation-form init-form) (handler-case - (sb!xc:make-load-form constant (make-null-lexenv)) + (sb!xc:make-load-form constant (make-null-lexenv)) (error (condition) - (compiler-error "(while making load form for ~S)~%~A" - constant - condition))) + (compiler-error 'make-load-form-error + :condition condition + :object constant))) (case creation-form (:sb-just-dump-it-normally (fasl-validate-structure constant *compile-object*) diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index 8a1cffb..3217c38 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -49,7 +49,8 @@ (*toplevel-lambdas* ()) (*block-compile* nil) (*compiler-error-bailout* - (lambda () + (lambda (&optional error) + (declare (ignore error)) (compiler-mumble "~2&fatal error, aborting compilation~%") (return-from actually-compile (values nil t nil)))) diff --git a/tests/package-locks.impure.lisp b/tests/package-locks.impure.lisp index 9a1b121..9acdd24 100644 --- a/tests/package-locks.impure.lisp +++ b/tests/package-locks.impure.lisp @@ -435,6 +435,16 @@ ,form))) package-lock-violation)))) +;;;; Program-errors from lexical violations +(reset-test) +(set-test-locks t) +(dolist (pair *illegal-compile-time-forms-alist*) + (destructuring-bind (sym . form) pair + (declare (ignore sym)) + (let ((fun (compile nil `(lambda () + ,form)))) + (assert (raises-error? (funcall fun) program-error))))) + ;;;; See that trace on functions in locked packages doesn't break ;;;; anything. (assert (trace test:function :break t)) diff --git a/version.lisp-expr b/version.lisp-expr index 92f5a39..120f163 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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.12.17" +"0.8.12.18" -- 1.7.10.4