- (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)))))