(res (copy-structure sslot)))))))
(res)))
+;;; Early definitions of slot accessor creators.
+;;;
+;;; Slot accessors must be generic functions, but ANSI does not seem
+;;; to specify any of them, and we cannot support it before end of
+;;; warm init. So we use ordinary functions inside SBCL, and switch to
+;;; GFs only at the end of building.
+(declaim (notinline install-condition-slot-reader
+ install-condition-slot-writer))
+(defun install-condition-slot-reader (name condition slot-name)
+ (declare (ignore condition))
+ (setf (fdefinition name)
+ (lambda (condition)
+ (condition-reader-function condition slot-name))))
+(defun install-condition-slot-writer (name condition slot-name)
+ (declare (ignore condition))
+ (setf (fdefinition name)
+ (lambda (new-value condition)
+ (condition-writer-function condition new-value slot-name))))
+
(defun %define-condition (name slots documentation report default-initargs)
(let ((class (find-classoid name)))
(setf (condition-classoid-slots class) slots)
(dolist (slot slots)
;; Set up reader and writer functions.
- (let ((name (condition-slot-name slot)))
+ (let ((slot-name (condition-slot-name slot)))
(dolist (reader (condition-slot-readers slot))
- (setf (fdefinition reader)
- (lambda (condition)
- (condition-reader-function condition name))))
+ (install-condition-slot-reader reader name slot-name))
(dolist (writer (condition-slot-writers slot))
- (setf (fdefinition writer)
- (lambda (new-value condition)
- (condition-writer-function condition new-value name))))))
+ (install-condition-slot-writer writer name slot-name))))
;; Compute effective slots and set up the class and hairy slots
;; (subsets of the effective slots.)
(define-condition simple-condition ()
((format-control :reader simple-condition-format-control
- :initarg :format-control)
+ :initarg :format-control
+ :type format-control)
(format-arguments :reader simple-condition-format-arguments
:initarg :format-arguments
- :initform '()))
+ :initform '()
+ :type list))
(:report simple-condition-printer))
(define-condition simple-warning (simple-condition warning) ())
:initform '()))
(:report
(lambda (condition stream)
- (let ((error-stream (stream-error-stream condition)))
- (format stream "READER-ERROR ~@[at ~W ~]on ~S:~%~?"
- (file-position error-stream) error-stream
- (reader-error-format-control condition)
- (reader-error-format-arguments condition))))))
+ (let* ((error-stream (stream-error-stream condition))
+ (pos (file-position error-stream)))
+ (let (lineno colno)
+ (when (and pos
+ (< pos sb!xc:array-dimension-limit)
+ ;; KLUDGE: lseek() (which is what FILE-POSITION
+ ;; reduces to on file-streams) is undefined on
+ ;; "some devices", which in practice means that it
+ ;; can claim to succeed on /dev/stdin on Darwin
+ ;; and Solaris. This is obviously bad news,
+ ;; because the READ-SEQUENCE below will then
+ ;; block, not complete, and the report will never
+ ;; be printed. As a workaround, we exclude
+ ;; interactive streams from this attempt to report
+ ;; positions. -- CSR, 2003-08-21
+ (not (interactive-stream-p error-stream))
+ (file-position error-stream :start))
+ (let ((string
+ (make-string pos
+ :element-type (stream-element-type error-stream))))
+ (when (= pos (read-sequence string error-stream))
+ (setq lineno (1+ (count #\Newline string))
+ colno (- pos
+ (or (position #\Newline string :from-end t) -1)
+ 1))))
+ (file-position error-stream pos))
+ (format stream
+ "READER-ERROR ~@[at ~W ~]~
+ ~@[(line ~W~]~@[, column ~W) ~]~
+ on ~S:~%~?"
+ pos lineno colno error-stream
+ (reader-error-format-control condition)
+ (reader-error-format-arguments condition)))))))
\f
;;;; various other (not specified by ANSI) CONDITIONs
;;;;