root/src/error.c

/* [<][>][^][v][top][bottom][index][help] */

DEFINITIONS

This source file includes following definitions.
  1. message_print
  2. message_allocate
  3. message_get
  4. message_set
  5. syserror_allocate
  6. readerror_allocate
  7. porterror_allocate
  8. syserror_number_get
  9. syserror_number_set
  10. readerror_port_get
  11. readerror_port_set
  12. readerror_line_get
  13. readerror_line_set
  14. readerror_dummy_get
  15. readerror_dummy_set
  16. porterror_port_get
  17. porterror_port_set
  18. compound_allocate
  19. Scm_MakeCompoundCondition
  20. conditions_get
  21. conditions_set
  22. Scm_MakeThreadException
  23. Scm_MakeError
  24. Scm_MakeSystemError
  25. Scm_MakeReadError
  26. Scm_ConditionHasType
  27. Scm_ConditionMessage
  28. Scm_ConditionTypeName
  29. Scm_Error
  30. get_syserrmsg
  31. get_errno
  32. Scm_SysError
  33. Scm_PortError
  34. Scm_Warn
  35. Scm_FWarn
  36. Scm_Raise
  37. Scm_RaiseCondition
  38. Scm_ShowStackTrace
  39. Scm_PrintDefaultErrorHeading
  40. report_error_inner
  41. Scm_ReportError
  42. 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 

/* [<][>][^][v][top][bottom][index][help] */