1 | ;;;-*-Mode: LISP; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2009 Clozure Associates |
---|
4 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
5 | ;;; This file is part of Clozure CL. |
---|
6 | ;;; |
---|
7 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
---|
8 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
---|
9 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
10 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
11 | ;;; conflict, the preamble takes precedence. |
---|
12 | ;;; |
---|
13 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
---|
14 | ;;; |
---|
15 | ;;; The LLGPL is also available online at |
---|
16 | ;;; http://opensource.franz.com/preamble.html |
---|
17 | |
---|
18 | (in-package "CCL") |
---|
19 | |
---|
20 | (defun %kernel-restart (error-type &rest args) |
---|
21 | (%kernel-restart-internal error-type args (%get-frame-ptr))) |
---|
22 | |
---|
23 | (defun %kernel-restart-internal (error-type args frame-ptr) |
---|
24 | ;(declare (dynamic-extent args)) |
---|
25 | (dolist (f *kernel-restarts* (%err-disp-internal error-type args frame-ptr)) |
---|
26 | (when (eq (car f) error-type) |
---|
27 | (return (apply (cdr f) frame-ptr args))))) |
---|
28 | |
---|
29 | ;;; this is the def of %err-disp. |
---|
30 | ;;; Yup. That was my first guess. |
---|
31 | (defun %err-disp (err-num &rest errargs) |
---|
32 | (%err-disp-internal err-num errargs (%get-frame-ptr))) |
---|
33 | |
---|
34 | (defun %errno-disp (errno &rest errargs) |
---|
35 | (%errno-disp-internal errno errargs (%get-frame-ptr))) |
---|
36 | |
---|
37 | #+windows-target |
---|
38 | (defun %windows-error-disp (errno &rest errargs) |
---|
39 | (%err-disp-common errno 0 (%windows-error-string errno) errargs (%get-frame-ptr))) |
---|
40 | |
---|
41 | (defun %errno-disp-internal (errno errargs frame-ptr) |
---|
42 | (declare (fixnum errno)) |
---|
43 | (let* ((err-type (max (ash errno -16) 0)) |
---|
44 | (errno (%word-to-int errno)) |
---|
45 | (error-string (%strerror errno)) |
---|
46 | (format-string (if errargs |
---|
47 | (format nil "~a : ~a" error-string "~s") |
---|
48 | error-string))) |
---|
49 | (%err-disp-common nil err-type format-string errargs frame-ptr))) |
---|
50 | |
---|
51 | |
---|
52 | (defun %err-disp-internal (err-num errargs frame-ptr) |
---|
53 | (declare (fixnum err-num)) |
---|
54 | ;;; The compiler (finally !) won't tail-apply error. But we kind of |
---|
55 | ;;; expect it to ... |
---|
56 | (let* ((err-typ (max (ash err-num -16) 0)) |
---|
57 | (err-num (%word-to-int err-num)) |
---|
58 | (format-string (%rsc-string err-num))) |
---|
59 | (%err-disp-common err-num err-typ format-string errargs frame-ptr))) |
---|
60 | |
---|
61 | (defparameter *foreign-error-condition-recognizers* ()) |
---|
62 | |
---|
63 | |
---|
64 | (defun %err-disp-common (err-num err-typ format-string errargs frame-ptr) |
---|
65 | (let* ((condition-name (or (uvref *simple-error-types* err-typ) |
---|
66 | (%cdr (assq err-num *kernel-simple-error-classes*))))) |
---|
67 | ;;(dbg format-string) |
---|
68 | (if condition-name |
---|
69 | (funcall '%error |
---|
70 | (case condition-name |
---|
71 | (type-error |
---|
72 | (if (cdr errargs) |
---|
73 | (make-condition condition-name |
---|
74 | :format-control format-string |
---|
75 | :datum (car errargs) |
---|
76 | :expected-type (%type-error-type (cadr errargs))) |
---|
77 | (make-condition condition-name |
---|
78 | :format-control format-string |
---|
79 | :datum (car errargs)))) |
---|
80 | (improper-list (make-condition condition-name |
---|
81 | :datum (car errargs))) |
---|
82 | (simple-file-error (make-condition condition-name |
---|
83 | :pathname (car errargs) |
---|
84 | :error-type format-string |
---|
85 | :format-arguments (cdr errargs))) |
---|
86 | (undefined-function (make-condition condition-name |
---|
87 | :name (car errargs))) |
---|
88 | (call-special-operator-or-macro |
---|
89 | (make-condition condition-name |
---|
90 | :name (car errargs) |
---|
91 | :function-arguments (cadr errargs))) |
---|
92 | (sequence-index-type-error |
---|
93 | (make-sequence-index-type-error (car errargs) (cadr errargs))) |
---|
94 | (cant-construct-arglist |
---|
95 | (make-condition condition-name |
---|
96 | :datum (car errargs) |
---|
97 | :format-control format-string)) |
---|
98 | (array-element-type-error |
---|
99 | (let* ((array (cadr errargs))) |
---|
100 | (make-condition condition-name |
---|
101 | :format-control format-string |
---|
102 | :datum (car errargs) |
---|
103 | :expected-type (array-element-type array) |
---|
104 | :array array))) |
---|
105 | (division-by-zero (make-condition condition-name)) |
---|
106 | (t (make-condition condition-name |
---|
107 | :format-control format-string |
---|
108 | :format-arguments errargs))) |
---|
109 | nil |
---|
110 | frame-ptr) |
---|
111 | (let* ((cond nil)) |
---|
112 | (if (and (eql err-num $XFOREIGNEXCEPTION) |
---|
113 | (dolist (recog *foreign-error-condition-recognizers*) |
---|
114 | (let* ((c (funcall recog (car errargs)))) |
---|
115 | (when c (return (setq cond c)))))) |
---|
116 | (funcall '%error cond nil frame-ptr) |
---|
117 | (funcall '%error format-string errargs frame-ptr)))))) |
---|
118 | |
---|
119 | (defun error (condition &rest args) |
---|
120 | "Invoke the signal facility on a condition formed from DATUM and ARGUMENTS. |
---|
121 | If the condition is not handled, the debugger is invoked." |
---|
122 | #| |
---|
123 | #+ppc-target |
---|
124 | (with-pstrs ((pstr (if (stringp condition) condition "Error"))) |
---|
125 | (#_DebugStr pstr)) |
---|
126 | |# |
---|
127 | (%error condition args (%get-frame-ptr))) |
---|
128 | |
---|
129 | (defun cerror (cont-string condition &rest args) |
---|
130 | (let* ((fp (%get-frame-ptr))) |
---|
131 | (restart-case (%error condition (if (condition-p condition) nil args) fp) |
---|
132 | (continue () |
---|
133 | :report (lambda (stream) |
---|
134 | (apply #'format stream cont-string args)) |
---|
135 | nil)))) |
---|
136 | |
---|
137 | (defun %error (condition args error-pointer) |
---|
138 | (setq *error-reentry-count* 0) |
---|
139 | (setq condition (condition-arg condition args 'simple-error)) |
---|
140 | (signal condition) |
---|
141 | (unless *interactive-streams-initialized* |
---|
142 | (bug (format nil "Error during early application initialization:~% |
---|
143 | ~a" condition)) |
---|
144 | (#_exit #-windows-target #$EX_SOFTWARE #+windows-target #$EXIT_FAILURE)) |
---|
145 | (application-error *application* condition error-pointer) |
---|
146 | (application-error |
---|
147 | *application* |
---|
148 | (condition-arg "~s returned. It shouldn't.~%If it returns again, I'll throw to toplevel." |
---|
149 | '(application-error) 'simple-error) |
---|
150 | error-pointer) |
---|
151 | (toplevel)) |
---|
152 | |
---|
153 | (defun make-sequence-index-type-error (idx sequence) |
---|
154 | (let* ((upper (length sequence))) |
---|
155 | (make-condition 'sequence-index-type-error |
---|
156 | :datum idx |
---|
157 | :sequence sequence |
---|
158 | :expected-type `(integer 0 (,upper))))) |
---|