"*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"
"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"
(return nil)))
(setf (getf (condition-assigned-slots res) (condition-slot-name hslot))
(find-slot-default class hslot))))
-
res))
\f
;;;; DEFINE-CONDITION
(condition-actual-initargs condition)
(condition-assigned-slots condition))))
\f
+;;;; 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)))))
+\f
;;;; various CONDITIONs specified by ANSI
(define-condition serious-condition (condition) ())
(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)
: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 "~~@<Lock on package ~A violated when ~A.~~:@>"
+ (package-name (package-error-package condition))
+ control)
+ (package-error-format-arguments condition))
+ (format stream "~@<Lock on package ~A violated.~:@>"
+ (package-name (package-error-package condition)))))))
;; no :default-initargs -- reference-stuff provided by the
;; signalling form in target-package.lisp
#!+sb-doc
"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
;;;; 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
;;; 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
please submit a bug report to the developers' mailing list, details of ~
which can be found at <http://sbcl.sourceforge.net/>.~:@>"
()))))
+
+;;; 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)
(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))
(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))
(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
(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 "~@<Unable to externalize ~:[~S~;~A~], ~
+ error from ~S:~:@>~% "
+ (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) ())
(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
(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
(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
;;;; 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
;;; 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
;;; 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
;;;
(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))
(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"
(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)
(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)
(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
(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))
(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)
(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)))
(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
\f
;;;; 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.
;;;
(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))
(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))))
(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*)
(*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))))
,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))
;;; 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"
projects / sbcl.git / commitdiff