/* [<][>][^][v][top][bottom][index][help] */
DEFINITIONS
This source file includes following definitions.
- message_print
- message_allocate
- message_get
- message_set
- syserror_allocate
- readerror_allocate
- porterror_allocate
- syserror_number_get
- syserror_number_set
- readerror_port_get
- readerror_port_set
- readerror_line_get
- readerror_line_set
- readerror_dummy_get
- readerror_dummy_set
- porterror_port_get
- porterror_port_set
- compound_allocate
- Scm_MakeCompoundCondition
- conditions_get
- conditions_set
- Scm_MakeThreadException
- Scm_MakeError
- Scm_MakeSystemError
- Scm_MakeReadError
- Scm_ConditionHasType
- Scm_ConditionMessage
- Scm_ConditionTypeName
- Scm_Error
- get_syserrmsg
- get_errno
- Scm_SysError
- Scm_PortError
- Scm_Warn
- Scm_FWarn
- Scm_Raise
- Scm_RaiseCondition
- Scm_ShowStackTrace
- Scm_PrintDefaultErrorHeading
- report_error_inner
- Scm_ReportError
- Scm__InitExceptions
1 /*
2 * error.c - error handling
3 *
4 * Copyright (c) 2000-2005 Shiro Kawai, All rights reserved.
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * 1. Redistributions of source code must retain the above copyright
11 * notice, this list of conditions and the following disclaimer.
12 *
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 *
17 * 3. Neither the name of the authors nor the names of its contributors
18 * may be used to endorse or promote products derived from this
19 * software without specific prior written permission.
20 *
21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 *
33 * $Id: error.c,v 1.66 2005/08/08 06:16:15 shirok Exp $
34 */
35
36 #include <errno.h>
37 #include <string.h>
38 #include <ctype.h>
39 #define LIBGAUCHE_BODY
40 #include "gauche.h"
41 #include "gauche/class.h"
42 #include "gauche/exception.h"
43 #include "gauche/vm.h"
44 #include "gauche/builtin-syms.h"
45
46 static void message_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx);
47 static ScmObj message_allocate(ScmClass *klass, ScmObj initargs);
48 static ScmObj syserror_allocate(ScmClass *klass, ScmObj initargs);
49 static ScmObj readerror_allocate(ScmClass *klass, ScmObj initargs);
50 static ScmObj porterror_allocate(ScmClass *klass, ScmObj initargs);
51 static ScmObj compound_allocate(ScmClass *klass, ScmObj initargs);
52
53 /* Setting up CPL is a bit tricky, since we have multiple
54 inheritance case. */
55
56 #define CONDITION_CPL \
57 SCM_CLASS_STATIC_PTR(Scm_ConditionClass), \
58 SCM_CLASS_STATIC_PTR(Scm_TopClass)
59
60 #define MESSAGE_SERIOUS_CPL \
61 SCM_CLASS_STATIC_PTR(Scm_MessageConditionClass), \
62 SCM_CLASS_STATIC_PTR(Scm_SeriousConditionClass), \
63 CONDITION_CPL
64
65 #define ERROR_CPL \
66 SCM_CLASS_STATIC_PTR(Scm_ErrorClass), \
67 MESSAGE_SERIOUS_CPL
68
69 /*-----------------------------------------------------------
70 * Base conditions
71 */
72 static ScmClass *condition_cpl[] = {
73 CONDITION_CPL,
74 NULL
75 };
76
77 SCM_DEFINE_BASE_CLASS(Scm_ConditionClass, ScmInstance,
78 NULL, NULL, NULL,
79 Scm_ObjectAllocate, SCM_CLASS_DEFAULT_CPL);
80 SCM_DEFINE_BASE_CLASS(Scm_MessageConditionClass, ScmMessageCondition,
81 message_print, NULL, NULL,
82 message_allocate, condition_cpl);
83 SCM_DEFINE_BASE_CLASS(Scm_SeriousConditionClass, ScmSeriousCondition,
84 NULL, NULL, NULL,
85 Scm_ObjectAllocate, condition_cpl);
86
87 static void message_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
88 {
89 ScmClass *k = Scm_ClassOf(obj);
90 Scm_Printf(port, "#<%A \"%30.1A\">",
91 Scm__InternalClassName(k),
92 SCM_ERROR_MESSAGE(obj));
93 }
94
95 static ScmObj message_allocate(ScmClass *klass, ScmObj initargs)
96 {
97 ScmError *e = SCM_ALLOCATE(ScmError, klass);
98 SCM_SET_CLASS(e, klass);
99 e->message = SCM_FALSE; /* would be set by initialize */
100 return SCM_OBJ(e);
101 }
102
103 static ScmObj message_get(ScmMessageCondition *obj)
104 {
105 return SCM_MESSAGE_CONDITION(obj)->message;
106 }
107
108 static void message_set(ScmMessageCondition *obj, ScmObj val)
109 {
110 obj->message = val;
111 }
112
113 static ScmClassStaticSlotSpec message_slots[] = {
114 SCM_CLASS_SLOT_SPEC("message", message_get, message_set),
115 { NULL }
116 };
117
118 /*------------------------------------------------------------
119 * Errors
120 */
121
122 static ScmClass *error_cpl[] = {
123 ERROR_CPL,
124 NULL
125 };
126
127 static ScmClass *porterror_cpl[] = {
128 SCM_CLASS_STATIC_PTR(Scm_PortErrorClass),
129 SCM_CLASS_STATIC_PTR(Scm_IOErrorClass),
130 ERROR_CPL,
131 NULL
132 };
133
134
135 SCM_DEFINE_BASE_CLASS(Scm_ErrorClass, ScmError,
136 message_print, NULL, NULL,
137 message_allocate, error_cpl+1);
138 SCM_DEFINE_BASE_CLASS(Scm_SystemErrorClass, ScmSystemError,
139 message_print, NULL, NULL,
140 syserror_allocate, error_cpl);
141 SCM_DEFINE_BASE_CLASS(Scm_ReadErrorClass, ScmReadError,
142 message_print, NULL, NULL,
143 readerror_allocate, error_cpl);
144 SCM_DEFINE_BASE_CLASS(Scm_IOErrorClass, ScmIOError,
145 message_print, NULL, NULL,
146 message_allocate, error_cpl);
147 SCM_DEFINE_BASE_CLASS(Scm_PortErrorClass, ScmPortError,
148 message_print, NULL, NULL,
149 porterror_allocate, porterror_cpl+1);
150 SCM_DEFINE_BASE_CLASS(Scm_IOReadErrorClass, ScmIOReadError,
151 message_print, NULL, NULL,
152 porterror_allocate, porterror_cpl);
153 SCM_DEFINE_BASE_CLASS(Scm_IOWriteErrorClass, ScmIOWriteError,
154 message_print, NULL, NULL,
155 porterror_allocate, porterror_cpl);
156 SCM_DEFINE_BASE_CLASS(Scm_IOClosedErrorClass, ScmIOClosedError,
157 message_print, NULL, NULL,
158 porterror_allocate, porterror_cpl);
159 SCM_DEFINE_BASE_CLASS(Scm_IOUnitErrorClass, ScmIOUnitError,
160 message_print, NULL, NULL,
161 porterror_allocate, porterror_cpl);
162
163 static ScmObj syserror_allocate(ScmClass *klass, ScmObj initargs)
164 {
165 ScmSystemError *e = SCM_ALLOCATE(ScmSystemError, klass);
166 SCM_SET_CLASS(e, klass);
167 e->common.message = SCM_FALSE; /* set by initialize */
168 e->error_number = 0; /* set by initialize */
169 return SCM_OBJ(e);
170 }
171
172 static ScmObj readerror_allocate(ScmClass *klass, ScmObj initargs)
173 {
174 ScmReadError *e = SCM_ALLOCATE(ScmReadError, klass);
175 SCM_SET_CLASS(e, klass);
176 e->common.message = SCM_FALSE; /* set by initialize */
177 e->port = NULL; /* set by initialize */
178 e->line = -1; /* set by initialize */
179 return SCM_OBJ(e);
180 }
181
182 static ScmObj porterror_allocate(ScmClass *klass, ScmObj initargs)
183 {
184 ScmPortError *e = SCM_ALLOCATE(ScmPortError, klass);
185 SCM_SET_CLASS(e, klass);
186 e->common.message = SCM_FALSE; /* set by initialize */
187 e->port = NULL; /* set by initialize */
188 return SCM_OBJ(e);
189 }
190
191 static ScmObj syserror_number_get(ScmSystemError *obj)
192 {
193 return SCM_MAKE_INT(obj->error_number);
194 }
195
196 static void syserror_number_set(ScmSystemError *obj, ScmObj val)
197 {
198 if (!SCM_INTP(val)) {
199 Scm_Error("small integer required, but got %S", val);
200 }
201 obj->error_number = SCM_INT_VALUE(val);
202 }
203
204 static ScmObj readerror_port_get(ScmReadError *obj)
205 {
206 if (obj->port) return SCM_OBJ(obj->port);
207 else return SCM_FALSE;
208 }
209
210 static void readerror_port_set(ScmReadError *obj, ScmObj val)
211 {
212 if (SCM_IPORTP(val)) {
213 obj->port = SCM_PORT(val);
214 }
215 else if (SCM_FALSEP(val)) {
216 obj->port = NULL;
217 }
218 else {
219 Scm_Error("input port or #f required, but got %S", val);
220 }
221 }
222
223 static ScmObj readerror_line_get(ScmReadError *obj)
224 {
225 return SCM_MAKE_INT(obj->line);
226 }
227
228 static void readerror_line_set(ScmReadError *obj, ScmObj val)
229 {
230 if (!SCM_INTP(val)){
231 Scm_Error("small integer required, but got %S", val);
232 }
233 obj->line = SCM_INT_VALUE(val);
234 }
235
236 static ScmObj readerror_dummy_get(ScmReadError *obj)
237 {
238 return SCM_FALSE;
239 }
240
241 static void readerror_dummy_set(ScmReadError *obj, ScmObj val)
242 {
243 /* nothing */
244 }
245
246
247 static ScmObj porterror_port_get(ScmPortError *obj)
248 {
249 return obj->port? SCM_OBJ(obj->port) : SCM_FALSE;
250 }
251
252 static void porterror_port_set(ScmPortError *obj, ScmObj val)
253 {
254 if (!SCM_PORTP(val) && !SCM_FALSEP(val)) {
255 Scm_Error("port or #f required, but got %S", val);
256 }
257 obj->port = SCM_FALSEP(val)? NULL : SCM_PORT(val);
258 }
259
260 static ScmClassStaticSlotSpec syserror_slots[] = {
261 SCM_CLASS_SLOT_SPEC("errno", syserror_number_get, syserror_number_set),
262 { NULL }
263 };
264
265 static ScmClassStaticSlotSpec readerror_slots[] = {
266 SCM_CLASS_SLOT_SPEC("port", readerror_port_get, readerror_port_set),
267 SCM_CLASS_SLOT_SPEC("line", readerror_line_get, readerror_line_set),
268 SCM_CLASS_SLOT_SPEC("column", readerror_dummy_get, readerror_dummy_set),
269 SCM_CLASS_SLOT_SPEC("position", readerror_dummy_get, readerror_dummy_set),
270 SCM_CLASS_SLOT_SPEC("span", readerror_dummy_get, readerror_dummy_set),
271 { NULL }
272 };
273
274 static ScmClassStaticSlotSpec porterror_slots[] = {
275 SCM_CLASS_SLOT_SPEC("port", porterror_port_get, porterror_port_set),
276 { NULL }
277 };
278
279 /*------------------------------------------------------------
280 * Compound conditions
281 */
282
283 static ScmClass *compound_cpl[] = {
284 SCM_CLASS_STATIC_PTR(Scm_CompoundConditionClass),
285 SCM_CLASS_STATIC_PTR(Scm_SeriousConditionClass),
286 CONDITION_CPL,
287 NULL
288 };
289
290 SCM_DEFINE_BASE_CLASS(Scm_CompoundConditionClass, ScmCompoundCondition,
291 NULL, NULL, NULL,
292 compound_allocate, compound_cpl+2);
293 SCM_DEFINE_BASE_CLASS(Scm_SeriousCompoundConditionClass, ScmCompoundCondition,
294 NULL, NULL, NULL,
295 compound_allocate, compound_cpl);
296
297 static ScmObj compound_allocate(ScmClass *klass, ScmObj initargs)
298 {
299 ScmCompoundCondition *e = SCM_ALLOCATE(ScmCompoundCondition, klass);
300 SCM_SET_CLASS(e, klass);
301 e->conditions = SCM_NIL;
302 return SCM_OBJ(e);
303 }
304
305 ScmObj Scm_MakeCompoundCondition(ScmObj conditions)
306 {
307 ScmObj h = SCM_NIL, t = SCM_NIL, cp, cond;
308 int serious = FALSE;
309 int nconds = Scm_Length(conditions);
310
311 /* some boundary cases */
312 if (nconds < 0) {
313 Scm_Error("Scm_MakeCompoundCondition: list required, but got %S",
314 conditions);
315 }
316 if (nconds == 0) {
317 return compound_allocate(SCM_CLASS_COMPOUND_CONDITION, SCM_NIL);
318 }
319 if (nconds == 1) {
320 if (!SCM_CONDITIONP(SCM_CAR(conditions))) {
321 Scm_Error("make-compound-condition: given non-condition object: %S", SCM_CAR(conditions));
322 }
323 return SCM_CAR(conditions);
324 }
325
326 /* collect conditions and creates compound one */
327 SCM_FOR_EACH(cp, conditions) {
328 ScmObj c = SCM_CAR(cp);
329 if (!SCM_CONDITIONP(c)) {
330 Scm_Error("make-compound-condition: given non-condition object: %S", SCM_CAR(cp));
331 }
332 if (SCM_SERIOUS_CONDITION_P(c)) {
333 serious = TRUE;
334 }
335
336 if (SCM_COMPOUND_CONDITION_P(c)) {
337 ScmCompoundCondition *cc = SCM_COMPOUND_CONDITION(c);
338 SCM_APPEND(h, t, cc->conditions);
339 } else {
340 SCM_APPEND1(h, t, c);
341 }
342 }
343 cond = compound_allocate((serious?
344 SCM_CLASS_COMPOUND_CONDITION :
345 SCM_CLASS_SERIOUS_COMPOUND_CONDITION),
346 SCM_NIL);
347 SCM_COMPOUND_CONDITION(cond)->conditions = h;
348 return cond;
349 }
350
351 static ScmObj conditions_get(ScmCompoundCondition *obj)
352 {
353 return obj->conditions;
354 }
355
356 static void conditions_set(ScmCompoundCondition *obj, ScmObj conds)
357 {
358 ScmObj cp;
359 SCM_FOR_EACH(cp, conds) {
360 if (!SCM_CONDITIONP(SCM_CAR(cp))) goto err;
361 }
362 if (!SCM_NULLP(cp)) {
363 err:
364 Scm_Error("conditions slot of a compound condition must be a list of conditions, but got %S", conds);
365 }
366 obj->conditions = conds;
367 }
368
369 static ScmClassStaticSlotSpec compound_slots[] = {
370 SCM_CLASS_SLOT_SPEC("%conditions", conditions_get, conditions_set),
371 { NULL }
372 };
373
374
375 /*
376 * C-level Constructors & generic API
377 */
378
379 /* actual class structure of thread exceptions are in ext/threads */
380 ScmObj Scm_MakeThreadException(ScmClass *klass, ScmVM *thread)
381 {
382 ScmThreadException *e = SCM_NEW(ScmThreadException);
383 SCM_SET_CLASS(e, klass);
384 e->thread = thread;
385 e->data = SCM_UNDEFINED;
386 return SCM_OBJ(e);
387 }
388
389 ScmObj Scm_MakeError(ScmObj message)
390 {
391 ScmError *e = SCM_ERROR(message_allocate(SCM_CLASS_ERROR, SCM_NIL));
392 e->message = message;
393 return SCM_OBJ(e);
394 }
395
396 ScmObj Scm_MakeSystemError(ScmObj message, int en)
397 {
398 ScmSystemError *e =
399 SCM_SYSTEM_ERROR(syserror_allocate(SCM_CLASS_SYSTEM_ERROR, SCM_NIL));
400 e->common.message = message;
401 e->error_number = en;
402 return SCM_OBJ(e);
403 }
404
405 ScmObj Scm_MakeReadError(ScmObj message, ScmPort *port, int line)
406 {
407 ScmReadError *e =
408 SCM_READ_ERROR(readerror_allocate(SCM_CLASS_READ_ERROR, SCM_NIL));
409 e->common.message = message;
410 e->port = port;
411 e->line = line;
412 return SCM_OBJ(e);
413 }
414
415 int Scm_ConditionHasType(ScmObj c, ScmObj k)
416 {
417 ScmObj cp;
418
419 if (!SCM_CONDITIONP(c)) return FALSE;
420 if (!SCM_CLASSP(k)) return FALSE;
421 if (!SCM_COMPOUND_CONDITION_P(c)) return SCM_ISA(c, SCM_CLASS(k));
422 SCM_FOR_EACH(cp, SCM_COMPOUND_CONDITION(c)->conditions) {
423 if (SCM_ISA(SCM_CAR(cp), SCM_CLASS(k))) return TRUE;
424 }
425 return FALSE;
426 }
427
428 ScmObj Scm_ConditionMessage(ScmObj c)
429 {
430 if (SCM_MESSAGE_CONDITION_P(c)) {
431 return SCM_MESSAGE_CONDITION(c)->message;
432 } else if (SCM_COMPOUND_CONDITION_P(c)) {
433 ScmObj cp;
434 SCM_FOR_EACH(cp, SCM_COMPOUND_CONDITION(c)->conditions) {
435 if (SCM_MESSAGE_CONDITION_P(SCM_CAR(cp))) {
436 return SCM_MESSAGE_CONDITION(SCM_CAR(cp))->message;
437 }
438 }
439 }
440 return SCM_FALSE;
441 }
442
443 /* Returns a ScmString representiong the 'type name' of the condition,
444 suitable for the error message. Because of personal preference
445 and backward compatibility, I upcase the class name of the condition
446 sans brackets. If it is a composite condition, the component's typenames
447 are joind with commas.
448 */
449 ScmObj Scm_ConditionTypeName(ScmObj c)
450 {
451 ScmObj sname;
452 static SCM_DEFINE_STRING_CONST(cond_name_delim, ",", 1, 1);
453
454 /* just a safety net */
455 if (!SCM_CONDITIONP(c)) return SCM_MAKE_STR("(not a condition)");
456
457 if (!SCM_COMPOUND_CONDITION_P(c)) {
458 sname = Scm__InternalClassName(Scm_ClassOf(c));
459 } else {
460 ScmObj h = SCM_NIL, t = SCM_NIL, cp;
461 SCM_FOR_EACH(cp, SCM_COMPOUND_CONDITION(c)->conditions) {
462 ScmObj cc = SCM_CAR(cp);
463 SCM_APPEND1(h, t, Scm__InternalClassName(Scm_ClassOf(cc)));
464 }
465 if (SCM_NULLP(h)) {
466 /* not usual, but tolerate */
467 sname = Scm__InternalClassName(Scm_ClassOf(c));
468 } else {
469 sname = Scm_StringJoin(h, &cond_name_delim, SCM_STRING_JOIN_INFIX);
470 }
471 }
472 return sname;
473 }
474
475 /*================================================================
476 * Error handling
477 *
478 * The interaction with dynamic environment of VM is handled by
479 * Scm_VMThrowException() in vm.c. These routines provide
480 * application interface.
481 */
482
483 /*
484 * C-like interface
485 */
486
487 void Scm_Error(const char *msg, ...)
488 {
489 ScmObj e;
490 ScmVM *vm = Scm_VM();
491 va_list args;
492
493 if (SCM_VM_RUNTIME_FLAG_IS_SET(vm, SCM_ERROR_BEING_HANDLED)) {
494 e = Scm_MakeError(SCM_MAKE_STR("Error occurred in error handler"));
495 Scm_VMThrowException(vm, e);
496 }
497 SCM_VM_RUNTIME_FLAG_SET(vm, SCM_ERROR_BEING_HANDLED);
498
499 SCM_UNWIND_PROTECT {
500 ScmObj ostr = Scm_MakeOutputStringPort(TRUE);
501 va_start(args, msg);
502 Scm_Vprintf(SCM_PORT(ostr), msg, args, TRUE);
503 va_end(args);
504 e = Scm_MakeError(Scm_GetOutputString(SCM_PORT(ostr)));
505 }
506 SCM_WHEN_ERROR {
507 /* TODO: should check continuation? */
508 e = Scm_MakeError(SCM_MAKE_STR("Error occurred in error handler"));
509 }
510 SCM_END_PROTECT;
511 Scm_VMThrowException(vm, e);
512 Scm_Panic("Scm_Error: Scm_VMThrowException returned. something wrong.");
513 }
514
515 /*
516 * Just for convenience to report a system error. Add strerror() message
517 * after the provided message.
518 */
519
520 static ScmObj get_syserrmsg(int en)
521 {
522 ScmObj syserr;
523 #ifndef __MINGW32__
524 syserr = SCM_MAKE_STR_COPYING(strerror(en));
525 #else /*__MINGW32__*/
526 LPTSTR msgbuf;
527 FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER|FORMAT_MESSAGE_FROM_SYSTEM,
528 NULL,
529 en,
530 0,
531 (LPTSTR)&msgbuf,
532 0, NULL);
533 syserr = SCM_MAKE_STR_COPYING(msgbuf);
534 LocalFree(msgbuf);
535 #endif /*__MINGW32__*/
536 return syserr;
537 }
538
539 static int get_errno(void)
540 {
541 #ifndef __MINGW32__
542 return errno;
543 #else /*__MINGW32__*/
544 return GetLastError();
545 #endif /*__MINGW32__*/
546 }
547
548 void Scm_SysError(const char *msg, ...)
549 {
550 ScmObj e;
551 va_list args;
552 ScmVM *vm = Scm_VM();
553 int en = get_errno();
554 ScmObj syserr = get_syserrmsg(en);
555
556 SCM_UNWIND_PROTECT {
557 ScmObj ostr = Scm_MakeOutputStringPort(TRUE);
558 va_start(args, msg);
559 Scm_Vprintf(SCM_PORT(ostr), msg, args, TRUE);
560 va_end(args);
561 SCM_PUTZ(": ", -1, ostr);
562 SCM_PUTS(syserr, ostr);
563 e = Scm_MakeSystemError(Scm_GetOutputString(SCM_PORT(ostr)), en);
564 }
565 SCM_WHEN_ERROR {
566 /* TODO: should check continuation */
567 e = Scm_MakeError(SCM_MAKE_STR("Error occurred in error handler"));
568 }
569 SCM_END_PROTECT;
570 Scm_VMThrowException(vm, e);
571 Scm_Panic("Scm_Error: Scm_VMThrowException returned. something wrong.");
572 }
573
574 /*
575 * A convenience function to throw port-relates errors.
576 * It creates either one of <port-error>, <io-read-error>,
577 * <io-write-error>, <io-closed-error>, or <io-unit-error>,
578 * depending on the 'reason' argument being
579 * SCM_PORT_ERROR_{OTHER,INPUT,OUTPUT,CLOSED,UNIT}, respectively.
580 * If errno isn't zero, it also creates a <system-error> and throws
581 * a compound condition of both.
582 */
583 void Scm_PortError(ScmPort *port, int reason, const char *msg, ...)
584 {
585 ScmObj e, smsg, pe;
586 ScmClass *peclass;
587 ScmVM *vm = Scm_VM();
588 va_list args;
589 int en = get_errno();
590
591 SCM_UNWIND_PROTECT {
592 ScmObj ostr = Scm_MakeOutputStringPort(TRUE);
593 va_start(args, msg);
594 Scm_Vprintf(SCM_PORT(ostr), msg, args, TRUE);
595 va_end(args);
596 if (en != 0) {
597 ScmObj syserr = get_syserrmsg(en);
598 SCM_PUTZ(": ", -1, ostr);
599 SCM_PUTS(syserr, ostr);
600 }
601 smsg = Scm_GetOutputString(SCM_PORT(ostr));
602
603 switch (reason) {
604 case SCM_PORT_ERROR_INPUT:
605 peclass = SCM_CLASS_IO_READ_ERROR; break;
606 case SCM_PORT_ERROR_OUTPUT:
607 peclass = SCM_CLASS_IO_WRITE_ERROR; break;
608 case SCM_PORT_ERROR_CLOSED:
609 peclass = SCM_CLASS_IO_CLOSED_ERROR; break;
610 case SCM_PORT_ERROR_UNIT:
611 peclass = SCM_CLASS_IO_UNIT_ERROR; break;
612 default:
613 peclass = SCM_CLASS_PORT_ERROR; break;
614 }
615 pe = porterror_allocate(peclass, SCM_NIL);
616 SCM_ERROR(pe)->message = smsg;
617 SCM_PORT_ERROR(pe)->port = port;
618
619 if (en != 0) {
620 e = Scm_MakeCompoundCondition(SCM_LIST2(Scm_MakeSystemError(smsg, en),
621 pe));
622 } else {
623 e = pe;
624 }
625 }
626 SCM_WHEN_ERROR {
627 /* TODO: should check continuation */
628 e = Scm_MakeError(SCM_MAKE_STR("Error occurred in error handler"));
629 }
630 SCM_END_PROTECT;
631 Scm_VMThrowException(vm, e);
632 Scm_Panic("Scm_Error: Scm_VMThrowException returned. something wrong.");
633 }
634
635 /*
636 * Just print warning
637 * TODO: customize behavior
638 */
639
640 void Scm_Warn(const char *msg, ...)
641 {
642 va_list args;
643 ScmObj ostr = Scm_MakeOutputStringPort(TRUE);
644 va_start(args, msg);
645 Scm_Vprintf(SCM_PORT(ostr), msg, args, TRUE);
646 va_end(args);
647 Scm_Printf(SCM_CURERR, "WARNING: %A\n", Scm_GetOutputString(SCM_PORT(ostr)));
648 Scm_Flush(SCM_CURERR);
649 }
650
651 /* format & warn */
652 void Scm_FWarn(ScmString *fmt, ScmObj args)
653 {
654 ScmObj ostr = Scm_MakeOutputStringPort(TRUE);
655 Scm_Format(SCM_PORT(ostr), fmt, args, TRUE);
656 Scm_Printf(SCM_CURERR, "WARNING: %A\n", Scm_GetOutputString(SCM_PORT(ostr)));
657 Scm_Flush(SCM_CURERR);
658 }
659
660 /*
661 * General exception raising
662 */
663
664 /* An external API to hide Scm_VMThrowException. */
665 ScmObj Scm_Raise(ScmObj condition)
666 {
667 return Scm_VMThrowException(Scm_VM(), condition);
668 }
669
670 /* A convenient API---allows to call user-defined condition easily,
671 even the condition type is defined in Scheme. For example:
672
673 Scm_RaiseCondition(SCM_SYMBOL_VALUE("mymodule", "<my-error>"),
674 "error-type", SCM_INTERN("fatal"),
675 "error-code", SCM_MAKE_INT(3),
676 SCM_RAISE_CONDITION_MESSAGE,
677 "Fatal error occurred at %S", current_proc);
678
679 roughly corresponds to the Scheme code:
680
681 (raise (condition
682 (<my-error> (error-type 'fatal)
683 (error-code 3)
684 (message (format "Fatal error occurred at ~s"
685 current_proc)))))
686
687 This function isn't very efficient; but sometimes you want the convenience
688 more, right?
689 */
690
691 ScmObj Scm_RaiseCondition(ScmObj condition_type, ...)
692 {
693 ScmVM *vm = Scm_VM();
694 ScmObj argh = SCM_NIL, argt = SCM_NIL;
695 va_list ap;
696
697 if (!SCM_CLASSP(condition_type)
698 || !Scm_SubtypeP(SCM_CLASS(condition_type), SCM_CLASS_CONDITION)) {
699 /* If we don't get a condition type, fallback to a normal error. */
700 condition_type = SCM_OBJ(SCM_CLASS_ERROR);
701 }
702 SCM_APPEND1(argh, argt, condition_type);
703 va_start(ap, condition_type);
704 for (;;) {
705 const char *key = va_arg(ap, const char *);
706 if (key == NULL) {
707 break;
708 } else if (key == SCM_RAISE_CONDITION_MESSAGE) {
709 const char *msg = va_arg(ap, const char*);
710 ScmObj ostr = Scm_MakeOutputStringPort(TRUE);
711 Scm_Vprintf(SCM_PORT(ostr), msg, ap, TRUE);
712 SCM_APPEND1(argh, argt, SCM_MAKE_KEYWORD("message"));
713 SCM_APPEND1(argh, argt, Scm_GetOutputString(SCM_PORT(ostr)));
714 break;
715 } else {
716 ScmObj arg = va_arg(ap, ScmObj);
717 SCM_APPEND1(argh, argt, SCM_MAKE_KEYWORD(key));
718 SCM_APPEND1(argh, argt, arg);
719 }
720 }
721 va_end(ap);
722 return Scm_Apply(SCM_SYMBOL_VALUE("gauche", "error"), argh);
723 }
724
725 /*
726 * Show stack trace.
727 * stacklite - return value of Scm_GetStackLite
728 * maxdepth - maximum # of stacks to be shown.
729 * 0 to use the default. -1 for unlimited.
730 * skip - ignore this number of frames. Useful to call this from
731 * a Scheme error handling routine, in order to skip the
732 * frames of the handler itself.
733 * offset - add this to the frame number. Useful to show a middle part
734 * of frames only, by combining the skip parameter.
735 * format - SCM_STACK_TRACE_FORMAT_* enum value. EXPERIMENTAL.
736 */
737
738 #define STACK_DEPTH_LIMIT 30
739
740 #define FMT_ORIG SCM_STACK_TRACE_FORMAT_ORIGINAL
741 #define FMT_CC SCM_STACK_TRACE_FORMAT_CC
742
743 #define SHOW_EXPR(depth, expr) \
744 Scm_Printf(out, "%3d %66.1S\n", (depth), Scm_UnwrapSyntax(expr));
745
746 void Scm_ShowStackTrace(ScmPort *out, ScmObj stacklite,
747 int maxdepth, int skip, int offset, int format)
748 {
749 ScmObj cp;
750 int depth = offset;
751
752 if (maxdepth == 0) maxdepth = STACK_DEPTH_LIMIT;
753
754 SCM_FOR_EACH(cp, stacklite) {
755 if (skip-- > 0) continue;
756 if (format == FMT_ORIG) {
757 SHOW_EXPR(depth++, SCM_CAR(cp));
758 }
759 if (SCM_PAIRP(SCM_CAR(cp))) {
760 ScmObj srci = Scm_PairAttrGet(SCM_PAIR(SCM_CAR(cp)),
761 SCM_SYM_SOURCE_INFO, SCM_FALSE);
762 if (SCM_PAIRP(srci) && SCM_PAIRP(SCM_CDR(srci))) {
763 switch (format) {
764 case FMT_ORIG:
765 Scm_Printf(out, " At line %S of %S\n",
766 SCM_CADR(srci), SCM_CAR(srci));
767 break;
768 case FMT_CC:
769 Scm_Printf(out, "%A:%S:\n",
770 SCM_CAR(srci), SCM_CADR(srci));
771 break;
772 }
773 } else {
774 switch (format) {
775 case FMT_ORIG:
776 Scm_Printf(out, " [unknown location]\n");
777 break;
778 case FMT_CC:
779 Scm_Printf(out, "[unknown location]:\n");
780 break;
781 }
782 }
783 } else {
784 Scm_Printf(out, "\n");
785 }
786 if (format == FMT_CC) {
787 SHOW_EXPR(depth++, SCM_CAR(cp));
788 }
789
790 if (maxdepth >= 0 && depth >= STACK_DEPTH_LIMIT) {
791 Scm_Printf(out, "... (more stack dump truncated)\n");
792 break;
793 }
794 }
795 }
796
797 #undef SHOW_EXPR
798
799
800 /*
801 * Default error reporter
802 */
803
804 /* The default procedure to display the header of error message.
805 E is a thrown condition, not necessarily an error object. */
806 static void Scm_PrintDefaultErrorHeading(ScmObj e, ScmPort *out)
807 {
808 ScmObj msg;
809 char *heading, *p;
810
811 if (SCM_CONDITIONP(e)) {
812 heading = Scm_GetString(SCM_STRING(Scm_ConditionTypeName(e)));
813 /* TODO: considring that the class name may contain multibyte
814 characters, we should use string-upcase here. */
815 for (p=heading; *p; p++) {
816 *p = toupper(*p);
817 }
818 msg = Scm_ConditionMessage(e);
819 if (!SCM_FALSEP(msg)) {
820 Scm_Printf(out, "*** %s: %A\n", heading, msg);
821 } else {
822 Scm_Printf(out, "*** %s\n", heading);
823 }
824 } else {
825 Scm_Printf(out, "*** ERROR: unhandled exeption: %S\n", e);
826 }
827 }
828
829 static void report_error_inner(ScmVM *vm, ScmObj e)
830 {
831 ScmObj stack = Scm_VMGetStackLite(vm);
832 ScmPort *err = SCM_VM_CURRENT_ERROR_PORT(vm);
833
834 Scm_PrintDefaultErrorHeading(e, err);
835 SCM_PUTZ("Stack Trace:\n", -1, err);
836 SCM_PUTZ("_______________________________________\n", -1, err);
837 Scm_ShowStackTrace(err, stack, 0, 0, 0, FMT_ORIG);
838 /* NB: stderr is autoflushed by default, but in case err is replaced
839 by some other port, we explicitly flush it. */
840 SCM_FLUSH(err);
841 }
842
843 void Scm_ReportError(ScmObj e)
844 {
845 ScmVM *vm = Scm_VM();
846
847 if (SCM_VM_RUNTIME_FLAG_IS_SET(vm, SCM_ERROR_BEING_REPORTED)) {
848 /* An _uncaptured_ error occurred during reporting an error.
849 We can't proceed, for it will cause infinite loop.
850 Note that it is OK for an error to occur inside the error
851 reporter, as far as the error is handled by user-installed
852 handler. The user-installed handler can even invoke a
853 continuation that is captured outside; the flag is reset
854 in such case.
855 Be careful that it is possible that stderr is no longer
856 available here (since it may be the very cause of the
857 recursive error). All we can do is to abort. */
858 Scm_Abort("Unhandled error occurred during reporting an error. Process aborted.\n");
859 }
860
861 SCM_VM_RUNTIME_FLAG_SET(vm, SCM_ERROR_BEING_REPORTED);
862 SCM_UNWIND_PROTECT {
863 if (SCM_PROCEDUREP(vm->defaultEscapeHandler)) {
864 Scm_Apply(vm->defaultEscapeHandler, SCM_LIST1(e));
865 } else {
866 report_error_inner(vm, e);
867 }
868 }
869 SCM_WHEN_ERROR {
870 /* NB: this is called when a continuation captured outside is
871 invoked inside the error reporter. It may be invoked by
872 the user's error handler. */
873 SCM_VM_RUNTIME_FLAG_CLEAR(vm, SCM_ERROR_BEING_REPORTED);
874 }
875 SCM_END_PROTECT;
876 SCM_VM_RUNTIME_FLAG_CLEAR(vm, SCM_ERROR_BEING_REPORTED);
877 }
878
879 /*
880 * Initialization
881 */
882 extern void Scm_Init_exclib(ScmModule *module);
883
884 void Scm__InitExceptions(void)
885 {
886 ScmModule *mod = Scm_GaucheModule();
887 ScmClass *cond_meta;
888
889 ScmObj mes_ser_supers
890 = SCM_LIST2(SCM_OBJ(SCM_CLASS_MESSAGE_CONDITION),
891 SCM_OBJ(SCM_CLASS_SERIOUS_CONDITION));
892 ScmObj com_ser_supers
893 = SCM_LIST2(SCM_OBJ(SCM_CLASS_COMPOUND_CONDITION),
894 SCM_OBJ(SCM_CLASS_SERIOUS_CONDITION));
895
896 Scm_InitStaticClassWithMeta(SCM_CLASS_CONDITION,
897 "<condition>",
898 mod, NULL, SCM_FALSE, NULL, 0);
899 cond_meta = Scm_ClassOf(SCM_OBJ(SCM_CLASS_CONDITION));
900 Scm_InitStaticClassWithMeta(SCM_CLASS_SERIOUS_CONDITION,
901 "<serious-condition>",
902 mod, cond_meta, SCM_FALSE, NULL, 0);
903 Scm_InitStaticClassWithMeta(SCM_CLASS_MESSAGE_CONDITION,
904 "<message-condition>",
905 mod, cond_meta, SCM_FALSE, message_slots, 0);
906
907 Scm_InitStaticClassWithMeta(SCM_CLASS_ERROR,
908 "<error>",
909 mod, cond_meta, mes_ser_supers,
910 message_slots, 0);
911 Scm_InitStaticClassWithMeta(SCM_CLASS_SYSTEM_ERROR,
912 "<system-error>",
913 mod, cond_meta, SCM_FALSE,
914 syserror_slots, 0);
915 Scm_InitStaticClassWithMeta(SCM_CLASS_READ_ERROR,
916 "<read-error>",
917 mod, cond_meta, SCM_FALSE,
918 readerror_slots, 0);
919 Scm_InitStaticClassWithMeta(SCM_CLASS_IO_ERROR,
920 "<io-error>",
921 mod, cond_meta, SCM_FALSE,
922 NULL, 0);
923 Scm_InitStaticClassWithMeta(SCM_CLASS_PORT_ERROR,
924 "<port-error>",
925 mod, cond_meta, SCM_FALSE,
926 porterror_slots, 0);
927 Scm_InitStaticClassWithMeta(SCM_CLASS_IO_READ_ERROR,
928 "<io-read-error>",
929 mod, cond_meta, SCM_FALSE,
930 porterror_slots, 0);
931 Scm_InitStaticClassWithMeta(SCM_CLASS_IO_WRITE_ERROR,
932 "<io-write-error>",
933 mod, cond_meta, SCM_FALSE,
934 porterror_slots, 0);
935 Scm_InitStaticClassWithMeta(SCM_CLASS_IO_CLOSED_ERROR,
936 "<io-closed-error>",
937 mod, cond_meta, SCM_FALSE,
938 porterror_slots, 0);
939 Scm_InitStaticClassWithMeta(SCM_CLASS_IO_UNIT_ERROR,
940 "<io-unit-error>",
941 mod, cond_meta, SCM_FALSE,
942 porterror_slots, 0);
943
944 Scm_InitStaticClassWithMeta(SCM_CLASS_COMPOUND_CONDITION,
945 "<compound-condition>",
946 mod, cond_meta, SCM_FALSE,
947 compound_slots, 0);
948 Scm_InitStaticClassWithMeta(SCM_CLASS_SERIOUS_COMPOUND_CONDITION,
949 "<serious-compound-condition>",
950 mod, cond_meta, com_ser_supers,
951 compound_slots, 0);
952
953 Scm_Init_exclib(mod);
954 }
955