Mercurial > hg > xemacs-beta

comparison lisp/prim/cmdloop.el @ 171:929b76928fce r20-3b12

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b12
author cvs
date Mon, 13 Aug 2007 09:47:52 +0200
parents 15872534500d
children 8eaf7971accc
comparison
equal deleted inserted replaced
170:98a42ee61975 171:929b76928fce
162 (add-hook 'pre-gc-hook 'truncate-command-history-for-gc) 162 (add-hook 'pre-gc-hook 'truncate-command-history-for-gc)
163 163
164 164
165 ;;;; Object-oriented programming at its finest 165 ;;;; Object-oriented programming at its finest
166 166
167 (defun display-error (error-object stream) ;(defgeneric report-condition ...) 167 ;; Now in src/print.c; used by Ferror_message_string and others
168 "Display `error-object' on `stream' in a user-friendly way." 168 ;(defun display-error (error-object stream) ;(defgeneric report-condition ...)
169 (funcall (or (let ((type (car-safe error-object))) 169 ; "Display `error-object' on `stream' in a user-friendly way."
170 (catch 'error 170 ; (funcall (or (let ((type (car-safe error-object)))
171 (and (consp error-object) 171 ; (catch 'error
172 (symbolp type) 172 ; (and (consp error-object)
173 ;;(stringp (get type 'error-message)) 173 ; (symbolp type)
174 (consp (get type 'error-conditions)) 174 ; ;;(stringp (get type 'error-message))
175 (let ((tail (cdr error-object))) 175 ; (consp (get type 'error-conditions))
176 (while (not (null tail)) 176 ; (let ((tail (cdr error-object)))
177 (if (consp tail) 177 ; (while (not (null tail))
178 (setq tail (cdr tail)) 178 ; (if (consp tail)
179 (throw 'error nil))) 179 ; (setq tail (cdr tail))
180 t) 180 ; (throw 'error nil)))
181 ;; (check-type condition condition) 181 ; t)
182 (get type 'error-conditions) 182 ; ;; (check-type condition condition)
183 ;; Search class hierarchy 183 ; (get type 'error-conditions)
184 (let ((tail (get type 'error-conditions))) 184 ; ;; Search class hierarchy
185 (while (not (null tail)) 185 ; (let ((tail (get type 'error-conditions)))
186 (cond ((not (and (consp tail) 186 ; (while (not (null tail))
187 (symbolp (car tail)))) 187 ; (cond ((not (and (consp tail)
188 (throw 'error nil)) 188 ; (symbolp (car tail))))
189 ((get (car tail) 'display-error) 189 ; (throw 'error nil))
190 (throw 'error (get (car tail) 190 ; ((get (car tail) 'display-error)
191 'display-error))) 191 ; (throw 'error (get (car tail)
192 (t 192 ; 'display-error)))
193 (setq tail (cdr tail))))) 193 ; (t
194 ;; Default method 194 ; (setq tail (cdr tail)))))
195 #'(lambda (error-object stream) 195 ; ;; Default method
196 (let ((type (car error-object)) 196 ; #'(lambda (error-object stream)
197 (tail (cdr error-object)) 197 ; (let ((type (car error-object))
198 (first t) 198 ; (tail (cdr error-object))
199 (print-message-label 'error)) 199 ; (first t)
200 (if (eq type 'error) 200 ; (print-message-label 'error))
201 (progn (princ (car tail) stream) 201 ; (if (eq type 'error)
202 (setq tail (cdr tail))) 202 ; (progn (princ (car tail) stream)
203 (princ (or (gettext (get type 'error-message)) type) 203 ; (setq tail (cdr tail)))
204 stream)) 204 ; (princ (or (gettext (get type 'error-message)) type)
205 (while tail 205 ; stream))
206 (princ (if first ": " ", ") stream) 206 ; (while tail
207 (prin1 (car tail) stream) 207 ; (princ (if first ": " ", ") stream)
208 (setq tail (cdr tail) 208 ; (prin1 (car tail) stream)
209 first nil)))))))) 209 ; (setq tail (cdr tail)
210 #'(lambda (error-object stream) 210 ; first nil))))))))
211 (princ (gettext "Peculiar error ") stream) 211 ; #'(lambda (error-object stream)
212 (prin1 error-object stream))) 212 ; (princ (gettext "Peculiar error ") stream)
213 error-object stream)) 213 ; (prin1 error-object stream)))
214 ; error-object stream))
214 215
215 (put 'file-error 'display-error 216 (put 'file-error 'display-error
216 #'(lambda (error-object stream) 217 #'(lambda (error-object stream)
217 (let ((tail (cdr error-object)) 218 (let ((tail (cdr error-object))
218 (first t)) 219 (first t))